gtvarcreate.f90

Go to the documentation of this file.

!> @file gtvarcreate.f90
!>
!> @author Yasuhiro MORIKAWA, Eizi TOYODA
!> @copyright Copyright (C) GFD Dennou Club, 2000-2026. All rights reserved. <br/>
!>            License is BSD-2-Clause. See [COPYRIGHT](@ref COPYRIGHT) in detail
!>
!> @en
!> @brief Create dependent variable
!>
!> This subroutine is provided through gtdata_generic.
!> @enden
!>
!> @ja
!> @brief 従属変数の作成
!>
!> このサブルーチンは gtdata_generic から提供されます。
!> @endja
!>
 
!>
!> @en
!> @brief Create variable with dimensions
!>
!> Creates a variable of GT_VARIABLE type with dimensions dims at
!> location url, and sets it to var. Like variables opened with Open,
!> var must later be closed with Close.
!>
!> If xtype is omitted, it defaults to "float".
!> Creation fails if the variable already exists, but continues by
!> overwriting if overwrite == .true..
!> (Note: overwrite behavior is not yet guaranteed.)
!> Omitting dims means setting a 0-dimensional variable.
!>
!> If an error occurs during creation, outputs a message and terminates.
!> If err is provided, returns .true. and program does not terminate.
!> @param[out] var       Variable handle
!> @param[in]  url       Variable URL
!> @param[in]  dims      Dimension variables (optional)
!> @param[in]  xtype     Data type (optional, default "float")
!> @param[in]  long_name Long name attribute (optional)
!> @param[in]  overwrite Allow overwrite (optional)
!> @param[out] err       Error flag (optional)
!> @enden
!>
!> @ja
!> @brief 次元を持つ変数を作成
!>
!> 場所 url に次元 dims を持った変数つまり GT_VARIABLE 型
!> の実体を作成し、それを第 1 引数 var にセットします。
!> Open されたものと同様、第1引数 var は後で必ず Close されなければなりません。
!>
!> 型 xtype を省略すると "float" とみなされます。
!> 既存変数があるとき失敗しますが、overwrite == .true. であれば
!> 上書きして続行します。(まだ overwrite の動作は保障されていません)。
!> dims の省略は 0 次元変数の設定を意味します。
!>
!> 作成の際にエラーが生じた場合、メッセージを出力してプログラムは
!> 強制終了します。err を与えてある場合にはこの引数に .true.
!> が返り、プログラムは終了しません。
!> @param[out] var       変数ハンドル
!> @param[in]  url       変数URL
!> @param[in]  dims      次元変数 (省略可能)
!> @param[in]  xtype     データ型 (省略可能、デフォルトは "float")
!> @param[in]  long_name 長い名前属性 (省略可能)
!> @param[in]  overwrite 上書き許可 (省略可能)
!> @param[out] err       エラーフラグ (省略可能)
!> @endja
!>
subroutine gtvarcreate(var, url, dims, xtype, long_name, overwrite, err)
  use gtdata_types, only: gt_variable
  use gtdata_internal_map, only: var_class, vtb_class_netcdf, &
    & map_create, gtvar_dump
  use gtdata_netcdf_generic, only: create, put_attr, inquire
  use gtdata_netcdf_types, only: gd_nc_variable
  use dc_string, only: strhead
  use dc_error, only: storeerror, dc_noerr
  use dc_types, only: token
  use dc_trace, only: beginsub, endsub, dbgmessage
  implicit none
  type(gt_variable), intent(out):: var
  character(len = *), intent(in):: url
  type(gt_variable), intent(in), optional:: dims(:)
  character(len = *), intent(in), optional:: xtype
  character(len = *), intent(in), optional:: long_name
  logical, intent(in), optional:: overwrite
  logical, intent(out), optional:: err
  type(gd_nc_variable), allocatable:: gdnc_dims(:)
  type(gd_nc_variable):: gdnc
  integer, allocatable:: allcount(:)
  integer:: i, ndims, stat, cause_i
  character(len = TOKEN):: myxtype
  character(len = *),      parameter:: subname = "GTVarCreate"
  character(len = *),      parameter:: version = &
    & '$Name:  $' // &
    & '$Id: gtvarcreate.f90,v 1.4 2009-05-25 09:55:58 morikawa Exp $'
continue
  stat = dc_noerr
  ndims = 0
  cause_i = 0
  if (present(dims)) ndims = size(dims)
  call beginsub(subname, 'url=%c ndims=%d', c1=trim(url), i=(/ndims/), &
    & version=version)
  ! gdnc 変数の作成
  if (present(err)) err = .false.
  if (present(xtype)) then
    myxtype = xtype
  else
    myxtype = "float"
  endif
  if (present(dims)) then
    allocate(gdnc_dims(ndims), allcount(ndims))
    do, i = 1, ndims
      call var_class(dims(i), cid=gdnc_dims(i)%id)
      call dbgmessage('dim=%d mapid=%d -> cid=%d', i=(/i, dims(i)%mapid, gdnc_dims(i)%id/))
      call inquire(gdnc_dims(i), dimlen=allcount(i))
    enddo
    call create(var=gdnc, url=url, dims=gdnc_dims, xtype=myxtype, &
      & overwrite=overwrite, err=err)
  else
    ndims = 0
    allocate(gdnc_dims(1), allcount(1)) ! dummy
    call create(var=gdnc, url=url, dims=gdnc_dims(1:0), &
      & xtype=myxtype, overwrite=overwrite, err=err)
  endif
  call map_create(var, vtb_class_netcdf, gdnc%id, ndims, allcount, stat)
  if (stat /= dc_noerr) then
    cause_i = ndims
    goto 999
  end if
  deallocate(gdnc_dims, allcount)
  if (present(long_name)) then
    call put_attr(gdnc, 'long_name', long_name, err=err)
  endif
  call gtvar_dump(var)
  call dbgmessage('var%%mapid=%d', i=(/var % mapid/))
999 continue
  call storeerror(stat, subname, err, cause_i=cause_i)
  call endsub(subname)
end subroutine gtvarcreate