Fortran and Sockets

Fortran and Sockets

I can't seem to find any working examples of programming with sockets in Fortran. Does anyone have

a good resource on this subject.

10 posts / 0 new
Last post
For more complete information about compiler optimizations, see our Optimization Notice.

Programming with sockets was mentioned here by Jugoslav Dujic but link to some examples is not working now. I think resources are only in C language.

If you need only functionality of http and ftp you can try wininet extension of sockets from microsoft (I am adding small example, you should link it agains wininet.lib)

use dfwinty
integer(HANDLE) hInternet
integer(HANDLE) hFile
character*10000 buffer
integer*4 iRead
logical*4 bret

integer*4,parameter :: INTERNET_OPEN_TYPE_DIRECT                       =1
integer*4,parameter :: INTERNET_FLAG_NO_CACHE_WRITE    =#04000000

interface
integer(handle) function  InternetOpen(d0,d1,d2,d3,d4) 
	use dfwinty
	!DEC$ ATTRIBUTES DEFAULT :: InternetOpen
	!DEC$IF DEFINED(_X86_)
	!DEC$ ATTRIBUTES STDCALL, ALIAS : '_InternetOpenA@20' :: InternetOpen
	!DEC$ELSE
	!DEC$ ATTRIBUTES STDCALL, ALIAS :  'InternetOpenA'  :: InternetOpen
	!DEC$ENDIF
	!DEC$ ATTRIBUTES REFERENCE :: d0,d2,d3
	!InternetOpenA(LPCSTR ,DWORD ,LPCSTR ,LPCSTR ,DWORD);
	character*(*) d0,d2,d3
	integer*4 d1,d4 
end function 

integer(handle) function  InternetOpenUrl(d0,d1,d2,d3,d4,d5) 
	use dfwinty
	!DEC$ ATTRIBUTES DEFAULT :: InternetOpenUrl
	!DEC$IF DEFINED(_X86_)
	!DEC$ ATTRIBUTES STDCALL, ALIAS : '_InternetOpenUrlA@24' :: InternetOpenUrl
	!DEC$ELSE
	!DEC$ ATTRIBUTES STDCALL, ALIAS :  'InternetOpenUrlA'  :: InternetOpenUrl
	!DEC$ENDIF
	!DEC$ ATTRIBUTES REFERENCE :: d1,d2
	! InternetOpenUrlA(HINTERNET ,LPCSTR ,LPCSTR ,DWORD ,DWORD ,DWORD_PTR);
	character*(*) d1,d2
	integer*4 d3,d4
	integer(HANDLE)  d0,d5
end function 

logical*4 function  InternetReadFile(d0,d1,d2,d3) 
	use dfwinty
	!DEC$ ATTRIBUTES DEFAULT :: InternetReadFile
	!DEC$IF DEFINED(_X86_)
	!DEC$ ATTRIBUTES STDCALL, ALIAS : '_InternetReadFile@16' :: InternetReadFile
	!DEC$ELSE
	!DEC$ ATTRIBUTES STDCALL, ALIAS :  'InternetReadFile'  :: InternetReadFile
	!DEC$ENDIF
	!DEC$ ATTRIBUTES REFERENCE :: d1,d3
	! InternetReadFile( HINTERNET ,LPVOID ,DWORD ,LPDWORD );
	character*(*) d1
	integer*4 d2,d3
	integer(HANDLE)  d0
end function 

logical*4 function  InternetCloseHandle(d0) 
	use dfwinty
	!DEC$ ATTRIBUTES DEFAULT :: InternetCloseHandle
	!DEC$IF DEFINED(_X86_)
	!DEC$ ATTRIBUTES STDCALL, ALIAS : '_InternetCloseHandle@4' :: InternetCloseHandle
	!DEC$ELSE
	!DEC$ ATTRIBUTES STDCALL, ALIAS :  'InternetCloseHandle'  :: InternetCloseHandle
	!DEC$ENDIF
	integer(HANDLE)  d0
end function 

end interface


