Loading...
Searching...
No Matches
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
56subroutine gtvargetpointerdouble1(var, value, err)
57 use gtdata_types, only: gt_variable
58 use gtdata_generic, only: get_slice, gtvargetdouble
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
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
122999 continue
123 call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
124end subroutine gtvargetpointerdouble1
125
126subroutine gtvargetpointerdouble2(var, value, err)
127 use gtdata_types, only: gt_variable
128 use gtdata_generic, only: get_slice, gtvargetdouble
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
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)
191999 continue
192 call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
193end subroutine gtvargetpointerdouble2
194
195subroutine gtvargetpointerdouble3(var, value, err)
196 use gtdata_types, only: gt_variable
197 use gtdata_generic, only: get_slice, gtvargetdouble
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
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)
263999 continue
264 call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
265end subroutine gtvargetpointerdouble3
266
267subroutine gtvargetpointerdouble4(var, value, err)
268 use gtdata_types, only: gt_variable
269 use gtdata_generic, only: get_slice, gtvargetdouble
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
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)
338999 continue
339 call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
340end subroutine gtvargetpointerdouble4
341
342subroutine gtvargetpointerdouble5(var, value, err)
343 use gtdata_types, only: gt_variable
344 use gtdata_generic, only: get_slice, gtvargetdouble
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
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)
416999 continue
417 call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
418end subroutine gtvargetpointerdouble5
419
420subroutine gtvargetpointerdouble6(var, value, err)
421 use gtdata_types, only: gt_variable
422 use gtdata_generic, only: get_slice, gtvargetdouble
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
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)
497999 continue
498 call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
499end subroutine gtvargetpointerdouble6
500
501subroutine gtvargetpointerdouble7(var, value, err)
502 use gtdata_types, only: gt_variable
503 use gtdata_generic, only: get_slice, gtvargetdouble
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
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)
581999 continue
582 call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
583end subroutine gtvargetpointerdouble7
584
585subroutine gtvargetpointerreal1(var, value, err)
586 use gtdata_types, only: gt_variable
587 use gtdata_generic, only: get_slice, gtvargetreal
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
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
651999 continue
652 call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
653end subroutine gtvargetpointerreal1
654
655subroutine gtvargetpointerreal2(var, value, err)
656 use gtdata_types, only: gt_variable
657 use gtdata_generic, only: get_slice, gtvargetreal
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
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)
720999 continue
721 call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
722end subroutine gtvargetpointerreal2
723
724subroutine gtvargetpointerreal3(var, value, err)
725 use gtdata_types, only: gt_variable
726 use gtdata_generic, only: get_slice, gtvargetreal
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
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)
792999 continue
793 call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
794end subroutine gtvargetpointerreal3
795
796subroutine gtvargetpointerreal4(var, value, err)
797 use gtdata_types, only: gt_variable
798 use gtdata_generic, only: get_slice, gtvargetreal
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
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)
867999 continue
868 call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
869end subroutine gtvargetpointerreal4
870
871subroutine gtvargetpointerreal5(var, value, err)
872 use gtdata_types, only: gt_variable
873 use gtdata_generic, only: get_slice, gtvargetreal
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
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)
945999 continue
946 call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
947end subroutine gtvargetpointerreal5
948
949subroutine gtvargetpointerreal6(var, value, err)
950 use gtdata_types, only: gt_variable
951 use gtdata_generic, only: get_slice, gtvargetreal
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)
1026999 continue
1027 call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
1028end subroutine gtvargetpointerreal6
1029
1030subroutine gtvargetpointerreal7(var, value, err)
1031 use gtdata_types, only: gt_variable
1032 use gtdata_generic, only: get_slice, gtvargetreal
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)
1110999 continue
1111 call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
1112end subroutine gtvargetpointerreal7
1113
1114subroutine gtvargetpointerint1(var, value, err)
1115 use gtdata_types, only: gt_variable
1116 use gtdata_generic, only: get_slice, gtvargetint
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
1180999 continue
1181 call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
1182end subroutine gtvargetpointerint1
1183
1184subroutine gtvargetpointerint2(var, value, err)
1185 use gtdata_types, only: gt_variable
1186 use gtdata_generic, only: get_slice, gtvargetint
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)
1249999 continue
1250 call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
1251end subroutine gtvargetpointerint2
1252
1253subroutine gtvargetpointerint3(var, value, err)
1254 use gtdata_types, only: gt_variable
1255 use gtdata_generic, only: get_slice, gtvargetint
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)
1321999 continue
1322 call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
1323end subroutine gtvargetpointerint3
1324
1325subroutine gtvargetpointerint4(var, value, err)
1326 use gtdata_types, only: gt_variable
1327 use gtdata_generic, only: get_slice, gtvargetint
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)
1396999 continue
1397 call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
1398end subroutine gtvargetpointerint4
1399
1400subroutine gtvargetpointerint5(var, value, err)
1401 use gtdata_types, only: gt_variable
1402 use gtdata_generic, only: get_slice, gtvargetint
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)
1474999 continue
1475 call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
1476end subroutine gtvargetpointerint5
1477
1478subroutine gtvargetpointerint6(var, value, err)
1479 use gtdata_types, only: gt_variable
1480 use gtdata_generic, only: get_slice, gtvargetint
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)
1555999 continue
1556 call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
1557end subroutine gtvargetpointerint6
1558
1559subroutine gtvargetpointerint7(var, value, err)
1560 use gtdata_types, only: gt_variable
1561 use gtdata_generic, only: get_slice, gtvargetint
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)
1639999 continue
1640 call storeerror(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
1641end subroutine gtvargetpointerint7
1642
subroutine gtvargetint(var, value, nvalue, err)
subroutine gtvargetdouble(var, value, nvalue, err)
subroutine gtvargetreal(var, value, nvalue, err)
subroutine gtvargetpointerreal6(var, value, err)
subroutine gtvargetpointerdouble3(var, value, err)
subroutine gtvargetpointerdouble5(var, value, err)
subroutine gtvargetpointerdouble2(var, value, err)
subroutine gtvargetpointerreal5(var, value, err)
subroutine gtvargetpointerint1(var, value, err)
subroutine gtvargetpointerdouble7(var, value, err)
subroutine gtvargetpointerint4(var, value, err)
subroutine gtvargetpointerreal3(var, value, err)
subroutine gtvargetpointerint3(var, value, err)
subroutine gtvargetpointerint6(var, value, err)
subroutine gtvargetpointerint2(var, value, err)
subroutine gtvargetpointerreal2(var, value, err)
subroutine gtvargetpointerdouble1(var, value, err)
subroutine gtvargetpointerint5(var, value, err)
subroutine gtvargetpointerint7(var, value, err)
subroutine gtvargetpointerdouble4(var, value, err)
subroutine gtvargetpointerreal4(var, value, err)
subroutine gtvargetpointerdouble6(var, value, err)
subroutine gtvargetpointerreal1(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
integer, parameter, public gt_erankmismatch
Definition dc_error.f90:545
integer, parameter, public gt_ebadallocatesize
Definition dc_error.f90:544
integer, parameter, public gt_enomoredims
Definition dc_error.f90:528
種別型パラメタを提供します。
Definition dc_types.f90:49
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition dc_types.f90:118
integer, parameter, public dp
倍精度実数型変数
Definition dc_types.f90:83
integer, parameter, public sp
単精度実数型変数
Definition dc_types.f90:73
subroutine map_set_rank(var, rank, stat)