| Path: | gtvargetpointernum.f90 |
| Last Update: | Sun Jun 04 21:48:43 JST 2006 |
| Authors: | Yasuhiro MORIKAWA, Eizi TOYODA |
| Version: | $Id: gtvargetpointernum.f90,v 1.8 2006/06/04 12:48:43 morikawa Exp $ |
| Tag Name: | $Name: gt4f90io-20060627 $ |
| Copyright: | Copyright (C) GFD Dennou Club, 2000-2005. All rights reserved. |
| License: | See COPYRIGHT |
以下のサブルーチン、関数は gtdata_generic から gtdata_generic#Get として提供されます。
| Subroutine : | |||
| var : | type(GT_VARIABLE), intent(inout) | ||
| value(:) : | real(DP), pointer
| ||
| err : | logical, intent(out), optional |
変数 var から value に数値データが入力されます。 value はポインタ配列であり、数値データのサイズに合わせた 配列サイズが自動的に割り付けられます。 Get は複数のサブルーチンの総称名であり、 1 〜 7 次元のポインタを与えることが可能です。 また value に固定長配列を与えることが可能な手続きもあります。 下記を参照してください。
value が既に割り付けられており、且つ入力する数値データと配列 サイズが異なる場合、エラー (コード dc_error#GT_EBADALLOCATESIZE) を生じます。原則的には value を空状態にして与えることを 推奨します。不定状態で与えることは予期せぬ動作を招く可能性が あるため禁止します。
数値データ入力や上記の割り付けの際にエラーが生じた場合、メッセージ を出力してプログラムは強制終了します。err を与えてある場合には の引数に .true. が返り、プログラムは終了しません。
入力しようとするデータの型が引数の型と異なる場合、データは引数の 型に変換されます。 この変換は netCDF の機能を用いています。 詳しくは netCDF 日本語版マニュアル の 3.3 型変換 を参照してください。
This subroutine returns multi-dimensional data to argument "value". You need to provide GT_VARIABLE variable to argument "var". If you provide logical argument "err", .true. is returned instead of abort with messages when error is occurred.
subroutine GTVarGetPointerDouble1(var, value, err)
!
!
!== ポインタ配列への数値データの入力
!
! 変数 *var* から *value* に数値データが入力されます。
! *value* はポインタ配列であり、数値データのサイズに合わせた
! 配列サイズが自動的に割り付けられます。
! *Get* は複数のサブルーチンの総称名であり、
! 1 〜 7 次元のポインタを与えることが可能です。
! また *value* に固定長配列を与えることが可能な手続きもあります。
! 下記を参照してください。
!
! *value* が既に割り付けられており、且つ入力する数値データと配列
! サイズが異なる場合、エラー (コード dc_error#GT_EBADALLOCATESIZE)
! を生じます。原則的には *value* を空状態にして与えることを
! 推奨します。不定状態で与えることは予期せぬ動作を招く可能性が
! あるため禁止します。
!
! 数値データ入力や上記の割り付けの際にエラーが生じた場合、メッセージ
! を出力してプログラムは強制終了します。*err* を与えてある場合には
! の引数に .true. が返り、プログラムは終了しません。
!
! 入力しようとするデータの型が引数の型と異なる場合、データは引数の
! 型に変換されます。 この変換は netCDF の機能を用いています。
! 詳しくは {netCDF 日本語版マニュアル}[link:../xref.htm#label-10]
! の 3.3 型変換 を参照してください。
!
!
! This subroutine returns multi-dimensional data to argument "value".
! You need to provide GT_VARIABLE variable to argument "var".
! If you provide logical argument "err", .true. is returned
! instead of abort with messages when error is occurred.
!
use gtdata_types, only: GT_VARIABLE
use gtdata_generic, only: Get_Slice, GTVarGetDouble, GTVarGetReal
use gt_map, only: map_set_rank
use an_generic, only: Get, AN_VARIABLE
use dc_types, only: STRING, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
use dc_error, only: StoreError, DC_NOERR, GT_EBADALLOCATESIZE, GT_ENOMOREDIMS, GT_ERANKMISMATCH
use dc_string, only: toChar
implicit none
type(GT_VARIABLE), intent(inout):: var
real(DP), pointer :: value(:) !(out)
logical, intent(out), optional :: err
integer :: stat, n(1), cause_i, data_rank
logical :: invalid_check(1)
real(DP), allocatable :: array1dim_tmp(:)
character(STRING) :: cause_c
character(*), parameter :: subname = 'GTVarGetPointerDouble1'
continue
call BeginSub(subname, 'var.mapid=%d', i=(/var%mapid/))
cause_i = 0
cause_c = ''
n(1) = -1
stat = DC_NOERR
call map_set_rank(var, 1, stat)
if (stat /= DC_NOERR) goto 999
call Get_Slice(var, dimord=1, count=n(1), count_compact=.false.)
if (n(1) < 0) then
! count_compact ではないので、ゼロ次元化していると n = -1 となる
n(1) = 1
endif
call DbgMessage('n(:)=%*d', i=n, n=(/size(n)/))
invalid_check = n > 0
if (.not. all(invalid_check)) then
stat = GT_ERANKMISMATCH
data_rank = count(invalid_check)
cause_c = trim(toChar(data_rank)) // ' and 1'
goto 999
end if
! value が allocate されていなければ allocate する.
! value が既に allocate されていてサイズが取得するデータと同じで
! あればそのまま取得.
! value が allocate されていてサイズが異なる場合はエラー.
!
if ( associated(value) ) then
if ( .not. size(value,1) == n(1) .or. .false. ) then
stat = GT_EBADALLOCATESIZE
if (stat /= DC_NOERR) goto 999
else
call DbgMessage('@ value is already allocated')
endif
else
call DbgMessage('@ allocate value')
allocate( value ( n(1) ) )
endif
if (allocated(array1dim_tmp)) then
deallocate(array1dim_tmp)
end if
allocate(array1dim_tmp(product(n)))
call GTVarGetDouble(var, array1dim_tmp, product(n), err)
! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
value = array1dim_tmp
999 continue
call StoreError(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
call EndSub(subname, 'n=%d', i=(/n/))
end subroutine GTVarGetPointerDouble1
| Subroutine : | |||
| var : | type(GT_VARIABLE), intent(inout) | ||
| value(:,:) : | real(DP), pointer
| ||
| err : | logical, intent(out), optional |
subroutine GTVarGetPointerDouble2(var, value, err)
!
!
use gtdata_types, only: GT_VARIABLE
use gtdata_generic, only: Get_Slice, GTVarGetDouble, GTVarGetReal
use gt_map, only: map_set_rank
use an_generic, only: Get, AN_VARIABLE
use dc_types, only: STRING, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
use dc_error, only: StoreError, DC_NOERR, GT_EBADALLOCATESIZE, GT_ENOMOREDIMS, GT_ERANKMISMATCH
use dc_string, only: toChar
implicit none
type(GT_VARIABLE), intent(inout):: var
real(DP), pointer :: value(:,:) !(out)
logical, intent(out), optional :: err
integer :: stat, n(2), cause_i, data_rank
logical :: invalid_check(2)
real(DP), allocatable :: array1dim_tmp(:)
character(STRING) :: cause_c
character(*), parameter :: subname = 'GTVarGetPointerDouble2'
continue
call BeginSub(subname, 'var.mapid=%d', i=(/var%mapid/))
cause_i = 0
cause_c = ''
n(2) = -1
stat = DC_NOERR
call map_set_rank(var, 2, stat)
if (stat /= DC_NOERR) goto 999
call Get_Slice(var, dimord=1, count=n(1), count_compact=.false.)
call Get_Slice(var, dimord=2, count=n(2), count_compact=.false.)
call DbgMessage('n(:)=%*d', i=n, n=(/size(n)/))
invalid_check = n > 0
if (.not. all(invalid_check)) then
stat = GT_ERANKMISMATCH
data_rank = count(invalid_check)
cause_c = trim(toChar(data_rank)) // ' and 2'
goto 999
end if
! value が allocate されていなければ allocate する.
! value が既に allocate されていてサイズが取得するデータと同じで
! あればそのまま取得.
! value が allocate されていてサイズが異なる場合はエラー.
!
if ( associated(value) ) then
if ( .not. size(value,1) == n(1) .or. .not. size(value,2) == n(2) .or. .false. ) then
stat = GT_EBADALLOCATESIZE
if (stat /= DC_NOERR) goto 999
else
call DbgMessage('@ value is already allocated')
endif
else
call DbgMessage('@ allocate value')
allocate( value ( n(1), n(2) ) )
endif
if (allocated(array1dim_tmp)) then
deallocate(array1dim_tmp)
end if
allocate(array1dim_tmp(product(n)))
call GTVarGetDouble(var, array1dim_tmp, product(n), err)
! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
value = reshape(array1dim_tmp, n)
999 continue
call StoreError(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
call EndSub(subname, 'n=%d', i=(/n/))
end subroutine GTVarGetPointerDouble2
| Subroutine : | |||
| var : | type(GT_VARIABLE), intent(inout) | ||
| value(:,:,:) : | real(DP), pointer
| ||
| err : | logical, intent(out), optional |
subroutine GTVarGetPointerDouble3(var, value, err)
!
!
use gtdata_types, only: GT_VARIABLE
use gtdata_generic, only: Get_Slice, GTVarGetDouble, GTVarGetReal
use gt_map, only: map_set_rank
use an_generic, only: Get, AN_VARIABLE
use dc_types, only: STRING, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
use dc_error, only: StoreError, DC_NOERR, GT_EBADALLOCATESIZE, GT_ENOMOREDIMS, GT_ERANKMISMATCH
use dc_string, only: toChar
implicit none
type(GT_VARIABLE), intent(inout):: var
real(DP), pointer :: value(:,:,:) !(out)
logical, intent(out), optional :: err
integer :: stat, n(3), cause_i, data_rank
logical :: invalid_check(3)
real(DP), allocatable :: array1dim_tmp(:)
character(STRING) :: cause_c
character(*), parameter :: subname = 'GTVarGetPointerDouble3'
continue
call BeginSub(subname, 'var.mapid=%d', i=(/var%mapid/))
cause_i = 0
cause_c = ''
n(3) = -1
stat = DC_NOERR
call map_set_rank(var, 3, stat)
if (stat /= DC_NOERR) goto 999
call Get_Slice(var, dimord=1, count=n(1), count_compact=.false.)
call Get_Slice(var, dimord=2, count=n(2), count_compact=.false.)
call Get_Slice(var, dimord=3, count=n(3), count_compact=.false.)
call DbgMessage('n(:)=%*d', i=n, n=(/size(n)/))
invalid_check = n > 0
if (.not. all(invalid_check)) then
stat = GT_ERANKMISMATCH
data_rank = count(invalid_check)
cause_c = trim(toChar(data_rank)) // ' and 3'
goto 999
end if
! value が allocate されていなければ allocate する.
! value が既に allocate されていてサイズが取得するデータと同じで
! あればそのまま取得.
! value が allocate されていてサイズが異なる場合はエラー.
!
if ( associated(value) ) then
if ( .not. size(value,1) == n(1) .or. .not. size(value,2) == n(2) .or. .not. size(value,3) == n(3) .or. .false. ) then
stat = GT_EBADALLOCATESIZE
if (stat /= DC_NOERR) goto 999
else
call DbgMessage('@ value is already allocated')
endif
else
call DbgMessage('@ allocate value')
allocate( value ( n(1), n(2), n(3) ) )
endif
if (allocated(array1dim_tmp)) then
deallocate(array1dim_tmp)
end if
allocate(array1dim_tmp(product(n)))
call GTVarGetDouble(var, array1dim_tmp, product(n), err)
! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
value = reshape(array1dim_tmp, n)
999 continue
call StoreError(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
call EndSub(subname, 'n=%d', i=(/n/))
end subroutine GTVarGetPointerDouble3
| Subroutine : | |||
| var : | type(GT_VARIABLE), intent(inout) | ||
| value(:,:,:,:) : | real(DP), pointer
| ||
| err : | logical, intent(out), optional |
subroutine GTVarGetPointerDouble4(var, value, err)
!
!
use gtdata_types, only: GT_VARIABLE
use gtdata_generic, only: Get_Slice, GTVarGetDouble, GTVarGetReal
use gt_map, only: map_set_rank
use an_generic, only: Get, AN_VARIABLE
use dc_types, only: STRING, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
use dc_error, only: StoreError, DC_NOERR, GT_EBADALLOCATESIZE, GT_ENOMOREDIMS, GT_ERANKMISMATCH
use dc_string, only: toChar
implicit none
type(GT_VARIABLE), intent(inout):: var
real(DP), pointer :: value(:,:,:,:) !(out)
logical, intent(out), optional :: err
integer :: stat, n(4), cause_i, data_rank
logical :: invalid_check(4)
real(DP), allocatable :: array1dim_tmp(:)
character(STRING) :: cause_c
character(*), parameter :: subname = 'GTVarGetPointerDouble4'
continue
call BeginSub(subname, 'var.mapid=%d', i=(/var%mapid/))
cause_i = 0
cause_c = ''
n(4) = -1
stat = DC_NOERR
call map_set_rank(var, 4, stat)
if (stat /= DC_NOERR) goto 999
call Get_Slice(var, dimord=1, count=n(1), count_compact=.false.)
call Get_Slice(var, dimord=2, count=n(2), count_compact=.false.)
call Get_Slice(var, dimord=3, count=n(3), count_compact=.false.)
call Get_Slice(var, dimord=4, count=n(4), count_compact=.false.)
call DbgMessage('n(:)=%*d', i=n, n=(/size(n)/))
invalid_check = n > 0
if (.not. all(invalid_check)) then
stat = GT_ERANKMISMATCH
data_rank = count(invalid_check)
cause_c = trim(toChar(data_rank)) // ' and 4'
goto 999
end if
! value が allocate されていなければ allocate する.
! value が既に allocate されていてサイズが取得するデータと同じで
! あればそのまま取得.
! value が allocate されていてサイズが異なる場合はエラー.
!
if ( associated(value) ) then
if ( .not. size(value,1) == n(1) .or. .not. size(value,2) == n(2) .or. .not. size(value,3) == n(3) .or. .not. size(value,4) == n(4) .or. .false. ) then
stat = GT_EBADALLOCATESIZE
if (stat /= DC_NOERR) goto 999
else
call DbgMessage('@ value is already allocated')
endif
else
call DbgMessage('@ allocate value')
allocate( value ( n(1), n(2), n(3), n(4) ) )
endif
if (allocated(array1dim_tmp)) then
deallocate(array1dim_tmp)
end if
allocate(array1dim_tmp(product(n)))
call GTVarGetDouble(var, array1dim_tmp, product(n), err)
! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
value = reshape(array1dim_tmp, n)
999 continue
call StoreError(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
call EndSub(subname, 'n=%d', i=(/n/))
end subroutine GTVarGetPointerDouble4
| Subroutine : | |||
| var : | type(GT_VARIABLE), intent(inout) | ||
| value(:,:,:,:,:) : | real(DP), pointer
| ||
| err : | logical, intent(out), optional |
subroutine GTVarGetPointerDouble5(var, value, err)
!
!
use gtdata_types, only: GT_VARIABLE
use gtdata_generic, only: Get_Slice, GTVarGetDouble, GTVarGetReal
use gt_map, only: map_set_rank
use an_generic, only: Get, AN_VARIABLE
use dc_types, only: STRING, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
use dc_error, only: StoreError, DC_NOERR, GT_EBADALLOCATESIZE, GT_ENOMOREDIMS, GT_ERANKMISMATCH
use dc_string, only: toChar
implicit none
type(GT_VARIABLE), intent(inout):: var
real(DP), pointer :: value(:,:,:,:,:) !(out)
logical, intent(out), optional :: err
integer :: stat, n(5), cause_i, data_rank
logical :: invalid_check(5)
real(DP), allocatable :: array1dim_tmp(:)
character(STRING) :: cause_c
character(*), parameter :: subname = 'GTVarGetPointerDouble5'
continue
call BeginSub(subname, 'var.mapid=%d', i=(/var%mapid/))
cause_i = 0
cause_c = ''
n(5) = -1
stat = DC_NOERR
call map_set_rank(var, 5, stat)
if (stat /= DC_NOERR) goto 999
call Get_Slice(var, dimord=1, count=n(1), count_compact=.false.)
call Get_Slice(var, dimord=2, count=n(2), count_compact=.false.)
call Get_Slice(var, dimord=3, count=n(3), count_compact=.false.)
call Get_Slice(var, dimord=4, count=n(4), count_compact=.false.)
call Get_Slice(var, dimord=5, count=n(5), count_compact=.false.)
call DbgMessage('n(:)=%*d', i=n, n=(/size(n)/))
invalid_check = n > 0
if (.not. all(invalid_check)) then
stat = GT_ERANKMISMATCH
data_rank = count(invalid_check)
cause_c = trim(toChar(data_rank)) // ' and 5'
goto 999
end if
! value が allocate されていなければ allocate する.
! value が既に allocate されていてサイズが取得するデータと同じで
! あればそのまま取得.
! value が allocate されていてサイズが異なる場合はエラー.
!
if ( associated(value) ) then
if ( .not. size(value,1) == n(1) .or. .not. size(value,2) == n(2) .or. .not. size(value,3) == n(3) .or. .not. size(value,4) == n(4) .or. .not. size(value,5) == n(5) .or. .false. ) then
stat = GT_EBADALLOCATESIZE
if (stat /= DC_NOERR) goto 999
else
call DbgMessage('@ value is already allocated')
endif
else
call DbgMessage('@ allocate value')
allocate( value ( n(1), n(2), n(3), n(4), n(5) ) )
endif
if (allocated(array1dim_tmp)) then
deallocate(array1dim_tmp)
end if
allocate(array1dim_tmp(product(n)))
call GTVarGetDouble(var, array1dim_tmp, product(n), err)
! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
value = reshape(array1dim_tmp, n)
999 continue
call StoreError(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
call EndSub(subname, 'n=%d', i=(/n/))
end subroutine GTVarGetPointerDouble5
| Subroutine : | |||
| var : | type(GT_VARIABLE), intent(inout) | ||
| value(:,:,:,:,:,:) : | real(DP), pointer
| ||
| err : | logical, intent(out), optional |
subroutine GTVarGetPointerDouble6(var, value, err)
!
!
use gtdata_types, only: GT_VARIABLE
use gtdata_generic, only: Get_Slice, GTVarGetDouble, GTVarGetReal
use gt_map, only: map_set_rank
use an_generic, only: Get, AN_VARIABLE
use dc_types, only: STRING, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
use dc_error, only: StoreError, DC_NOERR, GT_EBADALLOCATESIZE, GT_ENOMOREDIMS, GT_ERANKMISMATCH
use dc_string, only: toChar
implicit none
type(GT_VARIABLE), intent(inout):: var
real(DP), pointer :: value(:,:,:,:,:,:) !(out)
logical, intent(out), optional :: err
integer :: stat, n(6), cause_i, data_rank
logical :: invalid_check(6)
real(DP), allocatable :: array1dim_tmp(:)
character(STRING) :: cause_c
character(*), parameter :: subname = 'GTVarGetPointerDouble6'
continue
call BeginSub(subname, 'var.mapid=%d', i=(/var%mapid/))
cause_i = 0
cause_c = ''
n(6) = -1
stat = DC_NOERR
call map_set_rank(var, 6, stat)
if (stat /= DC_NOERR) goto 999
call Get_Slice(var, dimord=1, count=n(1), count_compact=.false.)
call Get_Slice(var, dimord=2, count=n(2), count_compact=.false.)
call Get_Slice(var, dimord=3, count=n(3), count_compact=.false.)
call Get_Slice(var, dimord=4, count=n(4), count_compact=.false.)
call Get_Slice(var, dimord=5, count=n(5), count_compact=.false.)
call Get_Slice(var, dimord=6, count=n(6), count_compact=.false.)
call DbgMessage('n(:)=%*d', i=n, n=(/size(n)/))
invalid_check = n > 0
if (.not. all(invalid_check)) then
stat = GT_ERANKMISMATCH
data_rank = count(invalid_check)
cause_c = trim(toChar(data_rank)) // ' and 6'
goto 999
end if
! value が allocate されていなければ allocate する.
! value が既に allocate されていてサイズが取得するデータと同じで
! あればそのまま取得.
! value が allocate されていてサイズが異なる場合はエラー.
!
if ( associated(value) ) then
if ( .not. size(value,1) == n(1) .or. .not. size(value,2) == n(2) .or. .not. size(value,3) == n(3) .or. .not. size(value,4) == n(4) .or. .not. size(value,5) == n(5) .or. .not. size(value,6) == n(6) .or. .false. ) then
stat = GT_EBADALLOCATESIZE
if (stat /= DC_NOERR) goto 999
else
call DbgMessage('@ value is already allocated')
endif
else
call DbgMessage('@ allocate value')
allocate( value ( n(1), n(2), n(3), n(4), n(5), n(6) ) )
endif
if (allocated(array1dim_tmp)) then
deallocate(array1dim_tmp)
end if
allocate(array1dim_tmp(product(n)))
call GTVarGetDouble(var, array1dim_tmp, product(n), err)
! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
value = reshape(array1dim_tmp, n)
999 continue
call StoreError(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
call EndSub(subname, 'n=%d', i=(/n/))
end subroutine GTVarGetPointerDouble6
| Subroutine : | |||
| var : | type(GT_VARIABLE), intent(inout) | ||
| value(:,:,:,:,:,:,:) : | real(DP), pointer
| ||
| err : | logical, intent(out), optional |
subroutine GTVarGetPointerDouble7(var, value, err)
!
!
use gtdata_types, only: GT_VARIABLE
use gtdata_generic, only: Get_Slice, GTVarGetDouble, GTVarGetReal
use gt_map, only: map_set_rank
use an_generic, only: Get, AN_VARIABLE
use dc_types, only: STRING, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
use dc_error, only: StoreError, DC_NOERR, GT_EBADALLOCATESIZE, GT_ENOMOREDIMS, GT_ERANKMISMATCH
use dc_string, only: toChar
implicit none
type(GT_VARIABLE), intent(inout):: var
real(DP), pointer :: value(:,:,:,:,:,:,:) !(out)
logical, intent(out), optional :: err
integer :: stat, n(7), cause_i, data_rank
logical :: invalid_check(7)
real(DP), allocatable :: array1dim_tmp(:)
character(STRING) :: cause_c
character(*), parameter :: subname = 'GTVarGetPointerDouble7'
continue
call BeginSub(subname, 'var.mapid=%d', i=(/var%mapid/))
cause_i = 0
cause_c = ''
n(7) = -1
stat = DC_NOERR
call map_set_rank(var, 7, stat)
if (stat /= DC_NOERR) goto 999
call Get_Slice(var, dimord=1, count=n(1), count_compact=.false.)
call Get_Slice(var, dimord=2, count=n(2), count_compact=.false.)
call Get_Slice(var, dimord=3, count=n(3), count_compact=.false.)
call Get_Slice(var, dimord=4, count=n(4), count_compact=.false.)
call Get_Slice(var, dimord=5, count=n(5), count_compact=.false.)
call Get_Slice(var, dimord=6, count=n(6), count_compact=.false.)
call Get_Slice(var, dimord=7, count=n(7), count_compact=.false.)
call DbgMessage('n(:)=%*d', i=n, n=(/size(n)/))
invalid_check = n > 0
if (.not. all(invalid_check)) then
stat = GT_ERANKMISMATCH
data_rank = count(invalid_check)
cause_c = trim(toChar(data_rank)) // ' and 7'
goto 999
end if
! value が allocate されていなければ allocate する.
! value が既に allocate されていてサイズが取得するデータと同じで
! あればそのまま取得.
! value が allocate されていてサイズが異なる場合はエラー.
!
if ( associated(value) ) then
if ( .not. size(value,1) == n(1) .or. .not. size(value,2) == n(2) .or. .not. size(value,3) == n(3) .or. .not. size(value,4) == n(4) .or. .not. size(value,5) == n(5) .or. .not. size(value,6) == n(6) .or. .not. size(value,7) == n(7) .or. .false. ) then
stat = GT_EBADALLOCATESIZE
if (stat /= DC_NOERR) goto 999
else
call DbgMessage('@ value is already allocated')
endif
else
call DbgMessage('@ allocate value')
allocate( value ( n(1), n(2), n(3), n(4), n(5), n(6), n(7) ) )
endif
if (allocated(array1dim_tmp)) then
deallocate(array1dim_tmp)
end if
allocate(array1dim_tmp(product(n)))
call GTVarGetDouble(var, array1dim_tmp, product(n), err)
! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
value = reshape(array1dim_tmp, n)
999 continue
call StoreError(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
call EndSub(subname, 'n=%d', i=(/n/))
end subroutine GTVarGetPointerDouble7
| Subroutine : | |||
| var : | type(GT_VARIABLE), intent(inout) | ||
| value(:) : | real, pointer
| ||
| err : | logical, intent(out), optional |
subroutine GTVarGetPointerReal1(var, value, err)
!
!
use gtdata_types, only: GT_VARIABLE
use gtdata_generic, only: Get_Slice, GTVarGetDouble, GTVarGetReal
use gt_map, only: map_set_rank
use an_generic, only: Get, AN_VARIABLE
use dc_types, only: STRING, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
use dc_error, only: StoreError, DC_NOERR, GT_EBADALLOCATESIZE, GT_ENOMOREDIMS, GT_ERANKMISMATCH
use dc_string, only: toChar
implicit none
type(GT_VARIABLE), intent(inout):: var
real, pointer :: value(:) !(out)
logical, intent(out), optional :: err
integer :: stat, n(1), cause_i, data_rank
logical :: invalid_check(1)
real, allocatable :: array1dim_tmp(:)
character(STRING) :: cause_c
character(*), parameter :: subname = 'GTVarGetPointerReal1'
continue
call BeginSub(subname, 'var.mapid=%d', i=(/var%mapid/))
cause_i = 0
cause_c = ''
n(1) = -1
stat = DC_NOERR
call map_set_rank(var, 1, stat)
if (stat /= DC_NOERR) goto 999
call Get_Slice(var, dimord=1, count=n(1), count_compact=.false.)
if (n(1) < 0) then
! count_compact ではないので、ゼロ次元化していると n = -1 となる
n(1) = 1
endif
call DbgMessage('n(:)=%*d', i=n, n=(/size(n)/))
invalid_check = n > 0
if (.not. all(invalid_check)) then
stat = GT_ERANKMISMATCH
data_rank = count(invalid_check)
cause_c = trim(toChar(data_rank)) // ' and 1'
goto 999
end if
! value が allocate されていなければ allocate する.
! value が既に allocate されていてサイズが取得するデータと同じで
! あればそのまま取得.
! value が allocate されていてサイズが異なる場合はエラー.
!
if ( associated(value) ) then
if ( .not. size(value,1) == n(1) .or. .false. ) then
stat = GT_EBADALLOCATESIZE
if (stat /= DC_NOERR) goto 999
else
call DbgMessage('@ value is already allocated')
endif
else
call DbgMessage('@ allocate value')
allocate( value ( n(1) ) )
endif
if (allocated(array1dim_tmp)) then
deallocate(array1dim_tmp)
end if
allocate(array1dim_tmp(product(n)))
call GTVarGetReal(var, array1dim_tmp, product(n), err)
! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
value = array1dim_tmp
999 continue
call StoreError(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
call EndSub(subname, 'n=%d', i=(/n/))
end subroutine GTVarGetPointerReal1
| Subroutine : | |||
| var : | type(GT_VARIABLE), intent(inout) | ||
| value(:,:) : | real, pointer
| ||
| err : | logical, intent(out), optional |
subroutine GTVarGetPointerReal2(var, value, err)
!
!
use gtdata_types, only: GT_VARIABLE
use gtdata_generic, only: Get_Slice, GTVarGetDouble, GTVarGetReal
use gt_map, only: map_set_rank
use an_generic, only: Get, AN_VARIABLE
use dc_types, only: STRING, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
use dc_error, only: StoreError, DC_NOERR, GT_EBADALLOCATESIZE, GT_ENOMOREDIMS, GT_ERANKMISMATCH
use dc_string, only: toChar
implicit none
type(GT_VARIABLE), intent(inout):: var
real, pointer :: value(:,:) !(out)
logical, intent(out), optional :: err
integer :: stat, n(2), cause_i, data_rank
logical :: invalid_check(2)
real, allocatable :: array1dim_tmp(:)
character(STRING) :: cause_c
character(*), parameter :: subname = 'GTVarGetPointerReal2'
continue
call BeginSub(subname, 'var.mapid=%d', i=(/var%mapid/))
cause_i = 0
cause_c = ''
n(2) = -1
stat = DC_NOERR
call map_set_rank(var, 2, stat)
if (stat /= DC_NOERR) goto 999
call Get_Slice(var, dimord=1, count=n(1), count_compact=.false.)
call Get_Slice(var, dimord=2, count=n(2), count_compact=.false.)
call DbgMessage('n(:)=%*d', i=n, n=(/size(n)/))
invalid_check = n > 0
if (.not. all(invalid_check)) then
stat = GT_ERANKMISMATCH
data_rank = count(invalid_check)
cause_c = trim(toChar(data_rank)) // ' and 2'
goto 999
end if
! value が allocate されていなければ allocate する.
! value が既に allocate されていてサイズが取得するデータと同じで
! あればそのまま取得.
! value が allocate されていてサイズが異なる場合はエラー.
!
if ( associated(value) ) then
if ( .not. size(value,1) == n(1) .or. .not. size(value,2) == n(2) .or. .false. ) then
stat = GT_EBADALLOCATESIZE
if (stat /= DC_NOERR) goto 999
else
call DbgMessage('@ value is already allocated')
endif
else
call DbgMessage('@ allocate value')
allocate( value ( n(1), n(2) ) )
endif
if (allocated(array1dim_tmp)) then
deallocate(array1dim_tmp)
end if
allocate(array1dim_tmp(product(n)))
call GTVarGetReal(var, array1dim_tmp, product(n), err)
! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
value = reshape(array1dim_tmp, n)
999 continue
call StoreError(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
call EndSub(subname, 'n=%d', i=(/n/))
end subroutine GTVarGetPointerReal2
| Subroutine : | |||
| var : | type(GT_VARIABLE), intent(inout) | ||
| value(:,:,:) : | real, pointer
| ||
| err : | logical, intent(out), optional |
subroutine GTVarGetPointerReal3(var, value, err)
!
!
use gtdata_types, only: GT_VARIABLE
use gtdata_generic, only: Get_Slice, GTVarGetDouble, GTVarGetReal
use gt_map, only: map_set_rank
use an_generic, only: Get, AN_VARIABLE
use dc_types, only: STRING, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
use dc_error, only: StoreError, DC_NOERR, GT_EBADALLOCATESIZE, GT_ENOMOREDIMS, GT_ERANKMISMATCH
use dc_string, only: toChar
implicit none
type(GT_VARIABLE), intent(inout):: var
real, pointer :: value(:,:,:) !(out)
logical, intent(out), optional :: err
integer :: stat, n(3), cause_i, data_rank
logical :: invalid_check(3)
real, allocatable :: array1dim_tmp(:)
character(STRING) :: cause_c
character(*), parameter :: subname = 'GTVarGetPointerReal3'
continue
call BeginSub(subname, 'var.mapid=%d', i=(/var%mapid/))
cause_i = 0
cause_c = ''
n(3) = -1
stat = DC_NOERR
call map_set_rank(var, 3, stat)
if (stat /= DC_NOERR) goto 999
call Get_Slice(var, dimord=1, count=n(1), count_compact=.false.)
call Get_Slice(var, dimord=2, count=n(2), count_compact=.false.)
call Get_Slice(var, dimord=3, count=n(3), count_compact=.false.)
call DbgMessage('n(:)=%*d', i=n, n=(/size(n)/))
invalid_check = n > 0
if (.not. all(invalid_check)) then
stat = GT_ERANKMISMATCH
data_rank = count(invalid_check)
cause_c = trim(toChar(data_rank)) // ' and 3'
goto 999
end if
! value が allocate されていなければ allocate する.
! value が既に allocate されていてサイズが取得するデータと同じで
! あればそのまま取得.
! value が allocate されていてサイズが異なる場合はエラー.
!
if ( associated(value) ) then
if ( .not. size(value,1) == n(1) .or. .not. size(value,2) == n(2) .or. .not. size(value,3) == n(3) .or. .false. ) then
stat = GT_EBADALLOCATESIZE
if (stat /= DC_NOERR) goto 999
else
call DbgMessage('@ value is already allocated')
endif
else
call DbgMessage('@ allocate value')
allocate( value ( n(1), n(2), n(3) ) )
endif
if (allocated(array1dim_tmp)) then
deallocate(array1dim_tmp)
end if
allocate(array1dim_tmp(product(n)))
call GTVarGetReal(var, array1dim_tmp, product(n), err)
! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
value = reshape(array1dim_tmp, n)
999 continue
call StoreError(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
call EndSub(subname, 'n=%d', i=(/n/))
end subroutine GTVarGetPointerReal3
| Subroutine : | |||
| var : | type(GT_VARIABLE), intent(inout) | ||
| value(:,:,:,:) : | real, pointer
| ||
| err : | logical, intent(out), optional |
subroutine GTVarGetPointerReal4(var, value, err)
!
!
use gtdata_types, only: GT_VARIABLE
use gtdata_generic, only: Get_Slice, GTVarGetDouble, GTVarGetReal
use gt_map, only: map_set_rank
use an_generic, only: Get, AN_VARIABLE
use dc_types, only: STRING, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
use dc_error, only: StoreError, DC_NOERR, GT_EBADALLOCATESIZE, GT_ENOMOREDIMS, GT_ERANKMISMATCH
use dc_string, only: toChar
implicit none
type(GT_VARIABLE), intent(inout):: var
real, pointer :: value(:,:,:,:) !(out)
logical, intent(out), optional :: err
integer :: stat, n(4), cause_i, data_rank
logical :: invalid_check(4)
real, allocatable :: array1dim_tmp(:)
character(STRING) :: cause_c
character(*), parameter :: subname = 'GTVarGetPointerReal4'
continue
call BeginSub(subname, 'var.mapid=%d', i=(/var%mapid/))
cause_i = 0
cause_c = ''
n(4) = -1
stat = DC_NOERR
call map_set_rank(var, 4, stat)
if (stat /= DC_NOERR) goto 999
call Get_Slice(var, dimord=1, count=n(1), count_compact=.false.)
call Get_Slice(var, dimord=2, count=n(2), count_compact=.false.)
call Get_Slice(var, dimord=3, count=n(3), count_compact=.false.)
call Get_Slice(var, dimord=4, count=n(4), count_compact=.false.)
call DbgMessage('n(:)=%*d', i=n, n=(/size(n)/))
invalid_check = n > 0
if (.not. all(invalid_check)) then
stat = GT_ERANKMISMATCH
data_rank = count(invalid_check)
cause_c = trim(toChar(data_rank)) // ' and 4'
goto 999
end if
! value が allocate されていなければ allocate する.
! value が既に allocate されていてサイズが取得するデータと同じで
! あればそのまま取得.
! value が allocate されていてサイズが異なる場合はエラー.
!
if ( associated(value) ) then
if ( .not. size(value,1) == n(1) .or. .not. size(value,2) == n(2) .or. .not. size(value,3) == n(3) .or. .not. size(value,4) == n(4) .or. .false. ) then
stat = GT_EBADALLOCATESIZE
if (stat /= DC_NOERR) goto 999
else
call DbgMessage('@ value is already allocated')
endif
else
call DbgMessage('@ allocate value')
allocate( value ( n(1), n(2), n(3), n(4) ) )
endif
if (allocated(array1dim_tmp)) then
deallocate(array1dim_tmp)
end if
allocate(array1dim_tmp(product(n)))
call GTVarGetReal(var, array1dim_tmp, product(n), err)
! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
value = reshape(array1dim_tmp, n)
999 continue
call StoreError(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
call EndSub(subname, 'n=%d', i=(/n/))
end subroutine GTVarGetPointerReal4
| Subroutine : | |||
| var : | type(GT_VARIABLE), intent(inout) | ||
| value(:,:,:,:,:) : | real, pointer
| ||
| err : | logical, intent(out), optional |
subroutine GTVarGetPointerReal5(var, value, err)
!
!
use gtdata_types, only: GT_VARIABLE
use gtdata_generic, only: Get_Slice, GTVarGetDouble, GTVarGetReal
use gt_map, only: map_set_rank
use an_generic, only: Get, AN_VARIABLE
use dc_types, only: STRING, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
use dc_error, only: StoreError, DC_NOERR, GT_EBADALLOCATESIZE, GT_ENOMOREDIMS, GT_ERANKMISMATCH
use dc_string, only: toChar
implicit none
type(GT_VARIABLE), intent(inout):: var
real, pointer :: value(:,:,:,:,:) !(out)
logical, intent(out), optional :: err
integer :: stat, n(5), cause_i, data_rank
logical :: invalid_check(5)
real, allocatable :: array1dim_tmp(:)
character(STRING) :: cause_c
character(*), parameter :: subname = 'GTVarGetPointerReal5'
continue
call BeginSub(subname, 'var.mapid=%d', i=(/var%mapid/))
cause_i = 0
cause_c = ''
n(5) = -1
stat = DC_NOERR
call map_set_rank(var, 5, stat)
if (stat /= DC_NOERR) goto 999
call Get_Slice(var, dimord=1, count=n(1), count_compact=.false.)
call Get_Slice(var, dimord=2, count=n(2), count_compact=.false.)
call Get_Slice(var, dimord=3, count=n(3), count_compact=.false.)
call Get_Slice(var, dimord=4, count=n(4), count_compact=.false.)
call Get_Slice(var, dimord=5, count=n(5), count_compact=.false.)
call DbgMessage('n(:)=%*d', i=n, n=(/size(n)/))
invalid_check = n > 0
if (.not. all(invalid_check)) then
stat = GT_ERANKMISMATCH
data_rank = count(invalid_check)
cause_c = trim(toChar(data_rank)) // ' and 5'
goto 999
end if
! value が allocate されていなければ allocate する.
! value が既に allocate されていてサイズが取得するデータと同じで
! あればそのまま取得.
! value が allocate されていてサイズが異なる場合はエラー.
!
if ( associated(value) ) then
if ( .not. size(value,1) == n(1) .or. .not. size(value,2) == n(2) .or. .not. size(value,3) == n(3) .or. .not. size(value,4) == n(4) .or. .not. size(value,5) == n(5) .or. .false. ) then
stat = GT_EBADALLOCATESIZE
if (stat /= DC_NOERR) goto 999
else
call DbgMessage('@ value is already allocated')
endif
else
call DbgMessage('@ allocate value')
allocate( value ( n(1), n(2), n(3), n(4), n(5) ) )
endif
if (allocated(array1dim_tmp)) then
deallocate(array1dim_tmp)
end if
allocate(array1dim_tmp(product(n)))
call GTVarGetReal(var, array1dim_tmp, product(n), err)
! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
value = reshape(array1dim_tmp, n)
999 continue
call StoreError(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
call EndSub(subname, 'n=%d', i=(/n/))
end subroutine GTVarGetPointerReal5
| Subroutine : | |||
| var : | type(GT_VARIABLE), intent(inout) | ||
| value(:,:,:,:,:,:) : | real, pointer
| ||
| err : | logical, intent(out), optional |
subroutine GTVarGetPointerReal6(var, value, err)
!
!
use gtdata_types, only: GT_VARIABLE
use gtdata_generic, only: Get_Slice, GTVarGetDouble, GTVarGetReal
use gt_map, only: map_set_rank
use an_generic, only: Get, AN_VARIABLE
use dc_types, only: STRING, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
use dc_error, only: StoreError, DC_NOERR, GT_EBADALLOCATESIZE, GT_ENOMOREDIMS, GT_ERANKMISMATCH
use dc_string, only: toChar
implicit none
type(GT_VARIABLE), intent(inout):: var
real, pointer :: value(:,:,:,:,:,:) !(out)
logical, intent(out), optional :: err
integer :: stat, n(6), cause_i, data_rank
logical :: invalid_check(6)
real, allocatable :: array1dim_tmp(:)
character(STRING) :: cause_c
character(*), parameter :: subname = 'GTVarGetPointerReal6'
continue
call BeginSub(subname, 'var.mapid=%d', i=(/var%mapid/))
cause_i = 0
cause_c = ''
n(6) = -1
stat = DC_NOERR
call map_set_rank(var, 6, stat)
if (stat /= DC_NOERR) goto 999
call Get_Slice(var, dimord=1, count=n(1), count_compact=.false.)
call Get_Slice(var, dimord=2, count=n(2), count_compact=.false.)
call Get_Slice(var, dimord=3, count=n(3), count_compact=.false.)
call Get_Slice(var, dimord=4, count=n(4), count_compact=.false.)
call Get_Slice(var, dimord=5, count=n(5), count_compact=.false.)
call Get_Slice(var, dimord=6, count=n(6), count_compact=.false.)
call DbgMessage('n(:)=%*d', i=n, n=(/size(n)/))
invalid_check = n > 0
if (.not. all(invalid_check)) then
stat = GT_ERANKMISMATCH
data_rank = count(invalid_check)
cause_c = trim(toChar(data_rank)) // ' and 6'
goto 999
end if
! value が allocate されていなければ allocate する.
! value が既に allocate されていてサイズが取得するデータと同じで
! あればそのまま取得.
! value が allocate されていてサイズが異なる場合はエラー.
!
if ( associated(value) ) then
if ( .not. size(value,1) == n(1) .or. .not. size(value,2) == n(2) .or. .not. size(value,3) == n(3) .or. .not. size(value,4) == n(4) .or. .not. size(value,5) == n(5) .or. .not. size(value,6) == n(6) .or. .false. ) then
stat = GT_EBADALLOCATESIZE
if (stat /= DC_NOERR) goto 999
else
call DbgMessage('@ value is already allocated')
endif
else
call DbgMessage('@ allocate value')
allocate( value ( n(1), n(2), n(3), n(4), n(5), n(6) ) )
endif
if (allocated(array1dim_tmp)) then
deallocate(array1dim_tmp)
end if
allocate(array1dim_tmp(product(n)))
call GTVarGetReal(var, array1dim_tmp, product(n), err)
! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
value = reshape(array1dim_tmp, n)
999 continue
call StoreError(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
call EndSub(subname, 'n=%d', i=(/n/))
end subroutine GTVarGetPointerReal6
| Subroutine : | |||
| var : | type(GT_VARIABLE), intent(inout) | ||
| value(:,:,:,:,:,:,:) : | real, pointer
| ||
| err : | logical, intent(out), optional |
subroutine GTVarGetPointerReal7(var, value, err)
!
!
use gtdata_types, only: GT_VARIABLE
use gtdata_generic, only: Get_Slice, GTVarGetDouble, GTVarGetReal
use gt_map, only: map_set_rank
use an_generic, only: Get, AN_VARIABLE
use dc_types, only: STRING, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
use dc_error, only: StoreError, DC_NOERR, GT_EBADALLOCATESIZE, GT_ENOMOREDIMS, GT_ERANKMISMATCH
use dc_string, only: toChar
implicit none
type(GT_VARIABLE), intent(inout):: var
real, pointer :: value(:,:,:,:,:,:,:) !(out)
logical, intent(out), optional :: err
integer :: stat, n(7), cause_i, data_rank
logical :: invalid_check(7)
real, allocatable :: array1dim_tmp(:)
character(STRING) :: cause_c
character(*), parameter :: subname = 'GTVarGetPointerReal7'
continue
call BeginSub(subname, 'var.mapid=%d', i=(/var%mapid/))
cause_i = 0
cause_c = ''
n(7) = -1
stat = DC_NOERR
call map_set_rank(var, 7, stat)
if (stat /= DC_NOERR) goto 999
call Get_Slice(var, dimord=1, count=n(1), count_compact=.false.)
call Get_Slice(var, dimord=2, count=n(2), count_compact=.false.)
call Get_Slice(var, dimord=3, count=n(3), count_compact=.false.)
call Get_Slice(var, dimord=4, count=n(4), count_compact=.false.)
call Get_Slice(var, dimord=5, count=n(5), count_compact=.false.)
call Get_Slice(var, dimord=6, count=n(6), count_compact=.false.)
call Get_Slice(var, dimord=7, count=n(7), count_compact=.false.)
call DbgMessage('n(:)=%*d', i=n, n=(/size(n)/))
invalid_check = n > 0
if (.not. all(invalid_check)) then
stat = GT_ERANKMISMATCH
data_rank = count(invalid_check)
cause_c = trim(toChar(data_rank)) // ' and 7'
goto 999
end if
! value が allocate されていなければ allocate する.
! value が既に allocate されていてサイズが取得するデータと同じで
! あればそのまま取得.
! value が allocate されていてサイズが異なる場合はエラー.
!
if ( associated(value) ) then
if ( .not. size(value,1) == n(1) .or. .not. size(value,2) == n(2) .or. .not. size(value,3) == n(3) .or. .not. size(value,4) == n(4) .or. .not. size(value,5) == n(5) .or. .not. size(value,6) == n(6) .or. .not. size(value,7) == n(7) .or. .false. ) then
stat = GT_EBADALLOCATESIZE
if (stat /= DC_NOERR) goto 999
else
call DbgMessage('@ value is already allocated')
endif
else
call DbgMessage('@ allocate value')
allocate( value ( n(1), n(2), n(3), n(4), n(5), n(6), n(7) ) )
endif
if (allocated(array1dim_tmp)) then
deallocate(array1dim_tmp)
end if
allocate(array1dim_tmp(product(n)))
call GTVarGetReal(var, array1dim_tmp, product(n), err)
! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
value = reshape(array1dim_tmp, n)
999 continue
call StoreError(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
call EndSub(subname, 'n=%d', i=(/n/))
end subroutine GTVarGetPointerReal7