gtdata_netcdf_internal.f90

Go to the documentation of this file.

 
 
module gtdata_netcdf_internal
  !
 
  use netcdf
  use gtdata_netcdf_types, only: &
    & gd_nc_variable, gd_nc_variable_entry, gd_nc_variable_search
  use dc_error
  use dc_trace, only: dbgmessage
  implicit none
  private
 
  type(GD_NC_VARIABLE_ENTRY), save, target, allocatable:: gdnctab(:)
  integer, parameter:: gdnctab_init_size = 16
 
  public:: vtable_add, vtable_delete, vtable_lookup, gd_nc_variable_entry
  public:: vtable_set_attrid
 
contains
 
  integer function vtable_add(var, entry) result(result)
    type(gd_nc_variable), intent(out):: var
    type(gd_nc_variable_search), intent(in):: entry
    type(gd_nc_variable_entry), allocatable:: tmp_table(:)
    integer:: i, n
 
    ! --- 必要なら初期確保 ---
    if (.not. allocated(gdnctab)) then
      allocate(gdnctab(gdnctab_init_size), stat=result)
      if (result /= 0) goto 999
      do, i = 1, gdnctab_init_size
        gdnctab(i)%fileid = 0
        gdnctab(i)%varid = 0
        gdnctab(i)%dimid = 0
        gdnctab(i)%attrid = 0
        nullify(gdnctab(i)%dimids)
      enddo
    endif
    ! --- 同じ内容が既登録ならばそれを返す (attrid は変更しない) ---
    do, i = 1, size(gdnctab)
      if (gdnctab(i)%fileid == entry%fileid &
        & .and. gdnctab(i)%varid == entry%varid &
        & .and. gdnctab(i)%dimid == entry%dimid) then
        var = gd_nc_variable(i)
        result = nf90_noerr
        call dbgmessage('gtdata_netcdf_internal.add: found %d', i=(/i/))
        return
      endif
    enddo
    !
    ! --- 空き地があればそこに割り当て ---
    var = gd_nc_variable(-1)
    do, i = 1, size(gdnctab)
      if (gdnctab(i)%fileid == 0) then
        var = gd_nc_variable(i)
        exit
      endif
    enddo
    if (var%id == -1) then
      ! --- 空き地はなかったのだから倍幅確保 ---
      n = size(gdnctab)
      allocate(tmp_table(n), stat=result)
      if (result /= 0) goto 999
      tmp_table(:) = gdnctab(:)
      deallocate(gdnctab, stat=result)
      if (result /= 0) goto 999
      allocate(gdnctab(n * 2), stat=result)
      if (result /= 0) goto 999
      gdnctab(1:n) = tmp_table(1:n)
      deallocate(tmp_table, stat=result)
      if (result /= 0) goto 999
      !
      gdnctab(n+2)%fileid = 0
      gdnctab(n+2)%varid = 0
      gdnctab(n+2)%dimid = 0
      gdnctab(n+2)%attrid = 0
      nullify(gdnctab(n+2)%dimids)
      gdnctab(n+3: n*2) = gdnctab(n+2)
      ! 確保域の先頭を使用
      var = gd_nc_variable(n + 1)
    endif
    gdnctab(var%id)%fileid = entry%fileid
    gdnctab(var%id)%varid = entry%varid
    gdnctab(var%id)%dimid = entry%dimid
    !
    ! --- 次元表の確保 ---
    call internal_build_dimids(gdnctab(var%id), result)
    if (result /= nf90_noerr) goto 999
    !
    result = nf90_noerr
    call dbgmessage('gtdata_netcdf_internal.add: added %d', i=(/var%id/))
    return
    !
999 continue
    var = gd_nc_variable(-1)
    result = nf90_enomem
    return
 
  contains
 
    subroutine internal_build_dimids(ent, stat)
!!      use netcdf, only: &
!!        & NF90_NOERR, NF90_ENOMEM, NF90_INQUIRE_VARIABLE
      type(gd_nc_variable_entry), intent(inout):: ent
      integer, intent(out):: stat
      integer:: ndims
      if (ent%varid > 0) then
        stat = nf90_inquire_variable(ent%fileid, ent%varid, ndims = ndims)
        if (stat /= nf90_noerr) return
        if ((ent%dimid > 0) .and. (ndims /= 1)) goto 100
        if (ndims == 0) then
          nullify(ent%dimids)
          stat = nf90_noerr
          return
        endif
        allocate(ent%dimids(ndims), stat=stat)
        if (stat /= 0) then
          stat = nf90_enomem
          return
        endif
        stat = nf90_inquire_variable(ent%fileid, ent%varid, dimids = ent%dimids)
        if (stat /= nf90_noerr) return
        if ((ent%dimid > 0) .and. (ent%dimids(1) /= ent%dimid)) then
          deallocate(ent%dimids)
          goto 100
        endif
      else
        allocate(ent%dimids(1), stat=stat)
        if (stat /= 0) then
          stat = nf90_enomem
          return
        endif
        ent%dimids(1) = ent%dimid
      endif
      stat = nf90_noerr
      return
 
100   continue
      ent%varid = 0
      allocate(ent%dimids(1))
      ent%dimids(1) = ent%dimid
    end subroutine internal_build_dimids
 
  end function vtable_add
 
  integer function vtable_delete(var) result(result)
    type(gd_nc_variable), intent(in):: var
    if (.not. allocated(gdnctab)) goto 999
    if (var%id <= 0 .or. var%id > size(gdnctab)) goto 999
    if (gdnctab(var%id)%fileid == 0) goto 999
    result = gdnctab(var%id)%fileid
    gdnctab(var%id)%fileid = 0
    gdnctab(var%id)%varid = 0
    gdnctab(var%id)%dimid = 0
    gdnctab(var%id)%attrid = 0
    if (associated(gdnctab(var%id)%dimids)) &
      & deallocate(gdnctab(var%id)%dimids)
    call dbgmessage('gtdata_netcdf_internal.delete: delete %d', i=(/var%id/))
    return
    !
999 continue
    result = nf90_enotvar
  end function vtable_delete
 
  integer function vtable_lookup(var, entry) result(result)
    type(gd_nc_variable), intent(in):: var
    type(gd_nc_variable_entry), intent(out):: entry
    if (.not. allocated(gdnctab)) goto 999
    if (var%id <= 0 .or. var%id > size(gdnctab)) goto 999
    if (gdnctab(var%id)%fileid == 0) goto 999
    entry = gdnctab(var%id)
    result = nf90_noerr
    return
    !
999 continue
    nullify(entry%dimids)
    entry%fileid = -1
    entry%varid = -1
    entry%dimid = -1
    entry%attrid = -1
    result = nf90_enotvar
  end function vtable_lookup
 
  integer function vtable_set_attrid(var, attrid) result(result)
    type(gd_nc_variable), intent(in):: var
    integer, intent(in):: attrid
    continue
    if (.not. allocated(gdnctab)) goto 999
    if (var%id <= 0 .or. var%id > size(gdnctab)) goto 999
    if (gdnctab(var%id)%fileid == 0) goto 999
    gdnctab(var%id)%attrid = attrid
    result = nf90_noerr
    return
    !
999 continue
    result = nf90_enotvar
  end function vtable_set_attrid
 
end module gtdata_netcdf_internal