Attribute VB_Name = "supportingFunctions"
Option Explicit
Dim lsMatrix(1 To 3, 1 To 3) As Double
Dim eigenvector(1 To 3, 1 To 3) As Double
Dim eigenvalue(1 To 3) As Double
Dim planeNormal(1 To 3) As Double
Dim planeRMSD As Double
Function CATIONXFYFZF(address1 As Range, address2 As Range, sgKey As Integer, xyz As Integer) As Double
'************************************************************************************
' Calculates new fractional coordinates of a cation when atom positional parameters *
' in address1 are altered, using the generators in address2                         *
'************************************************************************************
Dim element As Range, row As Range
Dim iColumn As Integer, atomID As Integer, symmID As Integer, lineToRead As Integer
Dim trLatt(1 To 3) As Integer
Dim atomNumber As Integer
Dim i As Integer, j As Integer
Dim atomXf(1 To 3) As Double, xfOutput(1 To 3) As Double
Dim symmMatrix(1 To 3, 1 To 3) As Double
Dim symmTr(1 To 3) As Double
'.....................
iColumn = 0
For Each element In address2.Columns
iColumn = iColumn + 1
If iColumn = 1 Then
atomID = element.value
ElseIf iColumn = 2 Then
symmID = element.value
ElseIf iColumn = 3 Then
trLatt(1) = element.value
ElseIf iColumn = 4 Then
trLatt(2) = element.value
ElseIf iColumn = 5 Then
trLatt(3) = element.value
End If
Next element
'......................
For Each row In address1.Rows
atomNumber = row.Cells(4).value
If atomNumber = atomID Then
For j = 1 To 3
atomXf(j) = row.Cells(j).value
Next j
End If
Next row
'Apply symmetry operation to atomXf and add lattice translation
If sgKey = 1 Then
  lineToRead = 1 + symmID
ElseIf sgKey = 2 Then
  lineToRead = 10 + symmID
ElseIf sgKey = 3 Then
  lineToRead = 19 + symmID
ElseIf sgKey = 4 Then
  lineToRead = 26 + symmID
ElseIf sgKey = 5 Then
  lineToRead = 35 + symmID
End If
With Sheets("symmetry operations")
For i = 1 To 3
For j = 1 To 3
symmMatrix(i, j) = .Cells(lineToRead, 4 * (i - 1) + j + 1).value
symmTr(i) = .Cells(lineToRead, 4 * i + 1).value
Next j
Next i
End With
For i = 1 To 3
xfOutput(i) = symmMatrix(i, 1) * atomXf(1) + symmMatrix(i, 2) * atomXf(2) + symmMatrix(i, 3) * atomXf(3)
xfOutput(i) = xfOutput(i) + symmTr(i) + trLatt(i)
Next i
CATIONXFYFZF = xfOutput(xyz)
End Function
Function XFYFZF(address1 As Range, address2 As Range, sgKey As Integer, xyz As Integer) As Double
'***********************************************************************************
' Calculates new fractional coordinates of an atom when atom positional parameters *
' in address1 are altered, using the generators in address2                        *
'***********************************************************************************
Dim element As Range
Dim nRow As Integer
Dim rowKey(1 To 32) As Integer
Dim rowXfYfZf(1 To 32) As Double
Dim atomID As Integer
Dim symmID As Integer, lineToRead As Integer
Dim itrX As Integer, itrY As Integer, itrZ As Integer
Dim atomXf(1 To 3) As Double, xfOutput(1 To 3) As Double, trLatt(1 To 3) As Double
Dim i As Integer, j As Integer, index As Integer
Dim symmMatrix(1 To 3, 1 To 3) As Double
Dim symmTr(1 To 3) As Double
'...read in block of atomic positions
nRow = 0
For Each element In address1.Rows
  nRow = nRow + 1
