gtvarlimitbinary.f90 File Reference

Unify dimension structure of two variables. More...

Go to the source code of this file.

Functions/Subroutines
subroutine	gtvarxformbinary (var1, var2, err)
subroutine	adjust_slice (var1, var2, idim1, idim2, offset, stepfact)

Detailed Description

Unify dimension structure of two variables.

Author

Eizi TOYODA, Yasuhiro MORIKAWA

Copyright

Copyright (C) GFD Dennou Club, 2000-2026. All rights reserved.
License is BSD-2-Clause. See COPYRIGHT in detail

Definition in file gtvarlimitbinary.f90.

Function/Subroutine Documentation

adjust_slice()

subroutine gtvarxformbinary::adjust_slice	(	type(gt_variable), intent(in)	var1,
		type(gt_variable), intent(in)	var2,
		integer, intent(in)	idim1,
		integer, intent(in)	idim2,
		integer, intent(out)	offset,
		integer, intent(out)	stepfact
	)

Definition at line 142 of file gtvarlimitbinary.f90.

    use gtdata_generic, only: get, open, close
    type(GT_VARIABLE), intent(in):: var1, var2
    integer, intent(in):: idim1, idim2
    integer, intent(out):: offset, stepfact
    type(GT_VARIABLE):: var_d
    integer:: n, buf(1)
    real, allocatable:: val1(:), val2(:)
  continue
    call beginsub('adjust_slice')
    call open(var_d, source_var=var1, dimord=idim1, count_compact=.true.)
    call inquire(var_d, size=n)
    allocate(val1(n))
    call get(var_d, val1, n)
    call close(var_d)
    !
    call open(var_d, source_var=var2, dimord=idim2, count_compact=.true.)
    call inquire(var_d, size=n)
    allocate(val2(n))
    call get(var_d, val2, n)
    call close(var_d)
    !
    buf(1:1) = minloc(abs(val1(:) - val2(1)))
    offset = buf(1) - 1
    if (size(val2) < 2 .or. size(val1) < 2) then
      stepfact = 1
    else
      buf(1:1) = minloc(abs(val1(:) - val2(2)))
      stepfact = buf(1) - (offset + 1)
    endif
    !
    deallocate(val1, val2)
    call endsub('adjust_slice')

References dc_units::add_okay(), dc_trace::beginsub(), dc_trace::dbgmessage(), dc_trace::endsub(), and dc_types::string.

Here is the call graph for this function:

gtvarxformbinary()

subroutine gtvarxformbinary	(	type(gt_variable), intent(inout)	var1,
		type(gt_variable), intent(inout)	var2,
		logical, intent(out), optional	err
	)

Unify dimension arrangement of two variables

Applies range constraints so that the dimension structure of var1 matches that of var2. If var1 has excess dimensions, they are hidden.

The result preserves var2's space and transforms var1. Dimensions of var2 take var2's width. Dimensions in var1 not in var2 become invisible and must be degenerate or absent.

If an error occurs, outputs a message and terminates. If err is provided, returns .true. and does not terminate.

Parameters

[in,out]	var1	First variable (to be transformed)
[in,out]	var2	Second variable (reference)
[out]	err	Error flag (optional)

Definition at line 58 of file gtvarlimitbinary.f90.

  use gtdata_types, only: gt_variable
  use gtdata_generic, only: inquire, get_slice
  use gtdata_internal_map, only: map_allocate, map_apply, gt_dimmap, gtvar_dump
  use dc_error, only: storeerror, gt_enomatchdim, dc_noerr
  use dc_trace, only: beginsub, endsub, dbgmessage
  implicit none
  type(GT_VARIABLE), intent(inout):: var1, var2
  logical, intent(out), optional:: err
  integer:: ndim1, ndim2, ndimo
  integer, allocatable:: map1(:), map2(:)
  type(GT_DIMMAP), pointer:: newmap(:)
  integer:: i, j, stat
  character(*), parameter:: subnam = "GTVarXformBinary"
