! 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