Polymorphism / Dynamic dispatch? Fortran 90.

FrankMonkey · Jan 5, 2018

Hello all,

I need to do the following in Fortran 90.

I have two subroutines that perform similar tasks, lets call them subroutine ALPHA and subroutine BRAVO. Lets say they have SAME dummy argument list, same sequence ranks, same kinds to all args.

So.. SUBROUTINE ALPHA(dummy_arg1,dummy_arg2,...)
SUBROUTINE BRAVO(dummy_arg1,dummy_arg2,...)

They are called from a MAIN program like so.

CALL ALPHA(arg_1,arg2,...) etc...

What I need to do is to make ONE call from the main and to make the switch between calling ALPHA or BRAVO depending on some logic in the main.

What I DO NOT WANT TO DO is the following
SELECT CASE(TEST)
CASE(1)
CALL ALPHA(arg1,arg2,...)
CASE(2)
CALL BRAVO(arg1,arg2,...)
END SELECT

or similar with an IF-ELSE-ENDIF

I want a single (ONE) subroutine call from the MAIN which will access either ALPHA or BRAVO depending on the logic in main, but again with a SINGLE call.

I understand this CAN be done with polymorphism / dynamic dispatch. Fortran 95 and beyond can do it relatively easily but it's much more complicated with earlier versions and I MUST basically use Fortran 90.

I've racked my brain and coded and just can't get this to work.

Anyone know how to do this???

Regards,

Frank

xwb · Jan 5, 2018

How do you decide which one to call? Is it determined by one of the parameter types? If all the parameters are of the same type then you could do something like this

Code:

! Declare a generic interface
MODULE POLYMOD

! Define two different types
TYPE atype
    SEQUENCE
    INTEGER kode
END TYPE

TYPE btype
    SEQUENCE
    INTEGER kode
END TYPE

! This is the polymorphic call
INTERFACE GREEK
    SUBROUTINE ALPHA(param, val)
        TYPE (atype), INTENT(INOUT):: param
        INTEGER, INTENT(IN):: val
    END SUBROUTINE ALPHA
    
    SUBROUTINE BETA(param, val)
        TYPE (btype), INTENT(INOUT):: param
        INTEGER, INTENT(IN):: val
    END SUBROUTINE BETA
END INTERFACE
CONTAINS

! Definition using atype
SUBROUTINE ALPHA(param, val)
    TYPE (atype), INTENT(INOUT):: param
    INTEGER, INTENT(IN):: val
    param%kode = val
    print *, 'alpha'
END SUBROUTINE ALPHA

! Definition using btype
SUBROUTINE BETA(param, val)
    TYPE (btype), INTENT(INOUT):: param
    INTEGER, INTENT(IN):: val
    param%kode = val
    print *, 'beta'
END SUBROUTINE BETA
END MODULE POLYMOD


PROGRAM main
    USE POLYMOD
    TYPE (atype):: adata
    TYPE (btype):: bdata
    
    ! See if it works
    call greek(adata, 65)
    call greek(bdata, 66)
    print *, 'adata ', adata%kode
    print *, 'bdata ', bdata%kode
end program

FrankMonkey · Jan 6, 2018

Hello xwb,

That's a valiant effort but it doesn't make it.

You can see from your main here:
call greek(adata, 65)
call greek(bdata, 66)

You are able to access the two different subroutines using the types 'adata' and 'bdata' to match the type of the called subroutine.

However that still means two different calls, the difference being the types adata and bdata.

As I said in the original post I need "I want a single (ONE) subroutine call" that can access both, CALL GREEK() end of. The reasoning for this is a select-case structure of if-else to select the 'right' routine would be horrendously wordy and slow, loads of code lines because a) the amount of subroutines that may be called is not just ALPHA through to BRAVO, but ALPHA through to ZEBRA and the argument list to the routines can be sizeable. I need one ring to rule them all. One call. I know it's a toughy it's been wrecking my brain.

Thank you for your effort though, it really is appreciated.

Regards,

Frank

xwb · Jan 6, 2018

Can you explain what you mean by "access both". Give a coding example, even if it is not syntactically correct for F90.

This doesn't sound like a polymorphic call. If there is no difference in the parameters, how does the code know which one to call.

