!! BDDEMO2.F90 Copyright(c) 1994 - 1998, Lahey Computer Systems, Inc. !! Copying for sale requires permission from Lahey Computers Systems. !! Otherwise, distribution of all or part of this file is permitted !! if these four lines are included. !!---------------------------------------------------------------------------- !! !! function : This is a FORTRAN source file intended to demonstrate one !! method of porting a standard Fortran 95 program to a GUI !! application created with LF95 and Borland Delphi. The original !! program, DEMO.F90, was modified as little as possible. The !! few adaptations made are listed below: !! !! 1) The MAIN program unit was deleted and replaced by a Delphi application. !! 2) All of the PRINT and WRITE statements have been replaced with !! calls to build_message_buffer( ) which stores text output in an array !! which is queried by calls from Delphi who then displays the output in a !! Windows message box. !! 3) Two other subroutines were written to manage the message buffer. !! clear_message_buffer( ) A routine that allows Delphi to clear the message buffer. !! get_message_buffer( ) The routine for data exchange with Delphi. !! 4) Calls to "my_pause()" were removed as their functionality is handled on the GUI side. !! 5) Subroutines were made callable from Delphi by DLL_EXPORT statements. !! !! !! remarks : Many of the functions below are written in recursive form. !! Those concerned with performance may wish to recast them !! in the iterative mode. !! !! Three of the examples in this demonstration program were !! inspired by Abelson and Sussman, The Structure and !! Interpretation of Computer Programs, Cambridge, MA: The !! MIT Press, 1985. !! !!---------------------------------------------------------------------------- !! module constants_module !! contains parameters for declaring KIND= and the like module constants_module integer, parameter :: large_int_kind = 4 integer, parameter :: large_real_kind = 8 integer, parameter :: buffer_size = 4000 integer, parameter :: create_new = 1 integer, parameter :: append = 2 integer, parameter :: append_to_same_line = 3 integer, parameter :: display = 4 end module constants_module module char_data_module use constants_module character (len=80), dimension(50), save :: string_array end module char_data_module !! !! subroutine : FACTORIAL_DEMO !! !! sets up the factorial demonstration and governs the !! invocation of 'factorizal' !! subroutine factorial_demo use constants_module dll_export factorial_demo integer(kind=large_int_kind) :: i,f,factorial character(len=77) :: int_file call build_message_buffer( " demo #1: factorials", create_new) call build_message_buffer( " ___________________", append) call build_message_buffer( " ", append) call build_message_buffer( " ", append) call build_message_buffer( " This routine calculates and prints out the", append) call build_message_buffer( " factorials of the integers from 1 through 12.", append) i = 1 do if (i > 12) exit f = factorial(i) write( int_file, ( "(' n = ',I2.1, ' factorial(n) = ',I9.1)")) i,f call build_message_buffer( trim( int_file), append) i = i + 1 end do end subroutine factorial_demo recursive function factorial(n) result(factresult) use constants_module integer(kind=large_int_kind) :: factresult integer(kind=large_int_kind) :: n if (n .eq. 1) then factresult = 1 else factresult = n * factorial(n - 1) end if end function factorial !! !! subroutine : CONVERSION_DEMO !! !! sets up the Fahrenheit to Celsius conversion demonstration !! subroutine conversion_demo use constants_module dll_export conversion_demo character(len=77) :: int_file real(kind=large_real_kind) :: h, l, i, celsius, fahr call build_message_buffer( " demo #2: Fahrenheit to Celsius conversion", create_new) call build_message_buffer( " _________________________________________", append) call build_message_buffer( " ", append) call build_message_buffer( " ", append) call build_message_buffer( " This routine calculates and prints out the", append) call build_message_buffer( " Celsius equivalent of every fifth integral", append) call build_message_buffer( " Fahrenheit value from 5 to 100 degrees.", append) call build_message_buffer( " ", append) l = 5 h = 100 i = 5 call build_message_buffer( ' deg F deg C', append) call build_message_buffer( ' ------- -------', append) do fahr = l, h, i celsius = (5.0/9.0) * (fahr - 32.0) write( int_file, ( "(' ',F7.2,' ',F7.2)")) fahr, celsius call build_message_buffer( trim( int_file), append) end do end subroutine conversion_demo !! !! subroutine : CARMICHAEL_DEMO !! !! sets up the Carmichael number demonstration and governs !! the invocation of 'carmichaels_in_range' !! !! Abelson & Sussman's "Structure and Interpretation of !! of Computer Programs" provided the inspiration for !! this example !! subroutine carmichael_demo use constants_module dll_export carmichael_demo call build_message_buffer( " demo #3: Carmichael numbers", create_new) call build_message_buffer( " ___________________________", append) call build_message_buffer( " ", append) call build_message_buffer( " ", append) call build_message_buffer( " A Carmichael number is a non-prime that fools", append) call build_message_buffer( " the Fermat test for primality. These numbers", append) call build_message_buffer( " are rare. This program examines the integers", append) call build_message_buffer( " from 2 to 3,000 and lists out the Carmichael", append) call build_message_buffer( " numbers discovered.", append) call build_message_buffer( " ", append) call build_message_buffer( " ", append) call carmichaels_in_range(2,3000) call build_message_buffer( " ", append) end subroutine carmichael_demo subroutine carmichaels_in_range(ialpha,omega) use constants_module integer(kind=large_int_kind) :: alpha,omega,ialpha alpha=ialpha do if (alpha > omega) exit call test_carmichael(alpha) alpha = alpha+1 end do end subroutine carmichaels_in_range subroutine test_carmichael(n) use constants_module integer(kind=large_int_kind) :: n logical :: fermat_test,naive_test,f character(len=77) :: int_file f = fermat_test(n) if (f .and. .not. naive_test(n)) then write( int_file, "(i8, ' is a Carmichael number!')" ) n call build_message_buffer( trim( int_file), append) end if end subroutine test_carmichael logical function fermat_test(int) use constants_module integer(kind=large_int_kind) :: int logical :: fast_prime fermat_test = fast_prime(int,9) end function fermat_test recursive function fast_prime(i,times) result(fast_result) use constants_module integer(kind=large_int_kind) :: i, times logical :: fermat,fast_result if (times .eq. 0) then fast_result = .true. else if (fermat(i) .eqv. .true.) then fast_result = fast_prime(i,times-1) else fast_result = .false. end if end if end function fast_prime logical function fermat(int) use constants_module integer(kind=large_int_kind) :: int, alpha,expmod alpha = 2 + ((int - 2) * rnd()) fermat = (alpha .eq. expmod(alpha,int,int)) end function fermat recursive function expmod(b,e,m) result(exp_result) use constants_module integer(kind=large_int_kind) :: b,e,m,tmp,exp_result if (0 .eq. e) then exp_result = 1 else if (0 .eq. mod(e,2)) then tmp = expmod(b,e/2,m) exp_result = mod(tmp*tmp, m) else tmp = expmod(b,e-1,m) exp_result = mod(b*tmp, m) end if end function expmod logical function naive_test(n) use constants_module integer(kind=large_int_kind) :: n,smallest_divisor naive_test = (n .eq. smallest_divisor(n)) end function naive_test function smallest_divisor(n) use constants_module integer(kind=large_int_kind) :: smallest_divisor integer(kind=large_int_kind) :: n,find_divisor smallest_divisor = find_divisor(n,2) end function smallest_divisor recursive function find_divisor(n, t) result(divisor) use constants_module integer(kind=large_int_kind) :: n,t,divisor if ((t * t) > n) then divisor = n else if (0 .eq. mod(n,t)) then divisor = t else divisor = find_divisor(n,t+1) end if end function find_divisor !! !! subroutine : RAMANUJAN_DEMO !! !! sets up the Ramanujan series demonstration and governs !! the invocation of 'search_ramanujans' !! !! Abelson & Sussman's "Structure and Interpretation of !! of Computer Programs" provided the inspiration for !! this example !! subroutine ramanujan_demo use constants_module dll_export ramanujan_demo call build_message_buffer( " demo #4: Ramanujan's series", create_new) call build_message_buffer( " ___________________________", append) call build_message_buffer( " ", append) call build_message_buffer( " ", append) call build_message_buffer( " G. H. Hardy, in his obituary for Srinavasa", append) call build_message_buffer( " Ramanujan, told of the time that he visited", append) call build_message_buffer( " Ramanujan when the latter was ill. Hardy ", append) call build_message_buffer( " took taxi number '1729' to where Ramanujan", append) call build_message_buffer( " was staying, and in passing told Ramanujan", append) call build_message_buffer( " that it seemed a very uninteresting number.", append) call build_message_buffer( " Ramanujan instantly took issue with Hardy,", append) call build_message_buffer( " pointing out that it is on the contrary", append) call build_message_buffer( " very interesting, because it is the smallest", append) call build_message_buffer( " positive integer that can be expressed as the", append) call build_message_buffer( " sum of 2 cubes in exactly 2 different ways.", append) call build_message_buffer( " The number '1729' has since been known as", append) call build_message_buffer( " Ramanujan's number and the series it begins", append) call build_message_buffer( " as Ramanujan's series.", append) call build_message_buffer( " ", append) call build_message_buffer( " This program prints out the Ramanujan numbers", append) call build_message_buffer( " discovered between 1 and 15,000.", append) call build_message_buffer( " ", append) call build_message_buffer( " ", append) call search_ramanujans(1,15000) call build_message_buffer( " ", append) end subroutine ramanujan_demo subroutine search_ramanujans(ialpha,omega) use constants_module integer(kind=large_int_kind) :: alpha,omega,ialpha logical :: is_ramanujan character(len=77) :: int_file alpha=ialpha do if (alpha > omega) exit if (is_ramanujan(alpha)) then write( int_file, "( i8, ' is a Ramanujan number!')") alpha call build_message_buffer( trim( int_file), append) end if alpha = alpha+1 end do end subroutine search_ramanujans logical function is_ramanujan(n) use constants_module integer(kind=large_int_kind) :: n,lim logical :: search lim = 1 + int((n/2)**(1.0/3.0)) is_ramanujan = search(n,1,lim,0) end function is_ramanujan recursive function search(n,a,o,cubes) result(searchres) use constants_module integer(kind=large_int_kind) :: n,a,o,cubes,ca,re,rc logical :: searchres if (a >= o) then if (2 .eq. cubes) then searchres = .true. else searchres = .false. end if else ca = a*a*a re = n - ca rc = int(re**(1.0/3.0)) if (rc*rc*rc .eq. re) then searchres = search(n,a+1,o,cubes+1) else searchres = search(n,a+1,o,cubes) end if end if end function search !! !! subroutine : STIRLING_DEMO !! !! sets up the demonstration that calculates Stirling !! numbers of the second kind and governs the invocation !! of 'stirling_numbers' !! subroutine stirling_demo use constants_module dll_export stirling_demo call build_message_buffer( " demo #5: Stirling numbers of the 2nd kind", create_new) call build_message_buffer( " _________________________________________", append) call build_message_buffer( " ", append) call build_message_buffer( " ", append) call build_message_buffer( " Stirling numbers of the 2nd kind, S(n,k),", append) call build_message_buffer( " are the numbers of possible partitions of", append) call build_message_buffer( " n items into k groups. They are useful in", append) call build_message_buffer( " calculating the expected probability of", append) call build_message_buffer( " some kinds of combinations of events.", append) call build_message_buffer( " ", append) call build_message_buffer( " This program prints out Stirling numbers", append) call build_message_buffer( " of the 2nd kind from S(12,0) to S(12,12).", append) call build_message_buffer( " ", append) call build_message_buffer( " ", append) call stirling_numbers(12,12,0,12) call build_message_buffer( " ", append) end subroutine stirling_demo subroutine stirling_numbers(ia1,io1,ia2,io2) use constants_module integer(kind=large_int_kind) :: ia1,io1,ia2,io2 integer(kind=large_int_kind) :: a1, o1, a2, o2, ia integer(kind=large_int_kind) :: s,s2 character(len=77) :: int_file a1=ia1 o1=io1 a2=ia2 o2=io2 do if (a1 > o1) exit ia = a2 do if (ia > o2) exit s = s2(a1,ia) write( int_file, ("(' n: ',I2.1,' k: ',I2.1,' S(n,k): ',I7.1)")) a1,ia,s call build_message_buffer( trim( int_file), append) ia=ia+1 end do a1=a1+1 end do end subroutine stirling_numbers recursive function s2(n,k) result(s2_result) use constants_module integer(kind=large_int_kind) :: n,k,s2_result if (n .eq. 0 .and. k .eq. 0) then s2_result = 1 else if (n .eq. 0 .or. k .eq. 0) then s2_result = 0 else s2_result = s2(n-1,k-1) + (k * s2(n-1,k)) end if end function s2 !! !! subroutine : CHI_SQUARE_DEMO !! !! sets up the chi-square quantiles demonstration and governs !! the invocation of 'get_chi_quantiles' !! subroutine chi_square_demo use constants_module dll_export chi_square_demo call build_message_buffer( " demo #6: chi-square quantiles", create_new) call build_message_buffer( " _____________________________", append) call build_message_buffer( " ", append) call build_message_buffer( " ", append) call build_message_buffer( " This program calculates the critical values", append) call build_message_buffer( " of the chi-square distribution for degrees of", append) call build_message_buffer( " freedom 10 through 200, with an increment of", append) call build_message_buffer( " 10, at significance level 0.90. The code is", append) call build_message_buffer( " based on ACM algorithm #451.", append) call build_message_buffer( " ", append) call build_message_buffer( " ", append) call get_chi_quantiles call build_message_buffer( " ", append) end subroutine chi_square_demO subroutine get_chi_quantiles use constants_module real(kind=large_real_kind) :: pa,csqa,chisqd integer(kind=large_int_kind) :: df,omega_df character(len=77) :: int_file pa = 0.1 df = 10 omega_df = 200 do if (df > omega_df) exit csqa = chisqd(pa,df) write( int_file, *) df,csqa call build_message_buffer( trim( int_file), append) df=df+10 end do end subroutine get_chi_quantiles function chisqd(p,n) use constants_module real(kind=large_real_kind) :: chisqd real(kind=large_real_kind) :: p,gaussd,f,f1,f2,t integer(kind=large_int_kind) :: n real(kind=large_real_kind) :: c(21),a(19) c = (/ & & 1.565326e-3, & ! c(01) & 1.060438e-3, & ! c(02) & -6.950356e-3, & ! c(03) & -1.323293e-2, & ! c(04) & 2.277679e-2, & ! c(05) & -8.986007e-3, & ! c(06) & -1.513904e-2, & ! c(07) & 2.530010e-3, & ! c(08) & -1.450117e-3, & ! c(09) & 5.169654e-3, & ! c(10) & -1.153761e-2, & ! c(11) & 1.128186e-2, & ! c(12) & 2.607083e-2, & ! c(13) & -0.2237368 , & ! c(14) & 9.780499e-5, & ! c(15) & -8.426812e-4, & ! c(16) & 3.125580e-3, & ! c(17) & -8.553069e-3, & ! c(18) & 1.348028e-4, & ! c(19) & 0.4713941 , & ! c(20) & 1.0000886 /) ! c(21) a = (/ & & 1.264616e-2, & ! a(01) & -1.425296e-2, & ! a(02) & 1.400483e-2, & ! a(03) & -5.886090e-3, & ! a(04) & -1.091214e-2, & ! a(05) & -2.304527e-2, & ! a(06) & 3.135411e-3, & ! a(07) & -2.728494e-4, & ! a(08) & -9.699681e-3, & ! a(09) & 1.316872e-2, & ! a(10) & 2.618914e-2, & ! a(11) & -0.2222222 , & ! a(12) & 5.406674e-5, & ! a(13) & 3.483789e-5, & ! a(14) & -7.274761e-4, & ! a(15) & 3.292181e-3, & ! a(16) & -8.729713e-3, & ! a(17) & 0.4714045 , & ! a(18) & 1.0000000 /) ! a(19) if (n-2 < 0) then chisqd = gaussd(0.5 * p) chisqd = chisqd * chisqd return else if (n-2 .eq. 0) then chisqd = -2.0 * log(p) return else f = real(n) f1 = 1.0 / f t = gaussd(p) f2 = sqrt(f1) * t if (n .ge. (2 + int(4.0 * abs(t)))) then chisqd = (((a(1) + a(2) * f2) * f1 +(((a(3) + & & a(4) * f2) * f2 & & + a(5)) * f2 + a(6))) * f1 + ((((( & & a(7) + a(8) * f2) * f2 + a(9)) * f2 & & + a(10)) * f2 + a(11)) * f2 + a(12))) & & * f1 + (((((a(13) * f2 & & + a(14)) * f2 + a(15)) * f2 + a(16)) * f2 & & + a(17)) * f2 * f2 & & + a(18)) * f2 + a(19) chisqd = chisqd * chisqd * chisqd * f return else chisqd = (((((((c(1) * f2 + c(2)) * f2 + c(3)) & & * f2 + c(4)) * f2 & & + c(5)) * f2 + c(6)) * f2 + c(7)) * f1 & & + ((((((c(8) + c(9) * f2) * f2 & & + c(10)) * f2 + c(11)) * f2 + c(12)) * & & f2 + c(13)) * f2 + c(14))) * f1 + & & (((((c(15) * f2 + c(16)) * f2 + c(17)) & & * f2 + c(18)) * f2 & & + c(19)) * f2 + c(20)) * f2 + c(21) chisqd = chisqd * chisqd * chisqd * f return end if end if end function chisqd function gaussd(prob) use constants_module real(kind=large_real_kind) :: gaussd real(kind=large_real_kind) :: prob,factor,acc factor = 1000.0 gaussd = acc(prob*factor,factor) end function gaussd function acc(tar,fct) use constants_module real(kind=large_real_kind) :: acc real(kind=large_real_kind) :: tar,act,fct,f,e,val act = 0.0 val = -5.0 - (1.0/fct) f = 1 / sqrt(2 * 3.14159265358979323846) do if (act >= tar) exit val = val + (1.0/fct) e = - ((val*val) / 2) act = act + (f * exp(e)) end do acc = val end function acc !! !! subroutine : PYTHAGORAS_DEMO !! !! sets up the Pythagorean triplets demonstration and governs !! the invocation of 'gen_triplets' !! subroutine pythagoras_demo use constants_module dll_export pythagoras_demo call build_message_buffer( " demo #7: Pythagorean triplets", create_new) call build_message_buffer( " _____________________________", append) call build_message_buffer( " ", append) call build_message_buffer( " ", append) call build_message_buffer( " A Pythagorean triplet is a set of 3 integers,", append) call build_message_buffer( " {x,y,z}, that satisfies the formula x*x + y*y", append) call build_message_buffer( " = z*z. All primitive Pythagorean triplets", append) call build_message_buffer( " can be derived from the formulas", append) call build_message_buffer( " ", append) call build_message_buffer( " x = 2uv", append) call build_message_buffer( " y = (u**2) - (v**2)", append) call build_message_buffer( " z = (u**2) + (v**2)", append) call build_message_buffer( " ", append) call build_message_buffer( " where u > v, u and v have no common factor,", append) call build_message_buffer( " and one of them is odd and the other even.", append) call build_message_buffer( " These formulas are presented geometrically in", append) call build_message_buffer( " the 10th book of Euclid's Elements.", append) call build_message_buffer( " ", append) call build_message_buffer( " This program prints out all of the primitive", append) call build_message_buffer( " Pythagorean triplets for values of u and v", append) call build_message_buffer( " from 1 through 9.", append) call build_message_buffer( " ", append) call build_message_buffer( " ", append) call gen_triplets(1,9) call build_message_buffer( " ", append) end subroutine pythagoras_demo recursive subroutine gen_triplets(ialpha,omega) use constants_module integer(kind=large_int_kind) :: alpha,omega,ialpha alpha=ialpha if (alpha <= omega) then call cycle_over_v(1,alpha) call gen_triplets(alpha+1,omega) end if end subroutine gen_triplets recursive subroutine cycle_over_v(v,u) use constants_module integer(kind=large_int_kind) :: u,v,gcd logical :: o_e if (v < u) then if ((gcd(u,v) .eq. 1) .and. (o_e(u,v))) then call print_triplet(v,u) end if call cycle_over_v(v+1,u) end if end subroutine cycle_over_v logical function o_e(u,v) use constants_module integer(kind=large_int_kind) :: u,v,mu,mv mu = mod(u,2) mv = mod(v,2) if ((mu .eq. 0) .and. (mv .eq. 0)) then o_e = .false. else if ((mu .ne. 0) .and. (mv .ne. 0)) then o_e = .false. else o_e = .true. end if end function o_e recursive function gcd(x,y) result(gcd_result) use constants_module integer(kind=large_int_kind) :: x,y,gcd_result if (0 .eq. y) then gcd_result = x else gcd_result = gcd(y,mod(x,y)) end if end function gcd subroutine print_triplet(v,u) use constants_module integer(kind=large_int_kind) :: u,v,x,y,z character(len=77) :: int_file x = 2*u*v y = (u*u) - (v*v) z = (u*u) + (v*v) write( int_file, ( "(' u: ',I2.1,' v: ',I2.1,' & &triplet: {', I5.1,',',I5.1,',',I5.1,'}')")) u,v,x,y,z call build_message_buffer( trim( int_file), append) end subroutine print_triplet function fact_iter(n) use constants_module integer(kind=large_int_kind) :: fact_iter integer(kind=large_int_kind) :: n, i, r r = 1 i = n do if (i <= 0) exit r = r * i i = i - 1 end do fact_iter = r end function fact_iter subroutine build_message_buffer( string, action) use constants_module use char_data_module implicit none character (len=*) :: string integer, save :: string_count integer :: action select case ( action) case (create_new) string_count = 1 string_array = "" case ( append) string_count = string_count + 1 end select if( string_count > 50) then string_count = 50 string = "***** string array overflow *****" end if if( len( string) > 77) then ! 80 minus 1 for the first character and minus 2 for the CR/LF pair string = "***** string length overflow *****" end if string_array( string_count) = char( 3 + len( string) ) // & & string // char(10) // char(13) ! Delphi uses the first char for length end subroutine build_message_buffer subroutine get_message_buffer( length, index, string) use constants_module use char_data_module implicit none integer :: index, length character( len=*) :: string dll_export get_message_buffer string = string_array( index) length = len_trim( string) end subroutine get_message_buffer subroutine clear_message_buffer( ) use constants_module use char_data_module implicit none dll_export clear_message_buffer string_array = "" end subroutine clear_message_buffer