hInternet = InternetOpen("Test"C, INTERNET_OPEN_TYPE_DIRECT, NULL_CHARACTER,&
								 NULL_CHARACTER,&
			INTERNET_FLAG_NO_CACHE_WRITE)
hFile = InternetOpenUrl( hInternet, "http://www.google.com", NULL_CHARACTER, 0, 0, 0 ) ;
ibuffer=1
do while (InternetReadFile( hFile, buffer(ibuffer:ibuffer), len(buffer)-ibuffer+1, iRead))
	if ( iRead == 0) then
		exit
	endif
    ibuffer=ibuffer+iread
enddo
bret=InternetCloseHandle(hFile)
bret=InternetCloseHandle(hInternet)

Jakub

If you email me g.bogle@auckland.ac.nz I'll send you the code I'm using.

Gib

Thank you for the reply. I do got this error:

error #6404: This name does not have a type, and must have an explicit type. [IBUFFER]

and wonder if inbuffer is something that I should declare or am i missing a USE module.

and since I get this error a syntax error for "logicallogical*4 bret" in this example, I

wonder if thats where I buffer should be declared. I dont think so, however since I buffer appears

to be a character array.

That should be just "logical" - this is an error in the code formatter in the forum. We'll fix that.

ibuffer is counter variable so it is integer*4.

My example may miss some declarations, because I get it from my real code and did not tested it if it is ok. If you will have problems to make it work I can prepare working example.

I am sorry.

Jakub

I have a GitHub project that demonstrates how to implement a TCP/IP sockets based client and server using Intel Visual FORTRAN.

The source code is located at the following link.

https://github.com/lassytouton/LittleDemos/tree/master/Intel%20Visual%20FORTRAN%20TCP%20IP%20Sockets%20Based%20Client%20Server

Thanks!

My colleague and I decided yesterday to implement sockets based communication between processes (so you dont need to have both processes on one machine).

I will look through it.

I have an older link in my favourites list, but I dont know, if it works. Its about Winsocks...
http://prasinos.blog2.fc2.com/blog-entry-21.html

Markus

Edit: I formatted the source code of the link and I had to add line 101 to get it compiled...

module winsock_types
	implicit none

	type wsadata
		integer(2):: version
		integer(2):: highversion
		character(257):: szDescription
		character(129):: szSystemStatus
		integer(2):: maxSockets
		integer(2):: maxUdpdg
		integer(4):: lpVenderinfo
	end type

	type sockaddr_in
		sequence
		integer(2):: sin_family
		integer(2):: sin_port
		integer(4):: sin_addr
		integer(4):: sin_zero(2)
	end type

	type socket_t
		integer(4):: ival
	end type

	type hostent_t
		integer(4):: h_name
		integer(4):: h_aliases
		integer(2):: h_addrtype
		integer(2):: h_length
		integer(4):: h_addr_list
	end type

end module

