gtvargetpointernum.f90
Go to the documentation of this file.
1 ! -*- coding: utf-8; mode: f90 -*-
2 !-------------------------------------------------------------------------------------
3 ! Copyright (c) 2000-2016 Gtool Development Group. All rights reserved.
4 !-------------------------------------------------------------------------------------
5 ! ** Important**
6 !
7 ! This file is generated from gtvargetpointernum.erb by ERB included Ruby 2.3.1.
8 ! Please do not edit this file directly. @see "gtvargetpointernum.erb"
9 !-------------------------------------------------------------------------------------
10 !
11 !++
12 != ポインタ配列への数値データの入力
13 !
14 ! Authors:: Yasuhiro MORIKAWA, Eizi TOYODA
15 ! Version:: $Id: gtvargetpointernum.rb2f90,v 1.5 2009-05-25 09:55:58 morikawa Exp $
16 ! Tag Name:: $Name: $
17 ! Copyright:: Copyright (C) GFD Dennou Club, 2000-2005. All rights reserved.
18 ! License:: See COPYRIGHT[link:../../COPYRIGHT]
19 !
20 ! 以下のサブルーチン、関数は gtdata_generic から gtdata_generic#Get
21 ! として提供されます。
22 
23  !
24  !
25  !== ポインタ配列への数値データの入力
26  !
27  ! 変数 *var* から *value* に数値データが入力されます。
28  ! *value* はポインタ配列であり、数値データのサイズに合わせた
29  ! 配列サイズが自動的に割り付けられます。
30  ! *Get* は複数のサブルーチンの総称名であり、
31  ! 1 〜 7 次元のポインタを与えることが可能です。
32  ! また *value* に固定長配列を与えることが可能な手続きもあります。
33  ! 下記を参照してください。
34  !
35  ! *value* が既に割り付けられており、且つ入力する数値データと配列
36  ! サイズが異なる場合、エラー (コード dc_error#GT_EBADALLOCATESIZE)
37  ! を生じます。原則的には *value* を空状態にして与えることを
38  ! 推奨します。不定状態で与えることは予期せぬ動作を招く可能性が
39  ! あるため禁止します。
40  !
41  ! 数値データ入力や上記の割り付けの際にエラーが生じた場合、メッセージ
42  ! を出力してプログラムは強制終了します。*err* を与えてある場合には
43  ! の引数に .true. が返り、プログラムは終了しません。
44  !
45  ! 入力しようとするデータの型が引数の型と異なる場合、データは引数の
46  ! 型に変換されます。 この変換は netCDF の機能を用いています。
47  ! 詳しくは {netCDF 日本語版マニュアル}[link:../xref.htm#label-10]
48  ! の 3.3 型変換 を参照してください。
49  !
50  !
51  ! This subroutine returns multi-dimensional data to argument "value".
52  ! You need to provide GT_VARIABLE variable to argument "var".
53  ! If you provide logical argument "err", .true. is returned
54  ! instead of abort with messages when error is occurred.
55 
56 subroutine gtvargetpointerdouble1(var, value, err)
60  use gtdata_netcdf_generic, only: get
62  use dc_types, only: string, dp
63  use dc_trace, only: dbgmessage
64  use dc_error, only: storeerror, dc_noerr, &
66  use dc_string, only: tochar
67  implicit none
68  type(gt_variable), intent(in):: var
69  real(DP), pointer :: value(:) !(out)
70  real(DP), allocatable :: array1dim_tmp(:)
71  logical, intent(out), optional :: err
72  integer :: stat, n(1), cause_i, data_rank
73  logical :: invalid_check(1)
74  character(STRING) :: cause_c
75  character(*), parameter :: subname = 'GTVarGetPointerDouble1'
76  continue
77  cause_i = 0
78  cause_c = ''
79  n(1) = -1
80  stat = dc_noerr
81  call map_set_rank(var, 1, stat)
82  if (stat /= dc_noerr) goto 999
83  call get_slice(var, dimord=1, count=n(1), count_compact=.false.)
84  if (n(1) < 0) then
85  ! count_compact ではないので、ゼロ次元化していると n = -1 となる
86  n(1) = 1
87  endif
88  call dbgmessage('n(:)=%*d', i=n, n=(/size(n)/))
89  invalid_check = n > 0
90  if (.not. all(invalid_check)) then
91  stat = gt_erankmismatch
92  data_rank = count(invalid_check)
93  cause_c = trim(tochar(data_rank)) // ' and 1'
94  goto 999
95  end if
96  ! value が allocate されていなければ allocate する.
97  ! value が既に allocate されていてサイズが取得するデータと同じで
98  ! あればそのまま取得.
99  ! value が allocate されていてサイズが異なる場合はエラー.
100  if ( associated(value) ) then
101  if ( &
102  & .not. size(value,1) == n(1) .or. &
103  & .false. ) then
104  stat = gt_ebadallocatesize
105  if (stat /= dc_noerr) goto 999
106  else
107  call dbgmessage('@ value is already allocated')
108  endif
109  else
110  call dbgmessage('@ allocate value')
111  allocate( value(&
112  & n(1)) &
113  & )
114  endif
115  if (allocated(array1dim_tmp)) then
116  deallocate(array1dim_tmp)
117  end if
118  allocate(array1dim_tmp(product(n)))
119  call gtvargetdouble(var, array1dim_tmp, product(n), err)
120  ! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
121  value = array1dim_tmp
122 999 continue
123  call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
124 end subroutine gtvargetpointerdouble1
125 
126 subroutine gtvargetpointerdouble2(var, value, err)
130  use gtdata_netcdf_generic, only: get
132  use dc_types, only: string, dp
133  use dc_trace, only: dbgmessage
134  use dc_error, only: storeerror, dc_noerr, &
136  use dc_string, only: tochar
137  implicit none
138  type(gt_variable), intent(in):: var
139  real(DP), pointer :: value(:,:) !(out)
140  real(DP), allocatable :: array1dim_tmp(:)
141  logical, intent(out), optional :: err
142  integer :: stat, n(2), cause_i, data_rank
143  logical :: invalid_check(2)
144  character(STRING) :: cause_c
145  character(*), parameter :: subname = 'GTVarGetPointerDouble2'
146  continue
147  cause_i = 0
148  cause_c = ''
149  n(2) = -1
150  stat = dc_noerr
151  call map_set_rank(var, 2, stat)
152  if (stat /= dc_noerr) goto 999
153  call get_slice(var, dimord=1, count=n(1), count_compact=.false.)
154  call get_slice(var, dimord=2, count=n(2), count_compact=.false.)
155  call dbgmessage('n(:)=%*d', i=n, n=(/size(n)/))
156  invalid_check = n > 0
157  if (.not. all(invalid_check)) then
158  stat = gt_erankmismatch
159  data_rank = count(invalid_check)
160  cause_c = trim(tochar(data_rank)) // ' and 2'
161  goto 999
162  end if
163  ! value が allocate されていなければ allocate する.
164  ! value が既に allocate されていてサイズが取得するデータと同じで
165  ! あればそのまま取得.
166  ! value が allocate されていてサイズが異なる場合はエラー.
167  if ( associated(value) ) then
168  if ( &
169  & .not. size(value,1) == n(1) .or. &
170  & .not. size(value,2) == n(2) .or. &
171  & .false. ) then
172  stat = gt_ebadallocatesize
173  if (stat /= dc_noerr) goto 999
174  else
175  call dbgmessage('@ value is already allocated')
176  endif
177  else
178  call dbgmessage('@ allocate value')
179  allocate( value(&
180  & n(1), &
181  & n(2)) &
182  & )
183  endif
184  if (allocated(array1dim_tmp)) then
185  deallocate(array1dim_tmp)
186  end if
187  allocate(array1dim_tmp(product(n)))
188  call gtvargetdouble(var, array1dim_tmp, product(n), err)
189  ! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
190  value = reshape(array1dim_tmp, n)
191 999 continue
192  call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
193 end subroutine gtvargetpointerdouble2
194 
195 subroutine gtvargetpointerdouble3(var, value, err)
199  use gtdata_netcdf_generic, only: get
201  use dc_types, only: string, dp
202  use dc_trace, only: dbgmessage
203  use dc_error, only: storeerror, dc_noerr, &
205  use dc_string, only: tochar
206  implicit none
207  type(gt_variable), intent(in):: var
208  real(DP), pointer :: value(:,:,:) !(out)
209  real(DP), allocatable :: array1dim_tmp(:)
210  logical, intent(out), optional :: err
211  integer :: stat, n(3), cause_i, data_rank
212  logical :: invalid_check(3)
213  character(STRING) :: cause_c
214  character(*), parameter :: subname = 'GTVarGetPointerDouble3'
215  continue
216  cause_i = 0
217  cause_c = ''
218  n(3) = -1
219  stat = dc_noerr
220  call map_set_rank(var, 3, stat)
221  if (stat /= dc_noerr) goto 999
222  call get_slice(var, dimord=1, count=n(1), count_compact=.false.)
223  call get_slice(var, dimord=2, count=n(2), count_compact=.false.)
224  call get_slice(var, dimord=3, count=n(3), count_compact=.false.)
225  call dbgmessage('n(:)=%*d', i=n, n=(/size(n)/))
226  invalid_check = n > 0
227  if (.not. all(invalid_check)) then
228  stat = gt_erankmismatch
229  data_rank = count(invalid_check)
230  cause_c = trim(tochar(data_rank)) // ' and 3'
231  goto 999
232  end if
233  ! value が allocate されていなければ allocate する.
234  ! value が既に allocate されていてサイズが取得するデータと同じで
235  ! あればそのまま取得.
236  ! value が allocate されていてサイズが異なる場合はエラー.
237  if ( associated(value) ) then
238  if ( &
239  & .not. size(value,1) == n(1) .or. &
240  & .not. size(value,2) == n(2) .or. &
241  & .not. size(value,3) == n(3) .or. &
242  & .false. ) then
243  stat = gt_ebadallocatesize
244  if (stat /= dc_noerr) goto 999
245  else
246  call dbgmessage('@ value is already allocated')
247  endif
248  else
249  call dbgmessage('@ allocate value')
250  allocate( value(&
251  & n(1), &
252  & n(2), &
253  & n(3)) &
254  & )
255  endif
256  if (allocated(array1dim_tmp)) then
257  deallocate(array1dim_tmp)
258  end if
259  allocate(array1dim_tmp(product(n)))
260  call gtvargetdouble(var, array1dim_tmp, product(n), err)
261  ! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
262  value = reshape(array1dim_tmp, n)
263 999 continue
264  call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
265 end subroutine gtvargetpointerdouble3
266 
267 subroutine gtvargetpointerdouble4(var, value, err)
271  use gtdata_netcdf_generic, only: get
273  use dc_types, only: string, dp
274  use dc_trace, only: dbgmessage
275  use dc_error, only: storeerror, dc_noerr, &
277  use dc_string, only: tochar
278  implicit none
279  type(gt_variable), intent(in):: var
280  real(DP), pointer :: value(:,:,:,:) !(out)
281  real(DP), allocatable :: array1dim_tmp(:)
282  logical, intent(out), optional :: err
283  integer :: stat, n(4), cause_i, data_rank
284  logical :: invalid_check(4)
285  character(STRING) :: cause_c
286  character(*), parameter :: subname = 'GTVarGetPointerDouble4'
287  continue
288  cause_i = 0
289  cause_c = ''
290  n(4) = -1
291  stat = dc_noerr
292  call map_set_rank(var, 4, stat)
293  if (stat /= dc_noerr) goto 999
294  call get_slice(var, dimord=1, count=n(1), count_compact=.false.)
295  call get_slice(var, dimord=2, count=n(2), count_compact=.false.)
296  call get_slice(var, dimord=3, count=n(3), count_compact=.false.)
297  call get_slice(var, dimord=4, count=n(4), count_compact=.false.)
298  call dbgmessage('n(:)=%*d', i=n, n=(/size(n)/))
299  invalid_check = n > 0
300  if (.not. all(invalid_check)) then
301  stat = gt_erankmismatch
302  data_rank = count(invalid_check)
303  cause_c = trim(tochar(data_rank)) // ' and 4'
304  goto 999
305  end if
306  ! value が allocate されていなければ allocate する.
307  ! value が既に allocate されていてサイズが取得するデータと同じで
308  ! あればそのまま取得.
309  ! value が allocate されていてサイズが異なる場合はエラー.
310  if ( associated(value) ) then
311  if ( &
312  & .not. size(value,1) == n(1) .or. &
313  & .not. size(value,2) == n(2) .or. &
314  & .not. size(value,3) == n(3) .or. &
315  & .not. size(value,4) == n(4) .or. &
316  & .false. ) then
317  stat = gt_ebadallocatesize
318  if (stat /= dc_noerr) goto 999
319  else
320  call dbgmessage('@ value is already allocated')
321  endif
322  else
323  call dbgmessage('@ allocate value')
324  allocate( value(&
325  & n(1), &
326  & n(2), &
327  & n(3), &
328  & n(4)) &
329  & )
330  endif
331  if (allocated(array1dim_tmp)) then
332  deallocate(array1dim_tmp)
333  end if
334  allocate(array1dim_tmp(product(n)))
335  call gtvargetdouble(var, array1dim_tmp, product(n), err)
336  ! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
337  value = reshape(array1dim_tmp, n)
338 999 continue
339  call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
340 end subroutine gtvargetpointerdouble4
341 
342 subroutine gtvargetpointerdouble5(var, value, err)
346  use gtdata_netcdf_generic, only: get
348  use dc_types, only: string, dp
349  use dc_trace, only: dbgmessage
350  use dc_error, only: storeerror, dc_noerr, &
352  use dc_string, only: tochar
353  implicit none
354  type(gt_variable), intent(in):: var
355  real(DP), pointer :: value(:,:,:,:,:) !(out)
356  real(DP), allocatable :: array1dim_tmp(:)
357  logical, intent(out), optional :: err
358  integer :: stat, n(5), cause_i, data_rank
359  logical :: invalid_check(5)
360  character(STRING) :: cause_c
361  character(*), parameter :: subname = 'GTVarGetPointerDouble5'
362  continue
363  cause_i = 0
364  cause_c = ''
365  n(5) = -1
366  stat = dc_noerr
367  call map_set_rank(var, 5, stat)
368  if (stat /= dc_noerr) goto 999
369  call get_slice(var, dimord=1, count=n(1), count_compact=.false.)
370  call get_slice(var, dimord=2, count=n(2), count_compact=.false.)
371  call get_slice(var, dimord=3, count=n(3), count_compact=.false.)
372  call get_slice(var, dimord=4, count=n(4), count_compact=.false.)
373  call get_slice(var, dimord=5, count=n(5), count_compact=.false.)
374  call dbgmessage('n(:)=%*d', i=n, n=(/size(n)/))
375  invalid_check = n > 0
376  if (.not. all(invalid_check)) then
377  stat = gt_erankmismatch
378  data_rank = count(invalid_check)
379  cause_c = trim(tochar(data_rank)) // ' and 5'
380  goto 999
381  end if
382  ! value が allocate されていなければ allocate する.
383  ! value が既に allocate されていてサイズが取得するデータと同じで
384  ! あればそのまま取得.
385  ! value が allocate されていてサイズが異なる場合はエラー.
386  if ( associated(value) ) then
387  if ( &
388  & .not. size(value,1) == n(1) .or. &
389  & .not. size(value,2) == n(2) .or. &
390  & .not. size(value,3) == n(3) .or. &
391  & .not. size(value,4) == n(4) .or. &
392  & .not. size(value,5) == n(5) .or. &
393  & .false. ) then
394  stat = gt_ebadallocatesize
395  if (stat /= dc_noerr) goto 999
396  else
397  call dbgmessage('@ value is already allocated')
398  endif
399  else
400  call dbgmessage('@ allocate value')
401  allocate( value(&
402  & n(1), &
403  & n(2), &
404  & n(3), &
405  & n(4), &
406  & n(5)) &
407  & )
408  endif
409  if (allocated(array1dim_tmp)) then
410  deallocate(array1dim_tmp)
411  end if
412  allocate(array1dim_tmp(product(n)))
413  call gtvargetdouble(var, array1dim_tmp, product(n), err)
414  ! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
415  value = reshape(array1dim_tmp, n)
416 999 continue
417  call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
418 end subroutine gtvargetpointerdouble5
419 
420 subroutine gtvargetpointerdouble6(var, value, err)
424  use gtdata_netcdf_generic, only: get
426  use dc_types, only: string, dp
427  use dc_trace, only: dbgmessage
428  use dc_error, only: storeerror, dc_noerr, &
430  use dc_string, only: tochar
431  implicit none
432  type(gt_variable), intent(in):: var
433  real(DP), pointer :: value(:,:,:,:,:,:) !(out)
434  real(DP), allocatable :: array1dim_tmp(:)
435  logical, intent(out), optional :: err
436  integer :: stat, n(6), cause_i, data_rank
437  logical :: invalid_check(6)
438  character(STRING) :: cause_c
439  character(*), parameter :: subname = 'GTVarGetPointerDouble6'
440  continue
441  cause_i = 0
442  cause_c = ''
443  n(6) = -1
444  stat = dc_noerr
445  call map_set_rank(var, 6, stat)
446  if (stat /= dc_noerr) goto 999
447  call get_slice(var, dimord=1, count=n(1), count_compact=.false.)
448  call get_slice(var, dimord=2, count=n(2), count_compact=.false.)
449  call get_slice(var, dimord=3, count=n(3), count_compact=.false.)
450  call get_slice(var, dimord=4, count=n(4), count_compact=.false.)
451  call get_slice(var, dimord=5, count=n(5), count_compact=.false.)
452  call get_slice(var, dimord=6, count=n(6), count_compact=.false.)
453  call dbgmessage('n(:)=%*d', i=n, n=(/size(n)/))
454  invalid_check = n > 0
455  if (.not. all(invalid_check)) then
456  stat = gt_erankmismatch
457  data_rank = count(invalid_check)
458  cause_c = trim(tochar(data_rank)) // ' and 6'
459  goto 999
460  end if
461  ! value が allocate されていなければ allocate する.
462  ! value が既に allocate されていてサイズが取得するデータと同じで
463  ! あればそのまま取得.
464  ! value が allocate されていてサイズが異なる場合はエラー.
465  if ( associated(value) ) then
466  if ( &
467  & .not. size(value,1) == n(1) .or. &
468  & .not. size(value,2) == n(2) .or. &
469  & .not. size(value,3) == n(3) .or. &
470  & .not. size(value,4) == n(4) .or. &
471  & .not. size(value,5) == n(5) .or. &
472  & .not. size(value,6) == n(6) .or. &
473  & .false. ) then
474  stat = gt_ebadallocatesize
475  if (stat /= dc_noerr) goto 999
476  else
477  call dbgmessage('@ value is already allocated')
478  endif
479  else
480  call dbgmessage('@ allocate value')
481  allocate( value(&
482  & n(1), &
483  & n(2), &
484  & n(3), &
485  & n(4), &
486  & n(5), &
487  & n(6)) &
488  & )
489  endif
490  if (allocated(array1dim_tmp)) then
491  deallocate(array1dim_tmp)
492  end if
493  allocate(array1dim_tmp(product(n)))
494  call gtvargetdouble(var, array1dim_tmp, product(n), err)
495  ! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
496  value = reshape(array1dim_tmp, n)
497 999 continue
498  call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
499 end subroutine gtvargetpointerdouble6
500 
501 subroutine gtvargetpointerdouble7(var, value, err)
505  use gtdata_netcdf_generic, only: get
507  use dc_types, only: string, dp
508  use dc_trace, only: dbgmessage
509  use dc_error, only: storeerror, dc_noerr, &
511  use dc_string, only: tochar
512  implicit none
513  type(gt_variable), intent(in):: var
514  real(DP), pointer :: value(:,:,:,:,:,:,:) !(out)
515  real(DP), allocatable :: array1dim_tmp(:)
516  logical, intent(out), optional :: err
517  integer :: stat, n(7), cause_i, data_rank
518  logical :: invalid_check(7)
519  character(STRING) :: cause_c
520  character(*), parameter :: subname = 'GTVarGetPointerDouble7'
521  continue
522  cause_i = 0
523  cause_c = ''
524  n(7) = -1
525  stat = dc_noerr
526  call map_set_rank(var, 7, stat)
527  if (stat /= dc_noerr) goto 999
528  call get_slice(var, dimord=1, count=n(1), count_compact=.false.)
529  call get_slice(var, dimord=2, count=n(2), count_compact=.false.)
530  call get_slice(var, dimord=3, count=n(3), count_compact=.false.)
531  call get_slice(var, dimord=4, count=n(4), count_compact=.false.)
532  call get_slice(var, dimord=5, count=n(5), count_compact=.false.)
533  call get_slice(var, dimord=6, count=n(6), count_compact=.false.)
534  call get_slice(var, dimord=7, count=n(7), count_compact=.false.)
535  call dbgmessage('n(:)=%*d', i=n, n=(/size(n)/))
536  invalid_check = n > 0
537  if (.not. all(invalid_check)) then
538  stat = gt_erankmismatch
539  data_rank = count(invalid_check)
540  cause_c = trim(tochar(data_rank)) // ' and 7'
541  goto 999
542  end if
543  ! value が allocate されていなければ allocate する.
544  ! value が既に allocate されていてサイズが取得するデータと同じで
545  ! あればそのまま取得.
546  ! value が allocate されていてサイズが異なる場合はエラー.
547  if ( associated(value) ) then
548  if ( &
549  & .not. size(value,1) == n(1) .or. &
550  & .not. size(value,2) == n(2) .or. &
551  & .not. size(value,3) == n(3) .or. &
552  & .not. size(value,4) == n(4) .or. &
553  & .not. size(value,5) == n(5) .or. &
554  & .not. size(value,6) == n(6) .or. &
555  & .not. size(value,7) == n(7) .or. &
556  & .false. ) then
557  stat = gt_ebadallocatesize
558  if (stat /= dc_noerr) goto 999
559  else
560  call dbgmessage('@ value is already allocated')
561  endif
562  else
563  call dbgmessage('@ allocate value')
564  allocate( value(&
565  & n(1), &
566  & n(2), &
567  & n(3), &
568  & n(4), &
569  & n(5), &
570  & n(6), &
571  & n(7)) &
572  & )
573  endif
574  if (allocated(array1dim_tmp)) then
575  deallocate(array1dim_tmp)
576  end if
577  allocate(array1dim_tmp(product(n)))
578  call gtvargetdouble(var, array1dim_tmp, product(n), err)
579  ! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
580  value = reshape(array1dim_tmp, n)
581 999 continue
582  call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
583 end subroutine gtvargetpointerdouble7
584 
585 subroutine gtvargetpointerreal1(var, value, err)
589  use gtdata_netcdf_generic, only: get
591  use dc_types, only: string, sp
592  use dc_trace, only: dbgmessage
593  use dc_error, only: storeerror, dc_noerr, &
595  use dc_string, only: tochar
596  implicit none
597  type(gt_variable), intent(in):: var
598  real(SP), pointer :: value(:) !(out)
599  real(SP), allocatable :: array1dim_tmp(:)
600  logical, intent(out), optional :: err
601  integer :: stat, n(1), cause_i, data_rank
602  logical :: invalid_check(1)
603  character(STRING) :: cause_c
604  character(*), parameter :: subname = 'GTVarGetPointerReal1'
605  continue
606  cause_i = 0
607  cause_c = ''
608  n(1) = -1
609  stat = dc_noerr
610  call map_set_rank(var, 1, stat)
611  if (stat /= dc_noerr) goto 999
612  call get_slice(var, dimord=1, count=n(1), count_compact=.false.)
613  if (n(1) < 0) then
614  ! count_compact ではないので、ゼロ次元化していると n = -1 となる
615  n(1) = 1
616  endif
617  call dbgmessage('n(:)=%*d', i=n, n=(/size(n)/))
618  invalid_check = n > 0
619  if (.not. all(invalid_check)) then
620  stat = gt_erankmismatch
621  data_rank = count(invalid_check)
622  cause_c = trim(tochar(data_rank)) // ' and 1'
623  goto 999
624  end if
625  ! value が allocate されていなければ allocate する.
626  ! value が既に allocate されていてサイズが取得するデータと同じで
627  ! あればそのまま取得.
628  ! value が allocate されていてサイズが異なる場合はエラー.
629  if ( associated(value) ) then
630  if ( &
631  & .not. size(value,1) == n(1) .or. &
632  & .false. ) then
633  stat = gt_ebadallocatesize
634  if (stat /= dc_noerr) goto 999
635  else
636  call dbgmessage('@ value is already allocated')
637  endif
638  else
639  call dbgmessage('@ allocate value')
640  allocate( value(&
641  & n(1)) &
642  & )
643  endif
644  if (allocated(array1dim_tmp)) then
645  deallocate(array1dim_tmp)
646  end if
647  allocate(array1dim_tmp(product(n)))
648  call gtvargetreal(var, array1dim_tmp, product(n), err)
649  ! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
650  value = array1dim_tmp
651 999 continue
652  call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
653 end subroutine gtvargetpointerreal1
654 
655 subroutine gtvargetpointerreal2(var, value, err)
659  use gtdata_netcdf_generic, only: get
661  use dc_types, only: string, sp
662  use dc_trace, only: dbgmessage
663  use dc_error, only: storeerror, dc_noerr, &
665  use dc_string, only: tochar
666  implicit none
667  type(gt_variable), intent(in):: var
668  real(SP), pointer :: value(:,:) !(out)
669  real(SP), allocatable :: array1dim_tmp(:)
670  logical, intent(out), optional :: err
671  integer :: stat, n(2), cause_i, data_rank
672  logical :: invalid_check(2)
673  character(STRING) :: cause_c
674  character(*), parameter :: subname = 'GTVarGetPointerReal2'
675  continue
676  cause_i = 0
677  cause_c = ''
678  n(2) = -1
679  stat = dc_noerr
680  call map_set_rank(var, 2, stat)
681  if (stat /= dc_noerr) goto 999
682  call get_slice(var, dimord=1, count=n(1), count_compact=.false.)
683  call get_slice(var, dimord=2, count=n(2), count_compact=.false.)
684  call dbgmessage('n(:)=%*d', i=n, n=(/size(n)/))
685  invalid_check = n > 0
686  if (.not. all(invalid_check)) then
687  stat = gt_erankmismatch
688  data_rank = count(invalid_check)
689  cause_c = trim(tochar(data_rank)) // ' and 2'
690  goto 999
691  end if
692  ! value が allocate されていなければ allocate する.
693  ! value が既に allocate されていてサイズが取得するデータと同じで
694  ! あればそのまま取得.
695  ! value が allocate されていてサイズが異なる場合はエラー.
696  if ( associated(value) ) then
697  if ( &
698  & .not. size(value,1) == n(1) .or. &
699  & .not. size(value,2) == n(2) .or. &
700  & .false. ) then
701  stat = gt_ebadallocatesize
702  if (stat /= dc_noerr) goto 999
703  else
704  call dbgmessage('@ value is already allocated')
705  endif
706  else
707  call dbgmessage('@ allocate value')
708  allocate( value(&
709  & n(1), &
710  & n(2)) &
711  & )
712  endif
713  if (allocated(array1dim_tmp)) then
714  deallocate(array1dim_tmp)
715  end if
716  allocate(array1dim_tmp(product(n)))
717  call gtvargetreal(var, array1dim_tmp, product(n), err)
718  ! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
719  value = reshape(array1dim_tmp, n)
720 999 continue
721  call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
722 end subroutine gtvargetpointerreal2
723 
724 subroutine gtvargetpointerreal3(var, value, err)
728  use gtdata_netcdf_generic, only: get
730  use dc_types, only: string, sp
731  use dc_trace, only: dbgmessage
732  use dc_error, only: storeerror, dc_noerr, &
734  use dc_string, only: tochar
735  implicit none
736  type(gt_variable), intent(in):: var
737  real(SP), pointer :: value(:,:,:) !(out)
738  real(SP), allocatable :: array1dim_tmp(:)
739  logical, intent(out), optional :: err
740  integer :: stat, n(3), cause_i, data_rank
741  logical :: invalid_check(3)
742  character(STRING) :: cause_c
743  character(*), parameter :: subname = 'GTVarGetPointerReal3'
744  continue
745  cause_i = 0
746  cause_c = ''
747  n(3) = -1
748  stat = dc_noerr
749  call map_set_rank(var, 3, stat)
750  if (stat /= dc_noerr) goto 999
751  call get_slice(var, dimord=1, count=n(1), count_compact=.false.)
752  call get_slice(var, dimord=2, count=n(2), count_compact=.false.)
753  call get_slice(var, dimord=3, count=n(3), count_compact=.false.)
754  call dbgmessage('n(:)=%*d', i=n, n=(/size(n)/))
755  invalid_check = n > 0
756  if (.not. all(invalid_check)) then
757  stat = gt_erankmismatch
758  data_rank = count(invalid_check)
759  cause_c = trim(tochar(data_rank)) // ' and 3'
760  goto 999
761  end if
762  ! value が allocate されていなければ allocate する.
763  ! value が既に allocate されていてサイズが取得するデータと同じで
764  ! あればそのまま取得.
765  ! value が allocate されていてサイズが異なる場合はエラー.
766  if ( associated(value) ) then
767  if ( &
768  & .not. size(value,1) == n(1) .or. &
769  & .not. size(value,2) == n(2) .or. &
770  & .not. size(value,3) == n(3) .or. &
771  & .false. ) then
772  stat = gt_ebadallocatesize
773  if (stat /= dc_noerr) goto 999
774  else
775  call dbgmessage('@ value is already allocated')
776  endif
777  else
778  call dbgmessage('@ allocate value')
779  allocate( value(&
780  & n(1), &
781  & n(2), &
782  & n(3)) &
783  & )
784  endif
785  if (allocated(array1dim_tmp)) then
786  deallocate(array1dim_tmp)
787  end if
788  allocate(array1dim_tmp(product(n)))
789  call gtvargetreal(var, array1dim_tmp, product(n), err)
790  ! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
791  value = reshape(array1dim_tmp, n)
792 999 continue
793  call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
794 end subroutine gtvargetpointerreal3
795 
796 subroutine gtvargetpointerreal4(var, value, err)
800  use gtdata_netcdf_generic, only: get
802  use dc_types, only: string, sp
803  use dc_trace, only: dbgmessage
804  use dc_error, only: storeerror, dc_noerr, &
806  use dc_string, only: tochar
807  implicit none
808  type(gt_variable), intent(in):: var
809  real(SP), pointer :: value(:,:,:,:) !(out)
810  real(SP), allocatable :: array1dim_tmp(:)
811  logical, intent(out), optional :: err
812  integer :: stat, n(4), cause_i, data_rank
813  logical :: invalid_check(4)
814  character(STRING) :: cause_c
815  character(*), parameter :: subname = 'GTVarGetPointerReal4'
816  continue
817  cause_i = 0
818  cause_c = ''
819  n(4) = -1
820  stat = dc_noerr
821  call map_set_rank(var, 4, stat)
822  if (stat /= dc_noerr) goto 999
823  call get_slice(var, dimord=1, count=n(1), count_compact=.false.)
824  call get_slice(var, dimord=2, count=n(2), count_compact=.false.)
825  call get_slice(var, dimord=3, count=n(3), count_compact=.false.)
826  call get_slice(var, dimord=4, count=n(4), count_compact=.false.)
827  call dbgmessage('n(:)=%*d', i=n, n=(/size(n)/))
828  invalid_check = n > 0
829  if (.not. all(invalid_check)) then
830  stat = gt_erankmismatch
831  data_rank = count(invalid_check)
832  cause_c = trim(tochar(data_rank)) // ' and 4'
833  goto 999
834  end if
835  ! value が allocate されていなければ allocate する.
836  ! value が既に allocate されていてサイズが取得するデータと同じで
837  ! あればそのまま取得.
838  ! value が allocate されていてサイズが異なる場合はエラー.
839  if ( associated(value) ) then
840  if ( &
841  & .not. size(value,1) == n(1) .or. &
842  & .not. size(value,2) == n(2) .or. &
843  & .not. size(value,3) == n(3) .or. &
844  & .not. size(value,4) == n(4) .or. &
845  & .false. ) then
846  stat = gt_ebadallocatesize
847  if (stat /= dc_noerr) goto 999
848  else
849  call dbgmessage('@ value is already allocated')
850  endif
851  else
852  call dbgmessage('@ allocate value')
853  allocate( value(&
854  & n(1), &
855  & n(2), &
856  & n(3), &
857  & n(4)) &
858  & )
859  endif
860  if (allocated(array1dim_tmp)) then
861  deallocate(array1dim_tmp)
862  end if
863  allocate(array1dim_tmp(product(n)))
864  call gtvargetreal(var, array1dim_tmp, product(n), err)
865  ! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
866  value = reshape(array1dim_tmp, n)
867 999 continue
868  call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
869 end subroutine gtvargetpointerreal4
870 
871 subroutine gtvargetpointerreal5(var, value, err)
875  use gtdata_netcdf_generic, only: get
877  use dc_types, only: string, sp
878  use dc_trace, only: dbgmessage
879  use dc_error, only: storeerror, dc_noerr, &
881  use dc_string, only: tochar
882  implicit none
883  type(gt_variable), intent(in):: var
884  real(SP), pointer :: value(:,:,:,:,:) !(out)
885  real(SP), allocatable :: array1dim_tmp(:)
886  logical, intent(out), optional :: err
887  integer :: stat, n(5), cause_i, data_rank
888  logical :: invalid_check(5)
889  character(STRING) :: cause_c
890  character(*), parameter :: subname = 'GTVarGetPointerReal5'
891  continue
892  cause_i = 0
893  cause_c = ''
894  n(5) = -1
895  stat = dc_noerr
896  call map_set_rank(var, 5, stat)
897  if (stat /= dc_noerr) goto 999
898  call get_slice(var, dimord=1, count=n(1), count_compact=.false.)
899  call get_slice(var, dimord=2, count=n(2), count_compact=.false.)
900  call get_slice(var, dimord=3, count=n(3), count_compact=.false.)
901  call get_slice(var, dimord=4, count=n(4), count_compact=.false.)
902  call get_slice(var, dimord=5, count=n(5), count_compact=.false.)
903  call dbgmessage('n(:)=%*d', i=n, n=(/size(n)/))
904  invalid_check = n > 0
905  if (.not. all(invalid_check)) then
906  stat = gt_erankmismatch
907  data_rank = count(invalid_check)
908  cause_c = trim(tochar(data_rank)) // ' and 5'
909  goto 999
910  end if
911  ! value が allocate されていなければ allocate する.
912  ! value が既に allocate されていてサイズが取得するデータと同じで
913  ! あればそのまま取得.
914  ! value が allocate されていてサイズが異なる場合はエラー.
915  if ( associated(value) ) then
916  if ( &
917  & .not. size(value,1) == n(1) .or. &
918  & .not. size(value,2) == n(2) .or. &
919  & .not. size(value,3) == n(3) .or. &
920  & .not. size(value,4) == n(4) .or. &
921  & .not. size(value,5) == n(5) .or. &
922  & .false. ) then
923  stat = gt_ebadallocatesize
924  if (stat /= dc_noerr) goto 999
925  else
926  call dbgmessage('@ value is already allocated')
927  endif
928  else
929  call dbgmessage('@ allocate value')
930  allocate( value(&
931  & n(1), &
932  & n(2), &
933  & n(3), &
934  & n(4), &
935  & n(5)) &
936  & )
937  endif
938  if (allocated(array1dim_tmp)) then
939  deallocate(array1dim_tmp)
940  end if
941  allocate(array1dim_tmp(product(n)))
942  call gtvargetreal(var, array1dim_tmp, product(n), err)
943  ! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
944  value = reshape(array1dim_tmp, n)
945 999 continue
946  call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
947 end subroutine gtvargetpointerreal5
948 
949 subroutine gtvargetpointerreal6(var, value, err)
953  use gtdata_netcdf_generic, only: get
955  use dc_types, only: string, sp
956  use dc_trace, only: dbgmessage
957  use dc_error, only: storeerror, dc_noerr, &
959  use dc_string, only: tochar
960  implicit none
961  type(gt_variable), intent(in):: var
962  real(SP), pointer :: value(:,:,:,:,:,:) !(out)
963  real(SP), allocatable :: array1dim_tmp(:)
964  logical, intent(out), optional :: err
965  integer :: stat, n(6), cause_i, data_rank
966  logical :: invalid_check(6)
967  character(STRING) :: cause_c
968  character(*), parameter :: subname = 'GTVarGetPointerReal6'
969  continue
970  cause_i = 0
971  cause_c = ''
972  n(6) = -1
973  stat = dc_noerr
974  call map_set_rank(var, 6, stat)
975  if (stat /= dc_noerr) goto 999
976  call get_slice(var, dimord=1, count=n(1), count_compact=.false.)
977  call get_slice(var, dimord=2, count=n(2), count_compact=.false.)
978  call get_slice(var, dimord=3, count=n(3), count_compact=.false.)
979  call get_slice(var, dimord=4, count=n(4), count_compact=.false.)
980  call get_slice(var, dimord=5, count=n(5), count_compact=.false.)
981  call get_slice(var, dimord=6, count=n(6), count_compact=.false.)
982  call dbgmessage('n(:)=%*d', i=n, n=(/size(n)/))
983  invalid_check = n > 0
984  if (.not. all(invalid_check)) then
985  stat = gt_erankmismatch
986  data_rank = count(invalid_check)
987  cause_c = trim(tochar(data_rank)) // ' and 6'
988  goto 999
989  end if
990  ! value が allocate されていなければ allocate する.
991  ! value が既に allocate されていてサイズが取得するデータと同じで
992  ! あればそのまま取得.
993  ! value が allocate されていてサイズが異なる場合はエラー.
994  if ( associated(value) ) then
995  if ( &
996  & .not. size(value,1) == n(1) .or. &
997  & .not. size(value,2) == n(2) .or. &
998  & .not. size(value,3) == n(3) .or. &
999  & .not. size(value,4) == n(4) .or. &
1000  & .not. size(value,5) == n(5) .or. &
1001  & .not. size(value,6) == n(6) .or. &
1002  & .false. ) then
1003  stat = gt_ebadallocatesize
1004  if (stat /= dc_noerr) goto 999
1005  else
1006  call dbgmessage('@ value is already allocated')
1007  endif
1008  else
1009  call dbgmessage('@ allocate value')
1010  allocate( value(&
1011  & n(1), &
1012  & n(2), &
1013  & n(3), &
1014  & n(4), &
1015  & n(5), &
1016  & n(6)) &
1017  & )
1018  endif
1019  if (allocated(array1dim_tmp)) then
1020  deallocate(array1dim_tmp)
1021  end if
1022  allocate(array1dim_tmp(product(n)))
1023  call gtvargetreal(var, array1dim_tmp, product(n), err)
1024  ! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
1025  value = reshape(array1dim_tmp, n)
1026 999 continue
1027  call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
1028 end subroutine gtvargetpointerreal6
1029 
1030 subroutine gtvargetpointerreal7(var, value, err)
1034  use gtdata_netcdf_generic, only: get
1036  use dc_types, only: string, sp
1037  use dc_trace, only: dbgmessage
1038  use dc_error, only: storeerror, dc_noerr, &
1040  use dc_string, only: tochar
1041  implicit none
1042  type(gt_variable), intent(in):: var
1043  real(SP), pointer :: value(:,:,:,:,:,:,:) !(out)
1044  real(SP), allocatable :: array1dim_tmp(:)
1045  logical, intent(out), optional :: err
1046  integer :: stat, n(7), cause_i, data_rank
1047  logical :: invalid_check(7)
1048  character(STRING) :: cause_c
1049  character(*), parameter :: subname = 'GTVarGetPointerReal7'
1050  continue
1051  cause_i = 0
1052  cause_c = ''
1053  n(7) = -1
1054  stat = dc_noerr
1055  call map_set_rank(var, 7, stat)
1056  if (stat /= dc_noerr) goto 999
1057  call get_slice(var, dimord=1, count=n(1), count_compact=.false.)
1058  call get_slice(var, dimord=2, count=n(2), count_compact=.false.)
1059  call get_slice(var, dimord=3, count=n(3), count_compact=.false.)
1060  call get_slice(var, dimord=4, count=n(4), count_compact=.false.)
1061  call get_slice(var, dimord=5, count=n(5), count_compact=.false.)
1062  call get_slice(var, dimord=6, count=n(6), count_compact=.false.)
1063  call get_slice(var, dimord=7, count=n(7), count_compact=.false.)
1064  call dbgmessage('n(:)=%*d', i=n, n=(/size(n)/))
1065  invalid_check = n > 0
1066  if (.not. all(invalid_check)) then
1067  stat = gt_erankmismatch
1068  data_rank = count(invalid_check)
1069  cause_c = trim(tochar(data_rank)) // ' and 7'
1070  goto 999
1071  end if
1072  ! value が allocate されていなければ allocate する.
1073  ! value が既に allocate されていてサイズが取得するデータと同じで
1074  ! あればそのまま取得.
1075  ! value が allocate されていてサイズが異なる場合はエラー.
1076  if ( associated(value) ) then
1077  if ( &
1078  & .not. size(value,1) == n(1) .or. &
1079  & .not. size(value,2) == n(2) .or. &
1080  & .not. size(value,3) == n(3) .or. &
1081  & .not. size(value,4) == n(4) .or. &
1082  & .not. size(value,5) == n(5) .or. &
1083  & .not. size(value,6) == n(6) .or. &
1084  & .not. size(value,7) == n(7) .or. &
1085  & .false. ) then
1086  stat = gt_ebadallocatesize
1087  if (stat /= dc_noerr) goto 999
1088  else
1089  call dbgmessage('@ value is already allocated')
1090  endif
1091  else
1092  call dbgmessage('@ allocate value')
1093  allocate( value(&
1094  & n(1), &
1095  & n(2), &
1096  & n(3), &
1097  & n(4), &
1098  & n(5), &
1099  & n(6), &
1100  & n(7)) &
1101  & )
1102  endif
1103  if (allocated(array1dim_tmp)) then
1104  deallocate(array1dim_tmp)
1105  end if
1106  allocate(array1dim_tmp(product(n)))
1107  call gtvargetreal(var, array1dim_tmp, product(n), err)
1108  ! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
1109  value = reshape(array1dim_tmp, n)
1110 999 continue
1111  call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
1112 end subroutine gtvargetpointerreal7
1113 
1114 subroutine gtvargetpointerint1(var, value, err)
1118  use gtdata_netcdf_generic, only: get
1120  use dc_types, only: string
1121  use dc_trace, only: dbgmessage
1122  use dc_error, only: storeerror, dc_noerr, &
1124  use dc_string, only: tochar
1125  implicit none
1126  type(gt_variable), intent(in):: var
1127  integer, pointer :: value(:) !(out)
1128  integer, allocatable :: array1dim_tmp(:)
1129  logical, intent(out), optional :: err
1130  integer :: stat, n(1), cause_i, data_rank
1131  logical :: invalid_check(1)
1132  character(STRING) :: cause_c
1133  character(*), parameter :: subname = 'GTVarGetPointerInt1'
1134  continue
1135  cause_i = 0
1136  cause_c = ''
1137  n(1) = -1
1138  stat = dc_noerr
1139  call map_set_rank(var, 1, stat)
1140  if (stat /= dc_noerr) goto 999
1141  call get_slice(var, dimord=1, count=n(1), count_compact=.false.)
1142  if (n(1) < 0) then
1143  ! count_compact ではないので、ゼロ次元化していると n = -1 となる
1144  n(1) = 1
1145  endif
1146  call dbgmessage('n(:)=%*d', i=n, n=(/size(n)/))
1147  invalid_check = n > 0
1148  if (.not. all(invalid_check)) then
1149  stat = gt_erankmismatch
1150  data_rank = count(invalid_check)
1151  cause_c = trim(tochar(data_rank)) // ' and 1'
1152  goto 999
1153  end if
1154  ! value が allocate されていなければ allocate する.
1155  ! value が既に allocate されていてサイズが取得するデータと同じで
1156  ! あればそのまま取得.
1157  ! value が allocate されていてサイズが異なる場合はエラー.
1158  if ( associated(value) ) then
1159  if ( &
1160  & .not. size(value,1) == n(1) .or. &
1161  & .false. ) then
1162  stat = gt_ebadallocatesize
1163  if (stat /= dc_noerr) goto 999
1164  else
1165  call dbgmessage('@ value is already allocated')
1166  endif
1167  else
1168  call dbgmessage('@ allocate value')
1169  allocate( value(&
1170  & n(1)) &
1171  & )
1172  endif
1173  if (allocated(array1dim_tmp)) then
1174  deallocate(array1dim_tmp)
1175  end if
1176  allocate(array1dim_tmp(product(n)))
1177  call gtvargetint(var, array1dim_tmp, product(n), err)
1178  ! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
1179  value = array1dim_tmp
1180 999 continue
1181  call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
1182 end subroutine gtvargetpointerint1
1183 
1184 subroutine gtvargetpointerint2(var, value, err)
1188  use gtdata_netcdf_generic, only: get
1190  use dc_types, only: string
1191  use dc_trace, only: dbgmessage
1192  use dc_error, only: storeerror, dc_noerr, &
1194  use dc_string, only: tochar
1195  implicit none
1196  type(gt_variable), intent(in):: var
1197  integer, pointer :: value(:,:) !(out)
1198  integer, allocatable :: array1dim_tmp(:)
1199  logical, intent(out), optional :: err
1200  integer :: stat, n(2), cause_i, data_rank
1201  logical :: invalid_check(2)
1202  character(STRING) :: cause_c
1203  character(*), parameter :: subname = 'GTVarGetPointerInt2'
1204  continue
1205  cause_i = 0
1206  cause_c = ''
1207  n(2) = -1
1208  stat = dc_noerr
1209  call map_set_rank(var, 2, stat)
1210  if (stat /= dc_noerr) goto 999
1211  call get_slice(var, dimord=1, count=n(1), count_compact=.false.)
1212  call get_slice(var, dimord=2, count=n(2), count_compact=.false.)
1213  call dbgmessage('n(:)=%*d', i=n, n=(/size(n)/))
1214  invalid_check = n > 0
1215  if (.not. all(invalid_check)) then
1216  stat = gt_erankmismatch
1217  data_rank = count(invalid_check)
1218  cause_c = trim(tochar(data_rank)) // ' and 2'
1219  goto 999
1220  end if
1221  ! value が allocate されていなければ allocate する.
1222  ! value が既に allocate されていてサイズが取得するデータと同じで
1223  ! あればそのまま取得.
1224  ! value が allocate されていてサイズが異なる場合はエラー.
1225  if ( associated(value) ) then
1226  if ( &
1227  & .not. size(value,1) == n(1) .or. &
1228  & .not. size(value,2) == n(2) .or. &
1229  & .false. ) then
1230  stat = gt_ebadallocatesize
1231  if (stat /= dc_noerr) goto 999
1232  else
1233  call dbgmessage('@ value is already allocated')
1234  endif
1235  else
1236  call dbgmessage('@ allocate value')
1237  allocate( value(&
1238  & n(1), &
1239  & n(2)) &
1240  & )
1241  endif
1242  if (allocated(array1dim_tmp)) then
1243  deallocate(array1dim_tmp)
1244  end if
1245  allocate(array1dim_tmp(product(n)))
1246  call gtvargetint(var, array1dim_tmp, product(n), err)
1247  ! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
1248  value = reshape(array1dim_tmp, n)
1249 999 continue
1250  call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
1251 end subroutine gtvargetpointerint2
1252 
1253 subroutine gtvargetpointerint3(var, value, err)
1257  use gtdata_netcdf_generic, only: get
1259  use dc_types, only: string
1260  use dc_trace, only: dbgmessage
1261  use dc_error, only: storeerror, dc_noerr, &
1263  use dc_string, only: tochar
1264  implicit none
1265  type(gt_variable), intent(in):: var
1266  integer, pointer :: value(:,:,:) !(out)
1267  integer, allocatable :: array1dim_tmp(:)
1268  logical, intent(out), optional :: err
1269  integer :: stat, n(3), cause_i, data_rank
1270  logical :: invalid_check(3)
1271  character(STRING) :: cause_c
1272  character(*), parameter :: subname = 'GTVarGetPointerInt3'
1273  continue
1274  cause_i = 0
1275  cause_c = ''
1276  n(3) = -1
1277  stat = dc_noerr
1278  call map_set_rank(var, 3, stat)
1279  if (stat /= dc_noerr) goto 999
1280  call get_slice(var, dimord=1, count=n(1), count_compact=.false.)
1281  call get_slice(var, dimord=2, count=n(2), count_compact=.false.)
1282  call get_slice(var, dimord=3, count=n(3), count_compact=.false.)
1283  call dbgmessage('n(:)=%*d', i=n, n=(/size(n)/))
1284  invalid_check = n > 0
1285  if (.not. all(invalid_check)) then
1286  stat = gt_erankmismatch
1287  data_rank = count(invalid_check)
1288  cause_c = trim(tochar(data_rank)) // ' and 3'
1289  goto 999
1290  end if
1291  ! value が allocate されていなければ allocate する.
1292  ! value が既に allocate されていてサイズが取得するデータと同じで
1293  ! あればそのまま取得.
1294  ! value が allocate されていてサイズが異なる場合はエラー.
1295  if ( associated(value) ) then
1296  if ( &
1297  & .not. size(value,1) == n(1) .or. &
1298  & .not. size(value,2) == n(2) .or. &
1299  & .not. size(value,3) == n(3) .or. &
1300  & .false. ) then
1301  stat = gt_ebadallocatesize
1302  if (stat /= dc_noerr) goto 999
1303  else
1304  call dbgmessage('@ value is already allocated')
1305  endif
1306  else
1307  call dbgmessage('@ allocate value')
1308  allocate( value(&
1309  & n(1), &
1310  & n(2), &
1311  & n(3)) &
1312  & )
1313  endif
1314  if (allocated(array1dim_tmp)) then
1315  deallocate(array1dim_tmp)
1316  end if
1317  allocate(array1dim_tmp(product(n)))
1318  call gtvargetint(var, array1dim_tmp, product(n), err)
1319  ! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
1320  value = reshape(array1dim_tmp, n)
1321 999 continue
1322  call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
1323 end subroutine gtvargetpointerint3
1324 
1325 subroutine gtvargetpointerint4(var, value, err)
1329  use gtdata_netcdf_generic, only: get
1331  use dc_types, only: string
1332  use dc_trace, only: dbgmessage
1333  use dc_error, only: storeerror, dc_noerr, &
1335  use dc_string, only: tochar
1336  implicit none
1337  type(gt_variable), intent(in):: var
1338  integer, pointer :: value(:,:,:,:) !(out)
1339  integer, allocatable :: array1dim_tmp(:)
1340  logical, intent(out), optional :: err
1341  integer :: stat, n(4), cause_i, data_rank
1342  logical :: invalid_check(4)
1343  character(STRING) :: cause_c
1344  character(*), parameter :: subname = 'GTVarGetPointerInt4'
1345  continue
1346  cause_i = 0
1347  cause_c = ''
1348  n(4) = -1
1349  stat = dc_noerr
1350  call map_set_rank(var, 4, stat)
1351  if (stat /= dc_noerr) goto 999
1352  call get_slice(var, dimord=1, count=n(1), count_compact=.false.)
1353  call get_slice(var, dimord=2, count=n(2), count_compact=.false.)
1354  call get_slice(var, dimord=3, count=n(3), count_compact=.false.)
1355  call get_slice(var, dimord=4, count=n(4), count_compact=.false.)
1356  call dbgmessage('n(:)=%*d', i=n, n=(/size(n)/))
1357  invalid_check = n > 0
1358  if (.not. all(invalid_check)) then
1359  stat = gt_erankmismatch
1360  data_rank = count(invalid_check)
1361  cause_c = trim(tochar(data_rank)) // ' and 4'
1362  goto 999
1363  end if
1364  ! value が allocate されていなければ allocate する.
1365  ! value が既に allocate されていてサイズが取得するデータと同じで
1366  ! あればそのまま取得.
1367  ! value が allocate されていてサイズが異なる場合はエラー.
1368  if ( associated(value) ) then
1369  if ( &
1370  & .not. size(value,1) == n(1) .or. &
1371  & .not. size(value,2) == n(2) .or. &
1372  & .not. size(value,3) == n(3) .or. &
1373  & .not. size(value,4) == n(4) .or. &
1374  & .false. ) then
1375  stat = gt_ebadallocatesize
1376  if (stat /= dc_noerr) goto 999
1377  else
1378  call dbgmessage('@ value is already allocated')
1379  endif
1380  else
1381  call dbgmessage('@ allocate value')
1382  allocate( value(&
1383  & n(1), &
1384  & n(2), &
1385  & n(3), &
1386  & n(4)) &
1387  & )
1388  endif
1389  if (allocated(array1dim_tmp)) then
1390  deallocate(array1dim_tmp)
1391  end if
1392  allocate(array1dim_tmp(product(n)))
1393  call gtvargetint(var, array1dim_tmp, product(n), err)
1394  ! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
1395  value = reshape(array1dim_tmp, n)
1396 999 continue
1397  call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
1398 end subroutine gtvargetpointerint4
1399 
1400 subroutine gtvargetpointerint5(var, value, err)
1404  use gtdata_netcdf_generic, only: get
1406  use dc_types, only: string
1407  use dc_trace, only: dbgmessage
1408  use dc_error, only: storeerror, dc_noerr, &
1410  use dc_string, only: tochar
1411  implicit none
1412  type(gt_variable), intent(in):: var
1413  integer, pointer :: value(:,:,:,:,:) !(out)
1414  integer, allocatable :: array1dim_tmp(:)
1415  logical, intent(out), optional :: err
1416  integer :: stat, n(5), cause_i, data_rank
1417  logical :: invalid_check(5)
1418  character(STRING) :: cause_c
1419  character(*), parameter :: subname = 'GTVarGetPointerInt5'
1420  continue
1421  cause_i = 0
1422  cause_c = ''
1423  n(5) = -1
1424  stat = dc_noerr
1425  call map_set_rank(var, 5, stat)
1426  if (stat /= dc_noerr) goto 999
1427  call get_slice(var, dimord=1, count=n(1), count_compact=.false.)
1428  call get_slice(var, dimord=2, count=n(2), count_compact=.false.)
1429  call get_slice(var, dimord=3, count=n(3), count_compact=.false.)
1430  call get_slice(var, dimord=4, count=n(4), count_compact=.false.)
1431  call get_slice(var, dimord=5, count=n(5), count_compact=.false.)
1432  call dbgmessage('n(:)=%*d', i=n, n=(/size(n)/))
1433  invalid_check = n > 0
1434  if (.not. all(invalid_check)) then
1435  stat = gt_erankmismatch
1436  data_rank = count(invalid_check)
1437  cause_c = trim(tochar(data_rank)) // ' and 5'
1438  goto 999
1439  end if
1440  ! value が allocate されていなければ allocate する.
1441  ! value が既に allocate されていてサイズが取得するデータと同じで
1442  ! あればそのまま取得.
1443  ! value が allocate されていてサイズが異なる場合はエラー.
1444  if ( associated(value) ) then
1445  if ( &
1446  & .not. size(value,1) == n(1) .or. &
1447  & .not. size(value,2) == n(2) .or. &
1448  & .not. size(value,3) == n(3) .or. &
1449  & .not. size(value,4) == n(4) .or. &
1450  & .not. size(value,5) == n(5) .or. &
1451  & .false. ) then
1452  stat = gt_ebadallocatesize
1453  if (stat /= dc_noerr) goto 999
1454  else
1455  call dbgmessage('@ value is already allocated')
1456  endif
1457  else
1458  call dbgmessage('@ allocate value')
1459  allocate( value(&
1460  & n(1), &
1461  & n(2), &
1462  & n(3), &
1463  & n(4), &
1464  & n(5)) &
1465  & )
1466  endif
1467  if (allocated(array1dim_tmp)) then
1468  deallocate(array1dim_tmp)
1469  end if
1470  allocate(array1dim_tmp(product(n)))
1471  call gtvargetint(var, array1dim_tmp, product(n), err)
1472  ! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
1473  value = reshape(array1dim_tmp, n)
1474 999 continue
1475  call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
1476 end subroutine gtvargetpointerint5
1477 
1478 subroutine gtvargetpointerint6(var, value, err)
1482  use gtdata_netcdf_generic, only: get
1484  use dc_types, only: string
1485  use dc_trace, only: dbgmessage
1486  use dc_error, only: storeerror, dc_noerr, &
1488  use dc_string, only: tochar
1489  implicit none
1490  type(gt_variable), intent(in):: var
1491  integer, pointer :: value(:,:,:,:,:,:) !(out)
1492  integer, allocatable :: array1dim_tmp(:)
1493  logical, intent(out), optional :: err
1494  integer :: stat, n(6), cause_i, data_rank
1495  logical :: invalid_check(6)
1496  character(STRING) :: cause_c
1497  character(*), parameter :: subname = 'GTVarGetPointerInt6'
1498  continue
1499  cause_i = 0
1500  cause_c = ''
1501  n(6) = -1
1502  stat = dc_noerr
1503  call map_set_rank(var, 6, stat)
1504  if (stat /= dc_noerr) goto 999
1505  call get_slice(var, dimord=1, count=n(1), count_compact=.false.)
1506  call get_slice(var, dimord=2, count=n(2), count_compact=.false.)
1507  call get_slice(var, dimord=3, count=n(3), count_compact=.false.)
1508  call get_slice(var, dimord=4, count=n(4), count_compact=.false.)
1509  call get_slice(var, dimord=5, count=n(5), count_compact=.false.)
1510  call get_slice(var, dimord=6, count=n(6), count_compact=.false.)
1511  call dbgmessage('n(:)=%*d', i=n, n=(/size(n)/))
1512  invalid_check = n > 0
1513  if (.not. all(invalid_check)) then
1514  stat = gt_erankmismatch
1515  data_rank = count(invalid_check)
1516  cause_c = trim(tochar(data_rank)) // ' and 6'
1517  goto 999
1518  end if
1519  ! value が allocate されていなければ allocate する.
1520  ! value が既に allocate されていてサイズが取得するデータと同じで
1521  ! あればそのまま取得.
1522  ! value が allocate されていてサイズが異なる場合はエラー.
1523  if ( associated(value) ) then
1524  if ( &
1525  & .not. size(value,1) == n(1) .or. &
1526  & .not. size(value,2) == n(2) .or. &
1527  & .not. size(value,3) == n(3) .or. &
1528  & .not. size(value,4) == n(4) .or. &
1529  & .not. size(value,5) == n(5) .or. &
1530  & .not. size(value,6) == n(6) .or. &
1531  & .false. ) then
1532  stat = gt_ebadallocatesize
1533  if (stat /= dc_noerr) goto 999
1534  else
1535  call dbgmessage('@ value is already allocated')
1536  endif
1537  else
1538  call dbgmessage('@ allocate value')
1539  allocate( value(&
1540  & n(1), &
1541  & n(2), &
1542  & n(3), &
1543  & n(4), &
1544  & n(5), &
1545  & n(6)) &
1546  & )
1547  endif
1548  if (allocated(array1dim_tmp)) then
1549  deallocate(array1dim_tmp)
1550  end if
1551  allocate(array1dim_tmp(product(n)))
1552  call gtvargetint(var, array1dim_tmp, product(n), err)
1553  ! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
1554  value = reshape(array1dim_tmp, n)
1555 999 continue
1556  call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
1557 end subroutine gtvargetpointerint6
1558 
1559 subroutine gtvargetpointerint7(var, value, err)
1563  use gtdata_netcdf_generic, only: get
1565  use dc_types, only: string
1566  use dc_trace, only: dbgmessage
1567  use dc_error, only: storeerror, dc_noerr, &
1569  use dc_string, only: tochar
1570  implicit none
1571  type(gt_variable), intent(in):: var
1572  integer, pointer :: value(:,:,:,:,:,:,:) !(out)
1573  integer, allocatable :: array1dim_tmp(:)
1574  logical, intent(out), optional :: err
1575  integer :: stat, n(7), cause_i, data_rank
1576  logical :: invalid_check(7)
1577  character(STRING) :: cause_c
1578  character(*), parameter :: subname = 'GTVarGetPointerInt7'
1579  continue
1580  cause_i = 0
1581  cause_c = ''
1582  n(7) = -1
1583  stat = dc_noerr
1584  call map_set_rank(var, 7, stat)
1585  if (stat /= dc_noerr) goto 999
1586  call get_slice(var, dimord=1, count=n(1), count_compact=.false.)
1587  call get_slice(var, dimord=2, count=n(2), count_compact=.false.)
1588  call get_slice(var, dimord=3, count=n(3), count_compact=.false.)
1589  call get_slice(var, dimord=4, count=n(4), count_compact=.false.)
1590  call get_slice(var, dimord=5, count=n(5), count_compact=.false.)
1591  call get_slice(var, dimord=6, count=n(6), count_compact=.false.)
1592  call get_slice(var, dimord=7, count=n(7), count_compact=.false.)
1593  call dbgmessage('n(:)=%*d', i=n, n=(/size(n)/))
1594  invalid_check = n > 0
1595  if (.not. all(invalid_check)) then
1596  stat = gt_erankmismatch
1597  data_rank = count(invalid_check)
1598  cause_c = trim(tochar(data_rank)) // ' and 7'
1599  goto 999
1600  end if
1601  ! value が allocate されていなければ allocate する.
1602  ! value が既に allocate されていてサイズが取得するデータと同じで
1603  ! あればそのまま取得.
1604  ! value が allocate されていてサイズが異なる場合はエラー.
1605  if ( associated(value) ) then
1606  if ( &
1607  & .not. size(value,1) == n(1) .or. &
1608  & .not. size(value,2) == n(2) .or. &
1609  & .not. size(value,3) == n(3) .or. &
1610  & .not. size(value,4) == n(4) .or. &
1611  & .not. size(value,5) == n(5) .or. &
1612  & .not. size(value,6) == n(6) .or. &
1613  & .not. size(value,7) == n(7) .or. &
1614  & .false. ) then
1615  stat = gt_ebadallocatesize
1616  if (stat /= dc_noerr) goto 999
1617  else
1618  call dbgmessage('@ value is already allocated')
1619  endif
1620  else
1621  call dbgmessage('@ allocate value')
1622  allocate( value(&
1623  & n(1), &
1624  & n(2), &
1625  & n(3), &
1626  & n(4), &
1627  & n(5), &
1628  & n(6), &
1629  & n(7)) &
1630  & )
1631  endif
1632  if (allocated(array1dim_tmp)) then
1633  deallocate(array1dim_tmp)
1634  end if
1635  allocate(array1dim_tmp(product(n)))
1636  call gtvargetint(var, array1dim_tmp, product(n), err)
1637  ! call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))
1638  value = reshape(array1dim_tmp, n)
1639 999 continue
1640  call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
1641 end subroutine gtvargetpointerint7
1642 
subroutine gtvargetpointerdouble1(var, value, err)
subroutine gtvargetpointerdouble3(var, value, err)
subroutine gtvargetpointerdouble7(var, value, err)
integer, parameter, public gt_erankmismatch
Definition: dc_error.f90:545
subroutine gtvargetpointerint2(var, value, err)
subroutine gtvargetpointerreal7(var, value, err)
subroutine, public storeerror(number, where, err, cause_c, cause_i)
Definition: dc_error.f90:830
integer, parameter, public dc_noerr
Definition: dc_error.f90:509
subroutine gtvargetdouble(var, value, nvalue, err)
Definition: gtvargetnum.f90:42
subroutine gtvargetpointerreal5(var, value, err)
subroutine gtvargetpointerint3(var, value, err)
subroutine gtvargetpointerreal1(var, value, err)
subroutine map_set_rank(var, rank, stat)
integer, parameter, public dp
倍精度実数型変数
Definition: dc_types.f90:83
subroutine gtvargetpointerreal3(var, value, err)
subroutine gtvargetint(var, value, nvalue, err)
subroutine, public dbgmessage(fmt, i, r, d, L, n, c1, c2, c3, ca)
Definition: dc_trace.f90:509
subroutine gtvargetpointerint6(var, value, err)
subroutine gtvargetpointerreal2(var, value, err)
integer, parameter, public gt_ebadallocatesize
Definition: dc_error.f90:544
subroutine gtvargetpointerint5(var, value, err)
文字型変数の操作.
Definition: dc_string.f90:24
種別型パラメタを提供します。
Definition: dc_types.f90:49
subroutine gtvargetpointerint7(var, value, err)
subroutine gtvargetpointerdouble5(var, value, err)
integer, parameter, public sp
単精度実数型変数
Definition: dc_types.f90:73
subroutine gtvargetpointerdouble2(var, value, err)
subroutine gtvargetpointerdouble6(var, value, err)
subroutine gtvargetpointerreal6(var, value, err)
subroutine gtvargetpointerdouble4(var, value, err)
subroutine gtvargetpointerint1(var, value, err)
integer, parameter, public gt_enomoredims
Definition: dc_error.f90:528
subroutine gtvargetpointerreal4(var, value, err)
subroutine gtvargetreal(var, value, nvalue, err)
Definition: gtvargetnum.f90:85
subroutine gtvargetpointerint4(var, value, err)
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118