Program ThreadingTest
   use ifcore
   use ifmt

	INTERFACE
    integer(4) FUNCTION Inquireproc(arg)
	  !DEC$ ATTRIBUTES STDCALL, ALIAS:"_InguireProc" :: InguireProc
     integer(4),POINTER :: arg
    END FUNCTION
    integer(4) FUNCTION Readproc(arg)
	   !DEC$ ATTRIBUTES STDCALL, ALIAS:"_ReadProc" :: ReadProc
     integer(4),POINTER :: arg
    END FUNCTION

   END INTERFACE

   integer(INT_PTR_KIND()) ThreadHandle(2)
   integer(INT_PTR_KIND()), PARAMETER :: security = 0
   integer(INT_PTR_KIND()), PARAMETER :: stack_size = 0
   integer(INT_PTR_KIND()) :: thread_id(2)
	integer(4) :: ivalue(2) = (/10,20/)

     

	! start thread testing presence of file
	! if following 2 lines are commented everything is OK
   ThreadHandle(1) = CreateThread(security,stack_size,InquireProc,loc(ivalue(1)), &
      0, thread_id(1) )
	
	! start thread redaing file
   ThreadHandle(2) = CreateThread(security,stack_size,ReadProc,loc(ivalue(2)), &
      0, thread_id(2) )

	! wait some time to finish threads
   call sleepqq(10000)

end  

integer(4) function InquireProc(arg)
   USE IFCORE
   USE IFMT
   !DEC$ ATTRIBUTES STDCALL, ALIAS:"_InguireProc" :: InguireProc

   integer(4), POINTER :: arg 
	character*20 Action
	logical*4 bOpened
	integer*4 ierr,i,j
	
	do j=1,10000
		
		do i=1,10000
			! simply check state of some file 
			inquire(FILE="testfile.txt",ACTION=Action,OPENED=iopened,IOSTAT=ierr)
			if (iopened) then
				write(*,*) 'file testfile.txt is opened'
			endif
		enddo
		write(*,*) 'Inquire thread still alive'
		
	enddo
   InquireProc = 0
   call ExitThread(0)
end function


recursive integer(4) function ReadProc(unitnum)
   USE IFCORE
   USE IFMT
   !DEC$ ATTRIBUTES STDCALL, ALIAS:"_ReadProc" :: ReadProc
   integer(4), POINTER :: unitnum
	character*20 fname,action
	logical*4 bOpened
	integer*4 ierr,i,j,k
	
   ! create something for reading	
	write(fname,'(A,I2,A)') 'file',unitnum,'.txt'
	open(unit=unitnum,file=fname)
	do i=1,50000
		write(unitnum,'(I5)',iostat=ierr) i
		if (ierr/=0) then
			write(*,*) 'Thread ', unitnum,' write error at line ',i,' error ',ierr
			ReadProc = 0
			call ExitThread(0)
		endif
	enddo
	close(unitnum)

	! now try to read file again and again
	do i=1,10000
		open(unit=unitnum,file=fname,action='read',iostat=ierr)
		if (ierr /= 0) then
			write(*,*) 'Thread ', unitnum,' file open error'
			ReadProc = 0
			call ExitThread(0)
		endif
		! read file
		k=0
		do j=1,50000
			read(unitnum,'(I5)',iostat=ierr) k
			if (ierr /=0) then
				write(*,*) 'Thread ', unitnum,' read error at line ',k,' error ',ierr
				ReadProc = 0
				call ExitThread(0)
			endif
		enddo
		close(unitnum)
		write(*,*) 'Thread ',unitnum,' still alive in cycle ',i
	enddo
		
   ReadProc = 0
   call ExitThread(0)

end function
	