FrankMonkey · Jan 6, 2018

This in code/psuedo-code is what I want to do.

MODULE JIMMY
!
CONTAINS
SUBROUTINE ALPHA (identical_dummy_arg_list)
! Does stuff with args
END SUBROUTINE ALPHA
!
SUBROUTINE BRAVO (identical_dummy_arg_list)
! Does different stuff with args but updates the same args
END SUBROUTINE BRAVO
!
END MODULE JIMMY

MAIN
USE JIMMY, ONLY : ALPHA,BRAVO

INTERFACE GREEK
PROCEDURE ALPHA,BRAVO
END INTERFACE GREEK

IF (TEST.EQ.1) THEN
! I will want to call ALPHA with the argument list
! so I need to change something to make that happen.
ELSE (IF TEST.EQ.2) THEN
! I will want to call BRAVO with the argument list
! so I need to change something to make that happen.
END IF
!
!Some code in here to make the call to GREEK call to the right ALPHA or BRAVO depending on the above logic.
!
CALL GREEK(argument_list) ! and GREEK calls the right ALPHA or BRAVO, i.e. a single call
! If it works Happiness ensues
!
RETURN
END

What I DON'T WANT is:
IF (TEST.EQ.1) THEN
CALL ALPHA(huge arg list)
ELSE (IF TEST.EQ.2) THEN
CALL BRAVO(huge_arg_list)
...
ELSE IF (ITEST.EQ.n) THEN
CALL ZEBRA(huge_arg_list)
END IF
-------------------------------------------------------------------------

Thanks again.

Regards,

Frank

mikrom · Jan 6, 2018

then make it simple and additionally to all the subroutines

Code:

SUBROUTINE ALPHA (identical_dummy_arg_list)
...
SUBROUTINE BRAVO (identical_dummy_arg_list)
...
SUBROUTINE ZEBRA (identical_dummy_arg_list)
...

create a subroutine with the same dummy arg list plus a selector, which calls the right procedure, e.g.:

Code:

subroutine SELECTED_SUBROUTINE (selector, identical_dummy_arg_list)
...
select case (selector)
   case ('ALPHA')
      call ALPHA(identical_dummy_arg_list)
   ...
   case ('BRAVO')
      call BRAVO(identical_dummy_arg_list)
   ...
   case ('ZEBRA')
      call ZEBRA(identical_dummy_arg_list)
   ...
   case default
      call ERROR_BAD_SELECTOR_VALUE
end select
end subroutine

and call it in your main program:

Code:

program main
   ...
   ! set the selector value depending on some logic
   ...
   call SELECTED_SUBROUTINE (selector, identical_arg_list) 
   ...
end program main

salgerman · Jan 6, 2018

mikrom beat me to the punch...I was about to say just about the same; basically, you cannot get away from the 'if-then' in some shape or form if you want to tell things apart. So, instead of putting the "if-then" in the main program, you place it inside the single function being call.

FrankMonkey · Jan 6, 2018

Again, thanks to all. I do appreciate it.

Simple yes, but in mikroms solution that single call now becomes two subroutine calls with a full (and large in this application) argument list and a long-as-your-arm select case or if-else structure in the first subroutine called before you even get to call the subroutine that you want. It won't do.

Do that a couple of million times and there goes the speed of the application and the one I'm working on must have the rivets ground down to be as aerodynamic as possible. No fat allowed!

Surely there has to be a way to do this?

Regards,

Frank

mikrom · Jan 6, 2018

Then the only thing that comes to my mind are procedure pointers. But unfortunately this feature is supported only in newer standard 2003, not in 90, so if you upgrade your compiler you can do it like this:

FrankMonkey.f95

Code:

[COLOR=#800080]module[/color] my_subroutines
  [COLOR=#2e8b57][b]implicit[/b][/color] [COLOR=#2e8b57][b]none[/b][/color]

  [COLOR=#2e8b57][b]type[/b][/color] subroutine_type
    [COLOR=#2e8b57][b]procedure[/b][/color](subroutine_interface), [COLOR=#2e8b57][b]nopass[/b][/color], [COLOR=#2e8b57][b]pointer[/b][/color] :: sub_ptr    
  [COLOR=#2e8b57][b]end type[/b][/color] subroutine_type

  [COLOR=#2e8b57][b]abstract[/b][/color] [COLOR=#800080]interface[/color]
    [COLOR=#800080]subroutine[/color]  subroutine_interface(foo, bar, baz)
      [COLOR=#2e8b57][b]double precision[/b][/color], [COLOR=#2e8b57][b]intent[/b][/color]([COLOR=#2e8b57][b]in[/b][/color]) :: foo, bar, baz
    [COLOR=#800080]end subroutine[/color] subroutine_interface
  [COLOR=#800080]end interface[/color]  

  [COLOR=#800080]contains[/color]

  [COLOR=#0000ff]! all subroutines to call[/color]
  [COLOR=#800080]subroutine[/color]  alpha(foo, bar, baz)
     [COLOR=#2e8b57][b]double precision[/b][/color], [COLOR=#2e8b57][b]intent[/b][/color]([COLOR=#2e8b57][b]in[/b][/color]) :: foo, bar, baz
     [COLOR=#a52a2a][b]write[/b][/color]([COLOR=#a52a2a][b]*[/b][/color],[COLOR=#a52a2a][b]*[/b][/color]) [COLOR=#ff00ff]"calling: ALPHA"[/color]    
  [COLOR=#800080]end subroutine[/color] alpha

  [COLOR=#800080]subroutine[/color]  bravo(foo, bar, baz)
     [COLOR=#2e8b57][b]double precision[/b][/color], [COLOR=#2e8b57][b]intent[/b][/color]([COLOR=#2e8b57][b]in[/b][/color]) :: foo, bar, baz
     [COLOR=#a52a2a][b]write[/b][/color]([COLOR=#a52a2a][b]*[/b][/color],[COLOR=#a52a2a][b]*[/b][/color]) [COLOR=#ff00ff]"calling: BRAVO"[/color]    
  [COLOR=#800080]end subroutine[/color] bravo
 
  [COLOR=#800080]subroutine[/color]  zebra(foo, bar, baz)
     [COLOR=#2e8b57][b]double precision[/b][/color], [COLOR=#2e8b57][b]intent[/b][/color]([COLOR=#2e8b57][b]in[/b][/color]) :: foo, bar, baz
     [COLOR=#a52a2a][b]write[/b][/color]([COLOR=#a52a2a][b]*[/b][/color],[COLOR=#a52a2a][b]*[/b][/color]) [COLOR=#ff00ff]"calling: ZEBRA"[/color]    
  [COLOR=#800080]end subroutine[/color] zebra
[COLOR=#800080]end module[/color] my_subroutines

[COLOR=#800080]program[/color] main
  [COLOR=#800080]use[/color] my_subroutines
  [COLOR=#2e8b57][b]implicit[/b][/color] [COLOR=#2e8b57][b]none[/b][/color]
  [COLOR=#2e8b57][b]CHARACTER[/b][/color]([COLOR=#2e8b57][b]len[/b][/color][COLOR=#a52a2a][b]=[/b][/color][COLOR=#ff00ff]5[/color]) :: arg
  [COLOR=#2e8b57][b]double precision[/b][/color] :: foo, bar, baz 
  [COLOR=#2e8b57][b]type[/b][/color](subroutine_type) :: my_proc

  [COLOR=#0000ff]! set the pointer value[/color]
  [COLOR=#008b8b]call[/color] [COLOR=#008b8b]get_command_argument[/color]([COLOR=#ff00ff]1[/color], arg)
  [COLOR=#a52a2a][b]select case[/b][/color] (arg)
    [COLOR=#a52a2a][b]case[/b][/color] ([COLOR=#ff00ff]'ALPHA'[/color])
      my_proc%sub_ptr [COLOR=#a52a2a][b]=>[/b][/color] alpha
    [COLOR=#a52a2a][b]case[/b][/color] ([COLOR=#ff00ff]'BRAVO'[/color])
      my_proc%sub_ptr [COLOR=#a52a2a][b]=>[/b][/color] bravo
    [COLOR=#a52a2a][b]case[/b][/color] ([COLOR=#ff00ff]'ZEBRA'[/color])
      my_proc%sub_ptr [COLOR=#a52a2a][b]=>[/b][/color] zebra
    [COLOR=#a52a2a][b]case[/b][/color] [COLOR=#a52a2a][b]default[/b][/color]
      [COLOR=#a52a2a][b]stop[/b][/color] [COLOR=#ff00ff]'Error calling subroutine !'[/color]
   [COLOR=#a52a2a][b]end select[/b][/color]

   [COLOR=#0000ff]! call the selected subroutine[/color]
   [COLOR=#008b8b]call[/color]  my_proc%sub_ptr(foo, bar, baz)

[COLOR=#800080]end program[/color]

Results:

Code:

$ gfortran FrankMonkey.f95 -o FrankMonkey
$ ./FrankMonkey ALPHA
 calling: ALPHA
$ ./FrankMonkey BRAVO
 calling: BRAVO
$ ./FrankMonkey
STOP Error calling subroutine !

xwb · Jan 7, 2018

Does your implementation of F90 have Cray pointers? Does the following compile on your compiler. If it does, you can do something similar to mikrom's solution using function pointers.

Code:

program craytest
	POINTER (p, picreg)
	INTEGER picreg
	INTEGER J(1024)

! This has the same effect as j(1) = 0, j(2) = 44
      p = LOC(j)
      picreg = 0
      p = p + 4   ! for 4-byte integer
      picreg = 44
	print *, j(1), j(2)
	print '(Z)', p
end program craytest

salgerman · Jan 7, 2018

And, no, with modules you do not need to pass a long list of arguments, just encapsulate the data and the functions that manipulate it in the same module.

mikrom · Jan 7, 2018

xwb you are awesome !
With the Cray pointers it seems to be very simple - i tried what you suggested:

FrankMonkey2.f95

Code:

[COLOR=#0000ff]! compilation:[/color]
[COLOR=#0000ff]!   gfortran FrankMonkey2.f95 -o FrankMonkey2 -fcray-pointer[/color]
[COLOR=#800080]module[/color] my_subroutines
  [COLOR=#2e8b57][b]implicit[/b][/color] [COLOR=#2e8b57][b]none[/b][/color]

  [COLOR=#800080]contains[/color]

  [COLOR=#0000ff]! all subroutines to call[/color]
  [COLOR=#800080]subroutine[/color]  alpha(foo, bar, baz)
     [COLOR=#2e8b57][b]double precision[/b][/color], [COLOR=#2e8b57][b]intent[/b][/color]([COLOR=#2e8b57][b]in[/b][/color]) :: foo, bar, baz
     [COLOR=#a52a2a][b]write[/b][/color]([COLOR=#a52a2a][b]*[/b][/color],[COLOR=#a52a2a][b]*[/b][/color]) [COLOR=#ff00ff]"calling: ALPHA"[/color]    
  [COLOR=#800080]end subroutine[/color] alpha

  [COLOR=#800080]subroutine[/color]  bravo(foo, bar, baz)
     [COLOR=#2e8b57][b]double precision[/b][/color], [COLOR=#2e8b57][b]intent[/b][/color]([COLOR=#2e8b57][b]in[/b][/color]) :: foo, bar, baz
     [COLOR=#a52a2a][b]write[/b][/color]([COLOR=#a52a2a][b]*[/b][/color],[COLOR=#a52a2a][b]*[/b][/color]) [COLOR=#ff00ff]"calling: BRAVO"[/color]    
  [COLOR=#800080]end subroutine[/color] bravo
 
  [COLOR=#800080]subroutine[/color]  zebra(foo, bar, baz)
     [COLOR=#2e8b57][b]double precision[/b][/color], [COLOR=#2e8b57][b]intent[/b][/color]([COLOR=#2e8b57][b]in[/b][/color]) :: foo, bar, baz
     [COLOR=#a52a2a][b]write[/b][/color]([COLOR=#a52a2a][b]*[/b][/color],[COLOR=#a52a2a][b]*[/b][/color]) [COLOR=#ff00ff]"calling: ZEBRA"[/color]    
  [COLOR=#800080]end subroutine[/color] zebra
[COLOR=#800080]end module[/color] my_subroutines

[COLOR=#800080]program[/color] main
  [COLOR=#800080]use[/color] my_subroutines
  [COLOR=#2e8b57][b]implicit[/b][/color] [COLOR=#2e8b57][b]none[/b][/color]
  [COLOR=#2e8b57][b]CHARACTER[/b][/color]([COLOR=#2e8b57][b]len[/b][/color][COLOR=#a52a2a][b]=[/b][/color][COLOR=#ff00ff]5[/color]) :: arg
  [COLOR=#2e8b57][b]double precision[/b][/color] :: foo, bar, baz 
  [COLOR=#2e8b57][b]pointer[/b][/color] (sub_ptr, selected_subroutine)
  [COLOR=#2e8b57][b]external[/b][/color] selected_subroutine

  [COLOR=#0000ff]! set the pointer to a subroutine[/color]
  [COLOR=#008b8b]call[/color] [COLOR=#008b8b]get_command_argument[/color]([COLOR=#ff00ff]1[/color], arg) 
  [COLOR=#a52a2a][b]select case[/b][/color] (arg)
    [COLOR=#a52a2a][b]case[/b][/color] ([COLOR=#ff00ff]'ALPHA'[/color])
      sub_ptr [COLOR=#a52a2a][b]=[/b][/color] loc(alpha)
    [COLOR=#a52a2a][b]case[/b][/color] ([COLOR=#ff00ff]'BRAVO'[/color])
      sub_ptr [COLOR=#a52a2a][b]=[/b][/color] loc(bravo)
    [COLOR=#a52a2a][b]case[/b][/color] ([COLOR=#ff00ff]'ZEBRA'[/color])
      sub_ptr [COLOR=#a52a2a][b]=[/b][/color] loc(zebra)
    [COLOR=#a52a2a][b]case[/b][/color] [COLOR=#a52a2a][b]default[/b][/color]
      [COLOR=#a52a2a][b]stop[/b][/color] [COLOR=#ff00ff]'Error calling subroutine !'[/color]
   [COLOR=#a52a2a][b]end select[/b][/color]

   [COLOR=#0000ff]! call the selected subroutine[/color]
   [COLOR=#008b8b]call[/color]  selected_subroutine(foo, bar, baz)
[COLOR=#800080]end program[/color]

Output:

Code:

$ gfortran FrankMonkey2.f95 -o FrankMonkey2 -fcray-pointer
$ ./FrankMonkey2 ALPHA
 calling: ALPHA
$ ./FrankMonkey2 BRAVO
 calling: BRAVO
$ ./FrankMonkey2 ZEBRA
 calling: ZEBRA
$ ./FrankMonkey2 foo bar baz
STOP Error calling subroutine !

mikrom · Jan 7, 2018

salgerman said:
And, no, with modules you do not need to pass a long list of arguments, just encapsulate the data and the functions that manipulate it in the same module.

Hi salgerman
Could you show a short code example, what you mean, please ?

salgerman · Jan 8, 2018

Code:

module my_module
    implicit none
    integer :: a
contains
    subroutine alpha()
        a = 1
    end subroutine alpha

    subroutine beta()
        a = 2
    end subroutine beta

    subroutine gamma()
        a = 3
    end subroutine gamma
end module my_module

program main
    use my_module
    a = 0
    call alpha()
    write(*,*) 'a = ', a
    call beta()
    write(*,*) 'a = ', a
    call gamma()
    write(*,*) 'a = ', a
end program main

salgerman · Jan 8, 2018

And, as I mentioned before, for as long as you need to tell things apart you are going to need a "select" or an "if-then" somewhere, there is no way around it...even the example with pointers needs a "select" to assign the pointer, so, what's the point of complicating the matter with potential memory leaks and the like problems? ...just saying.

mikrom · Jan 9, 2018

now I understand what you mean: instead of subroutine arguments to use module variables

Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Polymorphism / Dynamic dispatch? Fortran 90.

FrankMonkey

Systems Engineer

xwb

Programmer

FrankMonkey

Systems Engineer

xwb

Programmer

FrankMonkey

Systems Engineer

mikrom

Programmer

salgerman

Programmer

FrankMonkey

Systems Engineer

mikrom

Programmer

xwb

Programmer

salgerman

Programmer

mikrom

Programmer

mikrom

Programmer

salgerman

Programmer

salgerman

Programmer

mikrom

Programmer

Similar threads

Part and Inventory Search

Sponsor