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