module winsock
	use winsock_types
	implicit none
	interface

		integer(4) function wsastartup(reqver, wsainfo)
			!dec$ attributes dllimport, alias: '_WSAStartup@8' :: WSAStartup
			use winsock_types
			integer(2), intent(in):: reqver
			!dec$ attributes value:: reqver
			type(wsadata), intent(out):: wsainfo
		end function

		integer(4) function wsacleanup()
			!dec$ attributes stdcall, dllimport, alias: '_WSACleanup@0' :: WSACleanup
		end function

		integer(4) function wsagetlasterror()
			!dec$ attributes stdcall, dllimport, alias: '_WSAGetLastError@0' :: WSAGetLastError
		end function

		function socket(af, type, protocol) result(result)
			!dec$ attributes stdcall, dllimport, alias: '_socket@12' :: socket
			use winsock_types
			integer(4), intent(in):: af
			integer(4), intent(in):: type
			integer(4), intent(in):: protocol
			type(socket_t):: result
		end function

		integer(4) function closesocket(s)
			!dec$ attributes stdcall, dllimport, alias: '_closesocket@4' :: closesocket
			use winsock_types
			type(socket_t), intent(in):: s
		end function

	end interface

	integer(4), parameter:: AF_UNIX = 1
	integer(4), parameter:: AF_INET = 2
	integer(4), parameter:: AF_INET6 = 23
	integer(4), parameter:: SOCK_STREAM = 1
	integer(4), parameter:: SOCK_DGRAM =	2
	type(socket_t), parameter:: INVALID_SOCKET = socket_t(not(0))
	integer(4), parameter:: SOCKET_ERROR = -1
	type(sockaddr_in), parameter:: SOCKADDR_IN_ANY = sockaddr_in(AF_INET, 0, &
	& 0, (/2 * 0/))

	interface operator(==)
		module procedure socket_eq
	end interface

	interface

		integer(4) function bind(s, name, namelen)
			!dec$ attributes stdcall, dllimport, alias: '_bind@12' :: bind
			use winsock_types
			type(socket_t), intent(in):: s
			type(sockaddr_in), intent(in):: name
			!dec$ attributes reference:: name
			integer(4), intent(in):: namelen
		end function

		function accept(s, addr, addrlen) result(result)
			!dec$ attributes stdcall, dllimport, alias: '_accept@12' :: accept
            !DEC$ ATTRIBUTES REFERENCE :: addrlen
			use winsock_types
			type(socket_t), intent(in):: s
			type(sockaddr_in), intent(out):: addr
			!dec$ attributes reference:: addr
			integer(4), intent(out):: addrlen
			type(socket_t):: result
		end function

		! GUISE: return value is pointer to HOSTENT structure
		integer(4) function gethostbyname(szname)
			!dec$ attributes stdcall, dllimport, alias: '_gethostbyname@4' :: gethostbyname
			character(*), intent(in):: szname
			!dec$ attributes reference:: szname
		end function

		integer(4) function inet_addr(szname)
			!dec$ attributes stdcall, dllimport, alias: '_inet_addr@4' :: inet_addr
			character(*), intent(in):: szname
			!dec$ attributes reference:: szname
		end function

		integer(4) function connect(s, name, namelen)
			!dec$ attributes stdcall, dllimport, alias: '_connect@12' :: connect
			use winsock_types
			type(socket_t), intent(in):: s
			type(sockaddr_in), intent(in):: name
			!dec$ attributes reference:: name
			integer(4), intent(in):: namelen
		end function

	end interface

	interface send

		integer(4) function sendc(s, buf, len, flags)
			!dec$ attributes stdcall, dllimport, alias: '_send@16' :: sendc
			use winsock_types
			type(socket_t), intent(in):: s
			character(*), intent(in):: buf
			!dec$ attributes reference:: buf
			integer(4), intent(in):: len, flags
		end function

		integer(4) function send4(s, buf, len, flags)
			!dec$ attributes stdcall, dllimport, alias: '_send@16' :: send4
			use winsock_types
			type(socket_t), intent(in):: s
			integer, intent(in):: buf(*)
			!dec$ attributes reference:: buf
			integer(4), intent(in):: len, flags
		end function

	end interface

	interface recv

		integer(4) function recvc(s, buf, len, flags)
			!dec$ attributes stdcall, dllimport, alias: '_recv@16' :: recvc
			use winsock_types
			type(socket_t), intent(in):: s
			character(*), intent(out):: buf
			!dec$ attributes reference:: buf
			integer(4), intent(in):: len, flags
		end function

		integer(4) function recv4(s, buf, len, flags)
			!dec$ attributes stdcall, dllimport, alias: '_recv@16' :: recv4
			use winsock_types
			type(socket_t), intent(in):: s
			integer, intent(out):: buf(*)
			!dec$ attributes reference:: buf
			integer(4), intent(in):: len, flags
		end function

	end interface

