Attribute VB_Name = "c00_Init"
Option Explicit
Public init_done As Integer
Public Sub Initsesim()
Printdok "Initsesim"
Dim i As Long
Call check_new_base_data
'-- Randomized checkbox marked
If controlcenter.chkRandomize.value = 1 Then
Randomize
' Flag. 0=same random seed. 1=different seed.
random = 1
Printdok ("Randomized: New random number seed generated")
End If
' Flag. 0=same random seed. 1=different seed.
' random = 0
' Reset random numbers
If random = 0 Then
Rnd (-1)
'Randomize maxi(0, model_time)
Randomize base_year
End If
For i = 1 To m_icount
Call zero_i(i)
Next
For i = 1 To m_hcount
Call zero_h(i)
Next
Call zero_m
' Delete old binary files
If Dir(sesimpath & "\microdata\*.out") <> "" Then
status "Deleting temporary files"
Kill sesimpath & "\microdata\*.out"
End If
If Dir(sesimpath & "\microdata\*.sas") <> "" Then
Kill sesimpath & "\microdata\*.sas"
End If
If Dir(sesimpath & "\microdata\*.mdb") <> "" Then
Kill sesimpath & "\microdata\*.mdb"
End If
If Dir(sesimpath & "\microdata\*.ldb") <> "" Then
Kill sesimpath & "\microdata\*.ldb"
End If
If Dir(sesimpath & "\tempdata\*.mdb") <> "" Then
Kill sesimpath & "\tempdata\*.mdb"
End If
If Dir(sesimpath & "\tempdata\*.ldb") <> "" Then
Kill sesimpath & "\tempdata\*.ldb"
End If
' Reading variables from controlcenter form
' Weight
m_weight = controlcenter.txtWeight
Printdok ("Sample weight = " & m_weight & _
" Percent of sample = " & controlcenter.txtPercentofsample.text)
' -- Pension age
chkRetire65 = controlcenter.chkRetire65.value
txtRetire = CByte(controlcenter.txtRetire.text)
Printdok ("Exogenous pension = " & chkRetire65 & " at age " & txtRetire)
status "Reading data"
Call read_data(-1)
If m_icount = 0 Or m_hcount = 0 Then
status "No data!"
Exit Sub
End If
Dim percent_of_sample As Double
If IsNumeric(controlcenter.txtPercentofsample.text) Then
percent_of_sample = CLng(controlcenter.txtPercentofsample.text)
If percent_of_sample < 0 Then percent_of_sample = 0
If percent_of_sample > 100 Then percent_of_sample = 100
End If
' Subsampling to obtain percent_of_sample % of the original sample population
If percent_of_sample < 100 Then
Dim last_hhnr As Long, first_indnr As Long, last_indnr As Long, m_hcount1 As Long
m_hcount1 = m_hcount
m_hcount = CLng(percent_of_sample / 100 * m_hcount)
If m_hcount < 1 Then
m_hcount = 1
percent_of_sample = 1 / m_hcount1
End If
Call dyn_vect_h(m_hcount)
ReDim Preserve hhnr2index(1 To m_hcount)
största_hhnr = m_hcount
last_hhnr = h_hhnr(m_hcount)
Dim indnr As Long
indnr = h_first_indnr(hhnr2index(last_hhnr))
Do Until i_next_indnr(indnr) = 0
indnr = i_next_indnr(indnr2index(indnr))
Loop
m_icount = indnr
Call dyn_vect_i(m_icount)
ReDim Preserve indnr2index(1 To m_icount)
största_indnr = m_icount
controlcenter.antalindivider.Caption = m_icount
controlcenter.antalhushåll.Caption = m_hcount
controlcenter.antalindivider.Refresh
controlcenter.antalhushåll.Refresh
m_weight = m_weight * 100 / percent_of_sample
End If
For i = 0 To controlcenter.chkDataexist.count - 1
controlcenter.chkDataexist(i).ToolTipText = base_year + i
Next
' Assignment of individual error components or "luck factors" for
' the panel data regression models
Dim rand() As Double
ReDim rand(1 To 2 * m_icount)
Call RANNOR(2 * m_icount, rand(1), model_time + base_year + random * Rnd)
'Lösning för att generera en slumpvektor för tilldelning av sigma_my(i) _
vektorn töms när init är färdig. Subrutinen finns i a01_economics_2
ReDim randomValues(1 To 100000, 1 To 3)
Call randomnumbers
'Lösning för att fördela individer som i startdata pensionerats före den
'specificerade pensionsålder på övriga status. FJ 2004-03-02
Dim StatusAtAge61ToX() As Double
If chkRetire65 = True Then
StatusAtAge61ToX = f_calc_StatusAtAge61ToX(txtRetire) 'Generera fördelningen
End If
'-- Runtime option: Don't reactivate already retired in startdata
Dim set_StatusAtAge61ToX_Off As Byte
Call read_MY_parametrar
If get_scalefactor_active("Reactivate_Off") = 1 Then
set_StatusAtAge61ToX_Off = 1
End If
'
For i = 1 To m_icount
i_inc_ivariance(i) = sigma_my(i) 'Assign indvidual value corresponding to previous wage
i_unemp_ivariance(i) = rand(i) * Sqr(0.648)
i_sickleave_ivariance(i) = rand(i + m_icount) * Sqr(0.638)
' Assumed zero postponed housetax values at base year
i_housetax_postponed(i) = 0
' Calculate household capital income
h_inc_capital(hhnr2index(i_hhnr(i))) = h_inc_capital(hhnr2index(i_hhnr(i))) + _
i_inc_capital(i)
' The income is truncated at zero
If i_inc_earning(i) < 0 Then i_inc_earning(i) = 0
If i_inc_taxable(i) < 0 Then i_inc_taxable(i) = 0
'*** Possible to move this block to startdata
' -- PGI transformed to definitions in a06_Pension_Rules
If i_status(i) = 2 Then
i_pgi(i) = 0
End If
'Tilldela individer som pensionerats innan specificerad ålder en annan status
'Hjälp mig fundera på om detta ställer till problem med definitionen på andra
'variabler för individen!? FJ 2004-03-02
If chkRetire65 = True And i_status(i) = 2 And i_age(i) < txtRetire Then
If set_StatusAtAge61ToX_Off <> 1 Then
i_status(i) = f_set_StatusAtAge61ToX(StatusAtAge61ToX, i)
i_ap_pensmonth(i) = (txtRetire - 65) * 12
'-- 0-ställer alla pensionsförmåner
i_ap_atp(i) = 0
i_ap_atp_old(i) = 0
i_ap_pts(i) = 0
i_ap_fp(i) = 0
i_ap_fp30(i) = 0
i_ap_tp(i) = 0
i_ap_gp(i) = 0
i_ap_ip(i) = 0
i_ap_fiktiv(i) = 0
i_ap_pp(i) = 0
i_ap_fp30_1994(i) = 0
i_ap_atp_1994(i) = 0
i_ap_gartill(i) = 0
i_ap_tp(i) = 0
i_ap(i) = 0
i_ap_ap(i) = 0
i_op(i) = 0
End If
End If
If i_status(i) = 4 Then
i_pgb_antag(i) = i_pgi(i)
i_pgb(i) = i_pgi(i)
i_pgi(i) = 0
i_ftp(i) = i_ftp_atp(i) + i_ftp_fp(i) + i_ftp_pts(i)
End If
i_pu(i) = i_pgi(i) + i_pgb(i)
i_pu_orange(i) = i_pu(i)
i_pgi_orange(i) = i_pgi(i)
' -- Individual comparison pension base
' Register i_pu_ind_comp for year before child born. Used in calc pens rights child years
i_pu_ind_comp(i) = i_pgi(i) 'Approx start value in lack of information
Next
'Frigör utrymmet som randomValues och helpArrayRandomValues fälten upptagit
Erase randomValues()
Erase helpArrayRandomValues()
error_flag = 0
Call read_parameters
If error_flag = 1 Then
status "Error reading parameters"
Exit Sub
End If
' Initialize Socmod variables and parameters
' Call Init_Socmod
' Imputation of educational attainment for elderly
' The imputation is also done when producing the SESIM base dataset. If one wishes to study
' the Monte Carlo variance contribution due to the imputation one should activate Sub ImputeEducation
' in the initialization.
If get_scalefactor("ImputeEducationElderly") <> 1 Then Call ImputeEducation
' Do some macro calculations
Call calc_newyear_macro
' Calculate household emigration year
Call calc_hh_emig_year
' Calculate emigrant municipalities
Call calc_emig_municipality
' Initial prediction of labor market sector
' This is needed to adjust the observed distribution
' of sectors due to the fact that sector is assigned
' on a permanent basis (does not change) in SESIM
' TP030402
' For i = 1 To m_icount
' If i_age(i) <= 30 And i_abroad(i) = 0 And _
' (i_status(i) >= 6 And i_status(i) <= 8) Then
' i_sector(i) = Sector(i)
' End If
' Next
For i = 1 To m_icount
If i_status(i) = 2 Or i_status(i) = 5 Or i_status(i) = 6 Or i_status(i) = 8 Then
Update_Sector (i)
Select Case i_sector(i) '-- Counting qalifying years in different sectors
Case 1
i_op_pp_years_Blue(i) = pp_hist(i).n_years
i_op_pp_years_trans(i) = f_pp_years(i, 1995) 'STP
Case 2
i_op_pp_years_White(i) = pp_hist(i).n_years
Case 3
i_op_pp_years_State(i) = pp_hist(i).n_years
Case 4
i_op_pp_years_Local(i) = pp_hist(i).n_years
i_op_pp_years_trans(i) = f_pp_years(i, 1997) 'PA-KL
End Select
i_op_pp_years(i) = pp_hist(i).n_years
End If
Next
'*** TEST RELATIVES
' Matchningen måste göras i startdata - Testar bara att koppla ihop alla befintliga hushåll
'Dim mother_father(2) As Long
'Dim children(20) As Long, i_index As Long
'Dim i_nr As Long, c As Integer, h As Long, i_first_nr As Long
' For h = 1 To m_hcount
' i_nr = h_first_indnr(h)
' i_first_nr = i_nr
' Do While i_nr <> 0
' i_index = indnr2index(i_nr)
' If h_n_child(h) = 0 Then
' Relatives(i_index).father = 0
' Relatives(i_index).mother = 0
' Else
' ReDim mother_father(2) As Long
' ReDim children(h_n_child(h)) As Integer
' c = 0
' If i_bvux = 1 Then
' mother_father(i_sex(i_index)) = i_indnr(i_index)
' Else
' c = c + 1
' children(c) = i_indnr(i_index)
' End If
' End If
' i_nr = i_next_indnr(indnr2index(i_nr))
' Loop
'
' ReDim Relatives(mother_father(1)).children(h_n_children)
' ReDim Relatives(mother_father(2)).children(h_n_children)
' For c = 1 To h_n_child(h)
' Relatives(children(c)).father = mother_father(1)
' Relatives(children(c)).mother = mother_father(2)
' Relatives(mother_father(1)).children(c) = children(c)
' Relatives(mother_father(2)).children(c) = children(c)
' Next
' Calculate some statistics
Call demograf_stat
' Code some variables
Call code_variables
'*** The number of days with sickleave is taken from base data and hence
'*** no simulation is required at initialization. TP051211
' ' Simulate number of days with sickness absence
' If get_scalefactor("BabyBoom_Active") <> 1 Then
' Call Sick_leave_Health
' Else
' Call Sick_leave
' End If
Call Calculate_Deltal(m_ap_norm, 1 + (m_interest_long / 100))
'**** Possible to move the block below to Start data program
'-- Accumulation of occupational pension stocks up to base year
Call Init_Occupational_Pension_Rights
' -- Transformations of survivors and occupational pensions
Printdok " -- I loop Initsesim: Init survivors pensions & som other pension variables"
'-- Average taxable income e.g. used for calculation of pension income index
Dim j As Long
m_egenavg_pens_p = 0.0695 '*** Provisoriskt
m_inc_taxable_snitt4 = 0
m_inc_taxable_snitt3 = 0
m_inc_taxable_snitt2 = 0
m_inc_taxable_snitt1 = 0
m_inc_taxable_snitt = 0
j = 0
For i = 1 To m_icount
' -- Pension rights and pension contributions for the reformed system
Select Case i_pu(i)
Case Is < f_bas_deduct_min(1999)
i_pr_ip(i) = 0
i_pr_pp(i) = 0
Case Else
i_pr_ip(i) = m_ap_ip_avs * i_pu(i) * f_utfasning_ATP(i_born_year(i), f_ap_pensyear(1999, i_age(i), 0))
i_pr_pp(i) = m_ap_pp_avs * i_pu(i) * f_utfasning_ATP(i_born_year(i), f_ap_pensyear(1999, i_age(i), 0))
End Select
'-- Calculates pension funds as a mix of real data from RFV for domestic persons
' and calculated for persons abroad
' Reindexation of RFV-data to 1999 pricelvel including correction for
' administration and inheritance gains
Dim fiktiv_kvot As Double
i_pr_ip1(i) = m_ap_ip_avs * i_pu_orange(i) * f_utfasning_ATP(i_born_year(i), f_ap_pensyear(1999, i_age(i), 0))
If i_pbhi(i) > 0 Then ' -- Note: i_pbhi always missing for i_abroad=1
If i_pb_ip(i) > 0 Then
fiktiv_kvot = i_pb_fiktiv(i) / i_pb_ip(i)
Else
fiktiv_kvot = 1
End If
' -- Tidigare def av PB
'i_pb_ip(i) = ((i_pbhi(i) / 1.0173 / (1 - 0.00045)) - i_pr_ip1(i)) _
' / Arvsvinstfaktor(i_age(i))
i_pb_ip(i) = (((i_pbhi(i) / (1.0145)) / (1 - 0.00045))) _
/ Arvsvinstfaktor(i_age(i))
'-- Orange anger PB 2000 i 2001 års pris. Deflaterar
i_pb_ip(i) = i_pb_ip(i) / (m_ap_balind1 / m_ap_balind)
' Proportionerar pb_fiktiv
i_pb_fiktiv(i) = i_pb_fiktiv(i) * fiktiv_kvot
End If
'-- Tranformation of survivors pension variables from start data
i_surv(i) = i_surv_fp(i) + i_surv_atp(i)
'-- Ruff splitting up of i_op (occupational pensions)
If i_status(i) = 2 Then '-- Old age
' If i_age(i) >= 55 Then
i_op_ap_db(i) = i_op(i) '-- All current ocup pens supposed to life long defined benefit
' '-- Occupational disability benefits not implemented yet
' ElseIf i_status(i) = 4 Then '-- Disablity
' i_op_ftp(i) = i_op(i)
' '-- Occupational survivors benefits not implemented yet
' ElseIf i_surv(i) > 0 And i_age(i) > 18 And i_status(i) <> 4 And i_status(i) <> 2 Then
' i_surv_op (i) > 0
' ElseIf i_surv(i) > 0 And i_age(i) <= 18 And i_status(i) <> 4 And i_status(i) <> 2 Then
' i_surv_barn (i) > 0
Else
i_op(i) = 0
End If
'-- Compulsary retirement
' -- No one works after 70
If i_age(i) > 70 And i_status(i) <> 2 Then
i_status1(i) = i_status(i)
i_status(i) = 2
i_ap_pensmonth(i) = 60 ' (70-65) * 12 = 60 Not poosible to get more
End If
' -- If exogenous retirement age
If chkRetire65 = True Then
If i_age(i) >= txtRetire And i_status(i) <> 2 Then
'Debug.Print i & " " & i_age(i) & " " & i_inc_earning(i) & " " & i_abroad(i) & " " & i_trf_taxable(i) & " " & i_ap(i)
i_status1(i) = i_status(i)
i_status(i) = 2
i_ap_pensmonth(i) = (txtRetire - 65) * 12
End If
End If
'-- Private pensions
' If i_status(i) = 2 And i_wealth_pension_total(i) > 0 Then
' If Rnd > 0.7 Or i_wealth_pension_total(i) > 20 * m_basbelopp_f Then
' i_pp_payout_time(i) = -99 '-- Annuity
' Else
' i_pp_payout_time(i) = 5 '-- Fixed 5 year period
' End If
' End If
' i_pp(i) = f_Private_Pension_Benefits(i, i_pp_payout_time(i))
'-- Lagged status if retired
If i_status(i) = 2 Then
i_status1(i) = 2
End If
'-- Aggregations
i_ap(i) = i_ap_fp(i) + i_ap_pts(i) + i_ap_atp(i)
i_ap_atp_old(i) = i_ap_atp(i)
i_ap_atp_ut(i) = i_ap_atp(i)
i_ap_fp30_ut(i) = i_ap_fp30(i)
'i_trf_pension(i) = i_ap(i) + i_surv(i) + i_op(i) + i_ftp(i)
'************** OBS Räknar av i_trf_sickleave ******************
'*** i_inc_earning(i) = maxi(0, i_inc_earning(i) - i_trf_sickleave(i) + i_inc_selfemployed(i))
'**** i_inc_selfemployed(i) = 0
'************************************************************
' i_trf_taxable(i) = i_trf_pension(i) + i_trf_parentleave(i) + i_trf_sickleave(i) + i_trf_unemployed(i)
' i_inc_taxable(i) = i_inc_earning(i) + i_trf_taxable(i)
If i_age(i) > 15 And i_age(i) < 65 And i_abroad(i) = 0 And _
(i_inc_taxable(i) - i_ap(i) - i_surv(i) - i_op(i)) > 0 Then
j = j + 1
'm_inc_taxable_snitt = m_inc_taxable_snitt + (i_inc_taxable(i) * (1 - m_egenavg_pens_p))
m_inc_taxable_snitt = m_inc_taxable_snitt + _
((i_inc_taxable(i) - i_ap(i) - i_surv(i) - i_op(i)) * (1 - m_egenavg_pens_p))
m_inc_taxable_snitt1 = m_inc_taxable_snitt1 + (i_inc_taxable1(i) * (1 - m_egenavg_pens_p))
m_inc_taxable_snitt2 = m_inc_taxable_snitt2 + (i_inc_taxable2(i) * (1 - m_egenavg_pens_p))
m_inc_taxable_snitt3 = m_inc_taxable_snitt3 + (i_inc_taxable3(i) * (1 - m_egenavg_pens_p))
m_inc_taxable_snitt4 = m_inc_taxable_snitt4 + (i_inc_taxable4(i) * (1 - m_egenavg_pens_p))
End If
Next
m_inc_taxable_snitt = m_inc_taxable_snitt / j
m_inc_taxable_snitt1 = m_inc_taxable_snitt1 / j
m_inc_taxable_snitt2 = m_inc_taxable_snitt2 / j
m_inc_taxable_snitt3 = m_inc_taxable_snitt3 / j
m_inc_taxable_snitt4 = m_inc_taxable_snitt4 / j
'-- Initiating some aggregated pension variables
m_ap_apfond = f_GetMakro("m_ap_apfond", 1999, "Pension")
'-- Accumultead premium pension funds
m_ap_ppfond = L_SUMVEC(i_pb_pp(1), m_icount)
'-- Accumultead occupational pension funds
m_op_fond = L_SUMVEC(i_pb_op_ap(1), m_icount) + L_SUMVEC(i_pb_op_tp(1), m_icount)
'-- Accumulated fund of private pension savings
m_pp_fond = L_SUMVEC(i_wealth_pension_total(1), m_icount)
'-- Initiation of guarantee pension base help variable
m_basbelopp_gp = m_basbelopp
' Calculate wealth and pension savings
Call Wealth_PensionSavings
' Imputation of housing costs
Call ImputeHousingInfo
' Initialization of house purchase prices in base data
Call InitializeHousePurchasePrice
' Beräkna vissa regler det som definieras i stardata räknas inte om
Call calc_rules
' Various imputations for the Baby Boom modules
If get_scalefactor("BabyBoom_Active") <> 1 Then
' Imputation of closeness to relative
Call ClosenessToRelative
' Imputation of health index
Call Health
' Imputation of days with inpatient care
Call Inpatient_Care
' Imputation of disability (ADL)
Call ADL
' Imputation of assistance for elderly
Call AssistanceElderly
End If
' Project number of contributors in pension system for year 1999, for balance ratio
Call CalculatePensionContributors
' -- Optional printing of pension variables in PRN-format for export to eg. Aremos
If get_scalefactor_active("Pensions_macro") = 1 Then
Call Calculate_Macro
Call Print_Pensions_Macro
End If
If get_scalefactor_active("pension_debug") = 1 Then
Call Pension_debugging_files
End If
If get_scalefactor_active("pension_micro") = 1 Then
Call Pension_micro_file
End If
If get_scalefactor_active("Print_elderly_care") = 1 Then
Call Print_elderly_care_micro
End If
' Write income history (if enabled)
inchist.write_now
' Save binary data
If controlcenter.chk2Saveoutfiles = 1 Then Call Write_Data
If controlcenter.chk2SaveAccessdb = 1 Then Call MDIForm1.menu_writeaccess_Click
' Initiate output data type
Call InitOutputData
'*** Write output data.
'Call Write_output_ludata
Call Write_Output_Data_Old
init_done = 1
With controlcenter
.cmd1run.SetFocus
.cmdUnivar.enabled = True
.cmdKernel.enabled = True
.cmdDemo.enabled = True
.cmdDemohist.enabled = True
.cmdFreq.enabled = True
.cmdMicrodata.enabled = True
.CmdGlobalSelection.enabled = True
.cmd_OutputData.enabled = True
' Most options are only available before SESIM is initialized
.chk2Saveoutfiles.enabled = False
.chk2SaveAccessdb.enabled = False
.chk2Savehist.enabled = False
.chk2Saveincomehist.enabled = False
.chk2Price99.enabled = False
.txt2MYparameterfilname.enabled = False
.txt2BASEparameterfilname.enabled = False
.cmdBrowsepar1.enabled = False
.cmdBrowsepar2.enabled = False
.cmdSaveOptions.enabled = False
.txtWeight.enabled = False
.txtPercentofsample.enabled = False
.txt2Runsystem.enabled = False
.chkRetire65.enabled = False
.txtRetire.enabled = False
.chkRandomize.enabled = False
End With
' After initiation no selection exists and all individuals and
' households are therefore selected
For i = 1 To m_icount
select_i(i) = 1
'*** DEBUG
i_selected(i) = 1
If i <= m_hcount Then
select_h(i) = 1
'*** DEBUG
h_selected(i) = 1
End If
Next i
status "*** Init done ***"
Printdok " -- Initsesim ready"
End Sub
'*********************************************************************************
'*** Sub check_new_base_data checks for new data on the server and downloads it
'*** to the client if newer than the client data
'*********************************************************************************
Public Sub check_new_base_data()
Printdok " check_new_base_data"
Const data_path = "S:\data\startdata\"
' If new microdata is available at the server then copy it to
' the local computer.
Dim i As Long
On Error GoTo ErrorNetwork
If Dir(data_path & "ii.bin") <> "" And Dir(data_path & "hh.bin") <> "" Then
Dim fcopy As Boolean
fcopy = False
If Dir(sesimpath & "\microdata\ii.bin") = "" _
Or Dir(sesimpath & "\microdata\hh.bin") = "" Then fcopy = True
If Dir(sesimpath & "\microdata\ii.bin") <> "" Then
If FileDateTime(sesimpath & "\microdata\ii.bin") < _
FileDateTime(data_path & "ii.bin") Then fcopy = True
End If
If Dir(sesimpath & "\microdata\hh.bin") <> "" Then
If FileDateTime(sesimpath & "\microdata\hh.bin") < _
FileDateTime(data_path & "hh.bin") Then fcopy = True
End If
ErrorNetwork:
If Err.Number = 52 Then 'Error. Tell user what happened. Then clear the Err object.
MsgBox "Can't read network data", , "Error message"
Err.Clear ' Clear Err object fields
End If
On Error GoTo 0 ' Turn off error trapping.
If fcopy = True Then
If vbYes = MsgBox("New data available. Do You wan't to copy?", vbYesNo) Then
status "Copying ii.bin from network"
FileCopy data_path & "ii.bin", sesimpath & "\microdata\ii.bin"
status "Copying hh.bin from network"
FileCopy data_path & "hh.bin", sesimpath & "\microdata\hh.bin"
status "Copying done"
End If
End If
End If ' if data exists on server
End Sub
'*****
'Funktionen beräknar statusfördelningen för individer som är i ålder 61-64 år. Värdena
'som returneras används för att fördela pensionerade individer i denna ålder på
'andra status. Sannolikhetsfördelningen för respektive år aggregeras för varje
'ytterligare status. FJ 2004-03-02 Borde placeras i Service
'*****
Public Function f_calc_StatusAtAge61ToX(retAge As Byte) As Variant
'Dimensioneras med 10 positioner där position 10 summan av övriga status 1-9
ReDim arr(61 To retAge - 1, 1 To 10) As Double
ReDim probArr(61 To retAge - 1, 1 To 9) As Double
Dim i As Long
Dim j As Integer
For i = 1 To m_icount
If i_age(i) > 60 And i_age(i) < retAge And i_status(i) <> 2 Then
arr(i_age(i), i_status(i)) = arr(i_age(i), i_status(i)) + 1
arr(i_age(i), 10) = arr(i_age(i), 10) + 1
End If
Next
For i = 1 To 9
For j = 61 To retAge - 1
If i = 1 Then
probArr(j, i) = arr(j, i) / arr(j, 10)
Else
probArr(j, i) = probArr(j, i - 1) + arr(j, i) / arr(j, 10)
End If
Next
Next
f_calc_StatusAtAge61ToX = probArr
End Function
'*****
'Generera ett slumptal och sök igenom probArr efter intervallet som omsluter detta
'slumpvärde. FJ 2004-03-02 Borde placeras i Service
'*****
Public Function f_set_StatusAtAge61ToX(probArr() As Double, individ As Long) As Integer
Dim i As Integer
Dim rand As Double
rand = Rnd()
For i = 1 To 9
If i = 1 And rand < probArr(i_age(individ), i) Then
Exit For
ElseIf i > 1 And i < 9 Then
If rand > probArr(i_age(individ), i - 1) And rand < probArr(i_age(individ), i) Then
Exit For
End If
ElseIf i = 9 Then
Exit For
End If
Next
f_set_StatusAtAge61ToX = i
End Function