Line data Source code
1 : !F90 ISO_C_BINDING wrapper for socket communication.
2 : !MG got it from https://github.com/i-pi/i-pi/tree/master/drivers
3 :
4 : !Copyright (C) 2013, Michele Ceriotti
5 :
6 : !Permission is hereby granted, free of charge, to any person obtaining
7 : !a copy of this software and associated documentation files (the
8 : !"Software"), to deal in the Software without restriction, including
9 : !without limitation the rights to use, copy, modify, merge, publish,
10 : !distribute, sublicense, and/or sell copies of the Software, and to
11 : !permit persons to whom the Software is furnished to do so, subject to
12 : !the following conditions:
13 :
14 : !The above copyright notice and this permission notice shall be included
15 : !in all copies or substantial portions of the Software.
16 :
17 : !THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
18 : !EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
19 : !MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
20 : !IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
21 : !CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
22 : !TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
23 : !SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
24 :
25 :
26 : !Contains both the functions that transmit data to the socket and read the data
27 : !back out again once finished, and the function which opens the socket initially.
28 :
29 : !Functions:
30 : ! open_socket: Opens a socket with the required host server, socket type and port number.
31 : ! write_buffer: Writes a string to the socket.
32 : ! read_buffer: Reads data from the socket.
33 :
34 : #if defined HAVE_CONFIG_H
35 : #include "config.h"
36 : #endif
37 :
38 : MODULE m_fsockets
39 :
40 : use, intrinsic :: iso_c_binding
41 :
42 : IMPLICIT NONE
43 :
44 : INTERFACE writebuffer
45 : MODULE PROCEDURE writebuffer_s, writebuffer_d, writebuffer_dv, writebuffer_i
46 : END INTERFACE writebuffer
47 :
48 : INTERFACE readbuffer
49 : MODULE PROCEDURE readbuffer_s, readbuffer_dv, readbuffer_d, readbuffer_i
50 : END INTERFACE readbuffer
51 :
52 : INTERFACE
53 : SUBROUTINE open_csocket(psockfd, inet, port, host) BIND(C, name="open_socket")
54 : use, intrinsic :: iso_c_binding
55 : INTEGER(KIND=C_INT) :: psockfd, inet, port
56 : CHARACTER(KIND=C_CHAR), DIMENSION(*) :: host
57 : END SUBROUTINE open_csocket
58 :
59 : SUBROUTINE writebuffer_csocket(psockfd, pdata, plen) BIND(C, name="writebuffer")
60 : use, intrinsic :: iso_c_binding
61 : INTEGER(KIND=C_INT) :: psockfd
62 : TYPE(C_PTR), VALUE :: pdata
63 : INTEGER(KIND=C_INT) :: plen
64 : END SUBROUTINE writebuffer_csocket
65 :
66 : SUBROUTINE readbuffer_csocket(psockfd, pdata, plen) BIND(C, name="readbuffer")
67 : use, intrinsic :: iso_c_binding
68 : INTEGER(KIND=C_INT) :: psockfd
69 : TYPE(C_PTR), VALUE :: pdata
70 : INTEGER(KIND=C_INT) :: plen
71 : END SUBROUTINE readbuffer_csocket
72 : END INTERFACE
73 :
74 : CONTAINS
75 :
76 0 : SUBROUTINE open_socket(psockfd, inet, port, host)
77 : INTEGER, INTENT(IN) :: inet, port
78 : INTEGER, INTENT(OUT) :: psockfd
79 : CHARACTER(LEN=1024), INTENT(IN) :: host
80 : CHARACTER(LEN=1,KIND=C_CHAR) :: chost(1024)
81 :
82 0 : CALL fstr2cstr(host, chost)
83 0 : CALL open_csocket(psockfd, inet, port, host)
84 0 : END SUBROUTINE open_socket
85 :
86 0 : SUBROUTINE fstr2cstr(fstr, cstr, plen)
87 : CHARACTER(LEN=*), INTENT(IN) :: fstr
88 : CHARACTER(LEN=1,KIND=C_CHAR), INTENT(OUT) :: cstr(:)
89 : INTEGER, INTENT(IN), OPTIONAL :: plen
90 :
91 : INTEGER i,n
92 0 : IF (PRESENT(plen)) THEN
93 0 : n = plen
94 0 : DO i=1,n
95 0 : cstr(i) = fstr(i:i)
96 : ENDDO
97 : ELSE
98 0 : n = LEN_TRIM(fstr)
99 0 : DO i=1,n
100 0 : cstr(i) = fstr(i:i)
101 : ENDDO
102 0 : cstr(n+1) = C_NULL_CHAR
103 : END IF
104 0 : END SUBROUTINE fstr2cstr
105 :
106 0 : SUBROUTINE writebuffer_d (psockfd, fdata)
107 : use, intrinsic :: iso_c_binding
108 : INTEGER, INTENT(IN) :: psockfd
109 : REAL(KIND=8), INTENT(IN) :: fdata
110 :
111 : REAL(KIND=C_DOUBLE), TARGET :: cdata
112 :
113 0 : cdata = fdata
114 0 : CALL writebuffer_csocket(psockfd, c_loc(cdata), 8)
115 0 : END SUBROUTINE writebuffer_d
116 :
117 0 : SUBROUTINE writebuffer_i (psockfd, fdata)
118 : use, intrinsic :: iso_c_binding
119 : INTEGER, INTENT(IN) :: psockfd, fdata
120 :
121 : INTEGER(KIND=C_INT), TARGET :: cdata
122 :
123 0 : cdata = fdata
124 0 : CALL writebuffer_csocket(psockfd, c_loc(cdata), 4)
125 0 : END SUBROUTINE writebuffer_i
126 :
127 0 : SUBROUTINE writebuffer_s (psockfd, fstring, plen)
128 : use, intrinsic :: iso_c_binding
129 : INTEGER, INTENT(IN) :: psockfd
130 : CHARACTER(LEN=*), INTENT(IN) :: fstring
131 : INTEGER, INTENT(IN) :: plen
132 :
133 : INTEGER :: i
134 0 : CHARACTER(LEN=1, KIND=C_CHAR), TARGET :: cstring(plen)
135 :
136 0 : DO i = 1,plen
137 0 : cstring(i) = fstring(i:i)
138 : ENDDO
139 0 : CALL writebuffer_csocket(psockfd, c_loc(cstring(1)), plen)
140 0 : END SUBROUTINE writebuffer_s
141 :
142 0 : SUBROUTINE writebuffer_dv(psockfd, fdata, plen)
143 : use, intrinsic :: iso_c_binding
144 : INTEGER, INTENT(IN) :: psockfd, plen
145 : REAL(KIND=8), INTENT(IN), TARGET :: fdata(plen)
146 :
147 0 : CALL writebuffer_csocket(psockfd, c_loc(fdata(1)), 8*plen)
148 0 : END SUBROUTINE writebuffer_dv
149 :
150 0 : SUBROUTINE readbuffer_d (psockfd, fdata)
151 : use, intrinsic :: iso_c_binding
152 : INTEGER, INTENT(IN) :: psockfd
153 : REAL(KIND=8), INTENT(OUT) :: fdata
154 :
155 : REAL(KIND=C_DOUBLE), TARGET :: cdata
156 :
157 0 : CALL readbuffer_csocket(psockfd, c_loc(cdata), 8)
158 0 : fdata=cdata
159 0 : END SUBROUTINE readbuffer_d
160 :
161 0 : SUBROUTINE readbuffer_i (psockfd, fdata)
162 : use, intrinsic :: iso_c_binding
163 : INTEGER, INTENT(IN) :: psockfd
164 : INTEGER, INTENT(OUT) :: fdata
165 :
166 : INTEGER(KIND=C_INT), TARGET :: cdata
167 :
168 0 : CALL readbuffer_csocket(psockfd, c_loc(cdata), 4)
169 0 : fdata = cdata
170 0 : END SUBROUTINE readbuffer_i
171 :
172 0 : SUBROUTINE readbuffer_s (psockfd, fstring, plen)
173 : use, intrinsic :: iso_c_binding
174 : INTEGER, INTENT(IN) :: psockfd
175 : CHARACTER(LEN=*), INTENT(OUT) :: fstring
176 : INTEGER, INTENT(IN) :: plen
177 :
178 : INTEGER :: i
179 0 : CHARACTER(LEN=1, KIND=C_CHAR), TARGET :: cstring(plen)
180 :
181 0 : CALL readbuffer_csocket(psockfd, c_loc(cstring(1)), plen)
182 0 : fstring=""
183 0 : DO i = 1,plen
184 0 : fstring(i:i) = cstring(i)
185 : ENDDO
186 0 : END SUBROUTINE readbuffer_s
187 :
188 0 : SUBROUTINE readbuffer_dv(psockfd, fdata, plen)
189 : use, intrinsic :: iso_c_binding
190 : INTEGER, INTENT(IN) :: psockfd, plen
191 : REAL(KIND=8), INTENT(OUT), TARGET :: fdata(plen)
192 :
193 0 : CALL readbuffer_csocket(psockfd, c_loc(fdata(1)), 8*plen)
194 0 : END SUBROUTINE readbuffer_dv
195 :
196 0 : SUBROUTINE socket_from_string (srvaddress, socket)
197 : CHARACTER(len=*), INTENT(IN) :: srvaddress
198 : integer, INTENT(out) :: socket
199 0 : CHARACTER(len=len_trim(srvaddress)) :: address
200 : INTEGER :: port, inet, field_sep_pos
201 :
202 : ! Parses host name, port and socket type
203 0 : field_sep_pos = INDEX(srvaddress, ':', back=.true.)
204 0 : address = srvaddress(1:field_sep_pos-1)
205 :
206 : ! Check if UNIX type socket
207 0 : IF (trim(srvaddress(field_sep_pos+1 :)) == 'UNIX') then
208 0 : port = 1234 ! just a place-holder
209 0 : inet = 0
210 : !write(*,*) " Connecting to `", trim(address), "` using UNIX socket"
211 : ELSE
212 0 : read ( srvaddress ( field_sep_pos+1 : ), * ) port
213 0 : inet = 1
214 : !write(*,*) " Connecting to `", trim(address), ":", srvaddress (field_sep_pos+1:), " using INET socket"
215 : END IF
216 :
217 : ! Create the socket
218 0 : CALL open_socket (socket, inet, port, trim(address)//achar(0))
219 :
220 0 : END SUBROUTINE socket_from_string
221 :
222 0 : END MODULE m_fsockets
|