contains

	logical function socket_eq(s1, s2) result(result)
		type(socket_t), intent(in):: s1, s2
		result = s1%ival == s2%ival
	end function

	type(sockaddr_in) function make_sockaddr_in(name, port) result(result)
		character(*), intent(in):: name
		integer, intent(in):: port
		character(2048):: namebuf
		integer:: namelen
		integer(4):: addr, ival
		type(HOSTENT_T):: hostent
		integer(1):: bval(4)
		integer:: i
		pointer(addr, hostent)
		pointer(addr, ival)
		pointer(addr, bval)
		namebuf = name
		namelen = min(len(namebuf), len_trim(namebuf) + 1)
		namebuf(namelen:namelen) = char(0)
		addr = inet_addr(namebuf)
		if (addr /= not(0_4)) then
			result%sin_addr = addr
		else
			addr = gethostbyname(namebuf)
			if (addr == 0) then
				result%sin_addr = 255
				result%sin_port = 0
				return
			endif
			addr = hostent%h_addr_list
			addr = ival
			result%sin_addr = ival
		endif
		result%sin_family = AF_INET
!		result%sin_port = port
		result%sin_port = ior(ishft(iand(255, port), 8), iand(ishft(port, -8), 255))
		result%sin_zero(:) = 0
	end function

	character(60) function wsastrerror(errno) result(result)
		integer, intent(in), optional:: errno
		integer:: error_code
		if (present(errno)) then
			error_code = errno
		else
			error_code = wsagetlasterror()
		endif
		select case(error_code)
		case(10004); result = "interrupted function call"
		case(10009); result = "EBADF"
		case(10013); result = "permission denied"
		case(10014); result = "bad address"
		case(10022); result = "invalid function argument"
		case(10024); result = "too many open files"
		case(10035); result = "resource temporarily unavailable"
		case(10036); result = "operation now in progress"
		case(10037); result = "operation already in progress"
		case(10038); result = "socket operation on non-socket"
		case(10039); result = "destination address required"
		case(10040); result = "message too long"
		case(10041); result = "protocl wrong type for socket"
		case(10042); result = "bad protocol option"
		case(10043); result = "protocol not supported"
		case(10044); result = "socket type not supported"
		case(10045); result = "operation not supported"
		case(10046); result = "protocol family not supported"
		case(10047); result = "address family not supported by protocol family"
		case(10048); result = "address already in use"
		case(10049); result = "cannot assign requested address"
		case(10050); result = "network is down"
		case(10051); result = "network is unreachable"
		case(10052); result = "network dropped connection on reset"
		case(10053); result = "software caused connection abort"
		case(10054); result = "connection reset by peer"
		case(10055); result = "no buffer space is available"
		case(10056); result = "socket is already connected"
		case(10057); result = "socket is not connected"
		case(10058); result = "cannot send after socket shutdown"
		case(10059); result = "ETOOMANYREFS"
		case(10060); result = "connection timed out"
		case(10061); result = "connection refused"
		case(10062); result = "ELOOP"
		case(10063); result = "ENAMETOOLONG"
		case(10064); result = "host is down"
		case(10065); result = "no route to host"
		case(10066); result = "ENOTEMPTY"
		case(10067); result = "too many processes"
		case(10068); result = "EUSERS"
		case(10069); result = "EDQUOT"
		case(10070); result = "ESTALE"
		case(10071); result = "EREMOTE"
		case(10091); result = "network subsystem is unavailable"
		case(10092); result = "WINSOCK.DLL version out of range"
		case(10093); result = "successful WSAStartup not yet performed"
		case(10094); result = "graceful shutdown in progress"
		case(10101); result = "DISCON"
		case(10102); result = "NOMORE"
		case(10103); result = "CANCELLED"
		case(10104); result = "invalid procedure table from service provider"
		case(10105); result = "invalid service provider version number"
		case(10106); result = "unable to initialize a service provider"
		case(10107); result = "system call failure"
		case(10108); result = "SERVICE_NOT_FOUND"
		case(10109); result = "class type not found"
		case(10110); result = "NO_MORE"
		case(10111); result = "CANCELLED"
		case(10112); result = "REFUSED"
		case(11001); result = "authoritative DNS answer: host not found"
		case(11002); result = "non-authoritative: host not found; or server fail"
		case(11003); result = "non-recoverable DNS error FORMERR, REFUSED, or NOTIMP"
		case(11004); result = "no DNS data record of requested type"
		case default
			result = ""
			write(unit=result, fmt="('unknown Winsock error ',i12.1)") error_code
		end select
	end function

	character(1024) function sz2char(sz) result(result)
		character(*), intent(in):: sz
		character:: c
		integer:: i, j
		j = 1
		do, i = 1, len(sz)
			if ((j + 4) > len(result)) exit
			c = sz(i:i)
			select case(ichar(c))
			case(0)
				exit
			case(92)
				result(j:j+1) = c // c
				j = j + 2
			case(10)
				result(j:j+1) = char(92) // 'n'
				j = j + 2
			case(13)
				result(j:j+1) = char(92) // 'r'
				j = j + 2
			case(1:9, 11, 12, 14:31, 127:255)
				write(result(j:j+3), "(A2, Z2.2)") char(92) // 'x', ichar(c)
				j = j + 4
			case default
				result(j:j) = c
				j = j + 1
			end select
		enddo
		if (j < len(result)) then
			result(j: ) = ''
		endif
	end function