rowKey(nRow) = element.Cells(2).value
rowXfYfZf(nRow) = element.Cells(1).value
Next element
'...read in current atomID and symmetry generators
Dim iColumn As Integer
iColumn = 0
For Each element In address2.Columns
iColumn = iColumn + 1
If iColumn = 1 Then
atomID = element.value
ElseIf iColumn = 2 Then
symmID = element.value
ElseIf iColumn = 3 Then
trLatt(1) = element.value
ElseIf iColumn = 4 Then
trLatt(2) = element.value
ElseIf iColumn = 5 Then
trLatt(3) = element.value
End If
Next element
'Pick up (xf,yf,zf) parameters of current atom
  index = 0
  For i = 1 To nRow
  If rowKey(i) = atomID Then
  index = index + 1
  atomXf(index) = rowXfYfZf(i)
  End If
  Next i
'Apply symmetry operation to atomXf and add lattice translation
If sgKey = 1 Then
  lineToRead = 1 + symmID
ElseIf sgKey = 2 Then
  lineToRead = 10 + symmID
ElseIf sgKey = 3 Then
  lineToRead = 19 + symmID
ElseIf sgKey = 4 Then
  lineToRead = 26 + symmID
ElseIf sgKey = 5 Then
  lineToRead = 35 + symmID
End If
With Sheets("symmetry operations")
For i = 1 To 3
For j = 1 To 3
symmMatrix(i, j) = .Cells(lineToRead, 4 * (i - 1) + j + 1).value
symmTr(i) = .Cells(lineToRead, 4 * i + 1).value
Next j
Next i
End With
For i = 1 To 3
xfOutput(i) = symmMatrix(i, 1) * atomXf(1) + symmMatrix(i, 2) * atomXf(2) + symmMatrix(i, 3) * atomXf(3)
xfOutput(i) = xfOutput(i) + symmTr(i) + trLatt(i)
Next i
XFYFZF = xfOutput(xyz)
End Function
Function OCTVOLSA(address As Range, idFunction As Integer) As Double
'***************************************************************************
' idFunction = 1: Calculates the volume of an octahedron                   *
' idFunction = 2: Calculates the enclosed solid angle of an octahedron     *
' idFunction = 3: Calculates the projected area of a basal triangular face *
' The vertices are in cyclic projection order (star form)                  *
'***************************************************************************
Dim xC(1 To 6, 1 To 3) As Double
Dim sum(1 To 3) As Double
Dim i As Integer, j As Integer, ii As Integer
Dim v1 As Integer, v2 As Integer, v3 As Integer
Dim faceIncrement As Double
Dim vec1(1 To 3) As Double
Dim vec2(1 To 3) As Double
Dim vec3(1 To 3) As Double
Dim vec4(1 To 2) As Double
Dim vec5(1 To 2) As Double
Dim basalArea(1 To 2) As Double
Dim basalAreaUpper As Double, basalAreaLower As Double
Dim zc1 As Double, zc2 As Double
'Extract coordinates of vertices from range and adopt centre of coordinates as origin
For j = 1 To 3
sum(j) = 0
Next j
'...
For i = 1 To 6
For j = 1 To 3
xC(i, j) = address.Cells(i, j)
sum(j) = sum(j) + xC(i, j)
Next j
Next i
'...
For i = 1 To 6
For j = 1 To 3
xC(i, j) = xC(i, j) - sum(j) / 6
Next j
Next i
'....
OCTVOLSA = 0
For i = 1 To 8 'loop over faces
 If i <= 2 Then 'bottom or top face
  v1 = i
  v2 = i + 2
  v3 = i + 4
  If i = 1 Then
  zc1 = xC(v1, 3) 'z-height of vertex1
  Else
  zc2 = xC(v1, 3) 'z-height of vertex2
  End If
 Else 'side face
  v1 = i - 2
  v2 = i - 1
  v3 = i - 3
 End If
  If v2 = 7 Then v2 = 1
  If v3 = 0 Then v3 = 6
  For j = 1 To 3
  vec1(j) = xC(v1, j)
  vec2(j) = xC(v2, j)
  vec3(j) = xC(v3, j)
  Next j
'...basal area
If i <= 2 Then
    For j = 1 To 2
    vec4(j) = vec2(j) - vec1(j)
    vec5(j) = vec3(j) - vec1(j)
    Next j
    basalArea(i) = 0.5 * Abs(vec4(1) * vec5(2) - vec4(2) * vec5(1))
