[Fortran] 纯文本查看 复制代码
Module SACParameter
Implicit None
!Integer, parameter :: FileUnit = 100
Character( Len = * ), Parameter :: WaveformDIR = "..\WAV\AustrData\Waveform\"
Character( Len = * ), Parameter :: ResponseDIR = "..\WAV\AustrData\Response\"
Character ( Len = : ), Allocatable :: Buffer
REal( Kind = 8 ), Parameter :: PI = 3.14159265358979
Integer( kind = 4) :: FileNameLong
Character( Len = 1 ) :: separator = "."
Character( Len = 4 ) :: Station
Integer( kind = 4 ) :: StationNumber
Integer( kind = 4 ) :: FileNumber
Integer( kind = 4 ) :: DeltaTdt = 0.05
!
Type :: EventPara
Character( Len = 16 ), allocatable :: StationName(:)
Character( Len = 4 ), allocatable :: ComponentName(:)
Character( Len = 1 ), allocatable :: stringFileName(:)
Real(kind = 4), allocatable :: StationWaveformLong(:)
Real(kind = 4), allocatable :: StationMaximumAmplitude(:)
Real(kind = 4), allocatable :: StationDELTA(:)
Integer(kind = 4), allocatable :: Flag(:)
End Type EventPara
!
Type :: SACHeader
SEQUENCE
Real( Kind = 4 ), Allocatable :: Header1(:,:)
Integer( Kind = 4 ), Allocatable :: Header2(:,:)
Character( Len = 8 ), Allocatable :: Header3(:,:)
Character( Len = 4 ), Allocatable :: WaveformBinary(:,:)
Real( kind = 4 ), Allocatable :: Waveform(:,:)
Integer( Kind = 4 ), Allocatable :: WaveformLong(:)
End Type SACHeader
!
public WaveformDIR, ResponseDIR, Buffer, FileNameLong, separator, Station, DoWithWildcard, WriteName, EventPara, SACHeader, Response
!------------------------------------------------------------------------------------------
Contains
Subroutine DoWithWildcard(cWildcard,CallBack,iTotal)
Use DFLib,only:GetFileInfoQQ,GetLastErrorQQ,FILE$INFO,FILE$LAST,FILE$ERROR,FILE$FIRST,ERR$NOMEM,ERR$NOENT,FILE$DIR
type(EventPara) :: EVENT1
type(SACHeader) :: SACFILE1
Interface
Subroutine CallBack( FileName , loop )
Character( Len = * ),Intent(In) :: FileName
Integer,Intent(In) :: loop
End Subroutine CallBack
End Interface
Character*(*),Intent(In)::cWildcard
Integer,Intent(Out)::iTotal
TYPE (FILE$INFO) info
INTEGER(4)::Wildhandle,length,retInt
Wildhandle = FILE$FIRST
iTotal = 0
DO WHILE (.TRUE.)
length = GetFileInfoQQ(cWildCard,info,Wildhandle)
IF ((Wildhandle .EQ. FILE$LAST) .OR.(Wildhandle .EQ. FILE$ERROR)) THEN
SELECT CASE (GetLastErrorQQ())
CASE (ERR$NOMEM) !//内存不足
iTotal = - 1
Return
CASE (ERR$NOENT) !//碰到通配符序列尾
Return
CASE DEFAULT
iTotal = 0
Return
END SELECT
END IF
If ((info%permit.AND.FILE$DIR).Eq.0) then
Call CallBack( Trim(info.Name) , iTotal + 1 )
iTotal = iTotal + 1
End If
END DO
End Subroutine DoWithWildcard
Subroutine WriteName( FileName , loop )
Character( Len = * ), Intent(In) :: FileName
Integer, Intent(In) :: loop
Write(*,*) loop, FileName
StationNumber = loop
End Subroutine WriteName
Subroutine OpenFile( FileName , loop )
Character( Len = * ), Intent(In) :: FileName
Integer,Intent(In) :: loop
integer( kind = 4 ) :: iFileUnit
iFileUnit = 100 + loop
Write(*,*) iFileUnit, FileName
pause 3
!Open( Unit = iFileUnit, File = trim(FileName), access = 'Sequential', Form = 'Unformatted', Status = 'OLD', Action = 'READ' )
!Open( Unit = iFileUnit, File = FileName(1:len_trim(FileName)), Form = 'Unformatted', Status = 'OLD', Action = 'READ' )
Call GetFileN( iFileUnit , loop, FileName )
close( iFileUnit )
End Subroutine OpenFile
Subroutine GetFileN( iFileUnit , loop, FileName)
USE, INTRINSIC :: ISO_FORTRAN_ENV
Implicit None
type(EventPara) :: EVENT1
type(SACHeader) :: SACFILE1
Logical, Parameter :: FileIsNotEnd = .True.
Integer, Intent( IN ) :: iFileUnit
Integer, Intent( IN ) :: loop
Integer( Kind = 4 ) :: errvar
Character( Len = * ), Intent(In) :: FileName
Character( Len = 128 ) :: DIRName
Integer :: i = 1, j = 1, k = 1, l = 1
k = Index( FileName, separator, .True.)
l = len_trim( FileName )
if(FileName(( k + 1 ):l ) == "SAC") Then
DIRName = WaveformDIR(1:Len_trim(WaveformDIR))//FileName(1:Len_trim(FileName))
write(*,*) DIRName
Open( Unit = iFileUnit, File = DIRName(1:len_trim(DIRName)), Form = 'Unformatted', Access = "Stream", Status = 'OLD', Action = 'READ', iostat = errvar, convert = "LITTLE_ENDIAN" )
pause 4
Rewind( iFileUnit )
Do i = 1,70
Read( Unit = iFileUnit, iostat = k ) SACFILE1%Header1(i,loop)
End do
Do i = 1,40
Read( Unit = iFileUnit, iostat = k ) SACFILE1%Header2(i,loop)
End do
Read( Unit = iFileUnit, iostat = k ) SACFILE1%Header3(1,loop)
Read( Unit = iFileUnit, iostat = k ) SACFILE1%KEVNM(loop)
Do i = 2,22
Read( Unit = iFileUnit, iostat = k )SACFILE1%Header3(i,loop)
End do
Read(SACFILE1%Header1(1,loop),"(I4)")SACFILE1%WaveformLong(loop)
Allocate(SACFILE1%WaveformBinary(SACFILE1%WaveformLong(loop), Loop))! 波形(台站,记录)
SACFILE1%WaveformLong(loop) = 0
Do while( FileIsNotEnd )
Read( Unit = iFileUnit, iostat = k) SACFILE1%WaveformBinary( SACFILE1%WaveformLong(Loop) ,loop)
SACFILE1%WaveformLong(loop) = SACFILE1%WaveformLong(loop) + 1
If( k == IOSTAT_END ) Exit
End do
Rewind( iFileUnit )
Else
DIRName = ResponseDIR(1:Len_trim(ResponseDIR))//FileName(1:Len_trim(ResponseDIR))
Open( Unit = iFileUnit, File = DIRName(1:len_trim(DIRName)), Form = 'Unformatted', Status = 'OLD', Action = 'READ', IOstat = errvar )
Rewind( iFileUnit )
READ( Unit = iFileUnit, iostat = k, FMT = "(A100)" ) Buffer
If ( Buffer(1:6) == 'B053F06' ) Then
READ( Unit = iFileUnit, iostat = k, FMT = 160 ) RESPONSE1%FirstColumn, RESPONSE1%SecondColumn, RESPONSE1%NormalizationFactor( Loop )
READ( Unit = iFileUnit, iostat = k, FMT = 160 ) RESPONSE1%FirstColumn, RESPONSE1%SecondColumn, RESPONSE1%NormalizationFrequency( Loop )
READ( Unit = iFileUnit, iostat = k, FMT = 170 ) RESPONSE1%FirstColumn, RESPONSE1%SecondColumn, RESPONSE1%ZeroesNumber( Loop )
READ( Unit = iFileUnit, iostat = k, FMT = 170 ) RESPONSE1%FirstColumn, RESPONSE1%SecondColumn, RESPONSE1%PolesNumber( loop )
Do i = 0, RESPONSE1%ZeroesNumber( Loop ) - 1
Read( Unit = iFileUnit, iostat = k, FMT = 180 ) RESPONSE1%FirstColumn, j, RESPONSE1%Zeroes(i, Loop), RESPONSE1%ZeroesError(i, Loop)
End do
Do i = 0, RESPONSE1%PolesNumber( loop ) - 1
Read( Unit = iFileUnit, iostat = k, FMT = 180 ) RESPONSE1%FirstColumn, j, RESPONSE1%Poles(i, Loop), RESPONSE1%PolesError(i, Loop)
End do
Else
Continue
End if
Rewind( iFileUnit )
End if
End Subroutine GetFileN
End module SACParameter
!*************************************************************************
Program Main
USE SACParameter
Implicit None
type( EventPara ) :: EVENT1
type( SACHeader ) :: SACFILE1
type( Response ) :: RESPONSE1
Integer( Kind = 4 ) :: LoopNumber
Integer( Kind = 4 ) :: DELTAdt
Integer( Kind = 4 ), Allocatable :: Flag(:)
Integer( Kind = 4 ) :: i, j, k, m, n = 1
Interface
Subroutine BubbleSort(Object, Flag, LoopNumber)
Real(kind = 4), allocatable, Intent( INOUT ) :: Object(:)
Integer(kind = 4), allocatable, Intent( INOUT ) :: Flag(:)
Integer(kind = 4), Intent( IN ) :: LoopNumber
End Subroutine
End Interface
Call DoWithWildcard( '..\WAV\AustrData\Waveform\*.BHZ.*.SAC' , WriteName , N)
If ( N >= 0 ) then
Write(*,*) '共' , N , '个文件，',StationNumber,'个台站'
End If
pause 0
LoopNumber = StationNumber
Write(*,*) LoopNumber
pause 1
Allocate(EVENT1%StationName( LoopNumber ))
Allocate(EVENT1%ComponentName( LoopNumber ))
Allocate(EVENT1%stringFileName( LoopNumber ))
Allocate(EVENT1%StationWaveformLong( LoopNumber ))
Allocate(EVENT1%StationMaximumAmplitude( LoopNumber ))
Allocate(EVENT1%StationDELTA( LoopNumber ))
Allocate(SACFILE1%Header1(70, LoopNumber ))
Allocate(SACFILE1%Header2(40, LoopNumber ))
Allocate(SACFILE1%Header3(22, LoopNumber ))
Allocate(SACFILE1%WaveformLong( LoopNumber ))
Allocate(FLAG( LoopNumber ))
pause 2
n = 1
Call DoWithWildcard( '..\WAV\AustrData\Waveform\*.BHZ.*.SAC' , OpenFile , n )
pause 5
DELTAdt = DeltaTdt
Call RecordSACHeader( LoopNumber, SACFILE1 )
Do i = 1, StationNumber
Write(*,*) SACFILE1%STLA(i), SACFILE1%STLO(i)
End do
End Program Main
F 币
贡献
权杖
窥视卡
发表于 2016-3-8 16:52:26
微信
收藏
点赞
点踩
提升卡
置顶卡
变色卡
千斤顶
显身卡
楼主
发表于 2016-3-9 22:06:27