continue
  call beginsub(subnam, 'mapid=[%d, %d]', i=(/var1%mapid, var2%mapid/))
  call gtvar_dump(var1)
  call gtvar_dump(var2)
  !
  ! 二つの変数 var1, var2 から共有次元を調べ、対応表 map1, map2 をつくる。
  !
  if (present(err)) err = .false.
  call inquire(var1, alldims=ndim1)
  call inquire(var2, alldims=ndim2)
  ndimo = max(ndim1, ndim2, 0)
  allocate(map1(1:ndim1), map2(1:ndim2))
  call getmatch(var1, var2, ndim1, ndim2, map1, map2)
  call dbgmessage('map1=%*d map2=%*d', i=(/map1(1:ndim1), map2(1:ndim2)/), n=(/ndim1, ndim2/))
  if (all(map2(1:ndim2) == 0)) then
    stat = gt_enomatchdim
    goto 999
  endif
  !
  ! 再配置テーブル作成開始
  !
  ndimo = ndim2 + count(map1(1:ndim1) == 0)
  call map_allocate(newmap, ndimo)
  !
  ! 1..ndim2 は map2 によって var2 の次元たちにマップする
  !
  newmap(1:ndim2)%dimno = map2(1:ndim2)
  call inquire(var2, allcount=newmap(1:ndim2)%allcount)
  call get_slice(var2, count=newmap(1:ndim2)%count)
  do, j = 1, ndim2
    if (map2(j) == 0) then
      newmap(j)%start = 1
      newmap(j)%stride = 1
      call inquire(var2, j, url=newmap(j)%url)
    else
      ! 位置対応によって var1 側での開始位置を決定する
      call adjust_slice(var1, var2, map2(j), j, &
        & newmap(j)%start, newmap(j)%stride)
    endif
  enddo
  !
  ! ndim2+1.. ndimo は var2 に対応させられない var1 の次元をおく
  !
  j = 0
  loop1: do, i = ndim2 + 1, ndimo
    do
      j = j + 1
      if (j > ndim1) exit loop1
      if (map1(j) <= 0) exit
    enddo
    newmap(i)%dimno = j
    call inquire(var1, dimord=j, allcount=newmap(i)%allcount)
    call get_slice(var1, dimord=j, start=newmap(i)%start, &
      & count=newmap(i)%count, stride=newmap(i)%stride)
  end do loop1
  !
  call map_apply(var1, map=newmap)
  !
  stat = dc_noerr
999 continue
  call storeerror(stat, subnam, err)
  call endsub(subnam, 'stat=%d', i=(/stat/))
  deallocate(map1, map2)
  return
