| Path: | src/anvargetnum.f90 |
| Last Update: | Thu Sep 08 22:21:48 JST 2005 |
Copyright (C) GFD Dennou Club, 2000-2005. All rights reserved.
This file is created by "anvargettype.m4" by m4 command using "intrinsic_types.m4". Don‘t edit each files directly.
| var : | type(AN_VARIABLE), intent(in) |
| start(:) : | integer(INTK), intent(in) |
| cnt(:) : | integer(INTK), intent(in) |
| stride(:) : | integer(INTK), intent(in) |
| imap(:) : | integer(INTK), intent(in) |
| siz : | integer(INTK), intent(in) |
| value(siz) : | real(DP), intent(out) |
| iostat : | integer(INTK), intent(out) |
subroutine ANVarGetDouble(var, start, cnt, stride, imap, siz, value, iostat)
implicit none
type(AN_VARIABLE), intent(in):: var
integer(INTK), intent(in):: start(:)
integer(INTK), intent(in):: cnt(:)
integer(INTK), intent(in):: stride(:)
integer(INTK), intent(in):: imap(:)
integer(INTK), intent(in):: siz
real(DP), intent(out):: value(siz)
integer(INTK), intent(out):: iostat
integer(INTK):: nd, ipos, i
type(AN_VARIABLE_ENTRY):: ent
integer(INTK), allocatable:: istart(:), istride(:), iimap(:)
continue
call BeginSub('ANVarGetDouble', fmt='varmap=%d, start=%*d, cnt=%*d, stride=%*d, imap=%*d siz=%d', i=(/var%id, start(:), cnt(:), stride(:), imap(:), siz/), n=(/size(start), size(cnt), size(stride), size(imap)/))
iostat = vtable_lookup(var, ent)
if (iostat /= nf_noerr) goto 999
! --- nd check ---
nd = 0
if (associated(ent%dimids)) nd = size(ent%dimids)
if (min(size(start), size(cnt), size(stride), size(imap)) < nd) then
iostat = nf_einval
goto 999
endif
if (nd == 0) then
iostat = nf_get_var1_Double(ent%fileid, ent%varid, start, value(1))
goto 999
endif
! --- stride kakikae buffer ---
allocate(istart(nd), istride(nd), iimap(nd))
istart(1:nd) = start(1:nd)
istride(1:nd) = stride(1:nd)
iimap(1:nd) = imap(1:nd)
ipos = 1
! --- do read ---
if (ent%varid <= 0 .or. count(cnt(1:nd) == 1) >= 0) then
call BeginSub('fake_map_get')
call fake_map_get
call EndSub('fake_map_get', 'iostat=%d', i=(/iostat/))
else
! negative stride is not allowed for netcdf
do, i = 1, nd
if (stride(i) > 0) cycle
ipos = ipos + (cnt(i) - 1) * imap(i)
istart(i) = start(i) + (cnt(i) - 1) * stride(i)
istride(i) = -stride(i)
iimap(i) = -imap(i)
call DbgMessage('dim %d negate: stride->%d start->%d map->%d', i=(/i, istride(i), istart(i), iimap(i)/))
enddo
iostat = nf_get_varm_Double(ent%fileid, ent%varid, istart, cnt, istride, iimap, value(ipos))
endif
deallocate(istart, istride, iimap)
999 continue
call EndSub('ANVarGetDouble', 'iostat=%d', i=(/iostat/))
return
contains
subroutine fake_map_get
integer(INTK):: ofs(nd), here(nd)
integer(INTK):: j
continue
iostat = nf_noerr
ofs(1:nd) = 0
do
j = ipos + dot_product(ofs(1:nd), imap(1:nd))
here(1:nd) = istart(1:nd) + ofs(1:nd) * istride(1:nd)
if (j < 1 .or. j > siz) then
iostat = nf_einval
call DbgMessage('nf_get_var1_Double(ncid=%d, varid=%d, indx=[%*d], out-ofs=%d)', i=(/ent%fileid, ent%varid, here(1:nd), j/), n=(/nd/))
return
endif
if (ent%varid == 0) then
value(j) = j
iostat = nf_noerr
else
iostat = nf_get_var1_Double(ent%fileid, ent%varid, here(1), value(j))
endif
if (iostat /= nf_noerr) return
ofs(1) = ofs(1) + 1
do, j = 1, nd - 1
if (ofs(j) < cnt(j)) exit
ofs(j) = 0
ofs(j + 1) = ofs(j + 1) + 1
enddo
if (ofs(nd) >= cnt(nd)) exit
enddo
end subroutine
| var : | type(AN_VARIABLE), intent(in) |
| start(:) : | integer(INTK), intent(in) |
| cnt(:) : | integer(INTK), intent(in) |
| stride(:) : | integer(INTK), intent(in) |
| imap(:) : | integer(INTK), intent(in) |
| siz : | integer(INTK), intent(in) |
| value(siz) : | real(SP), intent(out) |
| iostat : | integer(INTK), intent(out) |
subroutine ANVarGetReal(var, start, cnt, stride, imap, siz, value, iostat)
implicit none
type(AN_VARIABLE), intent(in):: var
integer(INTK), intent(in):: start(:)
integer(INTK), intent(in):: cnt(:)
integer(INTK), intent(in):: stride(:)
integer(INTK), intent(in):: imap(:)
integer(INTK), intent(in):: siz
real(SP), intent(out):: value(siz)
integer(INTK), intent(out):: iostat
integer(INTK):: nd, ipos, i
type(AN_VARIABLE_ENTRY):: ent
integer(INTK), allocatable:: istart(:), istride(:), iimap(:)
continue
call BeginSub('ANVarGetReal', fmt='varmap=%d, start=%*d, cnt=%*d, stride=%*d, imap=%*d siz=%d', i=(/var%id, start(:), cnt(:), stride(:), imap(:), siz/), n=(/size(start), size(cnt), size(stride), size(imap)/))
iostat = vtable_lookup(var, ent)
if (iostat /= nf_noerr) goto 999
! --- nd check ---
nd = 0
if (associated(ent%dimids)) nd = size(ent%dimids)
if (min(size(start), size(cnt), size(stride), size(imap)) < nd) then
iostat = nf_einval
goto 999
endif
if (nd == 0) then
iostat = nf_get_var1_Real(ent%fileid, ent%varid, start, value(1))
goto 999
endif
! --- stride kakikae buffer ---
allocate(istart(nd), istride(nd), iimap(nd))
istart(1:nd) = start(1:nd)
istride(1:nd) = stride(1:nd)
iimap(1:nd) = imap(1:nd)
ipos = 1
! --- do read ---
if (ent%varid <= 0 .or. count(cnt(1:nd) == 1) >= 0) then
call BeginSub('fake_map_get')
call fake_map_get
call EndSub('fake_map_get', 'iostat=%d', i=(/iostat/))
else
! negative stride is not allowed for netcdf
do, i = 1, nd
if (stride(i) > 0) cycle
ipos = ipos + (cnt(i) - 1) * imap(i)
istart(i) = start(i) + (cnt(i) - 1) * stride(i)
istride(i) = -stride(i)
iimap(i) = -imap(i)
call DbgMessage('dim %d negate: stride->%d start->%d map->%d', i=(/i, istride(i), istart(i), iimap(i)/))
enddo
iostat = nf_get_varm_Real(ent%fileid, ent%varid, istart, cnt, istride, iimap, value(ipos))
endif
deallocate(istart, istride, iimap)
999 continue
call EndSub('ANVarGetReal', 'iostat=%d', i=(/iostat/))
return
contains
subroutine fake_map_get
integer(INTK):: ofs(nd), here(nd)
integer(INTK):: j
continue
iostat = nf_noerr
ofs(1:nd) = 0
do
j = ipos + dot_product(ofs(1:nd), imap(1:nd))
here(1:nd) = istart(1:nd) + ofs(1:nd) * istride(1:nd)
if (j < 1 .or. j > siz) then
iostat = nf_einval
call DbgMessage('nf_get_var1_Real(ncid=%d, varid=%d, indx=[%*d], out-ofs=%d)', i=(/ent%fileid, ent%varid, here(1:nd), j/), n=(/nd/))
return
endif
if (ent%varid == 0) then
value(j) = j
iostat = nf_noerr
else
iostat = nf_get_var1_Real(ent%fileid, ent%varid, here(1), value(j))
endif
if (iostat /= nf_noerr) return
ofs(1) = ofs(1) + 1
do, j = 1, nd - 1
if (ofs(j) < cnt(j)) exit
ofs(j) = 0
ofs(j + 1) = ofs(j + 1) + 1
enddo
if (ofs(nd) >= cnt(nd)) exit
enddo
end subroutine