ibm_ieee.bas

用vb读取标准segy数据

Attribute VB_Name = "IBM_IEEE"
Private Type MungeInteger
  Value As Integer
End Type

Private Type MungeLong
  Value As Long
End Type

Private Type Munge2Bytes
  Bytes(0 To 1) As Byte
End Type

Private Type Munge4Bytes
  Bytes(0 To 3) As Byte
End Type

Private Type MungeSingle
  a As Single
End Type

Private Type MungeDouble
  a As Double
End Type

Private Type Munge8Bytes
  B(0 To 7) As Byte
End Type


Private Sub SwapBytes(B() As Byte)
'
' Reverses the order of the bytes in the array.
'
Dim I As Long, Temp As Byte, Offset As Long
  Offset = LBound(B) + UBound(B)
  For I = LBound(B) To UBound(B) \ 2
    Temp = B(I)
    B(I) = B(Offset - I)
    B(Offset - I) = Temp
  Next I
End Sub

Public Function IBMToVBAInteger(ByVal IBM_Value As Integer) As Integer
'
' Converts an Integer in IBM 370 format to IEEE format
' by reversing the order of the bytes.
'
Dim iTemp As MungeInteger, bTemp As Munge2Bytes
  iTemp.Value = IBM_Value
  LSet bTemp = iTemp
  SwapBytes bTemp.Bytes
  LSet iTemp = bTemp
  IBMToVBAInteger = iTemp.Value
End Function

Public Function IBMToVBALong(ByVal IBM_Value As Long) As Long
'
' Converts a Long in IBM 370 format to IEEE format
' by reversing the order of the bytes.
'
  Dim lTemp As MungeLong, bTemp As Munge4Bytes
  lTemp.Value = IBM_Value
  
  LSet bTemp = lTemp
  SwapBytes bTemp.Bytes
  LSet lTemp = bTemp
  IBMToVBALong = lTemp.Value
End Function





Public Function IBMToVBASingle(ByVal IBM_Value As Single) As Single
'
' Converts a Single in IBM 370 format to IEEE format.
'
  IBMToVBASingle = 1E+38
  Dim sTemp As MungeSingle
  Dim bTemp As Munge4Bytes
 
  On Error GoTo 1000
  sTemp.a = IBM_Value
  LSet bTemp = sTemp
  IBM370_To_IEEE bTemp.Bytes
  SwapBytes bTemp.Bytes
  LSet sTemp = bTemp
  IBMToVBASingle = sTemp.a
1000
End Function

Public Function IBMToVBADouble(ByVal IBM_Value As Double) As Double
'
' Converts a Double in IBM 370 format to IEEE format
'
  Dim dTemp As MungeDouble
  Dim bTemp As Munge8Bytes
  'dTemp.Value = IBM_Value
  dTemp.a = IBM_Value
  LSet bTemp = dTemp
  IBM370_To_IEEE bTemp.B
  SwapBytes bTemp.B
  LSet dTemp = bTemp
  IBMToVBADouble = dTemp.a
  
End Function

Private Sub ShiftLeft(B() As Byte)
'
' Shifts all bits in the array 1 to the Left.
' Doesn't shift B(0) because it doesn't contain the mantissa.
'
Dim I As Long, MaxItem As Long, NewCarry As Long, OldCarry As Long
  MaxItem = UBound(B)
  For I = MaxItem To 1 Step -1
    NewCarry = B(I) And &H80
    B(I) = (B(I) And &H7F) * 2 + IIf(OldCarry, 1, 0)
    OldCarry = NewCarry
  Next I
End Sub

Private Sub ShiftRight(B() As Byte)
'
' Shifts all bits in the array 1 to the Right.
' Doesn't shift B(0) because it doesn't contain the mantissa.
'
Dim I As Long, MaxItem As Long, NewCarry As Long, OldCarry As Long
  MaxItem = UBound(B)
  For I = 1 To MaxItem
    NewCarry = B(I) And 1
    B(I) = (B(I) And &HFE) \ 2 + IIf(OldCarry, &H80, 0)
    OldCarry = NewCarry
  Next I
End Sub

Private Sub IBM370_To_IEEE(B() As Byte)
'
' This routine is the heart of the conversion.
'
Dim Sign As Long, Exponent As Long, I As Long, Temp As Long
'
' Extract sign.
'
  Sign = B(0) And &H80
'
' Extract exponent.
'
  Exponent = ((B(0) And &H7F) - 64) * 4 - 1
'
' Normalize the mantissa.
'
  Do While (B(1) And &H80) = 0 And I < 4  ' 4 since 4 bits per hex digit
    ShiftLeft B
    I = I + 1
    Exponent = Exponent - 1
  Loop
'
' Zero check.
'
  If I = 4 Then
    B(0) = 0      ' rest of bytes are 0 so output -> 0.0
'
' Put sign and exponent back in 4-byte number.
'
  ElseIf UBound(B) = 3 Then
    Exponent = Exponent + 127     ' Excess 127 offset
    If (Exponent And 1) = 1 Then  ' low bit goes into B(1)
      B(1) = B(1) Or &H80
    Else
      B(1) = B(1) And &H7F
    End If
    B(0) = Sign Or ((Exponent \ 2) And &H7F)
  Else
'
' Put sign and mantissa back in 8-byte number.
'
    ShiftRight B                  ' make room for longer exponent
    ShiftRight B
    ShiftRight B
    Exponent = Exponent + 1023    ' Excess 1023 format
    Temp = Exponent And &HF       ' Low 4 bits go into B(1)
    B(1) = (B(1) And &HF) Or Temp * 16
    B(0) = Sign Or ((Exponent \ 16) And &H7F)
  End If
End Sub