Intel® Fortran Compiler
Build applications that can scale for the future with optimized code designed for Intel® Xeon® and compatible processors.
29274 Discussions

Implementing MODBUS via FORTRAN

cfann61
Beginner
‎12-26-2008 12:31 PM
1,916 Views

I'm trying to find some source code for a client/server application that will allow me to communicate between two PC's via MODBUS protocol. I have found a few variations in C++, but I'm having trouble understanding them. Does anybody know of/have any Fortran source that could help? Also, I would like to write this myself. It may be over my head right now though, as I am fairly new to this. If anyone could help or point me in the right direction, it would be GREATLY appreciated.

Thanks,

Chris

0 Kudos

Link Copied

5 Replies
GVautier
New Contributor III
‎12-28-2008 02:42 AM
1,916 Views

Hello

I have wrote an application in C/Linux that implements the modbus protocol.

I am not at work next week but, if you are interrested, I can send you the resources I have used.

Under Dos/Windows, the problem will be the buffering of serial IO that is implemented in Linux kernel.

Best regards

0 Kudos
Copy link
cfann61
Beginner
‎12-29-2008 06:05 AM
1,916 Views
That would be great. Thank you.

0 Kudos
Copy link
GVautier
New Contributor III
‎12-29-2008 06:17 AM
1,916 Views

Hello

I find the initial ressources I used :

http://pes.free.fr/

or

http://sourceforge.net/projects/libmodbus/ for more recent sources

I think that it will help you.

0 Kudos
Copy link
Paul_Curtis
Valued Contributor I
‎12-31-2008 12:13 AM
1,916 Views
Quoting - cfann61

I'm trying to find some source code for a client/server application that will allow me to communicate between two PC's via MODBUS protocol. I have found a few variations in C++, but I'm having trouble understanding them. Does anybody know of/have any Fortran source that could help? Also, I would like to write this myself. It may be over my head right now though, as I am fairly new to this. If anyone could help or point me in the right direction, it would be GREATLY appreciated.

Thanks,

Chris

The attached code module is a wholly F90 Modbus driver which frames Modbus commands, sends them out a designated serial or Winsock port, receives and parses the reply. This is taken from a much larger program, but the missing context elements are generic and should be pretty obvious. There are settable flags to deal with the huge variations in how devices from different manufacturers actually implement (or fail to implement) "standard" Modbus. Also, the program has a tracemode feature for writing debug info to either a text window or a file, so each element of each Modbus transaction is fully self-documenting. This code works perfectly with a great many Modbus devices (each of which have wholly custom register sets, etc.), all in a polled mode.

Well, AddFiles doesn't seem to work, so I'll try pasting the code:

[cpp]MODULE ModBus
	USE serial_defs
	USE charfunc
	USE tracediag
	
	PRIVATE
	PUBLIC Modbus_Read, Modbus_Write, Modbus_Read_Real, crc16
	
	INTEGER(KIND=2), SAVE           :: tns = 1
	
	!   real value byte order
	INTEGER, PARAMETER              :: FPB  = 1  ! big endian
	INTEGER, PARAMETER              :: FPBB = 2  ! big endian swapped
	INTEGER, PARAMETER              :: FPL  = 3  ! little endian
	INTEGER, PARAMETER              :: FPLB = 4  ! little endian swapped
	
	!   protocol variant bitflags
	!INTEGER, PARAMETER              :: modbus_preamble = 0
	!INTEGER, PARAMETER              :: modbus_crc      = 1
	
	INTEGER, PARAMETER              :: mb_buflen = 40
    TYPE mb_connection
        CHARACTER(LEN=mb_buflen)    :: buf      ! byte buffer
        INTEGER                     :: nbuf     ! byte count in buf
        LOGICAL                     :: trace    ! debug flag
        INTEGER                     :: flags    ! these attributes are
    END TYPE                                    !  defined in globals.f90
    
    !   "show message not value" flag for dump() routine
    !INTEGER, PARAMETER              :: showmsg = -1111

    !   fixed parameters for Modbus over TCP/IP
    !INTEGER, PARAMETER  :: Modbus_server_ip_port = 502  ! Z'1F6'
    !INTEGER, PARAMETER  :: Modbus_ip_protocol    = IPPROTO_TCP
	
	!   protocol variant bitflags
	!INTEGER, PARAMETER  :: modbus_preamble = 0
	!INTEGER, PARAMETER  :: modbus_crc      = 1
	!INTEGER, PARAMETER  :: modbus_32bit    = 2
	!INTEGER, PARAMETER  :: modbus_FPB      = 3  ! big endian
	!INTEGER, PARAMETER  :: modbus_FPBB     = 4  ! big endian swapped
	!INTEGER, PARAMETER  :: modbus_FPL      = 5  ! little endian
	!INTEGER, PARAMETER  :: modbus_FPLB     = 6  ! little endian swapped

  