end module

subroutine main
	use winsock
	implicit none

	type(wsadata):: wsainfo
	integer(2):: reqver
	integer(4):: i
	type(socket_t):: s
	type(sockaddr_in):: sa
	character(1024):: buf

	reqver = 514
	i = wsastartup(reqver, wsainfo)
	print *, "WSAStartup =", i, wsainfo%version, wsainfo%highversion, &
	& "'"//trim(sz2char(wsainfo%szDescription))//"'("//trim(sz2char(wsainfo%szSystemStatus))//")"
	if (i /= 0) then
		stop 16
	endif

	s = socket(AF_INET, SOCK_STREAM, 0)
	print *, 'socket', s
	if (s == INVALID_SOCKET) then
		print *, 'socket:', wsastrerror()
		goto 900
	endif

	sa = make_sockaddr_in("www.asahi.com", 80)
	print *, ibits(sa%sin_addr, 0, 8), ibits(sa%sin_addr, 8, 8), &
		& ibits(sa%sin_addr, 16, 8), ibits(sa%sin_addr, 24, 8), &
		& ibits(sa%sin_port, 0, 8), ibits(sa%sin_port, 8, 8)
	if (sa%sin_port == 0) goto 900

	i = connect(s, sa, 16)
	print *, 'connect', i
	if (i == SOCKET_ERROR) then
		print *, 'connect:', wsastrerror()
		goto 910
	endif

	i = send(s, "GET /" // char(13) // char(10), 7, 0)
	if (i == SOCKET_ERROR) then
		print *, 'send:', wsastrerror()
		goto 910
	endif
	
	do	
		i = recv(s, buf, len(buf), 0)
		if (i == SOCKET_ERROR) then
			print *, 'recv:', wsastrerror()
			goto 910
		endif
		if (i == 0) exit
		print *, buf(1:i)
	enddo

	910 continue
	print *, 'closesocket', closesocket(s)
	print *, "WSACleanup =", wsacleanup()
	print *, "OK"
	return

	900 continue
	print *, "WSACleanup =", wsacleanup()
	print *, "OK"

end subroutine

call main
end

Are you sure that a buffer of 10,000 bytes is sufficient to handle all the datareceived from the open connection?

Best regards,
Sergey

I've updated my GitHub project demonstrating how to implement a TCP/IP sockets based client and server using Intel Visual FORTRAN... there was a bug in the original SendMsg routine implementation. This has now been fixed.

The source code is located at the following link.

https://github.com/lassytouton/LittleDemos/tree/master/Intel%20Visual%20FORTRAN%20TCP%20IP%20Sockets%20Based%20Client%20Server

Leave a Comment

Please sign in to add a comment. Not a member? Join today