#!/usr/bin/env ruby
# -*- f90 -*-
# vi: set sw=4 ts=8:
require("lib-rb2f90-macro")
require("optparse")
#
# "gtvargetpointernum.f90" Generator with Ruby.
#
opt = OptionParser.new
opt.on('--gtvarget_dim=VAL') {|v| $gtvarget_dim = v.to_i}
opt.parse!(ARGV)
$gtvarget_dim = 7 unless $gtvarget_dim
print <<"__EndOfFortran90Code__"
!--
#{rb2f90_header_comment}!
!++
!= ポインタ配列への数値データの入力
!
! Authors::   Yasuhiro MORIKAWA, Eizi TOYODA
! Version::   $Id: gtvargetpointernum.rb2f90,v 1.5 2009-05-25 09:55:58 morikawa Exp $
! Tag Name::  $Name: gtool5-20090729 $
! Copyright:: Copyright (C) GFD Dennou Club, 2000-2005. All rights reserved.
! License::   See COPYRIGHT[link:../../COPYRIGHT]
!
! 以下のサブルーチン、関数は gtdata_generic から gtdata_generic#Get
! として提供されます。

__EndOfFortran90Code__

types = ["Double", "Real", "Int"]
types.each{ |type|
for num in 1..$gtvarget_dim
print <<"__EndOfFortran90Code__"

subroutine GTVarGetPointer#{type}#{num}(var, value, err)
  !
                    #{ifelse(type, "Double", %Q{
                    #{ifelse(num, 1, %Q{
  !
  !== ポインタ配列への数値データの入力
  !
  ! 変数 *var* から *value* に数値データが入力されます。
  ! *value* はポインタ配列であり、数値データのサイズに合わせた
  ! 配列サイズが自動的に割り付けられます。
  ! *Get* は複数のサブルーチンの総称名であり、
  ! 1 〜 #{$gtvarget_dim} 次元のポインタを与えることが可能です。
  ! また *value* に固定長配列を与えることが可能な手続きもあります。
  ! 下記を参照してください。
  !
  ! *value* が既に割り付けられており、且つ入力する数値データと配列
  ! サイズが異なる場合、エラー (コード dc_error#GT_EBADALLOCATESIZE)
  ! を生じます。原則的には *value* を空状態にして与えることを
  ! 推奨します。不定状態で与えることは予期せぬ動作を招く可能性が
  ! あるため禁止します。
  !
  ! 数値データ入力や上記の割り付けの際にエラーが生じた場合、メッセージ
  ! を出力してプログラムは強制終了します。*err* を与えてある場合には
  ! の引数に .true. が返り、プログラムは終了しません。
  !
  ! 入力しようとするデータの型が引数の型と異なる場合、データは引数の
  ! 型に変換されます。 この変換は netCDF の機能を用いています。
  ! 詳しくは {netCDF 日本語版マニュアル}[link:../xref.htm#label-10]
  ! の 3.3 型変換 を参照してください。
  !
  !
  ! This subroutine returns multi-dimensional data to argument "value".
  ! You need to provide GT_VARIABLE variable to argument "var".
  ! If you provide logical argument "err", .true. is returned
  ! instead of abort with messages when error is occurred.
                    })}
                    })}
  !
  use gtdata_types,   only: GT_VARIABLE
  use gtdata_generic, only: Get_Slice, GTVarGetDouble, GTVarGetReal, GTVarGetInt
  use gtdata_internal_map,         only: map_set_rank
  use gtdata_netcdf_generic,     only: Get
  use gtdata_netcdf_types, only: GD_NC_VARIABLE
  use dc_types,       only: STRING, DP
  use dc_trace,       only: BeginSub, EndSub, DbgMessage
  use dc_error,       only: StoreError, DC_NOERR, GT_EBADALLOCATESIZE, &
    & GT_ENOMOREDIMS, GT_ERANKMISMATCH
  use dc_string,      only: toChar
  implicit none
  type(GT_VARIABLE), intent(in):: var
  #{$type_intent_out[type]}, pointer :: value#{array_colon("#{num}")} !(out)
  logical, intent(out), optional  :: err
  integer                         :: stat, n(#{num}), cause_i, data_rank
  logical                         :: invalid_check(#{num})
  #{$type_intent_out[type]}, allocatable :: array1dim_tmp(:)
  character(STRING)               :: cause_c
  character(*), parameter :: subname = 'GTVarGetPointer#{type}#{num}'
continue

  call BeginSub(subname, 'var.mapid=%d', i=(/var%mapid/))
  cause_i = 0
  cause_c = ''
  n(#{num}) = -1
  stat = DC_NOERR
  call map_set_rank(var, #{num}, stat)
  if (stat /= DC_NOERR) goto 999
                    #{forloop("\\$dimnum\\$", 1, num, %Q{
  call Get_Slice(var, dimord=$dimnum$, count=n($dimnum$), count_compact=.false.)
                    })}
                    #{ifelse(num, 1, %Q{
  if (n(1) < 0) then
    ! count_compact ではないので、ゼロ次元化していると n = -1 となる
    n(1) = 1
  endif
                    })}

  call DbgMessage('n(:)=%*d', i=n, n=(/size(n)/))

  invalid_check = n > 0
  if (.not. all(invalid_check)) then
    stat = GT_ERANKMISMATCH
    data_rank = count(invalid_check)
    cause_c = trim(toChar(data_rank)) // ' and #{num}'
    goto 999
  end if

  ! value が allocate されていなければ allocate する.
  ! value が既に allocate されていてサイズが取得するデータと同じで
  ! あればそのまま取得.
  ! value が allocate されていてサイズが異なる場合はエラー.
  !
  if ( associated(value) ) then
    if ( &
                    #{forloop("\\$dimnum\\$", 1, num, %Q{
      & .not. size(value,$dimnum$) == n($dimnum$) .or. &
                    })}
      & .false.                             ) then

      stat = GT_EBADALLOCATESIZE
      if (stat /= DC_NOERR) goto 999
    else
      call DbgMessage('@ value is already allocated')
    endif
  else
    call DbgMessage('@ allocate value')
    allocate( value (&
                    #{forloop("\\$dimnum\\$", 1, num-1, %Q{
      &    n($dimnum$), &
                    })}
      &    n(#{num})  )  &
      &  )
  endif

  if (allocated(array1dim_tmp)) then
    deallocate(array1dim_tmp)
  end if
  allocate(array1dim_tmp(product(n)))

  call GTVarGet#{type}(var, array1dim_tmp, product(n), err)
!    call DbgMessage('max=%f min=%f', d=(/maxval(value), minval(value)/))

                    #{ifelse(num, 1, %Q{
  value = array1dim_tmp
                    }, %Q{
  value = reshape(array1dim_tmp, n)
                    })}


999 continue
  call StoreError(stat, subname, err, cause_i=cause_i, cause_c=cause_c)
  call EndSub(subname, 'n=%d', i=(/n/))
end subroutine GTVarGetPointer#{type}#{num}

__EndOfFortran90Code__
end
}

print <<"__EndOfFooter__"
!--
! vi:set readonly sw=4 ts=8:
!
#{rb2f90_emacs_readonly}!
!++
__EndOfFooter__