CONTAINS    
    
    
	RECURSIVE SUBROUTINE ModBus_Write (sp, unit_id, reg_id, reg_val, flags)
		IMPLICIT NONE
		TYPE(serialport),INTENT(IN)			:: sp
		INTEGER, INTENT(IN)                 :: reg_id, unit_id, flags
		REAL, INTENT(IN)                    :: reg_val
		INTEGER								:: crc, nc
		TYPE(mb_connection), TARGET         :: c
		INTEGER, POINTER                    :: ngot
        
        ngot => c%nbuf
        c%trace = (tracing(sp) .AND. verbose)
        c%flags = flags
        
        CALL Modbus_Begin (c, unit_id)

        IF (BTEST(c%flags, modbus_32bit)) THEN
            CALL pack_INT  (c, 16,       1, 'function=multiwrite')
            CALL pack_INT  (c, reg_id-1, 2, 'starting register', .TRUE.)
            CALL pack_INT  (c, 2,        2, 'register count', .TRUE.)
            CALL pack_INT  (c, 4,        1, 'byte count', .TRUE.)
            CALL pack_REAL (c, reg_val, 'write value')
        
        ELSE
            CALL pack_INT (c, 6,        1, 'function=write')
            CALL pack_INT (c, reg_id-1, 2, 'starting register', .TRUE.)
            CALL pack_INT (c, IFIX(ANINT(reg_val)), 2, 'write value', .TRUE.)
        END IF
		
	    nc = Modbus_IO (sp, c)  ! byte position of tns_reply
		IF (demo .OR. nc <= 0) RETURN
        
        IF (c%trace) CALL dump (c%buf, 'starting register', nc+8, nc+9, showmsg, rx_color)
        nc = nc + 10

		IF (c%trace .AND. ngot >= nc+1) crc = unpack_INT(c, nc)

	END SUBROUTINE ModBus_Write


	RECURSIVE SUBROUTINE ModBus_Read (sp, unit_id, reg_id, reg_count, val, flags)
		IMPLICIT NONE
		TYPE(serialport), INTENT(IN)			:: sp
		INTEGER, INTENT(IN)                     :: unit_id, reg_id, reg_count, flags
		REAL, DIMENSION(reg_count), INTENT(OUT) :: val
		INTEGER                                 :: nc, j
		TYPE(mb_connection), TARGET             :: c
		INTEGER, POINTER                        :: ngot
        
        ngot    => c%nbuf
        c%trace =  (tracing(sp) .AND. verbose .AND. .NOT.trace_writeonly)
        c%flags =  flags

		!   register_count is actually the number of discrete
		!   values, corresponding to "register sets" which may
		!   be double-registers for 32bit float format
		val(1:reg_count) = unmeasured
        
        CALL Modbus_Begin (c, unit_id)

        CALL pack_INT (c, 3,         1, 'function=read')
        CALL pack_INT (c, reg_id-1,  2, 'starting register', .TRUE.)
        
        IF (BTEST(c%flags, modbus_32bit)) THEN
            CALL pack_INT (c, reg_count*2, 2, 'double registercount')
        ELSE
            CALL pack_INT (c, reg_count,   2, 'registercount')
        END IF
        
	    nc = Modbus_IO (sp, c)  ! nc == byte position of tns_reply
		IF (demo .OR. nc <= 0) RETURN
       
        IF (BTEST(c%flags, modbus_preamble)) THEN
        
            !   nc is the byte position of the transaction code
            IF (c%trace) CALL dump (c%buf, 'data bytecount', nc+8, nc+8, showmsg, rx_color, .TRUE.)
            nc = nc + 9                  ! 1st data byte in reply
		    
		ELSE
		
		    !   without preamble, nc is always 1
            IF (c%trace) THEN
                CALL dump (c%buf, 'data bytecount', nc+2, nc+2, showmsg, rx_color, .TRUE.)
            END IF
            nc = nc + 3                  ! 1st data byte in reply
		
		END IF
		
		!   32-bit floats, 4 bytes per value
        IF (BTEST(c%flags, modbus_32bit)) THEN
		    DO j = 1, reg_count
		        IF (ngot >= nc+3) val(j) = unpack_REAL(c, nc)
		        nc = nc + 4
		    END DO
		
		!   regular reads, 2 bytes per value
		ELSE
		    DO j = 1, reg_count
		        IF (ngot >= nc+1) val(j) = FLOAT(unpack_INT(c, nc))
		        nc = nc + 2
		    END DO
		
		END IF
		
	END SUBROUTINE ModBus_Read
	
	
    !   special routine for Honeywell UDC3300 (and others?) where REAL
    !   values are stored in contiguous 2-byte registers; this uses
    !   modbus function 4 instead of function 3
	RECURSIVE SUBROUTINE ModBus_Read_Real (sp, unit_id, reg_id, val, flags)
		IMPLICIT NONE
		TYPE(serialport), INTENT(IN)			:: sp
		INTEGER, INTENT(IN)                     :: reg_id, unit_id, flags
		REAL, INTENT(OUT)                       :: val
		INTEGER                                 :: nc, j
		TYPE(mb_connection), TARGET             :: c
		INTEGER, POINTER                        :: ngot
        
        ngot    => c%nbuf
        c%trace =  (tracing(sp) .AND. verbose)
        c%flags =  flags
		val     =  unmeasured
        
        CALL Modbus_Begin (c, unit_id)

        CALL pack_INT (c, 4,         1, 'function=read input')
        CALL pack_INT (c, reg_id-1,  2, 'starting register')
        CALL pack_INT (c, 2,         2, 'registercount for REAL')
        
	    nc = Modbus_IO (sp, c)  ! nc == byte position of tns_reply
		IF (demo .OR. nc <= 0) RETURN
       
        IF (BTEST(c%flags, modbus_preamble)) THEN
            IF (c%trace)    &
                CALL dump (c%buf, 'data bytecount', nc+8, nc+8, showmsg, rx_color, .TRUE.)
            nc = nc + 9                  ! 1st data byte in reply
		    IF (ngot >= nc+3) val = unpack_REAL(c, nc)
		
		ELSE
            IF (c%trace)    &
                CALL dump (c%buf, 'data bytecount', nc+2, nc+2, showmsg, rx_color, .TRUE.)
            nc = nc + 3                  ! 1st data byte in reply
		    IF (ngot >= nc+3) val = unpack_REAL(c, nc)
		
		END IF

	END SUBROUTINE ModBus_Read_Real
    
    
	RECURSIVE SUBROUTINE Modbus_Begin (c, unit_id)
	    IMPLICIT NONE
		TYPE(mb_connection), INTENT(INOUT) :: c
		INTEGER, INTENT(IN)     :: unit_id
		INTEGER                 :: local_tns, crc
        
        !   initialize communications buffer
        c%buf  = ''
        c%nbuf = 0
        
        IF (BTEST(c%flags, modbus_preamble)) THEN
    	
		    !   unique 2-byte transaction code
	 	    tns = tns + 1
		    IF (tns > 32767) tns = 1
		    local_tns = tns
            CALL pack_INT (c, local_tns, 2, 'transaction id')

            CALL pack_INT (c, 0,         2, 'modbus protocol')
        	
		    !   crc bytecount
		    IF (BTEST(c%flags, modbus_crc)) THEN
		        crc = 2
		    ELSE
		        crc = 0
		    END IF
            CALL pack_INT (c, 6 + crc,   2, 'payload bytecount')
        END IF
        
        CALL pack_INT (c, unit_id,   1, 'unit id')
        
    END SUBROUTINE Modbus_Begin
	
	
	RECURSIVE INTEGER FUNCTION Modbus_IO (sp, c) RESULT (nc)
	    IMPLICIT NONE
		TYPE(serialport),INTENT(IN)			       :: sp
		TYPE(mb_connection), TARGET, INTENT(INOUT) :: c
		CHARACTER(LEN=2)                           :: tns_reply
		INTEGER                                    :: iret

        nc = 0  ! error reply
        
		IF (use_mutex) THEN
		    SELECT CASE (WaitForSingleObject(ghMutex, mutex_wait))
		    CASE (WAIT_OBJECT_0, WAIT_ABANDONED)
		    CASE DEFAULT
		        RETURN
		    END SELECT
		END IF
	        
	    !   CRC calculation on the message contents only,
	    !   starting with the unit address
	    IF (BTEST(c%flags, modbus_crc)) THEN
	        IF (BTEST(c%flags, modbus_preamble)) THEN
	            nc = crc16(c%buf(7:), c%nbuf-6)
	        ELSE
	            nc = crc16(c%buf, c%nbuf)
	        END IF
	        CALL pack_INT (c,       IAND(nc, Z'00FF'),     1, 'CRC low byte')
	        CALL pack_INT (c, ISHFT(IAND(nc, Z'FF00'),-8), 1, 'CRC high byte')
	    END IF
	    
        tns_reply = c%buf(1:2)	    
		IF (Is_Winsock(sp%port)) THEN
		    CALL Set_Winsock_Port (sp)
            CALL Winsock_send (sp, c%buf, c%nbuf, forcehex=.TRUE.)
            c%nbuf = Winsock_receive (2, sp, c%buf, 20, forcehex=.TRUE.)
		    CALL Winsock_close (sp%port)
		ELSE
			CALL set_serial_port (sp)
            CALL serial_send (sp, c%buf, c%nbuf, forcehex=.TRUE.)
            c%nbuf = serial_read (sp, CHAR(0), c%buf, 20, forcehex=.TRUE.)
		    CALL serial_close (sp%port)
		END IF

        nc = 0  ! pre-set error reply
        IF (c%nbuf > 0) THEN
            IF (BTEST(c%flags, modbus_preamble)) THEN
                nc = INDEX(c%buf, tns_reply)
                IF (nc == 0) THEN
                    IF (c%trace) CALL trace_display ('No TNS reply', 12, darkred)
                ELSE
                    IF (c%trace) THEN
                        CALL dump (c%buf, 'transaction id',  nc,   nc+1, showmsg, rx_color)
                        CALL dump (c%buf, 'modbus protocol', nc+2, nc+3, showmsg, rx_color)
                        CALL dump (c%buf, 'reply bytecount', nc+4, nc+5, showmsg, rx_color, .TRUE.)
                        CALL dump (c%buf, 'unit id',         nc+6, nc+6, showmsg, rx_color)
                    END IF
                    IF (Modbus_ErrorCheck(c, nc+7)) nc = 0
                END IF
            
            !   different parsing if no preamble
            ELSE
                nc = 1  !   return should start with the unit_id
                IF (c%trace) CALL dump (c%buf, 'unit id', nc, nc, showmsg, rx_color)
                IF (Modbus_ErrorCheck(c, nc+1)) nc = 0
            END IF

        END IF
        IF (use_mutex) iret = ReleaseMutex (ghMutex)
 	    
	END FUNCTION Modbus_IO
	
	
	LOGICAL FUNCTION Modbus_ErrorCheck (c, ncfc)
	    IMPLICIT NONE
 	    TYPE(mb_connection), INTENT(IN)  :: c
        INTEGER, INTENT(IN)              :: ncfc ! byte position of function code
        INTEGER                          :: ncp1, mptr
		CHARACTER(LEN=20), DIMENSION(6)  :: msg = (/'function code error', &
		                                            'register addr error', &
		                                            'write illegal value', &
		                                            'unknown error code ', &
		                                            '===ERROR flag===   ', &
		                                            'function code      '  /) 

        !   error return == original function code + Z'80'
        Modbus_ErrorCheck = (ICHAR(c%buf(ncfc:ncfc)) > Z'80')

        IF (c%trace) THEN
            IF (Modbus_ErrorCheck) THEN
                CALL dump (c%buf, msg(5), ncfc, ncfc, showmsg, rx_color)
                ncp1 = ncfc + 1 ! following byte contains the error code
                mptr = ICHAR(c%buf(ncp1:ncp1))
                IF (mptr < 1 .OR. mptr > 3) mptr = 4
                CALL dump (c%buf, msg(mptr), ncp1, ncp1, showmsg, rx_color)
            ELSE
                CALL dump (c%buf, msg(6), ncfc, ncfc, showmsg, rx_color)
            END IF
        END IF
        
    END FUNCTION Modbus_ErrorCheck
	    

    
    RECURSIVE SUBROUTINE pack_INT (c, ival, ilen, legend, showit)
        IMPLICIT NONE
 	    TYPE(mb_connection), INTENT(INOUT), TARGET  :: c
        INTEGER, INTENT(IN)                         :: ival, ilen
        CHARACTER(LEN=*), INTENT(IN)                :: legend
        LOGICAL, INTENT(IN), OPTIONAL               :: showit
        
        CHARACTER(LEN=mb_buflen), POINTER           :: buf
        INTEGER, POINTER                            :: nb
        nb  => c%nbuf
        buf => c%buf
        
        !   modbus byte-order is big-endian
        SELECT CASE (ilen)
        CASE (1)
            buf(nb+1:nb+1) = CHAR(IAND(ival, Z'000000FF'))
        CASE (2)    
            buf(nb+1:nb+1) = CHAR(ISHFT(IAND(ival, Z'0000FF00'),-8))
            buf(nb+2:nb+2) = CHAR(IAND(ival, Z'000000FF'))
        END SELECT
        
        IF (c%trace) THEN
            IF (PRESENT(showit)) THEN
                CALL dump (buf, legend, nb+1, nb+ilen, ival, tx_color, .TRUE.)
            ELSE
                CALL dump (buf, legend, nb+1, nb+ilen, ival, tx_color)
            END IF
        END IF
        
        nb = nb + ilen
    END SUBROUTINE pack_INT

    
    RECURSIVE INTEGER FUNCTION unpack_INT (c, nb) RESULT (ival)
        IMPLICIT NONE
 	    TYPE(mb_connection), INTENT(IN) :: c
 	    INTEGER, INTENT(IN)             :: nb
        CHARACTER(LEN=2)                :: buf
        buf = c%buf(nb:)
        
        !   assume data is packed big-endian
        ival = 256*ICHAR(buf(1:1)) + ICHAR(buf(2:2))
        
        IF (c%trace) CALL dump (buf, 'data bytes', 1, 2, ival, rx_color, .TRUE.)
    END FUNCTION unpack_INT

    
    RECURSIVE SUBROUTINE pack_REAL (c, val, legend)
        IMPLICIT NONE
 	    TYPE(mb_connection), INTENT(INOUT), TARGET  :: c
 	    REAL, INTENT(IN)                            :: val
        CHARACTER(LEN=*), INTENT(IN)                :: legend
 	    
 	    REAL                                        :: rval
        CHARACTER(LEN=4)                            :: rbuf
        EQUIVALENCE(rval, rbuf)
        
        CHARACTER(LEN=mb_buflen), POINTER           :: buf
        INTEGER, POINTER                            :: nb
        nb  => c%nbuf
        buf => c%buf
        
        rval = val
        buf(nb+1:) = RealByteOrder(rbuf, c%flags)
        
        IF (c%trace) CALL rdump (buf, legend, nb+1, val, tx_color)
        
        nb = nb + 4
    END SUBROUTINE pack_REAL
    
    
    RECURSIVE REAL FUNCTION unpack_REAL (c, nb) RESULT (rval)
        IMPLICIT NONE
 	    TYPE(mb_connection), INTENT(IN) :: c
 	    INTEGER, INTENT(IN)             :: nb
 	    INTEGER                         :: j
 	    REAL                            :: rbuf
        CHARACTER(LEN=4)                :: buf
        EQUIVALENCE(rbuf, buf)
        
        buf = RealByteOrder(c%buf(nb:), c%flags)
        rval = rbuf
        
        IF (c%trace) CALL rdump (buf, 'data bytes', 1, rval, rx_color)
        
    END FUNCTION unpack_REAL
    
    
    !   byte-order repacking for REALs
    RECURSIVE FUNCTION RealByteOrder (buf1, flags) RESULT (buf2)
        IMPLICIT NONE
        INTEGER, INTENT(IN)             :: flags
        CHARACTER(LEN=4), INTENT(IN)    :: buf1
        CHARACTER(LEN=4)                :: buf2
        
        !   rearrange byte-order for REALs; only
        !   one of these bitflags will be set for
        !   a given device
        
        !   little-endian
        IF      (BTEST(flags, modbus_FPL)) THEN
            buf2(1:1) = buf1(4:4)
            buf2(2:2) = buf1(3:3)
            buf2(3:3) = buf1(2:2)
            buf2(4:4) = buf1(1:1)
            
        !   big-endian byte-swapped
        ELSE IF (BTEST(flags, modbus_FPBB)) THEN
            buf2(3:3) = buf1(4:4)
            buf2(4:4) = buf1(3:3)
            buf2(1:1) = buf1(2:2)
            buf2(2:2) = buf1(1:1)
            
        !   little-endian byte-swapped
        ELSE IF (BTEST(flags, modbus_FPLB)) THEN
            buf2(1:1) = buf1(2:2)
            buf2(2:2) = buf1(1:1)
            buf2(3:3) = buf1(4:4)
            buf2(4:4) = buf1(3:3)
        
        !   big-endian (Intel default)
        ELSE
             buf2 = buf1
        
        END IF
       
    END FUNCTION RealByteOrder
    

    RECURSIVE INTEGER FUNCTION crc16 (string, nc) RESULT (crc)
        IMPLICIT NONE
        CHARACTER(LEN=*), INTENT(IN)    :: string
        INTEGER, INTENT(IN)             :: nc
        INTEGER                         :: j, bit
        
        crc = Z'FFFF'
        DO j = 1, nc
            crc = IEOR(crc, ICHAR(string(j:j)))
            DO bit = 0, 7
                IF (IAND(crc, Z'0001') > 0) THEN
                    crc = ISHFT(crc, -1)
                    crc = IEOR(crc, Z'A001')
                ELSE
                    crc = ISHFT(crc, -1)
                END IF
            END DO
        END DO
        
    END FUNCTION crc16
END MODULE modbus[/cpp]

0 Kudos
Copy link
cfann61
Beginner
‎01-02-2009 01:27 PM
1,916 Views

Thanks. Don't understand all of it yet. But I'm gonna look at it a while before I ask any questions.

0 Kudos
Copy link
Reply

Community support is provided Monday to Friday. Other contact methods are available here.

Intel does not verify all solutions, including but not limited to any file transfers that may appear in this community. Accordingly, Intel disclaims all express and implied warranties, including without limitation, the implied warranties of merchantability, fitness for a particular purpose, and non-infringement, as well as any warranty arising from course of performance, course of dealing, or usage in trade.

For more complete information about compiler optimizations, see our Optimization Notice.