Well, I cut most of the code and left just a part that can run fine under Debug and not under Release. The point is that you will need a bmp file containing a black figure on a white background. If you need one of my figures, just let me know and I send you by e-mail. Hope this helps.
Best regards,
Agustin
module datos
character(len=128) :: archivo = ''
character128 :: file =''
character(len=128) output,output2
integer long_archivo,place
character a(3,1024,1024)
integer hres,vres,nb_colours,ier,i,k,control,red,white,black,j,green,c2,blue
integer colour1,colour2,colour3,colour4,colour5,ans
type coordenate
real x
real y
end type coordenate
type(coordenate),dimension(:),allocatable :: matrix,contorno
integer,dimension(:,:),allocatable :: b_matrix
integer col,num_pixels,pixels_contorno,pp
real8 x_ref,y_ref,sum_x,sum_y
real*8 :: h_mean = 0.0, width=0.0,slope=0.0
character(len=24) :: str = 'desea salir realmente?'
end module datos
program imagine
use mswin
use datos
implicit none
integer select_file,calcular_circular,calcular_lineal,check_file,ctrl,dimension_fractal
external select_file,calcular_circular,calcular_lineal,check_file,dimension_fractal
ans=winio@('%ca[Determinación de Contornos en Colonias Circulares]&')
ans=winio@('%nl RUGOSIDAD........ %5rf&',width) ans=winio@('%nl RADIO MEDIO...... %5rf&',h_mean)
ans=winio@('%nl Dimension Fractal.. %5rf&',slope) ans=winio@('%gr[rgb_colours]&',800l,600l,1)
ans=winio@('%bg[grey]%ww%lw&',ctrl)
ans=winio@('%mn[&Archivo]&', select_file)
ans=winio@('%mn[&Calcular contorno[Circular,Lineal]]&',calcular_circular,calcular_lineal)
ans=winio@('%mn[C&hequear archivo]&',check_file)
ans=winio@('%mn[&Dimension Fractal]&',dimension_fractal)
ans=winio@('%mn[E&xit]','confirm_exit',str)
end program imagine
integer function select_file()
use mswin
use datos
implicit none
integer :: number_of_filters
logical :: must_exist
character(len=128),dimension (10) :: filter_names, filters
character(len=128) :: file_name,path
character (len=20) :: title
title = 'seleccionar archivo';path = 'c:';file_name = ' '
filter_names(1) = 'imagenes';filters(1) = '.bmp';filter_names(2) = 'all files';filters(2) = '.*'
number_of_filters = 2;must_exist = .true.
call get_filtered_file@(title, file_name, path, &
& filter_names, filters, number_of_filters,must_exist)
if(file_name /= '') then
ans = winio@('%ca[ARCHIVO]&')
ans = winio@('%bg[btnface]&')
ans = winio@('El archivo seleccionado es:'%ws'%2nl&', file_name)
ans = winio@('%cn%bt[OK]')
if (ans == 1) then
archivo=file_name
long_archivo=len(archivo)
else
ans=winio@('no se ha seleccionado ningún archivo')
endif
endif
call clear_screen@
select_file=1
end function select_file
integer function check_file()
check_file=1
end function check_file
integer function calcular_lineal()
calcular_lineal=1
end function calcular_lineal
integer function calcular_circular()
use mswin
use datos
file=archivo
if(file=='') then ! si no seleccioné primero un archivo el programa no sigue
ans=winio@('%bg&',RGB@(0,255,255))
ans=winio@('%si!¡NO SELECCIONÓ EL ARCHIVO!&')
ans=winio@('%2nl%cn%bt[OK]')
else
call clear_screen@
call set_rgb_colours_default@(1)
call get_dib_size@(file,hres,vres,nb_colours,ier)
call create_graphics_region@(2,hres,vres)
call use_rgb_colours@(2,1)
call select_graphics_object@(2)
ihfile = import_bmp@(file,ierr)
call dib_paint@(0l,0l,ihfile,0l,0l)
call select_graphics_object@(1)
call copy_graphics_region@(1,0,0,600,600,2,0,0,hres,vres,srccopy)
call perform_graphics_update@
allocate(b_matrix(hres,vres))
allocate(matrix(hres*vres))
b_matrix=0
matrix%x=0
matrix%y=0
k=1
red= rgb@(255,0,0)
black=rgb@(0,0,0)
white=rgb@(255,255,255)
do i=1,hres-1
do j=1,vres-1
call get_rgb_value@(i,j,colour1)
call get_rgb_value@(i,j-1,colour2)
call get_rgb_value@(i,j+1,colour3)
if(colour1 /= white.and.colour2 == white.and.colour3 /=white) then
b_matrix(i,j) = 2
matrix(k)%x=i; matrix(k)%y=j
k=k+1
call draw_point@(i,j,red)
elseif(colour1 /= white.and.colour2 /= white.and.colour3 == white) then
b_matrix(i,j) = 2
matrix(k)%x=i; matrix(k)%y=j
k=k+1
call draw_point@(i,j,red)
else
cycle
endif
end do
end do
do j=1,vres-1
do i=1,hres-1
call get_rgb_value@(i,j,colour1)
call get_rgb_value@(i,j-1,colour2)
call get_rgb_value@(i,j+1,colour3)
if(colour1 /= white.and.colour2 == white.and.colour3 /=white) then
if(b_matrix(i,j) /= 2) then
matrix(k)%x=i; matrix(k)%y=j
k=k+1
call draw_point@(i,j,red)
endif
elseif(colour1 /= white.and.colour2 /= white.and.colour3 == white) then
if(b_matrix(i,j) /= 2) then
matrix(k)%x=i; matrix(k)%y=j
k=k+1
call draw_point@(i,j,red)
endif
else
cycle
endif
end do
end do
pixels_contorno=k
call create_graphics_region@(3,hres,vres)
call select_graphics_object@(3)
do i=1,hres-1
do j=1,vres-1
if(b_matrix(i,j) == 2) then
call draw_point@(i,j,red)
else
call draw_point@(i,j,white)
endif
end do
end do
call copy_graphics_region@(1,0,0,600,600,3,0,0,hres,vres,srccopy)
call perform_graphics_update@
deallocate(b_matrix)
endif
calcular_circular=1
end function calcular_circular
Integer function dimension_fractal()
dimension_fractal=1
end function dimension_fractal
