■

Fortranでインターネッツ。ping を打ってみます。

Linker のオプション。iphlpapi.lib を加える必要があります。

PROGRAM ping
USE ifwin
IMPLICIT NONE
!
TYPE :: t_ip_option_information
 INTEGER (UCHAR) :: Ttl
 INTEGER (UCHAR) :: Tos
 INTEGER (UCHAR) :: Flags
 INTEGER (UCHAR) :: OptionsSize
 INTEGER (PUCHAR) :: OptionsData
END TYPE
!
TYPE :: IPAddr
 INTEGER (UCHAR) :: iadd(4) 
END TYPE
!
TYPE :: t_icmp_echo_reply
  TYPE    (IPAddr) :: Address     !            // Replying address
  INTEGER (ULONG) ::  Status     !           // Reply IP_STATUS
  INTEGER (ULONG) ::  RoundTripTime   !      // RTT in milliseconds
  INTEGER (USHORT) :: DataSize   !           // Reply data size in bytes
  INTEGER (USHORT) :: Reserved   !           // Reserved for system use
  INTEGER (PVOID)  :: pData       !           // Pointer to the reply data
  TYPE (t_ip_option_information) :: Option   ! // Reply options
  CHARACTER (LEN = 1000) :: dummy ! ????
END TYPE
!
INTERFACE
 INTEGER (HANDLE) FUNCTION IcmpCreateFile()
 USE ifwinty
 !DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'IcmpCreateFile' :: IcmpCreateFile
 END FUNCTION
!
 INTEGER (DWORD) FUNCTION IcmpSendEcho(arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8)
 USE ifwinty
 !DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'IcmpSendEcho' :: IcmpSendEcho
 IMPORT !FORTRAN2003
 INTEGER (HANDLE) :: arg1
 TYPE (IPAddr)    :: arg2
 INTEGER (LPVOID) :: arg3
 INTEGER (WORD)   :: arg4
 INTEGER (LPLONG) :: arg5
 INTEGER (LPVOID) :: arg6
 INTEGER (DWORD)  :: arg7
 INTEGER (DWORD)  :: arg8
 END FUNCTION
END INTERFACE
!
INTEGER (DWORD) :: dwret
INTEGER (HANDLE) :: hicmp, hIP
TYPE (t_icmp_echo_reply) :: reply
POINTER (pIcmpCreateFile , IcmpCreateFile )
POINTER (pIcmpSendEcho   , IcmpSendEcho   )
CHARACTER (LEN = 100) :: send_data = ' '//CHAR(0)
TYPE (IPAddr) :: address
!address%iadd = (/209, 131, 36, 158/) ! Yahoo
address%iadd = (/59, 106, 108, 77/) ! Hatena
hIcmp  = LoadLibrary("ICMP.DLL")
pIcmpCreateFile  = GetProcAddress(hIcmp, "IcmpCreateFile")
pIcmpSendEcho    = GetProcAddress(hIcmp, "IcmpSendEcho"  )
hIP = IcmpCreateFile()
dwret = IcmpSendEcho(hIP, address, LOC(send_data), LEN(send_data), NULL, LOC(Reply), SIZEOF(Reply), 1000)
IF (dwret == 0) STOP 'error'
print *, reply%address, ' : ip '
print *, reply%RoundTripTime, 'mSec'
if (reply%status /= 0) print *, 'error code', reply%status, ' :: 11010 = time out' 
STOP
END PROGRAM ping