End If
'...
 If idFunction = 1 Then
 faceIncrement = volumeIncrement(vec1, vec2, vec3)
  OCTVOLSA = OCTVOLSA + faceIncrement
 ElseIf idFunction = 2 Then
 faceIncrement = solidAngleIncrement(vec1, vec2, vec3)
  OCTVOLSA = OCTVOLSA + faceIncrement
 End If
Next i
'...
If zc1 > zc2 Then
basalAreaUpper = basalArea(1)
basalAreaLower = basalArea(2)
Else
basalAreaLower = basalArea(1)
basalAreaUpper = basalArea(2)
End If
'...
If idFunction = 3 Then
OCTVOLSA = basalAreaUpper
ElseIf idFunction = 4 Then
OCTVOLSA = basalAreaLower
End If
'........
End Function
Function ILVOLSA(idSG As Integer, address As Range, idFunction As Integer, idSubFunction As Integer) As Double
'*************************************************************************************************************
' idFunction = 1: Calculates the enclosed volume of an interlayer cation coordination polyhedron.            *
' idFunction = 2: Calculates the enclosed solid angle of an interlayer cation coordination polyhedron        *
' as a fraction of 4*pi.                                                                                     *
' idFunction = 3: Calculates the height of the reference interlayer cation coordination polyhedron           *
' idFunction = 4: Calculates the projected areas of top and bottom faces of interlayer coordination polyh.   *
'*************************************************************************************************************
Dim xC(1 To 12, 1 To 3) As Double
Dim xcSideFace(1 To 4, 1 To 3) As Double
Dim sum(1 To 3) As Double
Dim i As Integer, j As Integer, k As Integer, ii As Integer, kk As Integer
Dim v1 As Integer, v2 As Integer, v3 As Integer
Dim faceIncrement As Double
Dim vec0(1 To 3) As Double
Dim vec1(1 To 3) As Double
Dim vec2(1 To 3) As Double
Dim vec3(1 To 3) As Double
Dim vec4(1 To 3) As Double
Dim ccFace(1 To 3) As Double
Dim iLower As Integer, iNextLower As Integer, iUpper As Integer, iNextUpper As Integer
Dim zTop As Double, zBottom As Double
Dim brv As Boolean
Dim area(1 To 2) As Double
'Extract coordinates of vertices from range and adopt centre of coordinates as origin
For j = 1 To 3
vec0(j) = 0
sum(j) = 0
Next j
'...
For i = 1 To 12
For j = 1 To 3
xC(i, j) = address.Cells(i, j)
sum(j) = sum(j) + xC(i, j)
Next j
Next i
'...
For i = 1 To 12
For j = 1 To 3
xC(i, j) = xC(i, j) - sum(j) / 12
Next j
Next i
'....
ILVOLSA = 0
'...Form pseudo-planar quadrilateral faces
            For iLower = 1 To 6
              iNextLower = iLower + 1
              If iNextLower = 7 Then iNextLower = 1
                iUpper = iLower + 6
                iNextUpper = iNextLower + 6
                For j = 1 To 3
                xcSideFace(1, j) = xC(iLower, j)
                xcSideFace(2, j) = xC(iUpper, j)
                xcSideFace(3, j) = xC(iNextUpper, j)
                xcSideFace(4, j) = xC(iNextLower, j)
                ccFace(j) = vec0(j)
'...
                For k = 1 To 4
                ccFace(j) = ccFace(j) + xcSideFace(k, j)
                Next k
                ccFace(j) = ccFace(j) / 4
                Next j
'....
                faceIncrement = 0
                For k = 1 To 4
                    kk = k + 1
                    If kk = 5 Then kk = 1
                      For j = 1 To 3
                      vec1(j) = xcSideFace(k, j)
                      vec2(j) = xcSideFace(kk, j)
                      Next j
                    If idFunction = 1 Then
                    faceIncrement = faceIncrement + volumeIncrement(ccFace, vec1, vec2)
                    Else
                    faceIncrement = faceIncrement + solidAngleIncrement(ccFace, vec1, vec2)
                    End If
                Next k
                    ILVOLSA = ILVOLSA + faceIncrement
                Next iLower
'.....lower and upper faces
            For i = 1 To 2
            area(i) = 0
               For j = 1 To 3
               ccFace(j) = vec0(j)
                For k = 1 To 6
                ccFace(j) = ccFace(j) + xC((i - 1) * 6 + k, j)
                Next k
               ccFace(j) = ccFace(j) / 6
               Next j
