! gt3read.f90 - GTOOL3 file input module
! Copyright (C) by TOYODA Eizi, 2000.  All rights reserved.
! vi: set sw=4 ts=8:

module gt3read

    use dcl, only: DclGetUnitNum
    implicit none

    private

    type GT3_HEADER
        integer:: idfm
        character(len = 16):: dataset, item
        character(len = 16):: edit(8)
        integer:: file_number, data_number
        character(len = 16 * 2):: title
        character(len = 16):: unit
        character(len = 16):: edit_title(8)
        integer:: time
        character(len = 16):: datetime, time_unit
        integer:: time_duration
        character(len = 16):: axis_item(3)
        integer:: axis_start(3), axis_end(3)
        character(len = 16):: format
        real:: missing_value, range_max, range_min
        real:: div_small, div_large
        integer:: scaling
        character(len = 16):: option(3), memo(12)
        character(len = 16):: create_date, create_user
        character(len = 16):: modify_date, modify_user
        integer:: record_size
    end type

    type GT3_FILE
        private
        integer:: number
    end type

    public GT3_FILE, GT3_HEADER, Open, Close, GetHeader, GetData
    public SkipRecord, Rewind, GetUnit, Get

    interface Open;  module procedure Gt3Open;  end interface
    interface Close;  module procedure Gt3Close;  end interface
    interface Rewind;  module procedure Gt3Rewind;  end interface
    interface GetHeader;  module procedure Gt3GetHeader;  end interface
    interface GetData;  module procedure Gt3GetData;  end interface
    interface SkipRecord;  module procedure Gt3SkipRecord;  end interface
    interface GetUnit;  module procedure Gt3GetUnit;  end interface
    interface Get
        module procedure Gt3GetHeader, Gt3GetUnit
    end interface

    integer, public, parameter:: END_OF_FILE = -3000
    integer, public, parameter:: ERROR_OPEN = 3300
    integer, public, parameter:: ERROR_CLOSE = 3301
    integer, public, parameter:: ERROR_REWIND = 3302
    integer, public, parameter:: ERROR_BAD_MAGIC = 3303
    integer, public, parameter:: ERROR_BAD_GTOOL3 = 3304
    integer, public, parameter:: ERROR_READ = 3305

