额滴个神，为神马就是读不进去？ - Fortran Coder

[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