!-- ! *** Caution!! *** ! ! This file is generated from "gtvargetpointernum.rb2f90" by Ruby 1.8.2. ! Please do not edit this file directly. ! ! [JAPANESE] ! ! ※※※ 注意!!! ※※※ ! ! このファイルは "gtvargetpointernum.rb2f90" から Ruby 1.8.2 ! によって自動生成されたファイルです. ! このファイルを直接編集しませんようお願い致します. ! ! !++ != ポインタ配列への数値データの入力 ! ! Authors:: Yasuhiro MORIKAWA, Eizi TOYODA ! Version:: $Id: gtvargetpointernum.f90,v 1.8 2006/06/04 12:48:43 morikawa Exp $ ! Tag Name:: $Name: gt4f90io-20070101 $ ! Copyright:: Copyright (C) GFD Dennou Club, 2000-2005. All rights reserved. ! License:: See COPYRIGHT[link:../../COPYRIGHT] ! ! 以下のサブルーチン、関数は gtdata_generic から gtdata_generic#Get ! として提供されます。 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 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 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 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 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 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 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 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 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 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 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 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 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 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 !-- ! vi:set readonly sw=4 ts=8: ! !Local Variables: !mode: f90 !buffer-read-only: t !End: ! !++