Fortran and Sockets

[fbalderasintel]

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

a good resource on this subject.

[ZlamalJakub]

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)

[fortran]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)

[/fortran]

Jakub

[gib]

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

Gib

[fbalderasintel]

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.

[IDZ_A_Intel]

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

[ZlamalJakub]

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

[lassytouton]

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

[onkelhotte]

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

[bash]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[/bash]

[SergeyKostrov]

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

Best regards,
Sergey

[lassytouton]

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