Equivalent of equivalence - Page 2

Simon_Geard · ‎02-24-2015

Having moved from fixed arrays that were equivalenced to dynamic arrays I'd like to reinstate an equivalent to the old equivalence.

[fortran]

program main
   use iso_c_binding
   implicit none
    real(4)    :: ra(0:11,3)
   integer(4) :: ia(0:11,3)
   common /x/ ra
   equivalence(ra(0,1),ia(0,1))

   real(4), allocatable :: wra(:,:)
   integer(4), pointer :: wia_ptr(:,:)

   ra = 0.0
   ra(0,1) = transfer(1,0.0)
   write(*,'(a,i0)') 'ia(0,1) = ',ia(0,1)

   allocate(wra(0:11,3), source=0.0)
   call c_f_pointer(c_loc(wra), wia_ptr, [12,3])

   wra(0,1) = transfer(1,0.0)
   write(*,'(a,i0)') 'wia_ptr(1,1) = ',wia_ptr(1,1)

end program main

[/fortran]

In order for my application to work I need wia_ptr(0,1) to be valid and == wra(0,1) but I can't work out the syntax. Is it possible using this method or is there another method that I should be using?

Thanks.

FortranFan · ‎03-03-2015

jimdempseyatthecove wrote:

>>Fortran 2003 has ways of achieving the same outcome (putting values of objects of different types behind the same designator) that are generally superior, from the point of view of the language feature being a better fit to what the programmer actually wants to specify.

Then it should be relatively easy for you to convert the post #1 into (putting values of objects of different types behind the same designator) This isn't overtly clear when reading the F2003 spec.

Jim Dempsey

Well, if the specific code in post #1 is the basis, then it is easily replicated in much simpler manner in Quote #8.

As to what is possible with "putting values of objects of different types behind the same designator) that are generally superior, from the point of view of the language feature being a better fit to what the programmer actually wants to specify," I think there are tremendous possibilities with the latest Fortran standard:

module m

   implicit none

   private

   type, public :: any_t

      private

      class(*), allocatable :: m_dat

   contains

      private
      procedure, pass(this) :: set_t
      procedure, pass(this) :: get_i_t
      procedure, pass(this) :: get_r_t
      procedure, pass(this) :: get_c_t
      !..
      procedure, pass(this), public :: ival => fget_i_t
      procedure, pass(this), public :: rval => fget_r_t
      procedure, pass(this), public :: cval => fget_c_t
      generic, public :: assignment(=) => set_t, get_i_t, get_r_t, get_c_t

   end type any_t

contains

   subroutine set_t(this, newval)

      class(any_t), intent(inout) :: this
      class(*), intent(in)        :: newval

      !..
      select type ( newval )
         type is ( integer )
            allocate( this%m_dat, source = newval )
         type is ( real)
            allocate( this%m_dat, source = newval )
         type is ( character(len=*) )
            allocate( this%m_dat, source = newval )
         class default
      end select

      return

   end subroutine set_t

   subroutine get_i_t(ival, this)

      integer, intent(out)     :: ival
      class(any_t), intent(in) :: this

      ival = this%ival()

      return

   end subroutine get_i_t

   subroutine get_r_t(rval, this)

      real, intent(out)        :: rval
      class(any_t), intent(in) :: this

      rval = this%rval()

      return

   end subroutine get_r_t

   subroutine get_c_t(sval, this)

      character(len=:), allocatable, intent(out) :: sval
      class(any_t), intent(in)                   :: this

      sval = this%cval()

      return

   end subroutine get_c_t

   function fget_i_t(this) result(ival)

      class(any_t), intent(in) :: this
      !..
      integer :: ival

      select type ( dat => this%m_dat )
         type is ( integer )
            ival = dat
         type is ( real )
            ival = transfer(dat, mold=ival)
         type is ( character(len=*) )
            ival = transfer(dat, mold=ival)
         class default
      end select

      return

   end function fget_i_t

   function fget_r_t(this) result(rval)

      class(any_t), intent(in) :: this
      !..
      real :: rval

      select type ( dat => this%m_dat )
         type is ( integer )
            rval = transfer(dat, mold=rval)
         type is ( real )
            rval = dat
         type is ( character(len=*) )
            rval = transfer(dat, mold=rval)
         class default
      end select

      return

   end function fget_r_t

   function fget_c_t(this) result(sval)

      class(any_t), intent(in) :: this
      !..
      character(len=:), allocatable :: sval

      select type ( dat => this%m_dat )
         type is ( integer )
            allocate( character(len=4) :: sval )
            sval = transfer(dat, mold=sval)
         type is ( real )
            allocate( character(len=4) :: sval )
            sval = transfer(dat, mold=sval)
         type is ( character(len=*) )
            sval = dat
         class default
      end select

      return

   end function fget_c_t

end module m

program p

   use m, only : any_t

   implicit none

   type(any_t) :: foo
   character(len=:), allocatable :: bar

   foo = 1
   print *, " foo = ", foo%ival()
   bar = foo
   print *, " bar = ", transfer(bar, mold=0)

   foo = 2.0
   print *, " foo = ", foo%rval()
   bar = foo
   print *, " bar = ", transfer(bar, mold=0.0)

   foo = "Hello World!"
   print *, " foo = ", foo%cval()

   bar = foo
   print *, " bar = ", bar

   stop

end program p

Upon execution,

  foo =  1
  bar =  1
  foo =  2.000000
  bar =  2.000000
  foo = Hello World!
  bar = Hello World!
Press any key to continue . . .

Steven_L_Intel1 · ‎03-04-2015

Ian, your program from post 20 works in the next major version, so it looks as if we fixed that one.

C:\Projects>ifort U541989.f90
Intel(R) Visual Fortran Intel(R) 64 Compiler XE for applications running on Intel(R) 64, Version Mainline Beta Build x
Built Feb 22 2015 23:51:01 by iclproj
Copyright (C) 1985-2015 Intel Corporation. All rights reserved.

-out:U541989.exe
-subsystem:console
U541989.obj

C:\Projects>U541989.exe
a(0,1) = 0
a(1,2) = 1.000000