contains

    subroutine Gt3Open(unit, file, iostat)
        type(GT3_FILE), intent(out):: unit
        character(len = *), intent(in):: file
        integer, intent(out):: iostat
    continue
        unit%number = DclGetUnitNum()
        open(unit=unit%number, file=file, access='SEQUENTIAL', &
            & form='UNFORMATTED', iostat=iostat, status='OLD')
        if (iostat /= 0) iostat = ERROR_OPEN
    end subroutine

    subroutine Gt3Close(unit, iostat)
        type(GT3_FILE), intent(inout):: unit
        integer, intent(out):: iostat
    continue
        close(unit=unit%number, iostat=iostat)
        if (iostat /= 0) iostat = ERROR_CLOSE
        unit%number = -unit%number
    end subroutine

    subroutine Gt3Rewind(unit, iostat)
        type(GT3_FILE), intent(inout):: unit
        integer, intent(out):: iostat
    continue
        rewind(unit=unit%number, iostat=iostat)
        if (iostat /= 0) iostat = ERROR_REWIND
    end subroutine

    subroutine BufferToHeader(header, buffer, iostat)
        type(GT3_HEADER), intent(out):: header
        character(len = 16), intent(in):: buffer(64)
        integer, intent(out):: iostat
        integer, parameter:: IDFM_NEW = 9010
        integer, parameter:: IDFM_OLD = 9009
    continue
        read(buffer(1), fmt="(i16)", iostat=iostat) header%idfm
        if (iostat /= 0 .or. header%idfm /= IDFM_NEW) then
            read(buffer(1), fmt="(i10)", iostat=iostat) header%idfm
            if (iostat /= 0) goto 990
            if (header%idfm /= IDFM_OLD) then
                iostat = ERROR_BAD_MAGIC
                return
            endif
        endif
        header%dataset = buffer(2)
        header%item = buffer(3)
        header%edit(1: 8) = buffer(4: 11)
        read(buffer(12), fmt="(i16)", iostat=iostat) header%file_number
        if (iostat /= 0) goto 990
        read(buffer(13), fmt="(i16)", iostat=iostat) header%data_number
        if (iostat /= 0) goto 990
        header%title = transfer(buffer(14: 15), header%title)
        header%unit = buffer(16)
        if (header%unit == '') &
            header%unit = '1'
        header%edit_title(1: 8) = buffer(17: 24)
        read(buffer(25), fmt="(i16)", iostat=iostat) header%time
        if (iostat /= 0) goto 990
        header%time_unit = buffer(26)
        header%datetime = buffer(27)
        read(buffer(28), fmt="(i16)", iostat=iostat) header%time_duration
        if (iostat /= 0) goto 990
        header%axis_item(1: 3) = buffer(29: 35: 3)
        read(buffer(30), fmt='(i16)', iostat=iostat) header%axis_start(1) 
        if (iostat /= 0) goto 990
        read(buffer(33), fmt='(i16)', iostat=iostat) header%axis_start(2) 
        if (iostat /= 0) goto 990
        read(buffer(36), fmt='(i16)', iostat=iostat) header%axis_start(3) 
        if (iostat /= 0) goto 990
        read(buffer(31), fmt='(i16)', iostat=iostat) header%axis_end(1) 
        if (iostat /= 0) goto 990
        read(buffer(34), fmt='(i16)', iostat=iostat) header%axis_end(2) 
        if (iostat /= 0) goto 990
        read(buffer(37), fmt='(i16)', iostat=iostat) header%axis_end(3) 
        if (iostat /= 0) goto 990
        header%format = buffer(38)
        read(buffer(39), fmt='(e16.7)', iostat=iostat) header%missing_value
        if (iostat /= 0) goto 990
        read(buffer(40), fmt='(e16.7)', iostat=iostat) header%range_min
        if (iostat /= 0) goto 990
        read(buffer(41), fmt='(e16.7)', iostat=iostat) header%range_max
        if (iostat /= 0) goto 990
        read(buffer(42), fmt='(e16.7)', iostat=iostat) header%div_small
        if (iostat /= 0) goto 990
        read(buffer(43), fmt='(e16.7)', iostat=iostat) header%div_large
        if (iostat /= 0) goto 990
        read(buffer(44), fmt="(i16)", iostat=iostat) header%scaling
        if (iostat /= 0) goto 990
        header%option(1: 3) = buffer(45: 47)
        header%memo(1: 12) = buffer(48: 59)
        header%create_date = buffer(60)
        header%create_user = buffer(61)
        header%modify_date = buffer(62)
        header%modify_user = buffer(63)
        read(buffer(64), fmt="(i16)", iostat=iostat) header%record_size
        if (iostat /= 0) goto 990
        iostat = 0
        return
        ! --- error handler ---
    990 continue
        iostat = ERROR_BAD_GTOOL3
        return
    end subroutine

    subroutine Gt3GetHeader(unit, header, iostat)
        type(GT3_FILE), intent(inout):: unit
        type(GT3_HEADER), intent(out):: header
        integer, intent(out):: iostat
        character(len = 16):: buffer(64)
    continue
        read(unit=unit%number, iostat=iostat) buffer
        if (iostat > 0) then
            iostat = ERROR_READ
            return
        else if (iostat < 0) then
            iostat = END_OF_FILE
            return
        endif
        call BufferToHeader(header, buffer, iostat)
    end subroutine

    ! 外部表現と内部表現に関する仮定がある
    !
    subroutine Gt3GetData(unit, header, array, iostat)
        type(GT3_FILE), intent(in):: unit
        type(GT3_HEADER), intent(in):: header
        real, pointer:: array(:, :, :)
        integer, intent(out):: iostat
        double precision, pointer:: darray(:, :, :)
        integer:: xs, xe, ys, ye, zs, ze
        if (header%format == 'UR4' .or. header%format == 'UR8') then
            xs = header%axis_start(1)
            ys = header%axis_start(2)
            zs = header%axis_start(3)
            xe = header%axis_end(1)
            ye = header%axis_end(2)
            ze = header%axis_end(3)
            if (header%format == 'UR4') then
                allocate(array(xs:xe, ys:ye, zs:ze))
                read(unit=unit%number, iostat=iostat) array(:, :, :)
            else if (header%format == 'UR8') then
                allocate(darray(xs:xe, ys:ye, zs:ze))
                read(unit=unit%number, iostat=iostat) darray(:, :, :)
                allocate(array(xs:xe, ys:ye, zs:ze))
                array = darray
                deallocate(darray)
            endif
            if (iostat < 0) then
                iostat = END_OF_FILE
            else if (iostat > 0) then
                iostat = ERROR_READ
            endif
        else
            print "('GT3 external format <', a, '> not supported')", &
                & trim(header%format)
            iostat = ERROR_BAD_GTOOL3
        endif
    end subroutine

    subroutine Gt3GetUnit(unit, header, buffer, iostat)
        type(GT3_FILE), intent(inout):: unit
        type(GT3_HEADER), intent(out):: header
        integer, intent(out):: iostat
        real, pointer:: buffer(:, :, :)
    continue
        call GetHeader(unit, header, iostat)
        if (iostat /= 0) return
        call GetData(unit, header, buffer, iostat)
    end subroutine

    subroutine Gt3SkipRecord(unit, iostat)
        type(GT3_FILE), intent(in):: unit
        integer, intent(out):: iostat
    continue
        read(unit=unit%number, iostat=iostat)
        if (iostat < 0) then
            iostat = END_OF_FILE
        else if (iostat > 0) then
            iostat = ERROR_READ
        endif
    end subroutine

end module
