! 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
    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

contains

    subroutine Gt3Open(unit, file, fail)
	type(GT3_FILE), intent(out):: unit
	character(len = *), intent(in):: file
	logical, intent(out), optional:: fail
	integer:: ios
    continue
	unit%number = DclGetUnitNum()
	open(unit=unit%number, file=file, access='SEQUENTIAL', &
	    & form='UNFORMATTED', iostat=ios, status='OLD')
	if (present(fail)) then
	    fail = ios /= 0
	else
	    if (ios /= 0) then
		print "(a)", 'gt3read#Open: cannot open <' // trim(file) // '>'
		stop
	    endif
	endif
    end subroutine

    subroutine Gt3Close(unit, fail)
	type(GT3_FILE), intent(inout):: unit
	logical, intent(out), optional:: fail
	integer:: ios
    continue
	close(unit=unit%number, iostat=ios)
	if (present(fail)) then
	    fail = ios /= 0
	else
	    if (ios /= 0) then
		print *, 'gt3read#Close: cannot close gtool3 file ', unit%number
		stop
	    endif
	endif
	unit%number = -unit%number
    end subroutine

    subroutine Gt3Rewind(unit, fail)
	type(GT3_FILE), intent(inout):: unit
	logical, intent(out), optional:: fail
	integer:: ios
    continue
	rewind(unit=unit%number, iostat=ios)
	if (present(fail)) then
	    fail = ios /= 0
	else
	    if (ios /= 0) then
		print *, 'gt3read#Rewind: cannot rewind gtool3 file ', &
		    & unit%number
		stop
	    endif
	endif
    end subroutine

    subroutine BufferToHeader(header, buffer)
	type(GT3_HEADER), intent(out):: header
	character(len = 16), intent(in):: buffer(64)
	integer, parameter:: IDFM_NEW = 9010
	integer, parameter:: IDFM_OLD = 9009
	integer:: ios
    continue
	read(buffer(1), fmt="(i16)", iostat=ios) header%idfm
	if (ios /= 0 .or. header%idfm /= IDFM_NEW) then
	    read(buffer(1), fmt="(i10)", iostat=ios) header%idfm
	    if (ios /= 0 .or. header%idfm /= IDFM_OLD) then
		print "('Gt3read#BufferToHeader: bad format id', a)", buffer(1)
		stop
	    endif
	endif
	header%dataset = buffer(2)
	header%item = buffer(3)
	header%edit(1: 8) = buffer(4: 11)
	read(buffer(12), fmt="(i16)", iostat=ios) header%file_number
	if (ios /= 0) stop 'Gtool3.GetHeader: bad file_number'
	read(buffer(13), fmt="(i16)", iostat=ios) header%data_number
	if (ios /= 0) stop 'Gtool3.GetHeader: bad data_number'
	header%title = transfer(buffer(14: 15), header%title)
	header%unit = buffer(16)
	header%edit_title(1: 8) = buffer(17: 24)
	read(buffer(25), fmt="(i16)", iostat=ios) header%time
	if (ios /= 0) stop 'Gtool3.GetHeader: bad time'
	header%time_unit = buffer(27)
	header%datetime = buffer(26)
	read(buffer(28), fmt="(i16)", iostat=ios) header%time_duration
	if (ios /= 0) stop 'Gtool3.GetHeader: bad time_duration'
	header%axis_item(1: 3) = buffer(29: 35: 3)
	read(buffer(30), fmt='(i16)', iostat=ios) header%axis_start(1) 
	if (ios /= 0) stop 'Gtool3.GetHeader: bad axis_start'
	read(buffer(33), fmt='(i16)', iostat=ios) header%axis_start(2) 
	if (ios /= 0) stop 'Gtool3.GetHeader: bad axis_start'
	read(buffer(36), fmt='(i16)', iostat=ios) header%axis_start(3) 
	if (ios /= 0) stop 'Gtool3.GetHeader: bad axis_start'
	read(buffer(31), fmt='(i16)', iostat=ios) header%axis_end(1) 
	if (ios /= 0) stop 'Gtool3.GetHeader: bad axis_end'
	read(buffer(34), fmt='(i16)', iostat=ios) header%axis_end(2) 
	if (ios /= 0) stop 'Gtool3.GetHeader: bad axis_end'
	read(buffer(37), fmt='(i16)', iostat=ios) header%axis_end(3) 
	if (ios /= 0) stop 'Gtool3.GetHeader: bad axis_end'
	header%format = buffer(38)
	read(buffer(39), fmt='(e16.7)', iostat=ios) header%missing_value
	if (ios /= 0) stop 'Gtool3.GetHeader: bad missing_value'
	read(buffer(40: 43), fmt='(4e16.7)', iostat=ios) &
	& header%range_max, header%range_min, header%div_small, header%div_large
	if (ios /= 0) stop 'Gtool3.GetHeader: bad range/div'
	read(buffer(44), fmt="(i16)", iostat=ios) header%scaling
	if (ios /= 0) stop 'Gtool3.GetHeader: bad scaling'
	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=ios) header%record_size
	if (ios /= 0) stop 'Gtool3.GetHeader: bad record_size'
    end subroutine

    subroutine Gt3GetHeader(unit, header, fail)
	type(GT3_FILE), intent(inout):: unit
	type(GT3_HEADER), intent(out):: header
	logical, intent(out), optional:: fail
	integer:: ios
	character(len = 16):: buffer(64)
    continue
	read(unit=unit%number, iostat=ios) buffer
	if (present(fail)) then
	    fail = ios /= 0
	else
	    if (ios /= 0) stop 'Gtool3.GetHeader: read error for file'
	endif
	call BufferToHeader(header, buffer)
    end subroutine

    ! 外部表現と内部表現に関する仮定がある
    !
    subroutine Gt3GetData(unit, header, array, fail)
	type(GT3_FILE), intent(in):: unit
	type(GT3_HEADER), intent(in):: header
	real, pointer:: array(:, :, :)
	logical, intent(out), optional:: fail
	double precision, pointer:: darray(:, :, :)
	integer:: xs, xe, ys, ye, zs, ze, ios
    continue
	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=ios) array(:, :, :)
	    else if (header%format == 'UR8') then
		allocate(darray(xs:xe, ys:ye, zs:ze))
		read(unit=unit%number, iostat=ios) darray(:, :, :)
		allocate(array(xs:xe, ys:ye, zs:ze))
		array = darray
		deallocate(darray)
	    endif
	    if (present(fail)) then
		fail = (ios /= 0)
	    else
		if (ios /= 0) stop 'Gt3read#GetData'
	    endif
	else
	    print "('GT3 external format <', a, '> not supported')", &
		& trim(header%format)
	    stop "Gt3GetData"
	endif
    end subroutine

    subroutine Gt3GetUnit(unit, header, buffer, fail)
	type(GT3_FILE), intent(inout):: unit
	type(GT3_HEADER), intent(out):: header
	logical, intent(out), optional:: fail
	real, pointer:: buffer(:, :, :)
    continue
	call GetHeader(unit, header, fail)
	call GetData(unit, header, buffer, fail)
    end subroutine

    subroutine Gt3SkipRecord(unit)
	type(GT3_FILE), intent(in):: unit
    continue
	read(unit=unit%number)
    end subroutine

end module
