ScoringFormulas: modGAP.bas

File modGAP.bas, 31.6 KB (added by Stein Tore Erdal, 10 years ago)

VB code from the last implementation of GAP in RACE

Line 
1Attribute VB_Name = "modGAP"
2'--------------------------------------------------------------------------------
3' RACE 4.0                                                                      -
4'--------------------------------------------------------------------------------
5' File:                                                                         -
6'    modGAP.bas                                                                 -
7' Purpose:                                                                      -
8'    Module for computing GAP results.                                          -
9' Comments:                                                                     -
10'    All distances in km.                                                       -
11'    Goal   = Goal of distance measuring                                        -
12'    ES     = End of speed section                                              -
13' History:                                                                      -
14'    20.10.99  ACM  Created                                                     -
15'    07.02.02  LG   Updated according Angelo Crapanzano (GAP 2002 Implemented)  -
16'--------------------------------------------------------------------------------
17
18Option Explicit
19
20'--------------------------------------------------------------------------------
21' Globals                                                                       -
22'--------------------------------------------------------------------------------
23
24'Values needed for calculation
25'Counter
26Public m_nPilotsTotal As Long                'All pilots registered
27Public m_nPilotsLaunched As Long             'Pilots who took off
28Public m_nPilotsGoal As Long                 'Pilots reached goal (of distance)
29Public m_nPilotsES As Long                   'Pilots reached ES (of time)
30Public m_nPilotsLO As Long                   'Pilots who landed out
31Public m_nPilotsABS As Long                  'Pilots who were absent
32Public m_nPilotsDNF As Long                  'Pilots who did not fly
33Public m_nPilotsPresent As Long              'Pilots who were present at start
34Public m_nPilotsMinimumDistance As Long      'Pilots who did not reach min distance
35Public m_nPilotsWithSpeedScore As Long       'Pilots who did get speed score
36
37'Tops
38Public m_fTopSpeed As Double                    'Top speed flown
39Public m_fTopDistance As Double                 'Top distance flown
40Public m_dtmTopTime As Date                     'Top time flown
41Public m_dtmTimeFirstInES As Date           'Earliest ES time
42Public m_dtmTimeFirstTakeoffWithES As Date  'First takeoff time with ES reached
43Public m_fSmallestLeadingCoefficient As Double      'Smallest Leading Coefficient (GAP 2002)
44Public m_bLCFieldIsUsed As Boolean
45
46'Distance Sums
47Public m_fSumDistance As Double                 'Sum of all distances flown
48Public m_fSumDistanceNominal As Double          'Sum of all distances greater nominal distance (as difference to nominal distance)
49Public m_fSumDistanceMinimum As Double          'Sum of all distances greater minimum distance (as difference to minimum distance)
50Public m_fAverageDistance As Double             'Average of all distances flown
51
52'Coefficients for day quality
53Public m_fCDistance As Double                   'see GAP documentation
54Public m_fCLaunch As Double
55Public m_fCTime As Double
56Public m_fDayQuality As Double
57     
58'Score distribution
59Public m_fDistanceWeight As Double              'see GAP documentation
60Public m_fTaskWeight As Double
61Public m_fAvailableScoreDistance As Double
62Public m_fAvailableScoreTime As Double
63Public m_fAvailableScoreDeparture As Double
64Public m_fAvailableScoreArrival As Double
65Public m_fAvailableScoreTotal As Double
66Public m_fMaxScoreTotal As Double
67
68'Pilots
69Public m_strPilotWithTopSpeed As String         'Pilot with top speed
70Public m_strPilotFirstES As String          'Pilot who first reached ES
71Public m_strPilotFirstTakeoffWithES As String 'Pilot who first took off and reached ES
72
73'--------------------------------------------------------------------------------
74' Types                                                                         -
75'--------------------------------------------------------------------------------
76
77'Type for GAP distance array
78Public Type DistanceArrayEntry
79   nLanded As Long
80   nLandedFullKM As Long
81   nDifficulty As Long
82   fRelDiff As Double
83   fScorePercent As Double
84End Type
85
86'--------------------------------------------------------------------------------
87' ComputePreValues                                                              -
88'--------------------------------------------------------------------------------
89' Computes all the values needed as input for the formula or to show in the     -
90' reports statistics page.                                                      -
91'--------------------------------------------------------------------------------
92
93Public Sub ComputePreValues(rsTask As DAO.Recordset, _
94   rsResults As DAO.Recordset, _
95   fMinimumDistance As Double, _
96   fNominalDistance As Double, _
97   fNominalTime As Double, _
98   fNominalGoal As Double, _
99   lTaskDistanceFlag As Long, _
100   lTaskSpeedFlag As Long, _
101   lDepartureFlag As Long, _
102   lArrivalFlag As Long, _
103   lGAPVersion As Long)
104
105   Dim strStatus As String
106   Dim bESReached As Boolean
107   Dim fDistance As Double
108   Dim dtmTimeSS As Date
109   Dim dtmTimeES As Date
110   Dim dtmTimeFlight As Date
111   Dim dtmTimeFirstInES As Date
112   Dim dblTimeLimitSpeedScore As Double
113   Dim k As Double
114   Dim fLeadingCoefficient As Double    'GAP 2002
115   Dim fLCTemp As Double
116   Dim j As Integer
117   Dim fLeadingVal As Double
118   Dim fSumLeadingVal As Double
119   Dim bLeadingValsAreGood As Boolean
120   
121   Dim bFieldLCIsFound As Boolean
122     
123   'Reset values
124   ResetPreValues
125   
126   fLCTemp = 0
127   fLeadingVal = 0#
128   fSumLeadingVal = 0#
129   bLeadingValsAreGood = False
130   'GAP 2002
131   'Looking for field resLeadingPosition in rsResults
132   
133   bFieldLCIsFound = False
134   For j = 0 To rsResults.Fields.Count - 1
135      If rsResults.Fields(j).Name = "resLeadingCoeff" Then
136         bFieldLCIsFound = True
137         bLeadingValsAreGood = True
138         j = rsResults.Fields.Count
139      End If
140   Next j
141
142   'loop over all pilots
143   rsResults.MoveFirst
144   While Not rsResults.EOF
145   
146      bESReached = rsResults.Fields("resReachedES").Value
147      strStatus = rsResults.Fields("resStatus").Value
148      dtmTimeSS = Null2EmptyTime(rsResults.Fields("resSSTime").Value)
149      dtmTimeES = Null2EmptyTime(rsResults.Fields("resESTime").Value)
150      dtmTimeFlight = Null2EmptyTime(rsResults.Fields("resTime").Value)
151      fDistance = rsResults.Fields("resDistance").Value
152
153      'set counter
154      Select Case strStatus
155         Case "ABS"
156            m_nPilotsABS = m_nPilotsABS + 1
157         Case "DNF"
158            m_nPilotsDNF = m_nPilotsDNF + 1
159            m_nPilotsPresent = m_nPilotsPresent + 1
160         Case "LO"
161            m_nPilotsLO = m_nPilotsLO + 1
162            m_nPilotsPresent = m_nPilotsPresent + 1
163            m_nPilotsLaunched = m_nPilotsLaunched + 1
164            If rsResults.Fields("resCommentCompute").Value = 1 Then m_nPilotsMinimumDistance = m_nPilotsMinimumDistance + 1
165         Case "GOAL"
166            m_nPilotsGoal = m_nPilotsGoal + 1
167            m_nPilotsPresent = m_nPilotsPresent + 1
168            m_nPilotsLaunched = m_nPilotsLaunched + 1
169      End Select
170     
171      If strStatus = "LO" Or strStatus = "GOAL" Then
172     
173         'top distance
174         If fDistance > m_fTopDistance Then m_fTopDistance = fDistance
175         
176         'compute distance sums
177         m_fSumDistance = m_fSumDistance + fDistance
178     
179         If fDistance > fNominalDistance Then
180            m_fSumDistanceNominal = m_fSumDistanceNominal + (fDistance - fNominalDistance)
181         End If
182         
183         If fDistance > fMinimumDistance Then
184            m_fSumDistanceMinimum = m_fSumDistanceMinimum + (fDistance - fMinimumDistance)
185         End If
186         
187         If (bFieldLCIsFound) And IsNull(rsResults.Fields("resLeadingCoeff").Value) = False Then
188             fLeadingVal = rsResults.Fields("resLeadingCoeff").Value
189             fSumLeadingVal = fSumLeadingVal + fLeadingVal
190             If (fLeadingVal < 0 Or fLeadingVal > 24) Then
191                 bLeadingValsAreGood = False
192             End If
193         End If
194         
195            'Smallest Leading Coefficient
196         If (bFieldLCIsFound) Then
197                If rsResults.Fields("resLeadingCoeff").Value > 0 Then
198                    fLeadingVal = rsResults.Fields("resLeadingCoeff").Value
199                    If (fLeadingVal > 0) Then
200                        If (fLeadingVal < fLCTemp Or fLCTemp = 0) Then
201                            fLCTemp = fLeadingVal
202                        End If
203                    End If
204                End If
205         Else
206               If dtmTimeFlight <> dtmEmptyDate Then
207                    If ((DecimalTimeFromDate(dtmTimeSS) + DecimalTimeFromDate(dtmTimeES)) < fLCTemp Or fLCTemp = 0) Then
208                        fLCTemp = DecimalTimeFromDate(dtmTimeSS) + DecimalTimeFromDate(dtmTimeES)
209                    End If
210               End If
211         End If
212         
213         'save best ES time
214         If bESReached Then
215         
216            m_nPilotsES = m_nPilotsES + 1
217     
218            If dtmTimeES <> dtmEmptyDate And (m_dtmTimeFirstInES = dtmEmptyDate Or dtmTimeES < m_dtmTimeFirstInES) Then
219               m_dtmTimeFirstInES = dtmTimeES
220               m_strPilotFirstES = rsResults.Fields("pilFirstName").Value + " " + rsResults.Fields("pilLastName").Value
221            End If
222                     
223                     
224            'top time/speed
225            If dtmTimeFlight <> dtmEmptyDate And (m_dtmTopTime = dtmEmptyDate Or dtmTimeFlight < m_dtmTopTime) Then
226               m_dtmTopTime = dtmTimeFlight
227               m_fTopSpeed = rsResults.Fields("resSpeed").Value
228               m_strPilotWithTopSpeed = rsResults.Fields("pilFirstName").Value + " " + rsResults.Fields("pilLastName").Value
229            End If
230         
231            'Earliest start time with ES reached
232            If dtmTimeFlight <> dtmEmptyDate And _
233               (m_dtmTimeFirstTakeoffWithES = dtmEmptyDate Or dtmTimeSS < m_dtmTimeFirstTakeoffWithES) Then
234               m_dtmTimeFirstTakeoffWithES = dtmTimeSS
235               'Don't set pilot if all pilots have same start time
236               If rsTask.Fields("tasTaskType").Value = "S" Then
237                  m_strPilotFirstTakeoffWithES = rsResults.Fields("pilFirstName").Value + " " + rsResults.Fields("pilLastName").Value
238               End If
239            End If
240           
241         End If
242         
243      End If
244
245      rsResults.MoveNext
246
247   Wend
248
249    If fSumLeadingVal = 0 Or bLeadingValsAreGood = False Or fLCTemp = 0 Then
250        bFieldLCIsFound = False
251    End If
252
253   If (bFieldLCIsFound) Then
254       m_fSmallestLeadingCoefficient = fLCTemp
255       m_bLCFieldIsUsed = True
256   Else
257       m_fSmallestLeadingCoefficient = fLCTemp - (2 * DecimalTimeFromDate(m_dtmTimeFirstTakeoffWithES))
258       m_bLCFieldIsUsed = False
259   End If
260   
261   'now loop over all pilots to get all pilots with speed score
262   dblTimeLimitSpeedScore = CDate(DecimalTimeFromDate(m_dtmTopTime) + Sqr(DecimalTimeFromDate(m_dtmTopTime)))
263   rsResults.MoveFirst
264   While Not rsResults.EOF
265      dtmTimeFlight = Null2EmptyTime(rsResults.Fields("resTime").Value)
266      If dtmTimeFlight <> dtmEmptyDate Then
267         If (rsResults.Fields("resStatus").Value = "LO" Or rsResults.Fields("resStatus").Value = "GOAL") And (DecimalTimeFromDate(dtmTimeFlight) < dblTimeLimitSpeedScore) Then
268            m_nPilotsWithSpeedScore = m_nPilotsWithSpeedScore + 1
269         End If
270      End If
271      rsResults.MoveNext
272   Wend
273
274   'some computing
275   m_nPilotsTotal = rsResults.RecordCount
276   If m_nPilotsLaunched <> 0 Then
277      m_fAverageDistance = m_fSumDistance / m_nPilotsLaunched
278   Else
279      m_fAverageDistance = 0#
280   End If
281   
282   'C launch
283   If m_nPilotsPresent <> 0 Then
284      k = m_nPilotsLaunched / m_nPilotsPresent
285      m_fCLaunch = 0.028 * k + 2.917 * (k * k) - 1.944 * (k * k * k)
286   Else
287      m_fCLaunch = 0#
288   End If
289   
290   If m_fCLaunch < 0# Then m_fCLaunch = 0#
291   If m_fCLaunch > 1# Then m_fCLaunch = 1#
292
293   'C Distance
294   If fNominalDistance <> fMinimumDistance And m_nPilotsLaunched <> 0 And lTaskDistanceFlag = 1 Then
295     
296      m_fCDistance = m_fSumDistanceMinimum / (m_nPilotsLaunched / 2# * ((fNominalGoal / 100# + 1#) * (fNominalDistance - fMinimumDistance) + fNominalGoal / 100# * (m_fTopDistance - fNominalDistance)))
297     
298   ElseIf lTaskDistanceFlag = 0 Then
299      m_fCDistance = 1#
300   Else
301      m_fCDistance = 0#
302   End If
303
304   If m_fCDistance < 0# Then m_fCDistance = 0#
305   If m_fCDistance > 1# Then m_fCDistance = 1#
306
307   'C Time
308   Dim fTopTimeUsed As Double
309   fTopTimeUsed = DecimalTimeFromDate(m_dtmTopTime)
310   
311   If m_nPilotsES = 0 And fNominalDistance <> 0# Then
312      fTopTimeUsed = fNominalTime * m_fTopDistance / fNominalDistance
313   End If
314
315   If fNominalTime > 0# And fTopTimeUsed < fNominalTime And lTaskSpeedFlag = 1 Then
316      k = fTopTimeUsed / fNominalTime
317      m_fCTime = -0.271 + 2.912 * k - 2.098 * (k ^ 2) + 0.457 * (k ^ 3)
318   Else
319      m_fCTime = 1#
320   End If
321
322   If m_fCTime < 0# Then m_fCTime = 0#
323   If m_fCTime > 1# Then m_fCTime = 1#
324
325   'Day Quality
326   m_fDayQuality = m_fCLaunch * m_fCDistance * m_fCTime
327   If m_fDayQuality > 1# Then m_fDayQuality = 1#
328
329   'Score distribution
330   If m_nPilotsLaunched <> 0 Then
331             
332      If lGAPVersion >= 2000 Then
333         k = m_nPilotsWithSpeedScore / m_nPilotsLaunched
334         m_fDistanceWeight = 0.9 - 1.665 * k + 1.713 * k * k - 0.587 * k * k * k
335      Else
336         k = m_nPilotsES / m_nPilotsLaunched
337         m_fDistanceWeight = 0.9 - 1.52 * k + 1.243 * k * k - 0.423 * k * k * k
338      End If
339     
340      m_fAvailableScoreDistance = 1000# * m_fDayQuality * m_fDistanceWeight
341      m_fAvailableScoreArrival = 1000# * m_fDayQuality * (1 - m_fDistanceWeight) * 1 / 8
342     
343      If lGAPVersion >= 2000 Then
344         m_fAvailableScoreDeparture = m_fAvailableScoreArrival * 1.4
345      Else
346         m_fAvailableScoreDeparture = m_fAvailableScoreArrival * 1.2
347      End If
348     
349      If lGAPVersion >= 2002 And lDepartureFlag = 0 Then
350         m_fAvailableScoreDeparture = 0#
351      End If
352     
353      If lGAPVersion >= 2002 And lArrivalFlag = 0 Then
354         m_fAvailableScoreArrival = 0#
355      End If
356     
357      m_fAvailableScoreTime = 1000# * m_fDayQuality * (1 - m_fDistanceWeight) - m_fAvailableScoreArrival - m_fAvailableScoreDeparture
358      m_fAvailableScoreTotal = m_fAvailableScoreDistance + m_fAvailableScoreArrival + m_fAvailableScoreDeparture + m_fAvailableScoreTime
359   
360   End If
361
362End Sub
363
364'--------------------------------------------------------------------------------
365' BuildDistanceArray                                                            -
366'--------------------------------------------------------------------------------
367' Build the distance array, needed to get distance score.                       -
368'--------------------------------------------------------------------------------
369
370Public Function BuildDistanceArray(rsResults As DAO.Recordset, fMinimumDistance As Double) As DistanceArrayEntry()
371
372   Dim i As Long
373   Dim j As Long
374   Dim aDistanceArray() As DistanceArrayEntry
375   Dim W As Long
376   Dim fSumDifficulty As Double
377   Dim fSumRelDifficulty As Double
378   Dim nKM As Long
379   Dim nKMRounded As Long
380   Dim nIndexMinimumDistance As Long
381
382   'Compute W
383   If m_nPilotsLaunched <> m_nPilotsGoal Then
384      W = Round((3 * m_fTopDistance / m_nPilotsLO), 0)
385   Else
386      W = 3
387   End If
388
389   If W < 3 Then W = 3
390
391   'Build Score Array
392   If m_fTopDistance <> 0# Then
393   
394      nKM = m_fTopDistance * 10# + 0.01
395      nKMRounded = (Int(m_fTopDistance + 1#)) * 10# + 0.01
396     
397      ReDim aDistanceArray(nKMRounded + 1)
398
399      'Count landed pilots
400      rsResults.MoveFirst
401      While Not rsResults.EOF
402         
403         If rsResults.Fields("resStatus").Value = "LO" Then
404            i = rsResults.Fields("resDistance").Value * 10# + 0.01
405            aDistanceArray(i).nLanded = aDistanceArray(i).nLanded + 1
406         End If
407         
408         rsResults.MoveNext
409         
410      Wend
411
412      'Compute LandedFullKM
413      j = 0
414      For i = 0 To nKMRounded
415         j = j + aDistanceArray(i).nLanded
416         If i Mod 10 = 0 Then
417            aDistanceArray(i).nLandedFullKM = j
418            j = 0
419         End If
420      Next i
421
422      'Compute Difficulty
423      For i = 0 To nKMRounded
424         j = i
425         While (j < i + (W * 10)) And (j <= nKMRounded)
426               aDistanceArray(i).nDifficulty = aDistanceArray(i).nDifficulty + aDistanceArray(j).nLanded
427            j = j + 1
428         Wend
429      Next i
430
431      'Build sum of difficulty
432      fSumDifficulty = 0#
433      For i = 0 To nKM
434         fSumDifficulty = fSumDifficulty + aDistanceArray(i).nDifficulty
435      Next i
436
437      'Compute relative difficulty
438      If fSumDifficulty <> 0# Then
439         For i = 0 To nKM
440            aDistanceArray(i).fRelDiff = aDistanceArray(i).nDifficulty / (2 * fSumDifficulty)
441         Next
442      End If
443
444      'Compute score %
445      fSumRelDifficulty = 0
446      For i = 0 To nKMRounded
447         fSumRelDifficulty = fSumRelDifficulty + aDistanceArray(i).fRelDiff
448         aDistanceArray(i).fScorePercent = fSumRelDifficulty
449      Next i
450
451      'set score to all distances below or equal minimum distance
452      nIndexMinimumDistance = fMinimumDistance * 10# + 0.01
453      For i = nIndexMinimumDistance - 1 To 0 Step -1
454         aDistanceArray(i).fScorePercent = aDistanceArray(nIndexMinimumDistance).fScorePercent
455      Next i
456
457      'output of distance array as csv for testing purposes
458     
459      'Dim nDistanceInt As Integer
460      'Dim fDistanceRemainder As Double
461      'Dim fPercentTopDistance As Double
462     
463      'nDistanceInt = Int(m_fTopDistance)
464      'fDistanceRemainder = m_fTopDistance - nDistanceInt
465
466      'Open "distance.csv" For Output As #1
467      'Print #1, "Distance Score Array"
468      'Print #1, "Dmax = " + Format(m_fTopDistance, "###0.000")
469      'Print #1, "Range = " + Str(W)
470      'Print #1, "Dmin = " + Format(fMinimumDistance, "###0.000")
471      'Print #1, "sum(difficulty) = " + Format(fSumDifficulty, "###0.000")
472      'Print #1, "km;landed;landed full km;difficulty;rel. difficulty;score %"
473      'For i = 0 To nKMRounded
474      '   Print #1, Format(i / 10#, "###0.0") + ";" + _
475      '      Str(aDistanceArray(i).nLanded) + ";" + _
476      '      Str(aDistanceArray(i).nLandedFullKM) + ";" + _
477      '      Str(aDistanceArray(i).nDifficulty) + ";" + _
478      '      Format(aDistanceArray(i).fRelDiff, "###0.000000") + ";" + _
479      '      Format(aDistanceArray(i).fScorePercent, "###0.000000")
480      'Next i
481      'Print #1, ";;;" + Str(Int(fSumDifficulty))
482      'Close #1
483     
484   End If
485   
486   BuildDistanceArray = aDistanceArray
487
488End Function
489
490'--------------------------------------------------------------------------------
491' ComputePilotScore                                                            -
492'--------------------------------------------------------------------------------
493' Give score to the pilots.                                                    -
494'--------------------------------------------------------------------------------
495
496Public Sub ComputePilotScore(rsTask As DAO.Recordset, _
497   rsResults As DAO.Recordset, _
498   aDistanceArray() As DistanceArrayEntry, _
499   fNominalTime As Double, _
500   lTaskDistanceFlag As Long, _
501   lTaskSpeedFlag As Long, _
502   lTaskDepartureFlag As Long, _
503   lTaskArrivalFlag As Long, _
504   lGAPVersion As Long, _
505   lGoalPenalty As Long)
506
507   Dim strStatus As String
508   Dim fScoreDistance As Double
509   Dim fScoreTime As Double
510   Dim fScoreDeparture As Double
511   Dim fScoreArrival As Double
512   Dim fScoreTotal As Double
513   Dim fSumScore As Double
514   Dim fSumScoreSquare As Double
515   Dim fLeadingCoefficient As Double
516   Dim x As Double
517   
518   fSumScore = 0#
519   fSumScoreSquare = 0#
520   
521   'get ES Place of each pilot for arrival score
522   DoESPlacing rsResults
523
524   'loop over all pilot results
525   rsResults.MoveFirst
526   
527
528   While Not rsResults.EOF
529
530      'prepare for update
531      rsResults.Edit
532
533      strStatus = rsResults.Fields("resStatus").Value
534     
535      'give only score to pilots with LO or GOAL
536      If strStatus = "LO" Or strStatus = "GOAL" Then
537     
538         'give distance score
539         If lTaskDistanceFlag = 1 And m_fTopDistance <> 0# Then
540         
541            Dim fDistanceScoreLinear As Double
542            Dim fDistanceScoreByDifficulty As Double
543           
544            'Score by difficulty
545            If m_nPilotsGoal = m_nPilotsLaunched Then
546               'GAP FIX September 99: all pilots launched in goal
547              fDistanceScoreByDifficulty = 0.5
548            Else
549              fDistanceScoreByDifficulty = aDistanceArray(Int(rsResults.Fields("resDistance").Value * 10#)).fScorePercent
550            End If
551           
552            'Linear score by distance
553            fDistanceScoreLinear = rsResults.Fields("resDistance").Value / 2# / m_fTopDistance
554           
555            'Add two distance score categories and round
556            fScoreDistance = (fDistanceScoreLinear + fDistanceScoreByDifficulty) * m_fAvailableScoreDistance
557            fScoreDistance = modTools.RoundValue(fScoreDistance, enumRoundTaskScore)
558            rsResults.Fields("resDistanceScore").Value = fScoreDistance
559         Else
560            fScoreDistance = 0#
561            rsResults.Fields("resDistanceScore").Value = 0#
562         End If
563   
564         'give speed score
565         If m_dtmTopTime <> dtmEmptyDate And _
566            Null2EmptyTime(rsResults.Fields("resTime").Value) <> dtmEmptyDate And _
567            lTaskSpeedFlag = 1 And _
568            rsResults.Fields("resReachedES").Value = True And _
569            (Null2EmptyTime(rsTask.Fields("tasESClose").Value) = dtmEmptyDate Or rsResults.Fields("resESTime").Value <= rsTask.Fields("tasESClose").Value) Then
570         
571            fScoreTime = 1 - (((DecimalTimeFromDate(rsResults.Fields("resTime").Value) - DecimalTimeFromDate(m_dtmTopTime)) / Sqr(DecimalTimeFromDate(m_dtmTopTime))) ^ (2# / 3#))
572            If fScoreTime < 0# Then fScoreTime = 0#
573            fScoreTime = fScoreTime * m_fAvailableScoreTime
574           
575            'Apply penalty
576            If lGoalPenalty = 1 And rsResults.Fields("resStatus").Value <> "GOAL" Then
577               fScoreTime = fScoreTime - (fScoreTime * 0.2)
578               If fScoreTime < 0 Then fScoreTime = 0
579            End If
580           
581            fScoreTime = modTools.RoundValue(fScoreTime, enumRoundTaskScore)
582            rsResults.Fields("resSpeedScore").Value = fScoreTime
583           
584            'give departure score
585            If lGAPVersion < 2002 And fNominalTime <> 0# And Null2EmptyTime(rsResults.Fields("resTime").Value) <> dtmEmptyDate And lTaskDepartureFlag = 1 Then
586           
587               x = (DecimalTimeFromDate(rsResults.Fields("resSSTime").Value) - DecimalTimeFromDate(m_dtmTimeFirstTakeoffWithES)) / fNominalTime
588               
589               If (lGAPVersion >= 2000 And x >= 1 / 2) Or (lGAPVersion < 2000 And x >= 1 / 3) Then
590                  fScoreDeparture = 0#
591               Else
592                  If (lGAPVersion < 2000) Then
593                     fScoreDeparture = 1 - 6.312 * x + 10.932 * x * x - 2.99 * x * x * x
594                  Else
595                     fScoreDeparture = 1 - 4.776 * x + 8.309 * x * x - 5.514 * x * x * x
596                  End If
597                  If m_fAvailableScoreTime <> 0# And m_fAvailableScoreDeparture <> 0# Then
598                     fScoreDeparture = fScoreDeparture * fScoreTime / (m_fAvailableScoreTime / m_fAvailableScoreDeparture)
599                  Else
600                     fScoreDeparture = 0#
601                  End If
602                  fScoreDeparture = modTools.RoundValue(fScoreDeparture, enumRoundTaskScore)
603               End If
604               
605               If fScoreDeparture > m_fAvailableScoreDeparture Then fScoreDeparture = m_fAvailableScoreDeparture
606               rsResults.Fields("resDepartureScore").Value = fScoreDeparture
607            Else
608               fScoreDeparture = 0#
609               rsResults.Fields("resDepartureScore").Value = 0#
610            End If
611           
612            'give arrival score
613            If m_nPilotsES <> 0# And Null2EmptyTime(rsResults.Fields("resTime").Value) <> dtmEmptyDate And lTaskArrivalFlag = 1 Then
614               x = 1 - ((rsResults.Fields("resPlaceES").Value - 1) / m_nPilotsES)
615               fScoreArrival = 0.2 + 0.037 * x + 0.13 * x * x + 0.633 * x * x * x
616               fScoreArrival = fScoreArrival * m_fAvailableScoreArrival
617               fScoreArrival = modTools.RoundValue(fScoreArrival, enumRoundTaskScore)
618               rsResults.Fields("resArrivalScore").Value = fScoreArrival
619            Else
620               fScoreArrival = 0#
621               rsResults.Fields("resArrivalScore").Value = 0#
622            End If
623         
624         Else
625            fScoreTime = 0#
626            fScoreArrival = 0#
627            fScoreDeparture = 0#
628            rsResults.Fields("resSpeedScore").Value = 0#
629            rsResults.Fields("resDepartureScore").Value = 0#
630            rsResults.Fields("resArrivalScore").Value = 0#
631         
632         End If
633           
634         'Give departure score for GAP 2002
635         If lGAPVersion >= 2002 And lTaskDepartureFlag = 1 Then
636            If m_bLCFieldIsUsed Then
637               fLeadingCoefficient = rsResults.Fields("resLeadingCoeff")
638            Else
639                If (DecimalTimeFromDate(rsResults.Fields("resESTime").Value) > 0) Then
640                    fLeadingCoefficient = (DecimalTimeFromDate(rsResults.Fields("resSSTime").Value) + _
641                                     DecimalTimeFromDate(rsResults.Fields("resESTime").Value) - _
642                                     2 * DecimalTimeFromDate(m_dtmTimeFirstTakeoffWithES))
643                Else
644                    fLeadingCoefficient = 0
645                End If
646            End If
647            If fLeadingCoefficient > 0 Then
648               fScoreDeparture = (fLeadingCoefficient - m_fSmallestLeadingCoefficient) / (m_fSmallestLeadingCoefficient ^ 0.5)
649               fScoreDeparture = fScoreDeparture ^ 0.666
650               fScoreDeparture = 1 - fScoreDeparture
651               If (fScoreDeparture < 0) Then fScoreDeparture = 0#
652            Else
653               fScoreDeparture = 0#
654            End If
655                   
656            If m_fAvailableScoreTime <> 0# And m_fAvailableScoreDeparture <> 0# Then
657               'fScoreDeparture = fScoreDeparture * fScoreTime / (m_fAvailableScoreTime / m_fAvailableScoreDeparture)
658               fScoreDeparture = fScoreDeparture * m_fAvailableScoreDeparture
659            Else
660               fScoreDeparture = 0#
661            End If
662            fScoreDeparture = modTools.RoundValue(fScoreDeparture, enumRoundTaskScore)
663           
664            If fScoreDeparture > m_fAvailableScoreDeparture Then fScoreDeparture = m_fAvailableScoreDeparture
665           
666            rsResults.Fields("resDepartureScore").Value = fScoreDeparture
667               
668         Else
669         
670         End If
671   
672         fScoreTotal = fScoreDistance + fScoreTime + fScoreDeparture + fScoreArrival
673         If fScoreTotal > m_fMaxScoreTotal Then m_fMaxScoreTotal = fScoreTotal
674         fScoreTotal = modTools.RoundValue(fScoreTotal, enumRoundTaskScoreTotal)
675         rsResults.Fields("resScore").Value = fScoreTotal
676         
677         fSumScore = fSumScore + fScoreTotal
678         fSumScoreSquare = fSumScoreSquare + fScoreTotal ^ 2
679   
680      Else
681     
682         rsResults.Fields("resDistanceScore").Value = 0#
683         rsResults.Fields("resSpeedScore").Value = 0#
684         rsResults.Fields("resDepartureScore").Value = 0#
685         rsResults.Fields("resArrivalScore").Value = 0#
686         rsResults.Fields("resScore").Value = 0#
687     
688      End If
689   
690      rsResults.Update
691      rsResults.MoveNext
692   
693   Wend
694
695   If m_nPilotsLaunched > 1 Then
696      m_fTaskWeight = Sqr((m_nPilotsLaunched * fSumScoreSquare - fSumScore ^ 2) / (m_nPilotsLaunched * (m_nPilotsLaunched - 1)))
697   End If
698
699End Sub
700
701'--------------------------------------------------------------------------------
702' DoESPlacing                                                                   -
703'--------------------------------------------------------------------------------
704' Sorts pilots by place at end of speed section and saves place in results      -
705' recordset.                                                                    -
706'--------------------------------------------------------------------------------
707
708Private Sub DoESPlacing(rsResults As DAO.Recordset)
709
710   Dim lPlace As Long
711   Dim dtmLastTime As Date
712   Dim lLastPlace As Long
713   Dim rsResultsSortedByESTime As DAO.Recordset
714   
715   rsResults.Sort = "resESTime ASC"
716   Set rsResultsSortedByESTime = rsResults.OpenRecordset
717
718   'init Place counter
719   lPlace = 0
720   dtmLastTime = CDate("23:59:59")
721   lLastPlace = 1
722   
723   While Not rsResultsSortedByESTime.EOF
724   
725      rsResultsSortedByESTime.Edit
726     
727      If rsResultsSortedByESTime.Fields("resReachedES").Value = True And Null2EmptyTime(rsResultsSortedByESTime.Fields("resESTime").Value) <> dtmEmptyDate Then
728         
729         lPlace = lPlace + 1
730         
731         'decide if place is same as before
732         If Null2EmptyTime(rsResultsSortedByESTime.Fields("resESTime").Value) = dtmLastTime Then
733            'same place
734            rsResultsSortedByESTime.Fields("resPlaceES").Value = lLastPlace
735         Else
736            rsResultsSortedByESTime.Fields("resPlaceES").Value = lPlace
737            dtmLastTime = Null2EmptyTime(rsResultsSortedByESTime.Fields("resESTime").Value)
738            lLastPlace = lPlace
739         End If
740      Else
741         rsResultsSortedByESTime.Fields("resPlaceES").Value = 0
742      End If
743     
744      rsResultsSortedByESTime.Update
745      rsResultsSortedByESTime.MoveNext
746     
747   Wend
748   
749   rsResultsSortedByESTime.Close
750   Set rsResultsSortedByESTime = Nothing
751
752End Sub
753
754'--------------------------------------------------------------------------------
755' ResetPreValues                                                                -
756'--------------------------------------------------------------------------------
757' Init values.                                                                  -
758'--------------------------------------------------------------------------------
759
760Private Sub ResetPreValues()
761
762   m_nPilotsLaunched = 0
763   m_nPilotsGoal = 0
764   m_nPilotsES = 0
765   m_nPilotsLO = 0
766   m_nPilotsABS = 0
767   m_nPilotsDNF = 0
768   m_nPilotsPresent = 0
769   m_nPilotsMinimumDistance = 0
770   m_nPilotsWithSpeedScore = 0
771   
772   'Tops
773   m_fTopSpeed = 0#
774   m_fTopDistance = 0#
775   m_dtmTopTime = dtmEmptyDate
776   m_dtmTimeFirstInES = dtmEmptyDate
777   m_dtmTimeFirstTakeoffWithES = dtmEmptyDate
778   m_fSumDistance = 0#
779   m_fSumDistanceNominal = 0#
780   m_fSumDistanceMinimum = 0#
781   m_fAverageDistance = 0#
782   m_fSmallestLeadingCoefficient = 0#
783   m_bLCFieldIsUsed = False
784   
785   'Coefficients for day quality
786   m_fCDistance = 0#
787   m_fCLaunch = 0#
788   m_fCTime = 0#
789   m_fDayQuality = 0#
790   
791   'Score distribution
792   m_fDistanceWeight = 0#
793   m_fTaskWeight = 0#
794   m_fAvailableScoreDistance = 0#
795   m_fAvailableScoreTime = 0#
796   m_fAvailableScoreDeparture = 0#
797   m_fAvailableScoreArrival = 0#
798   m_fAvailableScoreTotal = 0#
799
800   'Pilots
801   m_strPilotWithTopSpeed = ""
802   m_strPilotFirstES = ""
803   m_strPilotFirstTakeoffWithES = ""
804
805End Sub
806
807
808