x03_Service; Module1.bas
Attribute VB_Name = "x03_Service"
'***********************************************************************
' This module should only contain subroutines that provide general
' service to other modules. This means routines for calculation and/or
' administration that do not "belong" uniquely to any one of the other
' modules.
' The module also contains definitions of general data structures.
'***********************************************************************
Option Explicit
Private Declare Function GetUserName Lib "advapi32.dll" Alias _
"GetUserNameA" (ByVal lpBuffer As String, nsize As Long) As Long
Private Declare Function GetComputerName Lib "kernel32.dll" Alias _
"GetComputerNameA" (ByVal lpBuffer As String, nsize As Long) As Long
Option Base 1 ' Set default array subscripts to 1.
' Ranges of data types
Public Const CMaxLong = 2147483647
Public Const CMinLong = -CMaxLong
Public Const CMaxByte = 255
Public Const CMinByte = 0
Public Const CMaxInt = 32767
Public Const CMinInt = -CMaxInt
'Public drivetxt As String
Public sesimpath As String
Public error_flag As Integer
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, src As Any, ByVal bytes As Long)
Public lifehist As New Lifehistory
Public inchist As New Inchistory
Public coll_view As New Collection ' Collection of viewers
' Vectors for marking etc.
Public mark_i() As Long
Public mark_h() As Long
Public stack_i() As Long
Public stack_size As Long
Public pool_female() As Long
Public pool_female_size As Long
Public pool_male() As Long
Public pool_male_size As Long
' Vectors used for subsetting the population in the analysis
Public exclude_in_stat_compute() As Long ' 1: excluded, 0: included (individuals)
Public select_i() As Long ' 1: included, 0: excluded (individuals)
Public select_h() As Long ' 1: included, 0: excluded (households)
Public exclude_txt As String
Public exclude_tag As String ' Name of master viewer
' Vector for pointer between i-nr and index in i-vectors
Public indnr2index() As Long
' Vector for pointer between h-nr and index in h-vectors
Public hhnr2index() As Long
'Public hhnr2index_lag() As Long
'*** Tidsberoende globala variabler
'Public m_icount As Long
'Public m_hcount As Long
Public största_indnr As Long
Public största_hhnr As Long
Public model_time As Long
Public base_year As Long
' Flag. 0=same random seed. 1=different seed.
Public random As Integer
'*** Variables for calculation of partitioning value
Public dtal_stock(0 To 106, 0 To 9, 1 To 2) As Double
Public dtal_död(0 To 106, 0 To 9, 1 To 2) As Double
Public dtal_dödsrisk(0 To 106) As Double
'*** Övriga globala variabler
Public temp() As Variant
Public temp2() As Variant
Public income_vector(1 To 3, 1 To 100) As Double
'*** Data structure for handling information about
'*** output data sources
Public Type Type_OutputData
OutputActive As Boolean
filename As String
filenr As Integer
filenr2 As Integer
filetype As Byte ' 1: ASCII, 2: binary
FileCreated As Boolean
VarList_i() As String
VarList_h() As String
VarList_m() As String
End Type
Public OutputData As Type_OutputData
'*** Data-structure for storage of pension points (ATP)
Public Type pp_hist_ind
pp() As Integer ' vector of ATP pension points
pp_years() As Integer ' years for earnings in pp (elementwise synchronized with pp)
n_years As Integer ' number of years with ATP pension rights
End Type
Public pp_hist() As pp_hist_ind 'pension points histories for the entire population
'*** TEST RELATIVES Data-structure for family structure (Life long relations)
'Public Type Family
' mother() As Long ' Mothers idnr - 0 if deceased
' father() As Long ' Fathers idnr - 0 if deceased
' children() As Long ' Childrens innr - empty if no children
'End Type
'Public Relatives() As Family ' Life-long family relations
' Data structure for global selection: one element of type SelItem contains one
' selection condition. The list SelLst contains all current selection conditions.
Public Type SelItem
val As Double
op As String * 2
var As String
End Type
Public SelLst() As SelItem
Public nSelItems As Double ' number of current selections
Public SelIsOpen As Boolean ' True if a Global Selection window is open
'*** Data structure used for regional information. The smallest disaggregated
'*** level is the municipality (kommun) level.
'*** NOTE: the kommundata() list is accessed using the municipality index order.
'*** This order is achieved by sorting the municipalities by their codes in
'*** ascending order!
Public Type kommun
name As String ' kommunens namn
taxvalue As Integer 'genomsnittliga taxeringsvärden
kb As Single 'köpeskillingskoefficient
kod As Integer ' kommunkod
h_region As Byte 'H-region
abcd_region As Byte 'ABCD-region
bklimat As Byte 'klimatzon
immig_loc As Single 'allokeringsandelar för invandrarhushåll 1999
pop_loc As Single 'allokeringsandelar för Sveriges befolkning 1999
skatt99 As Single 'genomsnittlig kommunalskattesats för 1999
skatt00 As Single 'genomsnittlig kommunalskattesats för 2000
skatt01 As Single 'genomsnittlig kommunalskattesats för 2001
skatt02 As Single 'genomsnittlig kommunalskattesats för 2002
skatt03 As Single 'genomsnittlig kommunalskattesats för 2003
skatt04 As Single 'genomsnittlig kommunalskattesats för 2004
skatt05 As Single 'genomsnittlig kommunalskattesats för 2005
skatt06 As Single 'genomsnittlig kommunalskattesats för 2006
LA_region As Byte 'LA-region enligt 1999 års indelning
End Type
Public kommundata() As kommun
'-- Swithes in pension calculations
Public chkRetire65 As Boolean '-- Fixed pension age marked
Public txtRetire As Byte '-- Pension age if check box marked
Public Function summa(x)
Dim sum As Double
Dim i As Integer
sum = 0
For i = 1 To m_icount
sum = sum + x(i)
Next
summa = sum
End Function
Public Function round(x, decimaler) As Double
Dim y As Double
y = x * 10 ^ decimaler + 0.5
y = Int(y)
round = y / (10 ^ decimaler)
End Function
Public Function fspace(txt, bredd)
Dim txtbredd As String
Dim nspace As Integer
txtbredd = mini(bredd, Len(txt))
fspace = txt & Space(maxi(1, bredd - txtbredd))
End Function
'*** Delete individuals marked in vector mark_i
Public Sub delete_individuals()
Printdok "delete_individuals"
Dim i As Long, j As Long, inr As Long, hnr As Long, idx As Long
Dim hhsize As Integer, hdelete As Integer
hdelete = 0
' Delete previous markers
For i = 1 To m_hcount
mark_h(i) = 0
Next
'*** Erase previous information in the UD matrix
' For i = LBound(Ud) To UBound(Ud)
' Ud(i) = 0
' Next
'
' Update pointers to next ind and pointers to first ind
Printdok " i loop in delete_individuals: Calculate_Survivors_pension"
m_ap_atp_dead = 0
m_ap_fp30_dead = 0
m_ap_ip_dead = 0
m_ap_pp_dead = 0
For i = 1 To m_icount
If mark_i(i) = 1 Then
lifehist.write_hist i_indnr(i), "Dead"
'This function is replaced by code in a08_automatic_balancing
' '-- Sum up the deceased pensions (for calculation of automatic balancing)
' If i_age(i) > 60 And i_status(i) = 2 Then 'kräver att individen var pensionerad
' If (model_time + base_year) < 2003 Then
' 'Måste fundera på hur denna definieras!!! 0.5*i_ap_fp ger god anpassning men är ad-hoc
' Ud(mini(120, i_age(i))) = Ud(mini(120, i_age(i))) + i_ap_atp(i) + 0.5 * i_ap_fp(i) 'Lagt till i_ap_fp FJ 2004-03-02
'' Ud(mini(120, i_age(i))) = Ud(mini(120, i_age(i))) + i_ap_atp(i)
' Else
' Ud(mini(120, i_age(i))) = Ud(mini(120, i_age(i))) + i_ap_ap(i)
'' Ud(mini(120, i_age(i))) = Ud(mini(120, i_age(i))) + i_ap(i)
'
' End If
' End If
'-- Pensions not paid out to dead persons (exkl last years indexation)
m_ap_atp_dead = m_ap_atp_dead + (i_ap_atp(i) * m_weight)
m_ap_fp30_dead = m_ap_fp30_dead + (i_ap_fp30(i) * m_weight)
m_ap_ip_dead = m_ap_ip_dead + (i_ap_ip(i) * m_weight)
m_ap_pp_dead = m_ap_pp_dead + (i_ap_pp(i) * m_weight)
' -- Calculates survivors pension (in a06_Pension_Rules)
If i_civ_stat(i) = 1 Then
Call Calculate_Survivors_pension(i)
End If
hnr = i_hhnr(i)
hhsize = get_hh_size(hnr)
'*** Case 1 - household size = 1
If hhsize = 1 Then
mark_h(hhnr2index(hnr)) = 1
hdelete = 1
End If
'*** Case 2 - household size > 1
If hhsize > 1 Then
'*** Case 2.1 - ind is first
If i_indnr(i) = h_first_indnr(hhnr2index(hnr)) Then
' Change first_indnr in hh
h_first_indnr(hhnr2index(hnr)) = i_next_indnr(i)
'*** Case 2.2 - ind is last
ElseIf i_next_indnr(i) = 0 Then
' Set terminate on ind before
' Lookup ind before last
inr = h_first_indnr(hhnr2index(hnr))
For j = 2 To hhsize - 1
inr = i_next_indnr(indnr2index(inr))
Next
i_next_indnr(indnr2index(inr)) = 0
'*** Case 2.3 - ind is either first or last
Else
' Change next pointer on ind before
' Lookup ind before
inr = h_first_indnr(hhnr2index(hnr))
' Do until next pointer on me
Do Until i_next_indnr(indnr2index(inr)) = i_indnr(i)
inr = i_next_indnr(indnr2index(inr))
Loop
' Ind befores takes my next pointer
i_next_indnr(indnr2index(inr)) = i_next_indnr(i)
End If
' Updating household information
If i_bvux(i) = 1 Then
'*** Handle inheritance - if the deceased was a cohabiting adult the
'*** spouse inherits the financial wealth of the deceased
If h_n_adults(hhnr2index(hnr)) = 2 Then
If i_sex(i) = 1 Then
If h_indnr_female(hhnr2index(hnr)) <> 0 Then
idx = indnr2index(h_indnr_female(hhnr2index(hnr)))
i_wealth_financial(idx) = i_wealth_financial(idx) + i_wealth_financial(i)
i_widowed(idx) = 1
i_HasBeenWidowed(idx) = 1
h_indnr_male(hhnr2index(hnr)) = 0
End If
End If
If i_sex(i) = 2 Then
If h_indnr_male(hhnr2index(hnr)) <> 0 Then
idx = indnr2index(h_indnr_male(hhnr2index(hnr)))
i_wealth_financial(idx) = i_wealth_financial(idx) + i_wealth_financial(i)
i_widowed(idx) = 1
i_HasBeenWidowed(idx) = 1
h_indnr_female(hhnr2index(hnr)) = 0
End If
End If
End If
h_n_adults(hhnr2index(hnr)) = h_n_adults(hhnr2index(hnr)) - 1
' Reset variance components
h_wealth_debt_interest_varcomp_p(hhnr2index(hnr)) = 0
h_wealth_debt_interest_varcomp_r(hhnr2index(hnr)) = 0
h_wealth_debt_varcomp(hhnr2index(hnr)) = 0
h_wealth_financial_varcomp(hhnr2index(hnr)) = 0
h_wealth_debt_GLS1vc(hhnr2index(hnr)) = 0
h_wealth_debt_GLS2vc(hhnr2index(hnr)) = 0
h_wealth_debt_probit1vc(hhnr2index(hnr)) = 0
h_wealth_debt_probit2vc(hhnr2index(hnr)) = 0
Else
h_n_child(hhnr2index(hnr)) = h_n_child(hhnr2index(hnr)) - 1
End If
If i_age(i) >= 18 Then h_n_ge18(hhnr2index(hnr)) = h_n_ge18(hhnr2index(hnr)) - 1
If i_age(i) < 7 And i_bvux(i) = 0 Then _
h_n_childlt7(hhnr2index(hnr)) = h_n_childlt7(hhnr2index(hnr)) - 1
If i_age(i) < 12 And i_bvux(i) = 0 Then _
h_n_childlt12(hhnr2index(hnr)) = h_n_childlt12(hhnr2index(hnr)) - 1
h_size(hhnr2index(hnr)) = h_size(hhnr2index(hnr)) - 1
End If '*** hhsize > 1
End If '*** mark_i(i) = 1
Next
'Mark individuals as deleted in pointer vector
j = m_icount
For i = 1 To m_icount
If mark_i(i) = 1 Then
indnr2index(i_indnr(i)) = 0
j = j - 1
End If
Next
' Pack i-vectors
Call shift_up_marked_ii
m_icount = j
For i = 1 To m_icount
indnr2index(i_indnr(i)) = i
' Clear markers
mark_i(i) = 0
Next
' Time to delete households
If hdelete = 1 Then
j = m_hcount
For i = 1 To m_hcount
If mark_h(i) = 1 Then
hhnr2index(h_hhnr(i)) = 0
j = j - 1
End If
Next
' Pack household vectors
Call shift_up_marked_hh
m_hcount = j
For i = 1 To m_hcount
hhnr2index(h_hhnr(i)) = i
' Clear markers
mark_h(i) = 0
Next
End If
' Keeping data vectors packed to avoid errors
Call dyn_vect_i(m_icount)
Call dyn_vect_h(m_hcount)
End Sub
' Delete household h
'NOTE: this routine is NEVER called!! TP011022
Public Sub delete_household(h As Long)
Dim i As Long
'status "Delete hh nr " & cstr(h)
' Pack h-vectors
Call shift_up_hh(hhnr2index(h), m_hcount - 1)
'Mark household as deleted in pointer vector
hhnr2index(h) = 0
For i = h + 1 To största_hhnr
hhnr2index(i) = hhnr2index(i) - 1
Next
' New number of households
m_hcount = m_hcount - 1
End Sub
Public Sub status(text As String)
DoEvents
' If controlcenter.imgCalc.Visible = True Then
' If controlcenter.imgCalc.Width = 300 Then
' controlcenter.imgCalc.Width = 250
' controlcenter.imgCalc.Height = 250
' controlcenter.imgCalc.Top = controlcenter.imgCalc.Top + 25
' controlcenter.imgCalc.Left = controlcenter.imgCalc.Left + 25
' Else
' controlcenter.imgCalc.Width = 300
' controlcenter.imgCalc.Height = 300
' controlcenter.imgCalc.Top = controlcenter.imgCalc.Top - 25
' controlcenter.imgCalc.Left = controlcenter.imgCalc.Left - 25
' End If
' controlcenter.imgCalc.Refresh
' End If
If statusform.statuslist.ListCount > 30000 Then statusform.statuslist.Clear
statusform.statuslist.AddItem CStr(model_time) & " " & text
statusform.statuslist.Selected(statusform.statuslist.ListCount - 1) = True
statusform.statuslist.Refresh
End Sub
Function maxi(A, B)
maxi = A
If B > A Then maxi = B
End Function
Function mini(A, B)
mini = A
If B < A Then mini = B
End Function
' Return nr of individuals in household h
Function get_hh_size(h As Long) As Integer
Dim inr As Long
Dim count As Integer
Dim done As Integer
done = 0
count = 0
' First i-nr
inr = h_first_indnr(hhnr2index(h))
' Do Until done = 1
Do Until inr = 0
count = count + 1
' Next i-nr
inr = i_next_indnr(indnr2index(inr))
'If inr = 0 Then done = 1
Loop
get_hh_size = count
End Function
' Return the last persons individual nr in houshold h
Function get_hhlast_indnr(h As Long) As Long
Dim inr As Long
Dim done As Integer
' First i-nr
inr = h_first_indnr(hhnr2index(h))
get_hhlast_indnr = inr
' Do Until done = 1
Do Until inr = 0
' Next i-nr
inr = i_next_indnr(indnr2index(inr))
If inr > 0 Then get_hhlast_indnr = inr
Loop
End Function
' Return mean age of household h
Function get_mean_age(h As Long) As Double
Dim inr As Long
Dim count As Integer
Dim done As Integer
Dim sum As Double
done = 0
count = 0
' First i-nr
inr = h_first_indnr(hhnr2index(h))
Do Until done = 1
count = count + 1
sum = sum + i_age(indnr2index(inr))
' Next i-nr
inr = i_next_indnr(indnr2index(inr))
If inr = 0 Then done = 1
Loop
get_mean_age = sum / count
End Function
'Function to get max-value of any family variable. Input are variable name and
'any individual number from the family.
Public Function get_hh_max(indnr, vname)
Dim inr As Long
Dim index
inr = h_first_indnr(hhnr2index(i_hhnr(indnr)))
get_hh_max = 0
Do Until inr = 0
index = indnr2index(inr)
get_hh_max = maxi(get_value(vname, index), get_hh_max)
inr = i_next_indnr(index)
Loop
End Function
'Function to get summed values of any family variable. Input are variable name and
'any individual number from the family.
Public Function get_hh_sum(indnr, vname)
Dim inr As Long
Dim index
inr = h_first_indnr(hhnr2index(i_hhnr(indnr)))
get_hh_sum = 0
Do Until inr = 0
index = indnr2index(inr)
get_hh_sum = get_hh_sum + get_value(vname, index)
inr = i_next_indnr(index)
Loop
End Function
' No of persons in hh at least 18 older than me
Public Function count_18_older(h As Long, myage As Integer)
Dim inr As Long
Dim agediff As Integer
Dim count As Integer
Dim done As Integer
done = 0
count = 0
' First i-nr
inr = h_first_indnr(hhnr2index(h))
Do Until done = 1
agediff = i_age(indnr2index(inr)) - myage
If agediff >= 18 Then count = count + 1
' Next i-nr
inr = i_next_indnr(indnr2index(inr))
If inr = 0 Then done = 1
Loop
count_18_older = count
End Function
' Kids with age 0?
Function exist_newborn(h As Long) As Integer
Dim inr As Long
exist_newborn = 0
' First i-nr
inr = h_first_indnr(hhnr2index(h))
Do Until inr = 0
If i_age(indnr2index(inr)) = 0 Then
exist_newborn = 1
Exit Function
End If
' Next i-nr
inr = i_next_indnr(indnr2index(inr))
Loop
End Function
' Kids 0 to 3 years exist. Used to calculate pensionable means other than income,
Function exist_child0_3(h As Long) As Integer
Dim inr As Long
exist_child0_3 = 0
' First i-nr
inr = h_first_indnr(hhnr2index(h))
Do Until inr = 0
If i_age(indnr2index(inr)) < 4 Then
exist_child0_3 = 1
Exit Function
End If
' Next i-nr
inr = i_next_indnr(indnr2index(inr))
Loop
End Function
'*****************************************************************************
' Sub add_born appends newborn individuals to households that was randomized
' in sub rand_fertility. Some important variables are initiated (besides the
' necessary ones such as individual number) but most are set to zero.
'*****************************************************************************
Public Sub add_born()
Printdok "add_born"
Dim i As Long, j As Long, k As Long, nyindnr As Long
Dim inr As Long, hnr As Long, hhsize As Integer, hdelete As Long
'*** Optional debug output - set runtime parameter
If get_scalefactor("debug_fertility") <> 1 Then
Dim filenr As Integer
Dim debugfile As String
filenr = FreeFile
debugfile = sesimpath & "\tempdata\debug_fert.txt"
If model_time = 1 And Dir(debugfile) <> "" Then
Open debugfile For Output As #filenr
Else
Open debugfile For Append As #filenr
End If
If model_time = 1 Then Print #filenr, _
"year, birth, age, sex, edlevel, pgi, child, abroad, bvux"
For i = 1 To m_icount
Write #filenr, base_year + model_time, mark_i(i), i_age(i), _
i_sex(i), i_edlevel(i), i_pgi(i), h_n_child(hhnr2index(i_hhnr(i))), _
i_abroad(i), i_bvux(i)
Next
Close #filenr
End If
j = m_icount
For i = 1 To j
If mark_i(i) = 1 Then
största_indnr = största_indnr + 1
nyindnr = största_indnr
If m_icount >= UBound(i_indnr) Then
Call dyn_vect_i(m_icount + 500)
'Debug.Print "allocating memory - add_born"
End If
m_icount = m_icount + 1
' Set all variables to zero
Call zero_i(m_icount)
' Initiate some important variables
' i_d_born_in_sesim(m_icount) = 1
i_indnr(m_icount) = nyindnr
i_hhnr(m_icount) = i_hhnr(i)
i_next_indnr(m_icount) = 0
i_age(m_icount) = 0
i_status(m_icount) = 1
i_bvux(m_icount) = 0
i_sector(m_icount) = 0
' The ratio of newborn boys to newborn girls has been estimated using the
' national average during the period 1970-2004. There are no trends in the sex-
' ratio during the estimation period. TP051028
If Rnd < 0.514 Then i_sex(m_icount) = 1 Else i_sex(m_icount) = 2
' Set pointer from previous ind to newborn
hnr = i_hhnr(i)
hhsize = get_hh_size(hnr)
inr = h_first_indnr(hhnr2index(hnr))
For k = 2 To hhsize
inr = i_next_indnr(indnr2index(inr))
Next
i_next_indnr(indnr2index(inr)) = nyindnr
' Expand the individual indexation vector if necessary
' NOTE: 100 elements at a time increases the speed of calculations
If UBound(indnr2index) < nyindnr Then
ReDim Preserve indnr2index(nyindnr + 100) As Long
'Debug.Print "allocating memory - add_born"
End If
indnr2index(nyindnr) = m_icount
lifehist.write_hist i_indnr(i), "Birth"
lifehist.write_hist största_indnr, "Born"
' update household information
h_n_child(hhnr2index(hnr)) = h_n_child(hhnr2index(hnr)) + 1
h_size(hhnr2index(hnr)) = h_size(hhnr2index(hnr)) + 1
h_n_childlt7(hhnr2index(hnr)) = h_n_childlt7(hhnr2index(hnr)) + 1
h_n_childlt12(hhnr2index(hnr)) = h_n_childlt12(hhnr2index(hnr)) + 1
End If
mark_i(i) = 0
Next
' keep the data vectors packed to avoid errors
Call dyn_vect_i(m_icount)
End Sub
'*******************************************************************
' Sub leave_home_doit builds new households for individuals that are
' marked in mark_i
'*******************************************************************
Public Sub leave_home_doit()
Printdok "leave_home_doit"
Dim i As Long, j As Long, inr As Long, oldhnr As Long, hhidx As Long
Dim oldhidx As Long
Dim hhsize As Integer
' Update pointers to next ind and
' pointers to first ind
For i = 1 To m_icount
' Only handle marked individuals
If mark_i(i) = 1 Then
lifehist.write_hist i_indnr(i), "Leave hh"
oldhnr = i_hhnr(i)
oldhidx = hhnr2index(oldhnr)
hhsize = get_hh_size(oldhnr)
' If hhsize = 1 then this is an orphan that is 18 years of age or older
' that is to be the new head of his/her household
If hhsize = 1 Then
' Update household and individual information
i_bvux(i) = 1
hhidx = hhnr2index(i_hhnr(i))
h_n_adults(hhidx) = 1
h_n_ge18(hhidx) = 1
h_n_child(hhidx) = 0
h_n_childlt7(hhidx) = 0
h_n_childlt12(hhidx) = 0
lifehist.write_hist i_indnr(i), "Inherit hh"
'*** all housing variables are reset and recalculated in the housing module
h_house_area(hhidx) = 0
h_house_cost(hhidx) = 0
h_house_interest(hhidx) = 0
h_house_tax(hhidx) = 0
h_house_owner(hhidx) = 0
h_house_owner1(hhidx) = 0
h_inc_capital(hhidx) = 0
' h_inc_capital1(hhidx) = 0
h_wealth_debt(hhidx) = 0
h_wealth_debt1(hhidx) = 0
h_wealth_debt_interest(hhidx) = 0
h_wealth_financial(hhidx) = 0
h_wealth_financial1(hhidx) = 0
h_wealth_InterestDividends(hhidx) = 0
h_wealth_real(hhidx) = 0
h_wealth_real_home(hhidx) = 0
h_wealth_real_home1(hhidx) = 0
h_wealth_real_other(hhidx) = 0
h_wealth_real_other1(hhidx) = 0
h_wealth_CapitalGain(hhidx) = 0
h_new_housing(hhidx) = 1 ' Marked for tenure choice
'*** If not orphan -> create new household
Else
'*** Disconnect ind from other inds
'*** Case 1 - ind is first
If i_indnr(i) = h_first_indnr(hhnr2index(oldhnr)) Then
' Change first_indnr in hh
h_first_indnr(hhnr2index(oldhnr)) = i_next_indnr(i)
'*** Case 2 - ind is last
ElseIf i_next_indnr(i) = 0 Then
' Set terminate on ind before
' Lookup ind before last
inr = h_first_indnr(hhnr2index(oldhnr))
For j = 2 To hhsize - 1
inr = i_next_indnr(indnr2index(inr))
Next
i_next_indnr(indnr2index(inr)) = 0
'*** Case 3 - ind is either first or last
Else
' Change next pointer on ind before
' Lookup ind before
inr = h_first_indnr(hhnr2index(oldhnr))
' Do until next pointer on me
Do Until i_next_indnr(indnr2index(inr)) = i_indnr(i)
inr = i_next_indnr(indnr2index(inr))
Loop
' Ind befores takes my next pointer
i_next_indnr(indnr2index(inr)) = i_next_indnr(i)
End If
' Update individual characteristics
största_hhnr = största_hhnr + 1
i_hhnr(i) = största_hhnr 'I-vector done
i_next_indnr(i) = 0
i_bvux(i) = 1 ' Grown-up
i_civ_stat(i) = 0 ' Single person
' Allocate more memory for household data vectors if necessary
' NOTE: 500 elements at a time increases computation speed
If m_hcount = UBound(h_hhnr) Then
Call dyn_vect_h(m_hcount + 500)
'Debug.Print "allocating memory - leave_home_doit"
End If
m_hcount = m_hcount + 1
' Update information for new household
h_hhnr(m_hcount) = största_hhnr
h_first_indnr(m_hcount) = i_indnr(i)
h_n_adults(m_hcount) = 1 ' single adult
h_size(m_hcount) = 1 ' alone in hh
h_n_child(m_hcount) = 0
h_n_childlt7(m_hcount) = 0
h_n_childlt12(m_hcount) = 0
mark_h(m_hcount) = 0
' The new household does not move from the municipality
h_kommunindex(m_hcount) = h_kommunindex(oldhidx)
h_kommunkod(m_hcount) = kommundata(h_kommunindex(m_hcount)).kod
' h_la_region(m_hcount) = kommundata(h_kommunindex(m_hcount)).LA_region
h_BB_region(m_hcount) = BB_Region(h_kommunkod(m_hcount))
'*** all housing-related variables are reset and recalculated in the housing module
h_house_area(m_hcount) = 0
h_house_cost(m_hcount) = 0
h_house_interest(m_hcount) = 0
h_house_tax(m_hcount) = 0
h_house_owner(m_hcount) = 0
h_house_owner1(m_hcount) = 0
h_inc_capital(m_hcount) = 0
' h_inc_capital1(m_hcount) = 0
' Adult childrens share of household debt is assumed to be 14%
h_wealth_debt(m_hcount) = h_wealth_debt(oldhidx) * 0.14 * _
(1 / (h_n_ge18(oldhidx) - h_n_adults(oldhidx)))
h_wealth_debt1(m_hcount) = 0
h_wealth_debt_interest(m_hcount) = 0
' Adult childrens share of household financial wealth is assumed to be 20%
h_wealth_financial(m_hcount) = h_wealth_financial(oldhidx) * 0.2 * _
(1 / (h_n_ge18(oldhidx) - h_n_adults(oldhidx)))
h_wealth_financial1(m_hcount) = 0
h_wealth_InterestDividends(m_hcount) = 0
h_wealth_real(m_hcount) = 0
h_wealth_real_home(m_hcount) = 0
h_wealth_real_home1(m_hcount) = 0
h_wealth_real_other(m_hcount) = 0
h_wealth_real_other1(m_hcount) = 0
h_wealth_CapitalGain(m_hcount) = 0
h_new_housing(m_hcount) = 1 ' Marked for tenure choice
If i_abroad(i) = 1 Then
h_abroad(m_hcount) = 1
h_emig_year(m_hcount) = h_emig_year(oldhidx)
End If
' Update information for old household
h_wealth_debt(oldhidx) = h_wealth_debt(oldhidx) * _
(1 - 0.14 * (1 / (h_n_ge18(oldhidx) - h_n_adults(oldhidx))))
h_wealth_financial(oldhidx) = h_wealth_financial(oldhidx) * _
(1 - 0.2 * (1 / (h_n_ge18(oldhidx) - h_n_adults(oldhidx))))
h_size(oldhidx) = h_size(oldhidx) - 1
h_n_child(oldhidx) = h_n_child(oldhidx) - 1
h_n_ge18(oldhidx) = h_n_ge18(oldhidx) - 1
h_childmoveout(oldhidx) = 1
' Allocate more memory for household index vectors if necessary
' NOTE: 100 elements at a time increases computation speed
If UBound(hhnr2index) < största_hhnr Then
ReDim Preserve hhnr2index(största_hhnr + 100) As Long
End If
hhnr2index(största_hhnr) = m_hcount
lifehist.write_hist i_indnr(i), "New hhnr (Leave hh)"
End If ' if not orphan
End If ' if mark_i(i) = 1
mark_i(i) = 0
Next
' keeping the data vectors packed to prevent errors
Call dyn_vect_h(m_hcount)
End Sub
'************************************************************************************************
'*** Sub Clone_hh is used by the immigration module for the construction of immigrant households.
'************************************************************************************************
Public Sub clone_hh()
Printdok "clone_hh"
Dim i As Long, indi_nr As Long
Dim h As Integer
Dim allokprobs() As Single
Dim rand As Double, probsum As Double
ReDim allokprobs(1 To 289, 1 To 2)
'*** Create a vector of immigrant allocation probabilities sorted in ascending order. The
'*** probabilities is used to allocate immigrant households to the appropriate municipality.
For i = 1 To 289
allokprobs(i, 1) = kommundata(i).immig_loc / 100
allokprobs(i, 2) = i
Next
Call SORTMATRIX(289, 2, allokprobs(1, 1))
' Clone housholds marked in mark vector
For i = 1 To m_hcount
If mark_h(i) = 1 Then
' Houshold vectors
' New household nr
största_hhnr = största_hhnr + 1
' Do we have to enlarge vectors?
If m_hcount >= UBound(h_hhnr) Then
Call dyn_vect_h(m_hcount + 500)
'Debug.Print "allocating memory - clone_hh"
End If
' Increase number of housholds
m_hcount = m_hcount + 1
' Set important variables
h_hhnr(m_hcount) = största_hhnr
h_first_indnr(m_hcount) = största_indnr + 1
' Increase pointer vector if necessary
If UBound(hhnr2index) < största_hhnr Then
ReDim Preserve hhnr2index(största_hhnr + 100) As Long
' ReDim Preserve hhnr2index_lag(största_hhnr + 100) As Long
'Debug.Print "allocating memory - clone_hh"
End If
' Set pointer vector
hhnr2index(största_hhnr) = m_hcount
' SOME IMPORTANT VARIABLES ARE DEFINED OR COPIED FROM THE "CLONED" HOUSEHOLD -
' THE OTHERS ARE SET TO ZERO
h_abroad(m_hcount) = 0
h_new_immig(m_hcount) = 1
h_n_adults(m_hcount) = h_n_adults(i)
h_size(m_hcount) = h_size(i)
h_n_child(m_hcount) = h_n_child(i)
h_n_childlt12(m_hcount) = h_n_childlt12(i)
h_n_childlt7(m_hcount) = h_n_childlt7(i)
h_n_ge18(m_hcount) = h_n_ge18(i)
h_new_housing(m_hcount) = 1 ' marked for tenure choice
' Individual vectors
indi_nr = 0
' allocate immigrant household to one municipality
rand = Rnd
probsum = 0 'cumulative probability
For h = UBound(allokprobs) To 1 Step -1
probsum = probsum + allokprobs(h, 1)
If rand <= probsum Then
h_kommunindex(m_hcount) = allokprobs(h, 2)
h_kommunkod(m_hcount) = kommundata(h_kommunindex(m_hcount)).kod
h_BB_region(m_hcount) = BB_Region(h_kommunkod(m_hcount))
Exit For
End If
Next
' Clone every member
For h = 1 To get_hh_size(h_hhnr(i))
' First member in houshold
If h = 1 Then indi_nr = h_first_indnr(i)
' Following members in houshold
If h > 1 Then indi_nr = i_next_indnr(indnr2index(indi_nr))
' New individual number
största_indnr = största_indnr + 1
' Increase vectors if necessary
If m_icount >= UBound(i_indnr) Then
Call dyn_vect_i(m_icount + 500)
End If
m_icount = m_icount + 1
' New individual nr
i_indnr(m_icount) = största_indnr
' Increase pointer vector if necessary
If UBound(indnr2index) < största_indnr Then
ReDim Preserve indnr2index(största_indnr + 100) As Long
End If
' Set pointer vector
indnr2index(största_indnr) = m_icount
' Set important variables
i_hhnr(m_icount) = största_hhnr
If h < get_hh_size(h_hhnr(i)) Then
i_next_indnr(m_icount) = största_indnr + 1
Else
i_next_indnr(m_icount) = 0
End If
' SOME IMPORTANT VARIABLES ARE DEFINED OR COPIED FROM THE "CLONED" INDIVIDUAL -
' THE OTHERS ARE SET TO ZERO
i_binvar(m_icount) = model_time + base_year
i_born_abroad(m_icount) = 1
i_new_immig(m_icount) = 2 '*** First time immigrant
i_age(m_icount) = i_age(indnr2index(indi_nr))
i_sex(m_icount) = i_sex(indnr2index(indi_nr))
i_born_year(m_icount) = i_born_year(indnr2index(indi_nr))
i_bvux(m_icount) = i_bvux(indnr2index(indi_nr))
i_bvux1(m_icount) = i_bvux1(indnr2index(indi_nr))
i_civ_stat(m_icount) = i_civ_stat(indnr2index(indi_nr))
i_edlevel(m_icount) = i_edlevel(indnr2index(indi_nr))
i_edyears(m_icount) = i_edyears(indnr2index(indi_nr))
i_BB_region(m_icount) = h_BB_region(m_hcount)
' Write to history db
lifehist.write_hist i_indnr(m_icount), "Immigrate"
Next
End If
Next
Call dyn_vect_h(m_hcount) 'To keep data vectors packed
Call dyn_vect_i(m_icount) 'To keep data vectors packed
End Sub
Public Sub read_data(timetoread)
Printdok "read_data"
Dim timetxt As String, infil As String
Dim fnum As Integer
' Collection of variable names
If var_coll.count = 0 Then Call init_var_coll
' Read macro variables
If timetoread >= 0 Then
fnum = FreeFile
infil = sesimpath & "\microdata\mm" & Format$(timetoread, "00000") & ".out"
Open infil For Binary As fnum
Call read_m_bin(fnum)
Close fnum
End If
' Read indiviudals
infil = sesimpath & "\microdata\ii" & Format$(timetoread, "00000") & ".out"
If timetoread = -1 Then infil = sesimpath & "\microdata\ii.bin"
'If timetoread = -1 Then infil = "e:\ii.bin"
fnum = FreeFile
Open infil For Binary As fnum
Call read_i_bin(fnum)
Close fnum
If m_icount = 0 Then Exit Sub
' Read households
fnum = FreeFile
infil = sesimpath & "\microdata\hh" & Format$(timetoread, "00000") & ".out"
If timetoread = -1 Then infil = sesimpath & "\microdata\hh.bin"
'If timetoread = -1 Then infil = "e:\hh.bin"
Open infil For Binary As fnum
Call read_h_bin(fnum)
Close fnum
If m_hcount = 0 Then Exit Sub
controlcenter.antalindivider.Caption = m_icount
controlcenter.antalhushåll.Caption = m_hcount
controlcenter.antalindivider.Refresh
controlcenter.antalhushåll.Refresh
controlcenter.label_tid.Caption = model_time
controlcenter.lblYear.Caption = CStr(base_year + model_time)
'*** Create important household variables
Dim h As Long, indnr As Long
Dim hsize As Integer, n_adults As Integer, n_child As Integer
'*** Loop across all households
For h = 1 To m_hcount
n_adults = 0
n_child = 0
indnr = h_first_indnr(h)
'*** Loop across all household members and count adults and children
Do Until indnr = 0
If i_bvux(indnr2index(indnr)) = 1 Then
n_adults = n_adults + 1
Else
n_child = n_child + 1
End If
indnr = i_next_indnr(indnr2index(indnr))
Loop
h_size(h) = n_adults + n_child
h_n_child(h) = n_child
Next
'*** Check important variables
Call do_checks("After read data")
End Sub
Public Sub Write_Data()
Printdok "write_data"
Dim fnum As Integer
Dim nhh As Long, i As Long
status "Writing binary data"
' Write macro variables
fnum = FreeFile
Open sesimpath & "\microdata\mm" & Format$(model_time, "00000") & ".out" For Binary As fnum
Call write_m_bin(fnum)
Close fnum
' Write indiviudals
fnum = FreeFile
Open sesimpath & "\microdata\ii" & Format$(model_time, "00000") & ".out" For Binary As fnum
Call write_i_bin(fnum)
ReDim Preserve indnr2index(största_indnr)
Put #fnum, , indnr2index
Put #fnum, , pp_hist
Close fnum
' Write households
fnum = FreeFile
' Open "c:\sesim\microdata\hh" & CStr(model_time) & ".out" For Binary As fnum
Open sesimpath & "\microdata\hh" & Format$(model_time, "00000") & ".out" For Binary As fnum
Call write_h_bin(fnum)
ReDim Preserve hhnr2index(största_hhnr)
Put #fnum, , hhnr2index
Close fnum
If model_time <= 59 Then controlcenter.chkDataexist(model_time).enabled = True
status "Writing done"
End Sub
Public Function gauss(m As Double, s As Double) As Double
Dim w As Double, x1 As Double, x2 As Double, y1 As Double, y2 As Double
w = 100
Do While w >= 1
x1 = 2# * Rnd - 1#
x2 = 2# * Rnd - 1#
w = x1 * x1 + x2 * x2
Loop
w = Sqr((-2 * Log(w)) / w)
y1 = x1 * w
y2 = x2 * w
gauss = m + s * y1
End Function
Public Function gauss_2(m As Double, s As Double, ByVal indnr As Long) As Double
Dim w As Double, x1 As Double, x2 As Double, y1 As Double, y2 As Double
w = 100
Rnd (-1)
Randomize (indnr)
Do While w >= 1
x1 = 2# * Rnd - 1#
x2 = 2# * Rnd - 1#
w = x1 * x1 + x2 * x2
Loop
w = Sqr((-2 * Log(w)) / w)
y1 = x1 * w
y2 = x2 * w
gauss_2 = m + s * y1
End Function
' This routine clears some public helpvectors
Public Sub clear_marks()
ReDim mark_i(1 To m_icount)
ReDim stack_i(1 To m_icount)
ReDim mark_h(1 To m_hcount)
stack_size = 0
End Sub
Public Sub match_couples()
Dim f As Long, m As Long, k As Integer, indnr As Long, i As Long
Dim firstind As Long, age_diff As Integer, j As Long
Dim m_idx As Long, f_idx As Long, mh_idx As Long, fh_idx As Long
Dim housenetgain As Long
Call clear_marks
For f = 1 To pool_female_size
For age_diff = 0 To 5
For m = 1 To pool_male_size
' calculate index numbers for shorter notation below...
m_idx = indnr2index(pool_male(m))
mh_idx = hhnr2index(i_hhnr(m_idx))
f_idx = indnr2index(pool_female(f))
fh_idx = hhnr2index(i_hhnr(f_idx))
'*** Women are on the average three years younger than their spouses.
'*** (See S:\SESIM\Dokument\Dokumentation\SESIM\Estimation\cohab_split)
'*** NOTE: Spouses has to live in the same region. This prevents the "excess migration"
'*** among men that arises without this restriction (TP050321).
If mark_i(m) = 0 And _
Abs(i_age(m_idx) - 3 - i_age(f_idx)) <= age_diff And _
h_BB_region(mh_idx) = h_BB_region(fh_idx) Then
lifehist.write_hist pool_female(f), "Pair with " & pool_male(m)
lifehist.write_hist pool_male(m), "Pair with " & pool_female(f)
' Mark male hh for delete
mark_h(mh_idx) = 1
lifehist.write_hist pool_male(m), "Delete hh (cohab)"
' update hh-info for female
h_n_adults(fh_idx) = 2
h_n_child(fh_idx) = h_n_child(fh_idx) + h_n_child(mh_idx)
h_size(fh_idx) = h_n_adults(fh_idx) + h_n_child(fh_idx)
h_n_ge18(fh_idx) = h_n_ge18(fh_idx) + h_n_ge18(mh_idx)
h_form_year(fh_idx) = base_year + model_time
' Resetting variance components
h_wealth_debt_interest_varcomp_p(fh_idx) = 0
h_wealth_debt_interest_varcomp_r(fh_idx) = 0
h_wealth_debt_varcomp(fh_idx) = 0
h_wealth_financial_varcomp(fh_idx) = 0
h_wealth_debt_GLS1vc(fh_idx) = 0
h_wealth_debt_GLS2vc(fh_idx) = 0
h_wealth_debt_probit1vc(fh_idx) = 0
h_wealth_debt_probit2vc(fh_idx) = 0
' Updating civil status (i_civ_stat = 1 denotes cohabitation)
i_civ_stat(m_idx) = 1
i_civ_stat(f_idx) = 1
'Next step is not necessary at present. It is included for the possibility
'of matching people abroad or in case that latest emigration year become a
'parameter of interest. (Fredrik 15/10-01)
h_emig_year(fh_idx) = maxi(i_emig_year(m_idx), i_emig_year(f_idx)) 'Detta är en ny rad
'*** Handle cases where the man owns a home
If h_house_owner(mh_idx) = 1 Then
'*** 1) The man is a homeowner but the woman is not.
'*** The new family takes over the housing situation of the male households .
If h_house_owner(fh_idx) = 0 Then
h_house_area(fh_idx) = h_house_area(mh_idx)
h_house_cost(fh_idx) = h_house_cost(mh_idx)
h_house_interest(fh_idx) = h_house_interest(mh_idx)
h_house_purchase(fh_idx) = h_house_purchase(mh_idx)
h_house_owner(fh_idx) = h_house_owner(mh_idx)
h_house_tax(fh_idx) = h_house_tax(mh_idx)
' Calculate aggregates of financial variables
h_wealth_real_home(fh_idx) = h_wealth_real_home(fh_idx) + h_wealth_real_home(mh_idx)
h_wealth_real_other(fh_idx) = h_wealth_real_other(fh_idx) + h_wealth_real_other(mh_idx)
h_wealth_real(fh_idx) = h_wealth_real_home(fh_idx) + h_wealth_real_other(fh_idx)
h_wealth_financial(fh_idx) = h_wealth_financial(fh_idx) + h_wealth_financial(mh_idx)
h_wealth_debt(fh_idx) = h_wealth_debt(fh_idx) + h_wealth_debt(mh_idx)
'*** 2) Both man and woman are homeowners
'*** The man sells his house and moves in with the woman
Else
Dim HouseSellingPrice As Long
HouseSellingPrice = h_wealth_real_home(mh_idx)
' Real wealth of home is temporarily set to zero before the call to
' HandleHouseSalesPurchase. This handles a sale with no new purchase.
h_wealth_real_home(mh_idx) = 0
Call HandleHouseSalesPurchase(m_idx, HouseSellingPrice, 1)
' Real wealth of home is restored
h_wealth_real_home(mh_idx) = HouseSellingPrice
' Calculate aggregates of financial variables
h_wealth_real_other(fh_idx) = h_wealth_real_other(fh_idx) + h_wealth_real_other(mh_idx)
h_wealth_real(fh_idx) = h_wealth_real_home(fh_idx) + h_wealth_real_other(fh_idx)
h_wealth_financial(fh_idx) = h_wealth_financial(fh_idx) + h_wealth_financial(mh_idx)
h_wealth_debt(fh_idx) = h_wealth_debt(fh_idx) + h_wealth_debt(mh_idx)
End If
End If
' new hhnr to all members in mans hh from female
firstind = h_first_indnr(mh_idx)
indnr = firstind
Do Until indnr = 0
i_hhnr(indnr2index(indnr)) = i_hhnr(f_idx)
lifehist.write_hist indnr, "New hhnr (cohab)"
indnr = i_next_indnr(indnr2index(indnr))
Loop
' set last ind in females hh poiting to first in mans hh
i_next_indnr(indnr2index(get_hhlast_indnr(i_hhnr(f_idx)))) = firstind
Call Individualize_Debt(fh_idx)
Call Individualize_FinancialWealth(fh_idx)
' This man is now unavailable
mark_i(m) = -1
age_diff = 9999
Exit For ' no need to look at other age differences
End If
Next ' loop over male pool
Next ' loop over age differences
Next 'loop over female pool
' Time to delete households
j = m_hcount
For i = 1 To m_hcount
If mark_h(i) = 1 Then
hhnr2index(h_hhnr(i)) = 0
j = j - 1
End If
Next
Call shift_up_marked_hh
m_hcount = j
For i = 1 To m_hcount
hhnr2index(h_hhnr(i)) = i
' Clear vector
mark_h(i) = 0
Next
Call dyn_vect_h(m_hcount)
End Sub
Public Function getword(str, wordno, sep) As String
Dim i As Integer, j As Integer
Dim ord As String
Dim sökstr As String, tkn As String
sökstr = str
ord = ""
If wordno < 0 Then
For i = Len(str) To 1 Step -1
ord = ord & Mid$(str, i, 1)
Next
sökstr = ord
ord = ""
wordno = wordno * -1
End If
getword = ""
j = 1
For i = 1 To Len(str)
tkn = Mid$(sökstr, i, 1)
If tkn <> sep Then ord = ord & tkn
If Len(ord) > 0 And (tkn = sep Or i = Len(str)) Then
If j = wordno Then
getword = ord
If sökstr <> str Then
getword = ""
For j = Len(ord) To 1 Step -1
getword = getword & Mid$(ord, j, 1)
Next
End If
Exit Function
End If
j = j + 1
ord = ""
End If
Next
End Function
'***************************************************************************
' Function findlimit calculated the threshold value for selection of the K
' largest elements in an array of doubles.
'***************************************************************************
Public Function findlimit(arr() As Double, wanted_count As Long, deviation_allowed As Double) As Double
' Calling parameters
' 1. Array to be searched
' 2. Wanted count
' 3. Deviation allowed ( 0 - )
Dim i As Long
Dim limit(1 To 3) As Double
Dim limitcount(1 To 3) As Long
'status "Wanted: " & CStr(wanted_count)
' Find min and max
limit(1) = 9.9E+100
limit(3) = -9.9E+100
For i = 1 To UBound(arr)
If arr(i) < limit(1) Then limit(1) = 0.9 * arr(i)
If arr(i) > limit(3) Then limit(3) = 1.1 * arr(i)
Next
limitcount(1) = UBound(arr)
limitcount(3) = 0
' Use the midpoint value as the initial threshold value
limit(2) = limit(1) + (limit(3) - limit(1)) / 2
limitcount(2) = 0
' Count number of elements given the initial threshold
For i = 1 To UBound(arr)
If arr(i) > limit(2) Then limitcount(2) = limitcount(2) + 1
Next
Dim oldlimitcount As Long
oldlimitcount = -999999
Dim ggr As Integer
ggr = 0
Do While Abs(limitcount(2) - wanted_count) > deviation_allowed
oldlimitcount = limitcount(2)
ggr = ggr + 1
If ggr > 20 Then
Debug.Print "findlimit: maxiter overflow!"
If limitcount(2) <> 0 Then
Debug.Print "reldiff = " & wanted_count / limitcount(2)
End If
Debug.Print "absdiff = " & wanted_count - limitcount(2)
Exit Do
End If
' If too high threshold -> decrease it
If wanted_count < limitcount(2) Then
limit(1) = limit(2)
limitcount(1) = limitcount(2)
limit(2) = limit(1) + (limit(3) - limit(1)) / 2
If limitcount(3) - limitcount(2) > 0 Then
limit(2) = limit(1) + (wanted_count - limitcount(2)) / (limitcount(3) - limitcount(2)) * (limit(3) - limit(1)) / 2
End If
limitcount(2) = 0
' If to low threshold -> increase it
Else
limit(3) = limit(2)
limitcount(3) = limitcount(2)
limit(2) = limit(1) + (limit(3) - limit(1)) / 2
If limitcount(2) - limitcount(1) > 0 Then
limit(2) = limit(1) + (wanted_count - limitcount(1)) / (limitcount(2) - limitcount(1)) * (limit(3) - limit(1)) / 2
End If
limitcount(2) = 0
End If
' Count number of elements given the calculated threshold
For i = 1 To UBound(arr)
If arr(i) > limit(2) Then limitcount(2) = limitcount(2) + 1
Next
Loop
findlimit = limit(2)
End Function
Public Sub Printdok(txt)
If model_time < 2 Then
Print #101, "Time=" & CStr(model_time) & " " & txt
End If
End Sub
Public Function username()
Dim lpBuffer As String
Dim nsize As Long
Dim nreturn As Long
lpBuffer = Space(255)
nsize = 255
nreturn = GetUserName(lpBuffer, nsize)
lpBuffer = Trim(lpBuffer)
nsize = Len(lpBuffer)
Dim i As Integer
username = ""
For i = 1 To nsize
If Asc(Mid$(lpBuffer, i, 1)) > 32 And Asc(Mid$(lpBuffer, i, 1)) < 128 Then
username = username & Mid$(lpBuffer, i, 1)
End If
Next
username = LCase(username)
End Function
Public Function compname()
compname = ""
Dim ComputerName$, CName$, Success As Long
ComputerName$ = String$(1024, 32)
Success = GetComputerName(ComputerName$, 1024)
If Success Then
CName = LTrim(RTrim(ComputerName$))
' MsgBox "Computer Name Is/* Black */
.o2k7SkinBlack .mceToolbar .mceToolbarStart span, .o2k7SkinBlack .mceToolbar .mceToolbarEnd span, .o2k7SkinBlack .mceButton, .o2k7SkinBlack .mceSplitButton, .o2k7SkinBlack .mceSeparator, .o2k7SkinBlack .mceSplitButton a.mceOpen, .o2k7SkinBlack .mceListBox a.mceOpen {background-image:url(img/button_bg_black.png)}
.o2k7SkinBlack table, .o2k7SkinBlack .mceMenuItemTitle a, .o2k7SkinBlack .mceMenuItemTitle span.mceText, .o2k7SkinBlack .mceStatusbar div, .o2k7SkinBlack .mceStatusbar span, .o2k7SkinBlack .mceStatusbar a {background:#535353; color:#FFF}
.o2k7SkinBlack table.mceListBoxEnabled .mceText, o2k7SkinBlack .mceListBox .mceText {background:#FFF; border:1px solid #CBCFD4; border-bottom-color:#989FA9; border-right:0}
.o2k7SkinBlack table.mceListBoxEnabled:hover .mceText, .o2k7SkinBlack .mceListBoxHover .mceText, .o2k7SkinBlack .mceListBoxSelected .mceText {background:#FFF; border:1px solid #FFBD69; border-right:0}
.o2k7SkinBlack .mceExternalToolbar, .o2k7SkinBlack .mceListBox .mceText, .o2k7SkinBlack div.mceMenu, .o2k7SkinBlack table.mceLayout, .o2k7SkinBlack .mceMenuItemTitle a, .o2k7SkinBlack table.mceLayout tr.mceFirst td, .o2k7SkinBlack table.mceLayout, .o2k7SkinBlack .mceMenuItemTitle a, .o2k7SkinBlack table.mceLayout tr.mceLast td, .o2k7SkinBlack .mceIframeContainer {border-color: #535353;}
.o2k7SkinBlack table.mceSplitButtonEnabled:hover a.mceAction, .o2k7SkinBlack .mceSplitButtonHover a.mceAction, .o2k7SkinBlack .mceSplitButtonSelected {background-image:url(img/button_bg_black.png)}
.o2k7SkinBlack .mceMenu .mceMenuItemEnabled a:hover, .o2k7SkinBlack .mceMenu .mceMenuItemActive {background-color:#FFE7A1} urce
Do
index = InStr(index, ReplaceWord, Find, compare)
If index = 0 Then Exit Do
replaceIt = False
' check that it is preceded by a punctuation symbol
If index > 1 Then
charcode = Asc(UCase$(Mid$(ReplaceWord, index - 1, 1)))
Else
charcode = 32
End If
If (charcode < 65 Or charcode > 90) And charcode <> 95 Then
' check that it is followed by a punctuation symbol
charcode = Asc(UCase$(Mid$(ReplaceWord, index + Len(Find), _
1)) & " ")
If (charcode < 65 Or charcode > 90) And charcode <> 95 Then
replaceIt = True
End If
End If
If replaceIt Then
' do the replacement
ReplaceWord = Left$(ReplaceWord, index - 1) & ReplaceStr & Mid$ _
(ReplaceWord, index + findLen)
' skip over the string just added
index = index + replaceLen
' increment the replacement counter
counter = counter + 1
Else
' skip over this false match
index = index + findLen
End If
' Note that the Loop Until test will always fail if Count = -1
Loop Until counter = count
End Function
Public Sub get_malefemale_indnr(hh_nr As Long, indnrMale As Long, indnrFemale As Long)
Dim indnr As Long
Dim indexnr As Long
indnrMale = 0
indnrFemale = 0
indnr = h_first_indnr(hhnr2index(hh_nr))
Do While indnr <> 0
indexnr = indnr2index(indnr)
If i_bvux(indexnr) = 1 Then
If i_sex(indexnr) = 1 Then indnrMale = indnr
If i_sex(indexnr) = 2 Then indnrFemale = indnr
End If
indnr = i_next_indnr(indnr2index(indnr))
Loop
End Sub
'*******************************************************************************
' Sub Pack_Pension_Hist() packs the pension-point histories so that a minimum of
' memory is allocated. This is needed after reading from binary file.
'*******************************************************************************
Public Sub Pack_Pension_Hist()
Dim i As Long
For i = 1 To UBound(pp_hist)
If pp_hist(i).n_years > 0 Then
ReDim Preserve pp_hist(i).pp(pp_hist(i).n_years)
ReDim Preserve pp_hist(i).pp_years(pp_hist(i).n_years)
Else
Erase pp_hist(i).pp
Erase pp_hist(i).pp_years
End If
Next
End Sub
'*****************************************************************************
' Calculates the mean ATP-score - average of fifteen best ATP-scores.
' If less that fifteen scores are available the average of the existing scores
' are returned.
'*****************************************************************************
Public Function f_mean_ATP(indnr As Long) As Integer
Dim sum As Long
Dim mean As Long
Dim i As Integer, j As Integer
sum = 0
mean = 0
If pp_hist(indnr).n_years = 0 Then
f_mean_ATP = 0
Else
If pp_hist(indnr).n_years <= 15 Then
For i = 1 To pp_hist(indnr).n_years
sum = sum + pp_hist(indnr).pp(i)
Next i
f_mean_ATP = round(CDbl(sum / pp_hist(indnr).n_years), 0)
Else
Dim atpvec(15) As Integer
Dim min_idx As Integer
min_idx = 1
' Load the first 15 and find the smallest score
For i = 1 To 15
atpvec(i) = pp_hist(indnr).pp(i)
If atpvec(i) < atpvec(min_idx) Then min_idx = i
Next i
' Successive replacement of the smallest element in atpvec until largest 15 found
For i = 16 To pp_hist(indnr).n_years
If pp_hist(indnr).pp(i) > atpvec(min_idx) Then
atpvec(min_idx) = pp_hist(indnr).pp(i)
' Find new smallest element
min_idx = 1
For j = 1 To 15
If atpvec(j) < atpvec(min_idx) Then min_idx = j
Next j
End If
Next i
For i = 1 To 15
sum = sum + atpvec(i)
Next i
f_mean_ATP = round(CDbl(sum / 15), 0)
End If
End If
End Function
'*****************************************************************************
' Calculates the number of years of ATP-scores > x basic amounts
'*****************************************************************************
Public Function pp_hist_limit(indnr As Long, lim As Integer) As Integer
Dim i As Integer
pp_hist_limit = 0
If pp_hist(indnr).n_years > 0 Then
For i = 1 To pp_hist(indnr).n_years '-- Test if > limit basbel
If pp_hist(indnr).pp(i) > lim Then '*** Skalat 100x. Lagrar antal basb-1
pp_hist_limit = pp_hist_limit + 1
End If
Next i
End If
End Function
' -- Sorting procedure (modified version of the procedure decribed in "Programming VB 6"
' , sid 176 (Microsoft press)
' The array n_ calculates the rank for the elements in the orginal (unsorted) array
' Example: Call Sort(xx, False)
' where xx is an array
' False=descending, True=ascending
' Defined with Bygger på option base 1
Public Sub Sort(arr As Variant, descending As Boolean)
Dim index As Long, index2 As Long, firstItem As Long
Dim distance As Long, value As Variant
Dim rang As Long, numEls As Long, i As Long
' Exit if it is not an array
If vartype(arr) < vbArray Then Exit Sub
firstItem = LBound(arr)
numEls = UBound(arr)
ReDim n_(numEls)
For i = 1 To numEls
n_(i) = i
Next
' Find the best value for distance
Do
distance = distance * 3 + 1
Loop Until distance > numEls
' Sort the array
Do
distance = distance \ 3 ' Note: \ = integer divsion operator
For index = distance + firstItem To numEls + firstItem - 1
value = arr(index)
rang = n_(index)
index2 = index
Do While (arr(index2 - distance) > value) Xor descending
arr(index2) = arr(index2 - distance)
n_(index2) = n_(index2 - distance)
index2 = index2 - distance
If index2 - distance < firstItem Then Exit Do
Loop
arr(index2) = value
n_(index2) = rang
Next
Loop Until distance = 1
End Sub
'**********************************************************************
' Function percentile returns a named percentile from a supplied
' data vector.
' Arguments:
' alpha (IN) : percentile (1 - 100)
' data (IN) : data vector
'**********************************************************************
Public Function Percentile(ALPHA As Integer, data() As Double) As Double
Dim Sorted() As Double, index As Long
ReDim Sorted(UBound(data)) As Double
' Call D_SORTVEC(DATA(1), UBound(DATA), Sorted(1))
Sorted = wrap_D_SORTVEC(data, Sorted)
index = Ceiling((ALPHA / 100) * UBound(data))
If (UBound(data) Mod 2 = 0) Then ' even number of elements
Percentile = (Sorted(index) + Sorted(index + 1)) / 2
Else ' odd number of elements
Percentile = Sorted(index)
End If
End Function
'**********************************************************************
' Function floor returns a supplied number rounded downwards
' Arguments:
' number (IN) : arbitrary number
'**********************************************************************
Public Function Floor(Number) As Long
Floor = Int(Number)
End Function
'**********************************************************************
' Function Ceiling returns a supplied number rounded upwards
' Arguments:
' number (IN) : arbitrary number
'**********************************************************************
Public Function Ceiling(Number As Double) As Long
Ceiling = -Int(-Number)
End Function
'**********************************************************************
' Function PrintFile is used for debugging purposes. PrintFile writes
' the given data vector to the names textfile deleting the files
' previous contents.
' Arguments:
' filename: the name of the textfile
' data: the vector to be written to file
' returnvalue: 0 - error in write, 1 - successful write
'**********************************************************************
Public Function PrintFile(filename As String, data As Variant) As Integer
Dim filenr As Integer, i As Long
On Error Resume Next
PrintFile = 1
filenr = FreeFile
Open filename For Output As #filenr
For i = LBound(data) To UBound(data)
Print #filenr, data(i)
Next i
Close #filenr
If Err.Number <> 0 Then
PrintFile = 0
End If
End Function
'**********************************************************************
' Function HouseholdInfo returns a description of the specified
' household containing some important household variables and individual
' variables for all individuals in the household. Useful for debugging
' purposes.
' Arguments:
' hhnr: the household identity number (i.e. not the index number)
'**********************************************************************
Public Function HouseholdInfo(hhnr As Long) As String
Dim txt As String, hidx As Long, iidx As Long, indnr As Long, count As Integer
On Error Resume Next
hidx = hhnr2index(hhnr)
txt = "*** household ***" & vbCrLf & _
"hhnr: " & hhnr & vbCrLf & _
"hhnr2index: " & hidx & vbCrLf & _
"h_first_indnr: " & h_first_indnr(hidx) & vbCrLf & _
"h_n_adults: " & h_n_adults(hidx) & vbCrLf & _
"h_n_child: " & h_n_child(hidx) & vbCrLf & _
"h_size: " & h_size(hidx) & vbCrLf & _
"h_abroad: " & h_abroad(hidx) & vbCrLf & vbCrLf
indnr = h_first_indnr(hidx)
iidx = indnr2index(indnr)
count = 1
Do While indnr <> 0
txt = txt & "*** individual " & count & " ***" & vbCrLf & _
"i_indnr: " & indnr & vbCrLf & _
"i_indnr2idx: " & iidx & vbCrLf & _
"i_next_indnr: " & i_next_indnr(iidx) & vbCrLf & _
"i_bvux: " & i_bvux(iidx) & vbCrLf & _
"i_age: " & i_age(iidx) & vbCrLf & _
"i_sex: " & i_sex(iidx) & vbCrLf & _
"i_civstat: " & i_civ_stat(iidx) & vbCrLf & _
"i_status: " & i_status(iidx) & vbCrLf & vbCrLf
indnr = i_next_indnr(iidx)
If indnr > 0 Then iidx = indnr2index(indnr)
count = count + 1
Loop
HouseholdInfo = txt
If Err.Number <> 0 Then
HouseholdInfo = "ERROR"
End If
End Function
'************************************************************************************
'*** The following function "f_delningstal" and subroutines "stock_sub", "död_sub", "dödsrisk_sub" and "Spline"
'*** are used to calculate partitioning values
Public Function f_delningstal(ålder As Byte, Optional dtal As Double = 1.016) As Variant
Dim deltal As Double
Dim lx(0 To 106) As Double
Dim lx5(0 To 106) As Double
Dim Dubbelsumma As Double
Const lx_start As Long = 100000
Dim age As Integer
Dim x As Integer
Dubbelsumma = 0
If ålder > 106 Then ålder = 106
For age = 0 To 106
If age = 0 Then
lx(age) = lx_start * (1 - dtal_dödsrisk(age))
Else
lx(age) = lx(age - 1) * (1 - dtal_dödsrisk(age))
End If
Next
For age = 0 To 106
If age > 0 Then
If age < 106 Then
lx5(age) = (lx(age) + lx(age + 1)) / 2
Else
lx5(age) = lx(age)
End If
End If
Next
For age = ålder To 105
For x = 0 To 11
Dubbelsumma = Dubbelsumma + (dtal) ^ (-(age - ålder)) * _
(lx5(age) + (lx5(age + 1) - lx5(age)) _
* (x / 12)) * (dtal) ^ (-x / 12)
Next
Next
f_delningstal = Dubbelsumma / (12 * lx5(ålder))
End Function
'Kallas ifrån Demografics i inledningen av Mortality()
Sub stock_sub()
Dim year As Integer
Dim age As Integer
Dim sex As Integer
Dim i As Long
year = (model_time + base_year - 3) Mod 10
For age = 0 To 106
For sex = 1 To 2
dtal_stock(age, year, sex) = 0
Next
Next
For i = 1 To m_icount
age = i_age(i)
sex = i_sex(i)
If age > 106 Then age = 106
dtal_stock(age, year, sex) = dtal_stock(age, year, sex) + 1
Next
End Sub
'Kallas i Demografics under "Rand_mort" alldeles före "Call delete_individuals"
Sub död_sub()
Dim year As Integer
Dim age As Integer
Dim sex As Integer
Dim i As Long
year = (model_time + base_year - 3) Mod 10
For age = 0 To 106
For sex = 1 To 2
dtal_död(age, year, sex) = 0
Next
Next
For i = 1 To m_icount
age = i_age(i)
sex = i_sex(i)
If age > 106 Then age = 106
If mark_i(i) = 1 Then
dtal_död(age, year, sex) = dtal_död(age, year, sex) + 1
End If
Next
End Sub
'Kallas ifrån Demografics i slutet av Mortality()
Sub dödsrisk_sub()
Dim antal_stock(0 To 106, 0 To 9) As Long
Dim antal_död(0 To 106, 0 To 9) As Long
Dim age As Integer
Dim sex As Integer
Dim year As Integer
Dim dödsrisk1(0 To 106, 0 To 9) As Double
Dim dödsrisk2(0 To 106) As Double
If model_time < 10 Then
For age = 0 To 106
dödsrisk2(age) = (0.5145 * parm_death(mini(base_year + model_time, 2110), age, 1) + _
(1 - 0.5145) * parm_death(mini(base_year + model_time, 2110), age, 2))
Next
Else
For age = 0 To 29
dödsrisk2(age) = (0.5145 * parm_death(mini(base_year + model_time, 2110), age, 1) + _
(1 - 0.5145) * parm_death(mini(base_year + model_time, 2110), age, 2))
Next
Dim större_än_noll
For age = 30 To 106
dödsrisk2(age) = 0
större_än_noll = 0
For sex = 1 To 2
For year = 0 To 9
antal_stock(age, year) = antal_stock(age, year) + dtal_stock(age, year, sex)
antal_död(age, year) = antal_död(age, year) + dtal_död(age, year, sex)
Next
Next
'Variabeln "större_än_noll" används för att enbart dividera summan av dödsriskerna
'där antalet döda är en strikt positivt tal.
For year = 0 To 9
If antal_död(age, year) > 0 Then större_än_noll = större_än_noll + 1
If antal_stock(age, year) > 0 Then
dödsrisk1(age, year) = antal_död(age, year) / antal_stock(age, year)
Else
dödsrisk1(age, year) = 0
End If
dödsrisk2(age) = dödsrisk2(age) + dödsrisk1(age, year)
Next
If större_än_noll = 0 Then
dödsrisk2(age) = 0
Else
dödsrisk2(age) = dödsrisk2(age) / större_än_noll '10
End If
Next
'Använd splines för att jämna ut dödsriskkurvan då värdena bygger på simulerings-
'uppgifter. Jag använder de punkter som anges i listan nedan.
End If
Call Spline(dödsrisk2)
End Sub
Sub Spline(ByRef ds() As Double)
Dim ndata As Long
Dim n As Long
ndata = 19
n = 106
Dim i As Integer
'Följande punkter är valda utifrån målet att nå stabilitet i dödsriskerna. De är kon-
'centrerade till början av livet och fram till 29 år. Dessa risker är hämtade direkt
'ifrån SCB-data. Därefter blir serien stabil först kring 50 år.
ReDim xdata(0 To ndata) As Double
xdata(0) = 0: xdata(1) = 1: xdata(2) = 2: xdata(3) = 3: xdata(4) = 4
xdata(5) = 5: xdata(6) = 6: xdata(7) = 7: xdata(8) = 8: xdata(9) = 9
xdata(10) = 10: xdata(11) = 16: xdata(12) = 20: xdata(13) = 25: xdata(14) = 29
xdata(15) = 50: xdata(16) = 60: xdata(17) = 80: xdata(18) = 105
ReDim fdata(0 To ndata) As Double
'Om ds är 0 så åsätts värdet ifrån SCB:s skattade dödsrisker. Värdena är logaritmerade
'eftersom det ger en bättre anpassning av hazardvärdena (de är nära linjärt stigande
'för åldrar över 30 år).
For i = 0 To ndata
If ds(xdata(i)) = 0 Then
' fdata(i) = Log((parm_death(mini(base_year + model_time,2050), xdata(i), 1) + parm_death(mini(base_year + model_time,2050), xdata(i), 2)) * 1000000 / 2)
fdata(i) = Log((0.5145 * parm_death(mini(base_year + model_time, 2110), xdata(i), 1) _
+ (1 - 0.5145) * parm_death(mini(base_year + model_time, 2110), xdata(i), 2)) _
* 1000000)
Else
fdata(i) = Log(ds(xdata(i)) * 1000000)
End If
Next
ReDim value(0 To n) As Double
ReDim xvec(0 To n) As Double
For i = 0 To n
xvec(i) = i
Next
Call SPLINE_C(ndata, xdata(0), fdata(0), n + 1, xvec(0), dtal_dödsrisk(0))
For i = 0 To n
dtal_dödsrisk(i) = Exp(dtal_dödsrisk(i)) / 1000000
Next
'Debug.Print "År " & model_time + base_year & " är delningstal för 65 år = " & f_delningstal(65)
End Sub
'*** END function and subroutines for calculation of partitioning value
'************************************************************************************
'********************* arr_Percentile-function ******************************************
'Function for calculating percentiles. The function take as arguments a double array
'and a list of requested percentiles (real numbers 0'a dynamic array in the calling procedure. Returned is an n*2 array where n is the number
'of specified percentiles.
'Example:
'* Dim perc() As Double 'Declare dynamic array
'* perc = Percentil(h_income, 25, 50, 75) 'Retreive 25, 50, 75 percentiles from
'array h_income into perc(3,2)
'* q25 = perc(1, 2) 'Create percentiles from perc (if necessary)
'* q50 = perc(2, 2)
'* q75 = perc(3, 2)
'**************************************************************************************
Public Function arr_Percentile(arr() As Double, ParamArray pctl_list()) As Variant
Dim i As Integer
Dim n_pctl As Integer
Dim x As Variant
Dim index As Long
ReDim arr1(1 To UBound(arr)) As Double
n_pctl = UBound(pctl_list) + 1 'Number of parameters in pctl_list
ReDim pctl(1 To n_pctl, 1 To 2) As Double
'Call D_SORTVEC(arr(1), UBound(arr), arr1(1))
arr1 = wrap_D_SORTVEC(arr, arr1)
i = 0
If (UBound(arr) Mod 2 = 0) Then ' even number of elements
For Each x In pctl_list
i = i + 1
index = Ceiling(UBound(arr1) * x / 100)
pctl(i, 2) = (arr1(index) + arr1(index + 1)) / 2
pctl(i, 1) = x
Next
Else
For Each x In pctl_list
i = i + 1
index = Ceiling(UBound(arr1) * x / 100)
pctl(i, 2) = arr1(index)
pctl(i, 1) = x
Next
End If
arr_Percentile = pctl
End Function
'***********************************************************************
' Function logit calculates the logit transformation of its argument
'***********************************************************************
Public Function logit(num As Double) As Double
If num > 0 And num < 1 Then
logit = Log(num / (1 - num))
Else
Debug.Print "ERROR: logit(x) is only defined for x in [0,1]!"
Debug.Print "x = " & num
logit = 0
End If
End Function
'**************************************************************************************
'*** Sub calc_emig_municipality() assigns Swedish municipaliy codes to every emigrant
'*** household. The sub should only be called in the initialization of SESIM.
'**************************************************************************************
Public Sub calc_emig_municipality()
'! Calculating emigrant municipality
status "Calculating emigrant municipality"
Printdok " calc_emig_municipality"
Dim h As Long, i As Long
Dim allokprobs() As Single
Dim rand As Double, probsum As Double
ReDim allokprobs(1 To 289, 1 To 2)
'*** Create a vector of population allocation probabilities sorted in ascending order. The
'*** probabilities are used to assign emigrated households to Swedish municipalities.
'*** NOTE: The probabilities are calculated from individual data and used on households -
'*** this will generate errors if the average household composition varies strongly between
'*** regions (TP010523).
For i = 1 To 289
allokprobs(i, 1) = kommundata(i).pop_loc / 100
allokprobs(i, 2) = i
Next
Call SORTMATRIX(289, 2, allokprobs(1, 1))
For h = 1 To m_hcount
' Loop across emigrant households to find maximum of emigration years
If h_abroad(h) = 1 Then
' allocate emigrated household to a Swedish municipality
rand = Rnd
probsum = 0 'cumulative probability
For i = UBound(allokprobs) To 1 Step -1
probsum = probsum + allokprobs(i, 1)
If rand <= probsum Then
h_kommunindex(h) = allokprobs(i, 2)
h_kommunkod(h) = kommundata(h_kommunindex(h)).kod
' h_la_region(h) = kommundata(h_kommunindex(h)).LA_region
h_BB_region(h) = BB_Region(h_kommunkod(h))
Exit For
End If
Next
End If 'abroad
Next 'household
End Sub
'*************************************************************************
' Sub calc_hh_emig_year is used in the initiation step to calculate the
' household emigration year from the emigration years of its members.
' The maximum of the individual emigration years is used.
' Also, the municipality code for emigrated households is imputed using the
' observed
' NOTE: For individuals with missing emigration year the observed mean
' emigration year (by age) from emigrated individuals with non-missing
' values is imputed.
'*************************************************************************
Public Sub calc_hh_emig_year()
'!Calculating emigration year
status "Calculating emigration year"
Printdok "calc_hh_emig_year "
Dim h As Long, inr As Long
Dim emigyear As Integer
Dim yhat As Double
For h = 1 To m_hcount
' Loop across emigrant households to find maximum of emigration years
If h_abroad(h) = 1 Then
emigyear = 0
' First i-nr
inr = h_first_indnr(hhnr2index(h))
Do Until inr = 0
' A missing value is imputed using a simple model - for documentation
' see folder: N:\FI_E4\Sesim\Dokumentation\_Sesim\Estimering\Migration\_
' Impute_emigration_year
If i_emig_year(indnr2index(inr)) = 0 And i_bvux(indnr2index(inr)) = 1 Then
yhat = CInt(2009.54226 - 0.61763 * mini(61, i_age(indnr2index(inr))))
i_emig_year(indnr2index(inr)) = mini(base_year, CInt(yhat))
End If
If i_emig_year(indnr2index(inr)) > emigyear Then _
emigyear = i_emig_year(indnr2index(inr))
' Next i-nr
inr = i_next_indnr(indnr2index(inr))
Loop
h_emig_year(h) = emigyear
'*** The calculation of household emigration year above generates too few households
'*** that emigrated during the period 1996 - 1999. This causes the immigration module
'*** to generate too few reimmigrating households since the probability to return to
'*** Sweden decreases with the time since emigration. Below this is corrected in a
'*** rather dirty way. TP020911
If h_emig_year(h) = 1997 Then h_emig_year(h) = 1996
If h_emig_year(h) = 1998 Then h_emig_year(h) = 1996
h_emig_year(h) = mini(h_emig_year(h) + 3, base_year)
End If
Next
End Sub
Public Function maxval(vec As Variant) As Variant
Dim i As Long
maxval = -1E+100
For i = LBound(vec) To UBound(vec)
If vec(i) > maxval Then maxval = vec(i)
Next
End Function
Public Function minval(vec As Variant) As Variant
Dim i As Long
minval = 1E+100
For i = LBound(vec) To UBound(vec)
If vec(i) < minval Then minval = vec(i)
Next
End Function
'*** Sub Write_output_data writes data to file in several formats.
'*** Output variables can be chosen.
'*** Both individual data and household data are written.
Public Sub Write_Output_Data_Old()
Printdok "Write_output_data"
'*** Optional debug output - set runtime parameter
If get_scalefactor("output_lifecycle_data") <> 1 Then
Dim filenr As Integer
Dim filename As String
Dim i As Long, hidx As Long
filenr = FreeFile
filename = sesimpath & "\tempdata\lifecycle.txt"
If model_time = 0 And Dir(filename) <> "" Then
Open filename For Output As #filenr
Else
Open filename For Append As #filenr
End If
'*** Header row
If model_time = 0 Then Print #filenr, _
"year,i_abroad,i_age,i_born_abroad,i_bvux,i_civ_stat," & _
"i_edlevel,i_hhnr,i_inc_taxable,i_surv," & _
"i_indnr,i_pc_total,i_sex,i_status,i_student," & _
"i_tax_total,i_arbavg,i_inc_capital,i_ap,i_ftp," & _
"i_trf_parentleave,i_trf_sickleave,h_trf_study,i_trf_unemployed," & _
"h_maintenance_received,h_n_adults,h_n_child," & _
"h_trf_btp,h_trf_childallowance,h_trf_housingallowance," & _
"h_trf_socialassistance,h_inc_disposable,i_inc_earning,i_sector,ppyears," & _
"i_tax_contribution,i_tax_income,i_op,h_studyloan_repaid"
'*** Data rows
For i = 1 To m_icount
hidx = (hhnr2index(i_hhnr(i)))
' If i_hhnr(i) <> h_hhnr(hidx) Then Debug.Print "fel i hhnr"
Write #filenr, base_year + model_time, i_abroad(i), i_age(i), _
i_born_abroad(i), i_bvux(i), i_civ_stat(i), i_edlevel(i), _
i_hhnr(i), i_inc_taxable(i), i_surv(i), i_indnr(i), _
i_pc_total(i), i_sex(i), i_status(i), i_student(i), _
i_tax_total(i), i_arbavg(i), i_inc_capital(i), i_ap(i), i_ftp(i), _
i_trf_parentleave(i), i_trf_sickleave(i), h_trf_study(hidx), _
i_trf_unemployed(i), _
h_maintenance_received(hidx), h_n_adults(hidx), h_n_child(hidx), _
h_trf_btp(hidx), h_trf_childallowance(hidx), h_trf_housingallowance(hidx), _
h_trf_socialassistance(hidx), h_inc_disposable(hidx), i_inc_earning(i), _
i_sector(i), pp_hist(i).n_years, i_tax_contribution(i), i_tax_income(i), i_op(i), _
h_studyloan_repaid(hidx)
Next
Close #filenr
End If
End Sub
'************************ BINARYSEARCH *****************************************
'Binary search in an array of type double
' Returns the index of the matching item, or 0 if the search fails
'
' The arrays *must* be sorted, in ascending or descending
' order (the routines finds out the sort direction).
' LASTEL is the index of the last item to be searched, and is
' useful if the array is only partially filled.
'
Public Function BinarySearch(arr() As Single, search As Single, _
Optional lastEl As Variant) As Long
Dim index As Long
Dim first As Long
Dim last As Long
Dim middle As Long
Dim inverseOrder As Boolean
' account for optional arguments
If IsMissing(lastEl) Then lastEl = UBound(arr)
first = LBound(arr)
last = lastEl
' deduct direction of sorting
inverseOrder = (arr(first) > arr(last))
' assume searches failed
BinarySearch = first - 1
Do
middle = (first + last) \ 2
If arr(middle) = search Then
BinarySearch = middle
Exit Do
ElseIf ((arr(middle) < search) Xor inverseOrder) Then
first = middle + 1
Else
last = middle - 1
End If
Loop Until first > last
End Function
'********************************QUICKSORT**********************************************
'Följande två subrutiner sorterar en matris med godtycklig dimension efter angiven nyckel
' Fredrik 030318
'****************************************************************************************
Public Sub quicksort(vArray() As Single, Sorteringsvariabel As Long)
If Sorteringsvariabel > UBound(vArray, 2) Then
MsgBox ("Sorteringsnyckeln = " & Sorteringsvariabel & vbNewLine & "Antalet kolumner är bara " & UBound(vArray, 2))
End
End If
If Sorteringsvariabel <= 0 Or Not IsNumeric(Sorteringsvariabel) Then
MsgBox ("Du måste ange ett värde på vilken kolumn som är sorteringsnyckel!")
End
End If
ReDim vArray1(1 To UBound(vArray)) As Single
ReDim vArray2(1 To UBound(vArray)) As Single
ReDim vArray3(1 To UBound(vArray), 1 To UBound(vArray, 2)) As Single
Dim i As Long
Dim j As Long
For i = 1 To UBound(vArray)
vArray1(i) = vArray(i, Sorteringsvariabel)
vArray2(i) = i
For j = 1 To UBound(vArray, 2)
vArray3(i, j) = vArray(i, j)
Next
Next
Call vbQuickSort(vArray1, vArray2, 1, UBound(vArray))
For i = 1 To UBound(vArray)
For j = 1 To UBound(vArray, 2)
vArray(i, j) = vArray3(vArray2(i), j)
Next
Next
Erase vArray3
Erase vArray1
Erase vArray2
End Sub
'---This sorting procedure take a vector of singles and sorts it.---
Private Sub vbQuickSort(vArray() As Single, vArray1() As Single, l As Long, r As Long)
Dim i As Long
Dim j As Long
Dim x As Single
Dim y As Single
i = l
j = r
x = vArray((l + r) / 2)
While (i <= j)
While (vArray(i) < x And i < r)
i = i + 1
Wend
While (x < vArray(j) And j > l)
j = j - 1
Wend
If (i <= j) Then
y = vArray(i)
vArray(i) = vArray(j)
vArray(j) = y
y = vArray1(i)
vArray1(i) = vArray1(j)
vArray1(j) = y
i = i + 1
j = j - 1
End If
Wend
If (l < j) Then vbQuickSort vArray, vArray1, l, j
If (l < r) Then vbQuickSort vArray, vArray1, i, r
End Sub
'---This sorting procedure take a vector of doubles and sorts it.---
Private Sub D_vbQuickSort(vArray() As Double, vArray1() As Double, l As Long, r As Long)
Dim i As Long
Dim j As Long
Dim x As Double
Dim y As Double
i = l
j = r
x = vArray((l + r) / 2)
While (i <= j)
While (vArray(i) < x And i < r)
i = i + 1
Wend
While (x < vArray(j) And j > l)
j = j - 1
Wend
If (i <= j) Then
y = vArray(i)
vArray(i) = vArray(j)
vArray(j) = y
y = vArray1(i)
vArray1(i) = vArray1(j)
vArray1(j) = y
i = i + 1
j = j - 1
End If
Wend
If (l < j) Then D_vbQuickSort vArray, vArray1, l, j
If (l < r) Then D_vbQuickSort vArray, vArray1, i, r
End Sub
'---This function wraps D_SORTVEC. I the supplied array is less than 200000 observations
' D_SORTVEC is used, otherwise D_vbQuickSort is used. The reason is problems with the
' stack size when using large arrays for calls to Fortran routines.
Public Function wrap_D_SORTVEC(originalArr() As Double, returnArr() As Double) As Double()
If UBound(originalArr) < 200000 Then
Call D_SORTVEC(originalArr(1), UBound(originalArr), returnArr(1))
wrap_D_SORTVEC = returnArr
Else
'---D_SORTVEC does not sort the original array which vbQuickSort does.
' To prevent the original array from being sorted the routine first
' copies the original array to a temporary array then sort this and
' return the sorted temporary array. FJ 040518
ReDim arr(1 To UBound(originalArr)) As Double
Call CopyMemory(arr(1), originalArr(1), 8 * UBound(originalArr))
Call D_vbQuickSort(arr, returnArr, 1, UBound(returnArr))
wrap_D_SORTVEC = arr
End If
End Function
'*** Initialization of OutputData data type.
Public Sub InitOutputData()
Dim x() As String
x = Split(CStr(command), " ")
' If SESIM is running in batch mode with output data command line arguments
' this will be handled here. Otherwise outputdata object will be inactivated.
If UBound(x) >= 2 Then
Call Write_Output_Data
Else
OutputData.OutputActive = False
OutputData.filetype = 1 '*** default = ASCII
OutputData.FileCreated = False
End If
End Sub
'*** Sub Write_Output_Data writes data vectors to file. Output procedures are handled through
'*** the Manage Output Data form. Output can be written as space separated ASCII flat files or
'*** as binary data. Data written to binary files can be read to SAS-datasets using the
'*** read_binar_data.sas program (se related documents)
'*** TP040511
Public Sub Write_Output_Data()
Dim filename As String, rowdata As String, var As String
Dim varlist As Variant
Dim i As Long, hidx As Long, indx As Long
Dim filenr As Integer, filenr2 As Integer
If OutputData.OutputActive = False Then Exit Sub
status "Writing output data"
'*** If this is the first call to the sub then all file initialization
'*** must be done before any actual data can be written
If OutputData.FileCreated = False Then
'*** Output to ASCII file
If OutputData.filetype = 1 Then
filename = sesimpath & "\microdata\" & OutputData.filename & ".txt"
' Create file and write header row
filenr = FreeFile
Open filename For Output As filenr
rowdata = "year"
For i = 1 To UBound(OutputData.VarList_i)
rowdata = rowdata & " " & OutputData.VarList_i(i)
Next
For i = 1 To UBound(OutputData.VarList_h)
rowdata = rowdata & " " & OutputData.VarList_h(i)
Next
For i = 1 To UBound(OutputData.VarList_m)
rowdata = rowdata & " " & OutputData.VarList_m(i)
Next
Print #filenr, rowdata
Close filenr
OutputData.FileCreated = True
'*** Output to binary file
Else
filename = sesimpath & "\microdata\" & _
OutputData.filename & "_header.txt"
' Create file
OutputData.filenr = FreeFile
Open filename For Output As OutputData.filenr
filename = sesimpath & "\microdata\" & _
OutputData.filename & "_data.bin"
OutputData.filenr2 = FreeFile
Open filename For Binary As OutputData.filenr2
OutputData.FileCreated = True
End If
End If
'*** Output to ASCII file
If OutputData.filetype = 1 Then
'*** Write data to file
filenr = FreeFile
filename = sesimpath & "\microdata\" & OutputData.filename & ".txt"
Open filename For Append As filenr
For indx = 1 To m_icount
' Only write data for individuals that are selected
If i_selected(indx) = 1 Then
rowdata = CStr(model_time + base_year)
For i = 1 To UBound(OutputData.VarList_i)
If OutputData.VarList_i(i) <> "" Then _
rowdata = rowdata & " " & CStr(get_value(OutputData.VarList_i(i), indx))
Next
For i = 1 To UBound(OutputData.VarList_h)
If OutputData.VarList_h(i) <> "" Then _
rowdata = rowdata & " " & _
CStr(get_value(OutputData.VarList_h(i), hhnr2index(i_hhnr(indx))))
Next
For i = 1 To UBound(OutputData.VarList_m)
If OutputData.VarList_m(i) <> "" Then _
rowdata = rowdata & " " & get_macro_value(OutputData.VarList_m(i))
Next
Print #filenr, rowdata
End If
Next
Close filenr
'*** Output to binary file
Else
For i = 1 To UBound(OutputData.VarList_i)
If OutputData.VarList_i(i) <> "" Then _
Call WriteToBinaryFile(OutputData.VarList_i(i))
Next
For i = 1 To UBound(OutputData.VarList_h)
If OutputData.VarList_h(i) <> "" Then _
Call WriteToBinaryFile(OutputData.VarList_h(i))
Next
For i = 1 To UBound(OutputData.VarList_m)
If OutputData.VarList_m(i) <> "" Then _
Call WriteToBinaryFile(OutputData.VarList_m(i))
Next
End If
End Sub
'-----------------
Public Sub step_to_year(stryear As String)
Dim year As Integer, i As Integer
year = CInt(stryear)
If year <> base_year + model_time Then
If binary_files_exist(year - base_year) = True Then
status "Change to time" & CStr(year - base_year)
Call read_data(year - base_year)
controlcenter.antalindivider.Caption = m_icount
controlcenter.antalhushåll.Caption = m_hcount
Call controlcenter.update_viewers
status "Done"
Else
If year > base_year + model_time Then
i = year - (base_year + model_time)
controlcenter.comb1Yearstorun.text = CStr(i) & " year"
controlcenter.cmd1run_Click
Else
status "Restart is needed - no saved files"
Call Initsesim
i = year - (base_year + model_time)
controlcenter.comb1Yearstorun.text = CStr(i) & " year"
controlcenter.cmd1run_Click
End If
End If
End If
End Sub
'***
' Sub test_random_numbers() draws random numbers using FORTRAN routines from the IMSL library
' and writes the numbers to text files for further analysis (using e.g. SAS). It seems that
' there are some problems with the random number generators i IMSL. The first number in the returned
' vector has some other distrubution than what is specified!!! WHY IS THIS? NO EXPLANATION IS GIVEN
' IN THE IMSL DOCUMENTATION.
' THIS INDICATES THAT THE FIRST VECTOR ELEMENT ALWAYS SHOULD BE DISCARDED!! TP040930
'
Public Sub test_random_numbers()
Dim A() As Double, B() As Double, C() As Double
ReDim A(1 To 1000), B(1 To 1000), C(1 To 4)
Dim i As Long, j As Long
Rnd -1
Randomize
If Dir(sesimpath & "\a.txt") <> "" Then Kill sesimpath & "\a.txt"
If Dir(sesimpath & "\b.txt") <> "" Then Kill sesimpath & "\b.txt"
If Dir(sesimpath & "\c.txt") <> "" Then Kill sesimpath & "\c.txt"
If Dir(sesimpath & "\d.txt") <> "" Then Kill sesimpath & "\d.txt"
' Call RANNOR(1000, A(1), 12345)
' Call RANUNI(1000, B(1), 12345)
'
' For i = 1 To 1000
' Call Print_to_file("a.txt", "N", A(i))
' Call Print_to_file("b.txt", "N", B(i))
' Call RANNOR(2, c(1), 12345 + i)
' Call Print_to_file("c.txt", "N", c(2))
' Call RANUNI(2, c(1), 12345 + i)
' Call Print_to_file("d.txt", "N", c(2))
' Next
For i = 1 To 10000
Call RANNOR(4, C(1), 12345 + i)
Call Print_to_file("a.txt", "N", C(1), C(2), C(3), C(4))
Call RANUNI(4, C(1), 12345 + i)
Call Print_to_file("b.txt", "N", C(1), C(2), C(3), C(4))
Next
' SAS code example:
' proc import datafile = "C:\sesim\a.txt" out = test_a replace;
' getnames = no;
' run;
'
' proc means data = test_a;
' run;
'
' proc import datafile = "C:\sesim\b.txt" out = test_b replace;
' getnames = no;
' run;
'
' proc means data = test_b;
' run;
'
' proc univariate data = test_a noprint;
' histogram var1-var4;
' inset p5 mean p95;
' run;
'
' proc univariate data = test_B noprint;
' histogram var1-var4;
' inset p5 mean p95;
' run;
End Sub
'************************************************************************
'*** Function BB_Region(kkod) returns the BabyBoom-region corresponding
'*** to municipality code kkod. The regions are defined as:
'*** 1: Stockholm, 2: Göteborg, 3: Malmö/Lund, 4: Södra urban,
'*** 5: Mellersta urban, 6: Norra urban, 7: Södra rural,
'*** 8: Mellersta rural and 9: Norra rural
'*** TP041027
'************************************************************************
Public Function BB_Region(kkod As Integer) As Byte
Select Case kkod
Case 114, 115, 117, 120, 123, 125, 126, 127, 128, 136, 138, 139, 140, 160, 162, 163, 180, _
181, 182, 183, 184, 186, 187, 191, 192
BB_Region = 1 '*** Stockholm
Case 1384, 1401, 1402, 1407, 1415, 1419, 1480, 1481, 1482, 1440, 1441, 1442, 1489
BB_Region = 2 '*** Göteborg
Case 1230, 1231, 1233, 1261, 1262, 1263, 1280, 1281, 1287
BB_Region = 3 '*** Malmö/Lund
Case 562, 580, 581, 582, 586, 665, 680, 764, 780, 880, 1060, 1080, 1081, 1082, 1083, 1270, _
1272, 1275, 1276, 1277, 1278, 1290, 1292, 1293, 1214, 1256, 1257, 1260, 1264, 1265, 1266, _
1267, 1282, 1283, 1284, 1285, 1380, 1381, 1421, 1430, 1485, 1439, 1443, 1462, 1465, 1487, _
1488, 1490, 1491, 1444, 642, 643, 1471, 1495, 1496, 1498
BB_Region = 4 '*** Södra urban
Case 305, 319, 330, 380, 381, 461, 484, 488, 1715, 1761, 1763, 1764, 1780, 1814, 1861, 1880, _
1881, 1884, 1907, 1960, 1961, 1980, 1983, 2080, 2081, 2082
BB_Region = 5 '*** Mellersta urban
Case 2180, 2181, 2262, 2281, 2460, 2480, 2580
BB_Region = 6 '*** Norra urban
Case 509, 512, 513, 560, 561, 563, 583, 584, 604, 617, 662, 682, 683, 684, 685, 686, 687, 760, _
761, 763, 765, 767, 781, 821, 834, 840, 860, 861, 862, 881, 882, 883, 884, 885, 980, 1273, _
1291, 1286, 1315, 1382, 1383, 1427, 1435, 1484, 1486, 1438, 1452, 1460, 1461, 1463, 1466, _
1492, 1445, 1446, 1447, 1470, 1472, 1473, 1493, 1494, 1497, 1499
BB_Region = 7 '*** Södra rural
Case 188, 360, 382, 428, 480, 481, 482, 483, 486, 1730, 1737, 1760, 1762, 1765, 1766, 1781, _
1782, 1783, 1784, 1785, 1860, 1862, 1863, 1864, 1882, 1883, 1885, 1904, 1917, 1962, 1981, _
1982, 1984, 2021, 2023, 2026, 2029, 2031, 2034, 2039, 2061, 2062, 2083, 2084, 2085
BB_Region = 8 '*** Mellersta rural
Case 2101, 2104, 2121, 2132, 2161, 2182, 2183, 2184, 2260, 2280, 2282, 2283, 2284, 2303, 2305, _
2309, 2313, 2321, 2326, 2361, 2380, 2401, 2403, 2404, 2409, 2417, 2418, 2421, 2422, 2425, _
2462, 2463, 2481, 2482, 2505, 2506, 2510, 2513, 2514, 2518, 2521, 2523, 2560, 2581, 2582, _
2583, 2584
BB_Region = 9 '*** Norra rural
Case Else
BB_Region = 0 '*** Missing value - this should not occur
End Select
End Function
'*** TEST RELATIVES
'*** TEST AV UTBRYTNING AV VISS HÅRDKODAD KOD FRÅN XXVectordef FÖR ATT SLIPPA UPPDATERA
' ADDIN VID TILLÄGG AV EGENDEFINIERADE DATATYPER. DET FUNKAR
'-- Avkommentera denna kod, lägg till proceduranropen i addninnen vid förekomster av "pp-hist" och kör om
' och ersätt med följande anrop
'Call xdyn_vect_i(count)
'Call xzero_i(i)
'Call xshift_up_marked_ii(i, j)
'Call xcopy_individ_var(from_indinr, to_indinr)
'Call xread_i_bin(fnum)
'Public Sub xdyn_vect_i(count)
' 'DoEvents
' If count < 1 Then Exit Sub
' ReDim Preserve pp_hist(count) As pp_hist_ind
' ReDim Preserve Relatives(count) As Family
'End Sub
'Public Sub xzero_i(i)
' Erase pp_hist(i).pp
' Erase pp_hist(i).pp_years
' pp_hist(i).n_years = 0
' Erase Relatives(i).Children
' Relatives(i).Mother = 0
' Relatives(i).Father = 0
'End Sub
'
'Public Sub xshift_up_marked_ii(i, j)
' pp_hist(j) = pp_hist(i)
' Relatives(j) = Relatives(i)
'End Sub
'
'Public Sub xcopy_individ_var(from_indinr, to_indinr)
' pp_hist(indnr2index(to_indinr)) = pp_hist(indnr2index(from_indinr))
' Relatives(indnr2index(to_indinr)) = Relatives(indnr2index(from_indinr))
'End Sub
'
'Public Sub xread_i_bin(fnum)
' Get #fnum, , pp_hist
' Call Pack_Pension_Hist
'' Get #fnum, , Relatives
' '**** Skriva procedur f att packa Relatives anaogt m pp_hist??
'End Sub
'************************************************************************
'*** Sub UpdateVariables updates some individual and houshold variables
'*** at the beginning of each simulation year.
'************************************************************************
Public Sub UpdateVariables()
Dim i As Long, h As Long
ReDim h_n_ge18(1 To m_hcount) ' Resetting the variable to recalculate below
For i = 1 To m_icount
' Individual variables
i_age(i) = i_age(i) + 1
i_status1(i) = i_status(i)
' i_borndecade(i) = Int((base_year + model_time - i_age(i)) / 10) * 10
i_born_year(i) = base_year + model_time - i_age(i)
i_civ_stat1(i) = i_civ_stat(i) '-- Lagged civil status
i_new_em(i) = 0
i_new_immig(i) = 0
i_widowed(i) = 0
If i_age(i) >= 18 Then h_n_ge18(hhnr2index(i_hhnr(i))) = h_n_ge18(hhnr2index(i_hhnr(i))) + 1
' Updating lagged variables
' i_student1(i) = i_student(i)
i_bvux1(i) = i_bvux(i)
i_health1(i) = i_health(i)
i_health(i) = 0
i_health_latent1(i) = i_health_latent(i)
i_health_latent(i) = 0
' i_InpatientCare1(i) = i_InpatientCare(i)
i_InpatientCare(i) = 0
i_sick_ind1(i) = i_sick_ind(i)
i_sick_ind(i) = 0
i_inc_taxable5(i) = i_inc_taxable4(i)
i_inc_taxable4(i) = i_inc_taxable3(i)
i_inc_taxable3(i) = i_inc_taxable2(i)
i_inc_taxable2(i) = i_inc_taxable1(i)
i_inc_taxable1(i) = i_inc_taxable(i)
i_inc_taxable(i) = 0
i_wealth_pension_year1(i) = i_wealth_pension_year(i)
i_wealth_pension_year(i) = 0
Next
' Household variables
For h = 1 To m_hcount
' h_new_em(h) = 0
h_new_immig(h) = 0
h_childmoveout(h) = 0
' Updating lagged variables
' NOTE: wealth variables are generally lagged but not reset
h_close_relative1(h) = h_close_relative(h)
h_close_relative(h) = 0
' h_inc_disposable2(h) = h_inc_disposable1(h)
h_inc_disposable1(h) = h_inc_disposable(h)
h_inc_disposable(h) = 0
' h_inc_capital1(h) = h_inc_capital(h)
h_inc_capital(h) = 0
' h_kommunindex2(h) = h_kommunindex1(h)
' h_kommunindex1(h) = h_kommunindex(h)
' h_kommunkod2(h) = h_kommunkod1(h)
' h_kommunkod1(h) = h_kommunkod(h)
h_BB_region1(h) = h_BB_region(h)
h_n_child1(h) = h_n_child(h)
h_wealth_debt1(h) = h_wealth_debt(h)
h_wealth_real_home1(h) = h_wealth_real_home(h)
h_wealth_real_other1(h) = h_wealth_real_other(h)
h_wealth_financial1(h) = h_wealth_financial(h)
h_wealth_debt_interest1(h) = h_wealth_debt_interest(h)
h_wealth_debt_interest(h) = 0
h_wealth_debt_interestrate1(h) = h_wealth_debt_interestrate(h)
h_wealth_debt_interestrate(h) = 0
h_wealth_DebtInterest_ind1(h) = h_wealth_DebtInterest_ind(h)
h_wealth_DebtInterest_ind(h) = 0
h_new_housing1(h) = h_new_housing(h)
h_new_housing(h) = 0
h_house_owner1(h) = h_house_owner(h)
h_sum_inc_taxable1(h) = h_sum_inc_taxable(h)
Next
End Sub
'*** Sub Individualize_CapitalIncome distributes capital income within the
'*** household according to a predermined schedule (h_inc_capital --> i_inc_capital).
'*** Arguments:
'*** - h: household index number
Public Sub Individualize_CapitalIncome(ByVal h As Long)
Dim indnr As Long, indexnr As Long
' Redistribute capital income in household
indnr = h_first_indnr(h)
Do While indnr <> 0
indexnr = indnr2index(indnr)
i_inc_capital(indexnr) = 0
' Distribution depends on civil status and whether adult children are present
If h_n_adults(h) > 1 Then
If h_n_ge18(h) - h_n_adults(h) >= 1 Then
' Married/cohabiting with adult children - household debt divided between
' spouses and adult children
If i_bvux(indexnr) = 1 Then
If i_sex(indexnr) = 1 Then i_inc_capital(indexnr) = h_inc_capital(h) * 0.6
If i_sex(indexnr) = 2 Then i_inc_capital(indexnr) = h_inc_capital(h) * 0.25
Else
If i_age(indexnr) >= 18 Then _
i_inc_capital(indexnr) = (h_inc_capital(h) * 0.15) / (h_n_ge18(h) - h_n_adults(h))
End If
Else
' Married/cohabiting without adult children - household debt divided between
' spouses
If i_bvux(indexnr) = 1 Then
If i_sex(indexnr) = 1 Then i_inc_capital(indexnr) = h_inc_capital(h) * 0.65
If i_sex(indexnr) = 2 Then i_inc_capital(indexnr) = h_inc_capital(h) * 0.35
End If
End If
Else
If h_n_ge18(h) - h_n_adults(h) >= 1 Then
' Single with adult children - household debt divided between
' adult and adult children
If i_bvux(indexnr) = 1 Then
i_inc_capital(indexnr) = h_inc_capital(h) * (1 - 0.15)
Else
If i_age(indexnr) >= 18 Then _
i_inc_capital(indexnr) = (h_inc_capital(h) * 0.15) / (h_n_ge18(h) - h_n_adults(h))
End If
Else
' Single without adult children - household debt to the adult
If i_bvux(indexnr) = 1 Then i_inc_capital(indexnr) = h_inc_capital(h)
End If
End If
indnr = i_next_indnr(indexnr)
Loop
End Sub
'*** Sub Individualize_Debt distributes capital income within the household according to
'*** a predermined schedule (h_wealth_debt --> i_wealth_debt).
'*** Arguments:
'*** - h: household index number
Public Sub Individualize_Debt(ByVal h As Long)
Dim indnr As Long, indexnr As Long
' Distribute debt in household
indnr = h_first_indnr(h)
Do While indnr <> 0
indexnr = indnr2index(indnr)
i_wealth_debt(indexnr) = 0
' Distribution depends on civil status and whether adult children are present
If h_n_adults(h) > 1 Then
If h_n_ge18(h) - h_n_adults(h) >= 1 Then
' Married/cohabiting with adult children - household debt divided between
' spouses and adult children
If i_bvux(indexnr) = 1 Then
If i_sex(indexnr) = 1 Then i_wealth_debt(indexnr) = h_wealth_debt(h) * 0.68
If i_sex(indexnr) = 2 Then i_wealth_debt(indexnr) = h_wealth_debt(h) * 0.18
Else
If i_age(indexnr) >= 18 Then _
i_wealth_debt(indexnr) = (h_wealth_debt(h) * 0.14) / (h_n_ge18(h) - h_n_adults(h))
End If
Else
' Married/cohabiting without adult children - household debt divided between
' spouses
If i_bvux(indexnr) = 1 Then
If i_sex(indexnr) = 1 Then i_wealth_debt(indexnr) = h_wealth_debt(h) * 0.7
If i_sex(indexnr) = 2 Then i_wealth_debt(indexnr) = h_wealth_debt(h) * 0.3
End If
End If
Else
If h_n_ge18(h) - h_n_adults(h) >= 1 Then
' Single with adult children - household debt divided between
' adult and adult children
If i_bvux(indexnr) = 1 Then
i_wealth_debt(indexnr) = h_wealth_debt(h) * (1 - 0.14)
Else
If i_age(indexnr) >= 18 Then _
i_wealth_debt(indexnr) = (h_wealth_debt(h) * 0.14) / (h_n_ge18(h) - h_n_adults(h))
End If
Else
' Single without adult children - household debt to the adult
If i_bvux(indexnr) = 1 Then i_wealth_debt(indexnr) = h_wealth_debt(h)
End If
End If
indnr = i_next_indnr(indexnr)
Loop
End Sub
'*** Sub Individualize_FinancialWealth distributes financial wealth within the
'*** household according to a predermined schedule (h_wealth_financial --> i_wealth_financial).
'*** Arguments:
'*** - h: household index number
Public Sub Individualize_FinancialWealth(ByVal h As Long)
Dim indnr As Long, indexnr As Long
' Redistribute capital income in household
indnr = h_first_indnr(h)
Do While indnr <> 0
indexnr = indnr2index(indnr)
i_wealth_financial(indexnr) = 0
' Distribution depends on civil status and whether adult children are present
If h_n_adults(h) > 1 Then
If h_n_ge18(h) - h_n_adults(h) >= 1 Then
' Married/cohabiting with adult children - household debt divided between
' spouses and adult children
If i_bvux(indexnr) = 1 Then
If i_sex(indexnr) = 1 Then i_wealth_financial(indexnr) = h_wealth_financial(h) * 0.51
If i_sex(indexnr) = 2 Then i_wealth_financial(indexnr) = h_wealth_financial(h) * 0.29
Else
If i_age(indexnr) >= 18 Then _
i_wealth_financial(indexnr) = (h_wealth_financial(h) * 0.2) / (h_n_ge18(h) - h_n_adults(h))
End If
Else
' Married/cohabiting without adult children - household debt divided between
' spouses
If i_bvux(indexnr) = 1 Then
If i_sex(indexnr) = 1 Then i_wealth_financial(indexnr) = h_wealth_financial(h) * 0.6
If i_sex(indexnr) = 2 Then i_wealth_financial(indexnr) = h_wealth_financial(h) * 0.4
End If
End If
Else
If h_n_ge18(h) - h_n_adults(h) >= 1 Then
' Single with adult children - household debt divided between
' adult and adult children
If i_bvux(indexnr) = 1 Then
i_wealth_financial(indexnr) = h_wealth_financial(h) * (1 - 0.2)
Else
If i_age(indexnr) >= 18 Then _
i_wealth_financial(indexnr) = (h_wealth_financial(h) * 0.2) / (h_n_ge18(h) - h_n_adults(h))
End If
Else
' Single without adult children - household debt to the adult
If i_bvux(indexnr) = 1 Then i_wealth_financial(indexnr) = h_wealth_financial(h)
End If
End If
indnr = i_next_indnr(indexnr)
Loop
End Sub