contains
 
  !
  ! 二つの次元変数を調べ、軸上位置が対応するように
  ! start シフト数と stride ファクタを決定する
  !
  subroutine adjust_slice(var1, var2, idim1, idim2, offset, stepfact)
    use gtdata_generic, only: get, open, close
    type(GT_VARIABLE), intent(in):: var1, var2
    integer, intent(in):: idim1, idim2
    integer, intent(out):: offset, stepfact
    type(GT_VARIABLE):: var_d
    integer:: n, buf(1)
    real, allocatable:: val1(:), val2(:)
  continue
    call beginsub('adjust_slice')
    call open(var_d, source_var=var1, dimord=idim1, count_compact=.true.)
    call inquire(var_d, size=n)
    allocate(val1(n))
    call get(var_d, val1, n)
    call close(var_d)
    !
    call open(var_d, source_var=var2, dimord=idim2, count_compact=.true.)
    call inquire(var_d, size=n)
    allocate(val2(n))
    call get(var_d, val2, n)
    call close(var_d)
    !
    buf(1:1) = minloc(abs(val1(:) - val2(1)))
    offset = buf(1) - 1
    if (size(val2) < 2 .or. size(val1) < 2) then
      stepfact = 1
    else
      buf(1:1) = minloc(abs(val1(:) - val2(2)))
      stepfact = buf(1) - (offset + 1)
    endif
    !
    deallocate(val1, val2)
    call endsub('adjust_slice')
  end subroutine adjust_slice
 
  !
  ! 二つの変数から共有次元を調べ、対応表 map1, map2 を作る。
  ! すなわち、それぞれの次元番号から相方の次元番号を得る表である。
  !
  subroutine getmatch(var1, var2, ndim1, ndim2, map1, map2)
    use dc_types, only: string
    use dc_units, only: units, add_okay, assignment(=), clear, deallocate
    use gtdata_generic, only: get_attr, open, close
    type(GT_VARIABLE), intent(in):: var1, var2
    integer, intent(in):: ndim1, ndim2
    integer, intent(out):: map1(:), map2(:)
    type(GT_VARIABLE):: var_d
    integer, allocatable:: map(:, :)
    integer:: i, j
    character(STRING):: su1, su2
    type(UNITS), allocatable:: u1(:), u2(:)
  continue
    call beginsub('getmatch')
    ! 返却値はデフォルト 0
    map1(:) = 0
    map2(:) = 0
    ! 表の構築: 初期値は消去法をとることを示す
    allocate(map(ndim1, ndim2))
    map(:, :) = 1
 
    ! 単位による対応 --- 加算可能でなければ対にしない
    ! 単位の構成
    allocate(u1(ndim1), u2(ndim2))
    do, i = 1, ndim1
      call open(var_d, var1, i, count_compact=.true.)
      call get_attr(var_d, 'units', su1)
      call close(var_d)
      call clear(u1(i))
      u1(i) = su1
    enddo
    do, j = 1, ndim2
      call open(var_d, var2, j, count_compact=.true.)
      call get_attr(var_d, 'units', su2)
      call close(var_d)
      call clear(u2(j))
      u2(j) = su2
    enddo
    ! 処理
    do, i = 1, ndim1
      do, j = 1, ndim2
        if (.not. add_okay(u1(i), u2(j))) &
          & map(i, j) = 0
      enddo
    enddo
    ! 単位の廃棄
    do, i = 1, ndim1
      call deallocate(u1(i))
    enddo
    do, j = 1, ndim2
      call deallocate(u2(j))
    enddo
    deallocate(u1, u2)
 
    if (map_finished(map)) goto 1000
 
    ! --- it fails ---
    call endsub('getmatch', 'fail')
    return
 
1000 continue
    do, i = 1, ndim1
      call dbgmessage('map(%d, :)=%*d', i=(/i, map(i,:)/), n=(/ndim2/))
    enddo
    do, i = 1, ndim1
      if (all(map(i, :) <= 0)) then
        map1(i) = 0
      else
        map1(i:i) = maxloc(map(i, :))
      endif
    enddo
    do, j = 1, ndim2
      if (all(map(:, j) <= 0)) then 
        map2(j) = 0
      else
        map2(j:j) = maxloc(map(:, j), dim=1)
      endif
    enddo
    call endsub('getmatch', 'okay')
  end subroutine getmatch
 
  logical function map_finished(map) result(result)
    integer:: map(:, :)
    integer:: i, j, ni
  continue
    call beginsub('map_finished')
    ni = size(map, dim=1)
    do, i = 1, ni
      if (count(map(i, :) > 0) > 1) then
        result = .false.
        goto 999
      endif
    enddo
    do, j = 1, ni
      if (count(map(j, :) > 0) > 1) then
        result = .false.
        goto 999
      endif
    enddo
    result = .true.
999 continue
    call endsub('map_finished')
  end function map_finished
 

References adjust_slice(), dc_trace::beginsub(), dc_trace::dbgmessage(), dc_error::dc_noerr, dc_trace::endsub(), dc_error::gt_enomatchdim, gtdata_internal_map::gtvar_dump(), gtdata_internal_map::map_allocate(), gtdata_internal_map::map_apply(), and dc_error::storeerror().

Here is the call graph for this function: