program client
implicit none
integer n
do n=1,5
write(*, '(/A,G0)') '====>>> loading No. ',n
call loadAndRun
end do
end program

subroutine loadAndRun()
use kernel32
use, intrinsic :: iso_c_binding
implicit none

abstract interface
  function USERFUNC_int ()
!DEC$ ATTRIBUTES STDCALL :: USERFUNC_int
  integer USERFUNC_int
  end function USERFUNC_int
end interface

procedure(USERFUNC_int), pointer :: USERFUNC

integer(C_INTPTR_T) :: p_USERFUNC

integer(HANDLE) :: dll_handle
integer(BOOL) :: free_status
integer i, ret

write (*,'(A)') "Loading library..."
dll_handle = LoadLibrary (lpLibFileName="testDll.dll"//C_NULL_CHAR)
if (dll_handle == NULL) then
  call print_error ('loading DLL')
  stop
  end if

write (*,'(A)') "Getting routine address..."
p_USERFUNC = GetProcAddress (hModule=dll_handle, lpProcName="test"//C_NULL_CHAR)
if (p_USERFUNC == NULL) then
  call print_error ('looking up routine')
  stop
  end if
  
call C_F_PROCPOINTER (TRANSFER(p_USERFUNC, C_NULL_FUNPTR), USERFUNC)
  
  write (*,'(/A, G0)') "Calling USERFUN"
  ret = USERFUNC()
  write (*,'(A,G0)') "USERFUNC returned ", ret
  
write(*,'(/A)') "Unloading library..."
free_status = FreeLibrary (hLibModule=dll_handle)
if (free_status == 0) call print_error ('unloading DLL')

contains
!
subroutine print_error (string)
use kernel32
use, intrinsic :: iso_c_binding
implicit none

character(*), intent(IN) :: string

integer(DWORD) :: last_error
integer(DWORD) :: nTchars
integer(HANDLE) :: ret
type(C_PTR) :: message_buffer_cptr
character, pointer :: message_buffer(:)

last_error = GetLastError ()

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
  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 subroutine 