'...
              For k = 1 To 6
               kk = k + 1
               If kk = 7 Then kk = 1
                 For j = 1 To 3
                 vec1(j) = xC((i - 1) * 6 + k, j)
                 vec2(j) = xC((i - 1) * 6 + kk, j)
                 Next j
               If idFunction = 1 Then
               ILVOLSA = ILVOLSA + volumeIncrement(ccFace, vec1, vec2)
               ElseIf idFunction = 2 Then
               ILVOLSA = ILVOLSA + solidAngleIncrement(ccFace, vec1, vec2)
               ElseIf idFunction = 4 Or idFunction = 5 Then
               For j = 1 To 3
               vec3(j) = vec1(j) - ccFace(j)
               vec4(j) = vec2(j) - ccFace(j)
               Next j
               vec3(3) = 0
               vec4(3) = 0
               area(i) = area(i) + 0.5 * Abs(vec3(1) * vec4(2) - vec4(1) * vec3(2))
               End If
              Next k
                       
            Next i
            If idFunction = 4 Then
            ILVOLSA = area(1)
            ElseIf idFunction = 5 Then
            ILVOLSA = area(2)
            End If
'................................................................
               If idFunction = 3 Then
'Calculate height of polyhedron
'Construct mean ZC for whole top and bottom six-vertex sets. The difference is the polyhedron height.
            zBottom = 0
            zTop = 0
         For i = 1 To 6
         zBottom = zBottom + xC(i, 3)
         zTop = zTop + xC(i + 6, 3)
         Next i
         zBottom = zBottom / 6#
         zTop = zTop / 6#
         ILVOLSA = zTop - zBottom
               End If
