Untitled
unknown
plain_text
20 days ago
12 kB
1
Indexable
Never
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! DLL-Course Demo
!------------------------------------------------------------------------------
! This is a demo that is part of the DLL-Course for creating EMTDC components
! that are primarily executed through a DLL.
!
! Created By:
! ~~~~~~~~~~~
! PSCAD Design Team <pscad@hvdc.ca>
! Manitoba HVDC Research Centre Inc.
! Winnipeg, Manitoba. CANADA
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!-----------------------------------------------------------------------------------------------
! This code is for linking to PSCAD for an example of how to create wrapper function that are
! exported. A DLL may import and call those function.
!
! Instructions:
! 1. write a wrapper function that will be decorated (exported) that will wrap any
! functionality (function calls / subroutine calls) required by this DLL
!
! 2. Imported the decorated functions from the DLL
!
! 3. Call the DLL functions through the wrapper
!-----------------------------------------------------------------------------------------------
!======================================================================
! DynamicLoad
!----------------------------------------------------------------------
! This module interfaces definitions of each of the functions to be
! imported and a copy of the handle of the DLL and all the function
! pointers
!----------------------------------------------------------------------
MODULE DynamicLoad ! Module holds all of the pointers/interfaces for accessing our DLL
USE, INTRINSIC::ISO_C_BINDING ! provides access to required HANDLEs and Pointer types
IMPLICIT NONE ! Implicit none will make debugging easier, by preventing complication of variables/types we did not declare.
!------------------------------------------------------------
! INTERFACEs
!
! This should contain a list of interfaces for each of the
! function/subroutines that are to be imported from the
! DLL.
!
! In this example We are importing the function that has
! 2 Integers as inputs and 1 Integer as an output.
!
! It should be noted that multiple functions can share a
! single interface.
!
!------------------------------------------------------------
ABSTRACT INTERFACE ! We define an abstract interface as there is no concrete function behind it untill we load the DLL
SUBROUTINE rt_onestep(c1,c2,o1) ! We must provide what the function would look like if calling normally
REAL, INTENT(IN) :: c1 ! Defining each of the parameters of this function.
REAL, INTENT(IN) :: c2 ! Defining each of the parameters of this function.
REAL, INTENT(OUT) :: o1 ! Defining each of the parameters of this function.
END SUBROUTINE rt_onestep
END INTERFACE ! End of the interface
!------------------------------------------------------------
! Function Pointers
!
! This will require the list of function pointers that point
! to the function imported from the DLL
!
! In this example we are importing Dll Function
!------------------------------------------------------------
PROCEDURE(rt_onestep), POINTER :: rt_onestepPointer => NULL()
!------------------------------------------------------------
! DLL Handler
!
! This is the handle pointer to the DLL
!------------------------------------------------------------
INTEGER(C_INTPTR_T) :: DLL_HANDLE = 0 ! This variable will hold the handle to the DLL, that we can can see if the DLL is loaded.
CONTAINS ! Denotes the module subroutines start here
!======================================================================
! IMPORT_ROUTINES
!----------------------------------------------------------------------
! This function will import the DLL.
! Note: this is standard DLL importing. Not specific to this example
!----------------------------------------------------------------------
SUBROUTINE IMPORT_ROUTINES ! We need to define a routing that will load the DLL and extract the functions.
! Required for library import functions for Intel
! This will provided the LoadLibrary and GetProcAddress function automatically for Intel Fortran
!
#ifdef __INTEL_COMPILER
USE KERNEL32
#endif
USE, INTRINSIC :: ISO_C_BINDING ! Required for ISO Binding definitions
IMPLICIT NONE
! GFortran Requires using Interfaces to import the LoadLibrary and GetProcAddress
! Functions.
!
#ifdef __GFORTRAN__
INTERFACE
FUNCTION LoadLibrary(lpFileName) BIND(C,NAME='LoadLibraryA')
USE, INTRINSIC :: ISO_C_BINDING
IMPLICIT NONE
CHARACTER(KIND=C_CHAR) :: lpFileName(*)
!GCC$ ATTRIBUTES STDCALL :: LoadLibrary
INTEGER(C_INTPTR_T) :: LoadLibrary
END FUNCTION LoadLibrary
FUNCTION GetProcAddress(hModule, lpProcName) &
BIND(C, NAME='GetProcAddress')
USE, INTRINSIC :: ISO_C_BINDING
IMPLICIT NONE
!GCC$ ATTRIBUTES STDCALL :: GetProcAddress
TYPE(C_FUNPTR) :: GetProcAddress
INTEGER(C_INTPTR_T), VALUE :: hModule
CHARACTER(KIND=C_CHAR) :: lpProcName(*)
END FUNCTION GetProcAddress
END INTERFACE
#endif
! Import the DLL, We provide a relative path to the DLL that is going to be loaded. The path
! is relative to where the EXE will reside.
!
!
#ifdef __INTEL_COMPILER
#ifdef _WIN64
DLL_HANDLE = LoadLibrary(C_CHAR_'../DLLSource/x64/BasicInterface.dll'//C_NULL_CHAR)
#else
DLL_HANDLE = LoadLibrary(C_CHAR_'../DLLSource/x86/BasicInterface.dll'//C_NULL_CHAR)
#endif
#endif
#ifdef __GFORTRAN__
#if __SIZEOF_POINTER__ == 8
DLL_HANDLE = LoadLibrary(C_CHAR_'../DLLSource/BasicInterface.dll'//C_NULL_CHAR)
#endif
#endif
IF (DLL_HANDLE .EQ. 0) THEN
CALL print_error ('loading DLL')
STOP
ENDIF
! Extract the function pointers by name. Each of the function is extracted using the GetProcAddress
! then converted to the correct Function Pointer type. The conversion of function pointers is
! compiler dependent so we must use the correct function to perform it by detecting which type of
! compiler is being used.
!
#if defined (__INTEL_COMPILER)
CALL C_F_POINTER(TRANSFER(GetProcAddress(DLL_HANDLE, C_CHAR_'rt_onestep'//C_NULL_CHAR), C_NULL_PTR), rt_onestepPointer)
IF (.NOT. ASSOCIATED(rt_onestepPointer)) THEN
CALL print_error ('looking up routine')
STOP
ENDIF
#elif defined (__GFORTRAN__)
CALL C_F_PROCPOINTER(GetProcAddress(DLL_HANDLE, C_CHAR_'rt_onestep'//C_NULL_CHAR), rt_onestepPointer)
IF (.NOT. ASSOCIATED(rt_onestepPointer)) THEN
CALL print_error ('looking up routine')
STOP
ENDIF
#endif
END SUBROUTINE IMPORT_ROUTINES ! After Extracting the function the subroutine is done.
! Error processing routine. Gets the system error and
! its corresponding string, prints a message, then stops
! execution
!
SUBROUTINE print_error (string)
#ifdef __INTEL_COMPILER
USE KERNEL32
#endif
USE, INTRINSIC :: ISO_C_BINDING
IMPLICIT NONE
#ifdef __GFORTRAN__
INTERFACE
FUNCTION GetLastError() BIND(C,NAME='GetLastError')
USE, INTRINSIC :: ISO_C_BINDING
IMPLICIT NONE
!GCC$ ATTRIBUTES STDCALL :: GetLastError
INTEGER(C_LONG) :: GetLastError
END FUNCTION GetLastError
END INTERFACE
#endif
character(*), intent(IN) :: string
write (*,'(3A,Z8.8)') "An Error occurred while ", string, ": error status = ", GetLastError()
! INTEGER(C_LONG) :: last_error
! integer(C_LONG) :: nTchars
! integer(HANDLE) :: ret
! type(C_PTR) :: message_buffer_cptr
! character, pointer :: message_buffer(:)
! Get the actual system error code
!
! last_error = GetLastError ()
! Get the string corresponding to this error
! Use the option to have Windows allocate the message buffer - it puts the
! address in the lpBuffer argument. Here we pass it the C_PTR message_buffer_cptr,
! using TRANSFER to cast the address to an LPVOID. FORMAT_MESSAGE_IGNORE_INSERTS
! is used so that it doesn't try looking for arguments - a possible security violation.
! Again, we're using C interoperability features.
!
! nTchars = FormatMessage ( &
! dwFlags=IANY([FORMAT_MESSAGE_FROM_SYSTEM, FORMAT_MESSAGE_IGNORE_INSERTS, FORMAT_MESSAGE_ALLOCATE_BUFFER]), &
! lpSource=NULL, & ! ignored
! dwMessageId=last_error, &
! dwLanguageId=0, & ! will use a default
! lpBuffer=TRANSFER(C_LOC(message_buffer_cptr), 0_LPVOID), &
! nSize=100, & ! minimum size to allocate
! arguments=NULL)
! if (nTchars == 0) then
! write (*,'(A,Z8.8,3A,Z8.8)') "Format message failed for status ", last_error, " while ", &
! string, ": error status = ", GetLastError()
! else
! ! message_buffer_cptr is now pointing to the message. Use C_F_POINTER to convert
! ! this to an array of characters. Note the use of the Fortran 2008 unlimited
! ! repeat count specifier.
! call C_F_POINTER (message_buffer_cptr, message_buffer, [nTchars])
! write (*,'(3A,*(A))') "Error while ", string, ": ", message_buffer
! ! Free the memory Windows allocated for the message string
! ret = LocalFree (hMem=TRANSFER(message_buffer_cptr, 0_HANDLE))
! end if
! stop
END SUBROUTINE print_error
END MODULE DynamicLoad ! We have finished defining everything that we know about the DLL, we can end the module definition.
SUBROUTINE rt_onestep_begin
USE DynamicLoad
CALL IMPORT_ROUTINES()
END SUBROUTINE rt_onestep_begin
SUBROUTINE RT_ONESTEP_DYNAMICS(c1,c2,o1)
USE DynamicLoad
INCLUDE "nd.h"
INCLUDE "s0.h"
INCLUDE "branches.h"
REAL c1,c2
REAL o1
! Now call the function in a loop
!
! write (*,'(/A, G0)') "Calling USERFUNC with argument ", i
CALL rt_onestepPointer(c1,c2,o1)
! write (*,'(A,G0)') "USERFUNC returned ", ret
! End of main program
RETURN
END SUBROUTINE RT_ONESTEP_DYNAMICS
Leave a Comment