End Function
Function TETPAR(address As Range, idFunction As Integer) As Double
'*************************************************
' Calculates the parameters of an O4 tetrahedron *
'*************************************************
Dim xC(1 To 4, 1 To 3) As Double
Dim coordinateCentre(1 To 3) As Double
Dim pcOrigin(1 To 3) As Double
Dim i As Integer, j As Integer
Dim vecPC(1 To 3, 1 To 3) As Double
Dim vecA(1 To 3) As Double
Dim vecB(1 To 3) As Double
Dim vecC(1 To 3) As Double
Dim bCrossC(1 To 3) As Double
Dim aPC As Double, bPC As Double, cPC As Double
Dim alphaPC As Double, betaPC As Double, gammaPC As Double, volumePC As Double
Dim meanAxisLength As Double, lambdaPC As Double, sigmaPCDegrees As Double
Dim zcMin As Double
Dim idZcMin As Integer, nVertex As Integer
Dim vecPCLength(1 To 3) As Double
Dim dummy(1 To 3) As Double
Dim orderPC(1 To 3) As Integer
Dim tiltAngle As Double
Dim vecBaseA(1 To 3) As Double, vecBaseB(1 To 3) As Double, vbn(1 To 3) As Double
Dim nBase As Integer
Dim idBase(1 To 3) As Integer
Dim baseArea As Double, baseAreaProjection As Double, tiltAngle1 As Double
'Extract coordinates of vertices from range and adopt centre of coordinates as origin
For j = 1 To 3
coordinateCentre(j) = 0
Next j
'...
For i = 1 To 4
For j = 1 To 3
xC(i, j) = address.Cells(i, j)
coordinateCentre(j) = coordinateCentre(j) + xC(i, j) / 4
Next j
Next i
'Identify tetrahedral vertex with minimum xc(i,3) and take its inversion as the origin of the pseudocube
zcMin = 10000
For i = 1 To 4
If xC(i, 3) < zcMin Then
zcMin = xC(i, 3)
idZcMin = i
End If
Next i
'...
For i = 1 To 4
For j = 1 To 3
xC(i, j) = xC(i, j) - coordinateCentre(j)
Next j
Next i
'...
For j = 1 To 3
pcOrigin(j) = -xC(idZcMin, j)
Next j
nVertex = 0
For i = 1 To 4
If i <> idZcMin Then
nVertex = nVertex + 1
For j = 1 To 3
vecPC(nVertex, j) = xC(i, j) - pcOrigin(j)
Next j
vecPCLength(nVertex) = Sqr(vecPC(nVertex, 1) ^ 2 + vecPC(nVertex, 2) ^ 2 + vecPC(nVertex, 3) ^ 2)
End If
Next i
'...a(PC), b(PC), c(PC) are determined by decreasing order of length
Call ordar(vecPCLength, dummy, orderPC, 3)
For j = 1 To 3
vecA(j) = vecPC(orderPC(3), j)
vecB(j) = vecPC(orderPC(2), j)
vecC(j) = vecPC(orderPC(1), j)
Next j
'...
aPC = Sqr(vecA(1) ^ 2 + vecA(2) ^ 2 + vecA(3) ^ 2)
bPC = Sqr(vecB(1) ^ 2 + vecB(2) ^ 2 + vecB(3) ^ 2)
cPC = Sqr(vecC(1) ^ 2 + vecC(2) ^ 2 + vecC(3) ^ 2)
With WorksheetFunction
alphaPC = .Acos((vecB(1) * vecC(1) + vecB(2) * vecC(2) + vecB(3) * vecC(3)) / (bPC * cPC)) * 180# / .Pi()
betaPC = .Acos((vecC(1) * vecA(1) + vecC(2) * vecA(2) + vecC(3) * vecA(3)) / (cPC * aPC)) * 180# / .Pi()
gammaPC = .Acos((vecA(1) * vecB(1) + vecA(2) * vecB(2) + vecA(3) * vecB(3)) / (aPC * bPC)) * 180# / .Pi()
End With
bCrossC(1) = vecB(2) * vecC(3) - vecB(3) * vecC(2)
bCrossC(2) = vecB(3) * vecC(1) - vecB(1) * vecC(3)
bCrossC(3) = vecB(1) * vecC(2) - vecB(2) * vecC(1)
volumePC = Abs(vecA(1) * bCrossC(1) + vecA(2) * bCrossC(2) + vecA(3) * bCrossC(3))
meanAxisLength = (aPC + bPC + cPC) / 3
lambdaPC = (Abs(aPC - meanAxisLength) + Abs(bPC - meanAxisLength) + Abs(cPC - meanAxisLength)) / (3 * meanAxisLength)
sigmaPCDegrees = (Abs(alphaPC - 90#) + Abs(betaPC - 90#) + Abs(gammaPC - 90#)) / 3
'...tilt angle
nBase = 0
For i = 1 To 4
If i <> idZcMin Then
nBase = nBase + 1
idBase(nBase) = i
End If
Next i
For j = 1 To 3
vecBaseA(j) = xC(idBase(2), j) - xC(idBase(1), j)
vecBaseB(j) = xC(idBase(3), j) - xC(idBase(1), j)
Next j
Call vxv(vecBaseA, vecBaseB, vbn)
tiltAngle = WorksheetFunction.Acos(Abs(vbn(3)) / Sqr(vbn(1) ^ 2 + vbn(2) ^ 2 + vbn(3) ^ 2))
tiltAngle = WorksheetFunction.Degrees(tiltAngle)
baseArea = Sqr(vbn(1) ^ 2 + vbn(2) ^ 2 + vbn(3) ^ 2) / 2
baseAreaProjection = Abs(vecBaseA(1) * vecBaseB(2) - vecBaseA(2) * vecBaseB(1)) / 2
tiltAngle1 = WorksheetFunction.Acos(baseAreaProjection / baseArea)
tiltAngle1 = WorksheetFunction.Degrees(tiltAngle1)
'...
If idFunction = 1 Then
TETPAR = aPC
ElseIf idFunction = 2 Then
TETPAR = bPC
ElseIf idFunction = 3 Then
TETPAR = cPC
ElseIf idFunction = 4 Then
TETPAR = alphaPC
ElseIf idFunction = 5 Then
TETPAR = betaPC
ElseIf idFunction = 6 Then
TETPAR = gammaPC
ElseIf idFunction = 7 Then
TETPAR = volumePC / 3
ElseIf idFunction = 8 Then
TETPAR = lambdaPC
ElseIf idFunction = 9 Then
TETPAR = sigmaPCDegrees
ElseIf idFunction = 10 Then
TETPAR = WorksheetFunction.Radians(sigmaPCDegrees)
ElseIf idFunction = 11 Then
TETPAR = coordinateCentre(1)
ElseIf idFunction = 12 Then
TETPAR = coordinateCentre(2)
ElseIf idFunction = 13 Then
TETPAR = coordinateCentre(3)
ElseIf idFunction = 14 Then
TETPAR = tiltAngle
ElseIf idFunction = 15 Then
TETPAR = baseArea
ElseIf idFunction = 16 Then
TETPAR = baseAreaProjection
ElseIf idFunction = 17 Then
TETPAR = tiltAngle1
End If
End Function
Function DZOCT(address1 As Range, address2 As Range, address3 As Range, idFunction As Integer) As Double
'**************************************************************************************
' Calculates the displacement of central oxygen from mean plane of tetrahedral apices *
' address1: octahedron; address2: tetrahedron1; address3: tetrahedron2                *
'**************************************************************************************
Dim cell As Range, cell1 As Range, i As Integer, index As Integer
Dim nOctVertex As Integer
Dim octVertexMatched(1 To 6) As Boolean
Dim zOct(1 To 6) As Double, zMean As Double, dz As Double, dzMin As Double
Dim nMatch As Integer, idMin As Integer
Dim str1 As String
Dim octahedronRowNumber(1 To 6) As Integer
Dim tetrahedralAtomNumber(1 To 3) As Integer
Dim tetrahedralApexZ(1 To 4) As Double
Dim nApex As Integer
Dim vertexRelevant As Boolean
Dim dummy(1 To 4) As Double
Dim orderZ(1 To 4) As Integer
Dim zMeanLower As Double, zMeanUpper As Double
For i = 1 To 6
octVertexMatched(i) = False
Next i
nOctVertex = 0
For Each cell In address1.Rows
nOctVertex = nOctVertex + 1
zOct(nOctVertex) = cell.value
str1 = cell.address
index = InStrRev(str1, "$")
octahedronRowNumber(nOctVertex) = Right(str1, Len(str1) - index)
'...
For Each cell1 In address2.Rows
If Abs(cell1.value - zOct(nOctVertex)) < 0.00001 Then octVertexMatched(nOctVertex) = True
Next cell1
'...
For Each cell1 In address3.Rows
If Abs(cell1.value - zOct(nOctVertex)) < 0.00001 Then octVertexMatched(nOctVertex) = True
Next cell1
Next cell
'...at least two vertices will have been matched. If three have been matched, return zero
nMatch = 0
zMean = 0
For i = 1 To 6
If octVertexMatched(i) Then
nMatch = nMatch + 1
zMean = zMean + zOct(i)
tetrahedralAtomNumber(nMatch) = Cells(octahedronRowNumber(i), 6).value
End If
Next i
If nMatch = 3 Then
DZOCT = 0
Exit Function
Else
zMean = zMean / 2
dzMin = 1000
For i = 1 To 6
If Not octVertexMatched(i) Then
dz = Abs(zOct(i) - zMean)
'...
If dz < dzMin Then
dzMin = dz
idMin = i
End If
'...
End If
Next i
'...
If idFunction = 1 Then
DZOCT = zOct(idMin) - zMean
End If
'...
End If 'Not octVertexMatched(i)
'.....................................
If idFunction = 2 Then
nOctVertex = 0
nApex = 0
For Each cell In address1.Rows
nOctVertex = nOctVertex + 1
vertexRelevant = False
For i = 1 To nMatch
If tetrahedralAtomNumber(i) = Cells(octahedronRowNumber(nOctVertex), 6).value Then vertexRelevant = True
Next i
'...
If vertexRelevant Then
nApex = nApex + 1
tetrahedralApexZ(nApex) = cell.value
End If
'...
Next cell
'...
If nApex = 4 Then
Call ordar(tetrahedralApexZ, dummy, orderZ, nApex)
zMeanLower = (tetrahedralApexZ(orderZ(1)) + tetrahedralApexZ(orderZ(2))) / 2
zMeanUpper = (tetrahedralApexZ(orderZ(3)) + tetrahedralApexZ(orderZ(4))) / 2
DZOCT = zMeanUpper - zMeanLower
Else
DZOCT = 0
End If
'.....
End If
End Function
Function fOCC(rangeGenerator1 As Range, rangeArea1 As Range, rangeGenerator2 As Range, rangeArea2 As Range, _
rangeGenerator3 As Range, rangeArea3 As Range, nRange As Integer, ucAreaRange As Range) As Double
Dim i As Integer, j As Integer
Dim generatorString(1 To 3) As String
Dim ucArea As Double
Dim weight(1 To 3) As Double
Dim areaValue(1 To 3, 1 To 2) As Double
Dim areaSum As Double
generatorString(1) = rangeGenerator1.Cells(1, 1)
generatorString(2) = rangeGenerator2.Cells(1, 1)
generatorString(3) = rangeGenerator3.Cells(1, 1)
ucArea = ucAreaRange.Cells(1, 1)
'...
For j = 1 To 2
areaValue(1, j) = rangeArea1.Cells(j, 1)
areaValue(2, j) = rangeArea2.Cells(j, 1)
areaValue(3, j) = rangeArea3.Cells(j, 1)
Next j
'...
For i = 1 To nRange
If Mid(generatorString(i), 12, 1) = "1" Then
weight(i) = 1
Else
weight(i) = 2
End If
Next i
'...
areaSum = 0
For i = 1 To nRange
For j = 1 To 2
areaSum = areaSum + weight(i) * areaValue(i, j)
Next j
Next i
fOCC = areaSum / ucArea
End Function
Function refinementRMSD(range1 As Range, idFunction As Integer) As Variant
'************************************************************
' Calculates the r.m.s. deviation in a parameter refinement *
'************************************************************
Dim row As Range
Dim errorStatus As Boolean
Dim nActiveParameter As Integer
Dim dev2 As Double
Dim value As Double
'Check that entries in r.h. column are either Y or N
errorStatus = False
nActiveParameter = 0
dev2 = 0
For Each row In range1.Rows
If UCase(row.Cells(2).value) = "Y" Then
nActiveParameter = nActiveParameter + 1
value = row.Cells(1).value
dev2 = dev2 + value ^ 2
ElseIf UCase(row.Cells(2).value) <> "N" Then
errorStatus = True
End If
Next row
If errorStatus Then
'...
If idFunction = 1 Then
refinementRMSD = "Only Y or N!"
Else
refinementRMSD = 0
End If
'...
Else
If idFunction = 1 Then
refinementRMSD = Sqr(dev2 / nActiveParameter)
Else
refinementRMSD = nActiveParameter
End If
'.....
End If 'errorStatus block
End Function
Function RMSD(range1 As Range, range2 As Range) As Variant
'*************************************************************************
' Calculates the r.m.s. deviation of values in range1 compared to range2 *
'*************************************************************************
Dim cell As Range
Dim dev2 As Double
Dim nValue As Integer
If range1.Count <> range2.Count Then
RMSD = "!ERROR!"
Else
dev2 = 0
nValue = 0
For Each cell In range1.Rows
nValue = nValue + 1
dev2 = dev2 + (cell.value - range2.Cells(nValue)) ^ 2
Next cell
dev2 = dev2 / range1.Count
RMSD = Sqr(dev2)
End If
End Function
Function volumeIncrement(xc1() As Double, xc2() As Double, xc3() As Double) As Double
'***************************************************************************************
' Calculates the volume increment due to a triangular (sub)face defined by coordinates *
' xc1, xc2 & xc3. The apex of the triangular pyramid so formed is located at [0,0,0]   *
'***************************************************************************************
Dim j As Integer
Dim vec1(1 To 3) As Double
Dim vec2(1 To 3) As Double
Dim vec3(1 To 3) As Double
Dim modulus As Double, area As Double, height As Double
For j = 1 To 3
vec1(j) = xc2(j) - xc1(j)
vec2(j) = xc3(j) - xc1(j)
Next j
'vec3 is cross product
vec3(1) = vec1(2) * vec2(3) - vec1(3) * vec2(2)
vec3(2) = vec1(3) * vec2(1) - vec1(1) * vec2(3)
vec3(3) = vec1(1) * vec2(2) - vec1(2) * vec2(1)
modulus = Sqr(vec3(1) * vec3(1) + vec3(2) * vec3(2) + vec3(3) * vec3(3))
For j = 1 To 3
vec3(j) = vec3(j) / modulus
Next j
area = modulus / 2
height = Abs(xc1(1) * vec3(1) + xc1(2) * vec3(2) + xc1(3) * vec3(3))
volumeIncrement = area * height / 3
End Function
Function solidAngleIncrement(xc1() As Double, xc2() As Double, xc3() As Double) As Double
'********************************************************************************************
' Calculates the solid angle increment due to a triangular (sub)face defined by coordinates *
' xc1, xc2 & xc3. The apex of the triangular pyramid so formed is located at [0,0,0]        *
'********************************************************************************************
Dim modulus1 As Double, modulus2 As Double, modulus3 As Double
Dim alpha As Double, beta As Double, gamma As Double, arg As Double
Dim j As Integer
'....
modulus1 = Sqr(xc1(1) * xc1(1) + xc1(2) * xc1(2) + xc1(3) * xc1(3))
modulus2 = Sqr(xc2(1) * xc2(1) + xc2(2) * xc2(2) + xc2(3) * xc2(3))
modulus3 = Sqr(xc3(1) * xc3(1) + xc3(2) * xc3(2) + xc3(3) * xc3(3))
For j = 1 To 3
xc1(j) = xc1(j) / modulus1
xc2(j) = xc2(j) / modulus2
xc3(j) = xc3(j) / modulus3
Next j
With WorksheetFunction
alpha = .Acos(xc2(1) * xc3(1) + xc2(2) * xc3(2) + xc2(3) * xc3(3))
beta = .Acos(xc3(1) * xc1(1) + xc3(2) * xc1(2) + xc3(3) * xc1(3))
gamma = .Acos(xc1(1) * xc2(1) + xc1(2) * xc2(2) + xc1(3) * xc2(3))
arg = 1 + Cos(alpha) + Cos(beta) + Cos(gamma)
arg = arg / (4 * Cos(alpha / 2) * Cos(beta / 2) * Cos(gamma / 2))
solidAngleIncrement = 2 * .Acos(arg) / (4 * WorksheetFunction.Pi())
End With
End Function
Function interpretLine(ByVal inputLine As String, ByRef outputString() As String, ByRef nField As Integer) As Boolean
'***************************************************************
' Splits input line into component strings separated by spaces *
'***************************************************************
Dim inField As Boolean
Dim i As Integer, iStart As Integer, iEnd As Integer
On Error GoTo error:
interpretLine = False
nField = 0
inField = False
inputLine = inputLine & " " 'terminating blank
For i = 1 To Len(inputLine)
If Mid(inputLine, i, 1) <> " " Then
If (Not inField) Then iStart = i
inField = True
Else
If (inField) Then
iEnd = i - 1
nField = nField + 1
outputString(nField) = Mid(inputLine, iStart, iEnd - iStart + 1)
End If
inField = False
End If
Next i
interpretLine = True
error:
End Function
Sub ordar(ByRef value() As Double, ByRef dummy() As Double, ByRef orderInteger() As Integer, ByVal nelementsInList As Integer)
'************************************************
' Calculates the ascending order of real values *
'************************************************
Dim i As Integer, j As Integer, valueMin As Double, idMin As Integer
For i = 1 To nelementsInList
dummy(i) = value(i)
Next i
'.......
For i = 1 To nelementsInList
valueMin = 10000000000#
For j = 1 To nelementsInList
If dummy(j) < valueMin Then
valueMin = dummy(j)
idMin = j
End If
Next j
orderInteger(i) = idMin
dummy(idMin) = 20000000000#
Next i
End Sub
Sub vxv(ByRef vec1() As Double, ByRef vec2() As Double, ByRef vec3() As Double)
'***********************
' Vector cross product *
'***********************
      vec3(1) = vec1(2) * vec2(3) - vec1(3) * vec2(2)
      vec3(2) = vec1(3) * vec2(1) - vec1(1) * vec2(3)
      vec3(3) = vec1(1) * vec2(2) - vec1(2) * vec2(1)
End Sub

