Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

I would like to write a program in Mathematica to look for the integer $n$ such that the following definition holds for any $1 < m < n $

$$\frac{f(n)}{f(m)}>1+\frac{\log(n/m)}{\log(n) \log(\log(m))}$$

where $f(n)$ is for example number of divisors of $n$ (and also count the number of resulting sets).

I wrote the following code, but the problem is that when it finds the first j1 in the next step of the For, it looks for the value j2 for which

$$\frac{f(j_2)}{f(j_1)}>1+\frac{\log(j_2/j_1)}{\log(j_2) \log(\log( j_1))}$$

but I want it to find the j2 such that

$$\forall j,\ j_1 \le j < j_2 \implies \frac{f(j_2)}{f(j)}>1+\frac{\log(j_2/j)}{\log (j_2) \log(\log(j))}$$

Note: In the following example k[*] is a special and known sub sequence of integers.

i = 20;

count = 0;

list = {i};

For[j = i, j <= 100, j++,

    If[ f[k[j]]/f[k[i]] > 1 + Log[k[j]/k[i]]/(Log[k[j]] Log[Log[k[i]]]), i = j; 
        AppendTo[list, i];
        count = count + 1


Print["count= ", count]
share|improve this question
Have you seen DivisorSigma[] already? –  J. M. May 25 '13 at 19:21
@ J. M.♦, yes, but my problem is: assume we start with k[20], then when we reach to the first k[j] such that not only f[k[j]]/f[k[20]]>(1+Log[k[j]/k[20]]/(Log[k[j]]Log[Log[k[20]]])), also f[k[j]]/f[k[i]]>(1+Log[k[j]/k[i]]/(Log[k[j]]Log[Log[k[i]]])), for all i such that 20<i<j. –  asd May 25 '13 at 20:13
Could you give an example for f and k ? –  b.gatessucks May 28 '13 at 13:49
@b.gatessucks, for example f[n_]:=DivisorSigma[1,n]/n and k=Table[s[i],{i,20,100}] is a subsequence of superabundant or highly composite numbers –  asd May 28 '13 at 13:56
add comment

1 Answer 1

up vote 1 down vote accepted

try this for the original question (without the k..)

  Reap[ Do[If[ 
     And @@ Table[ 
        f[n]/f[m] > 1 + Log[n/m]/(Log[n] Log[Log[m]]) ,
                {m, 2, n - 1}] , Sow[n]] , {n, 3, 100}] ]

If you want to use explicit loops you need an outer n loop and inner m loop.

Last@Last@Reap[ Do[
        m = 2;
        While[m < n &&   f[n]/f[m] > 1 + Log[n/m]/(Log[n] Log[Log[m]]) , ++m] ;
        If[ m == n, Sow[n]];, {n, 3, 100}] ]
share|improve this answer
add comment

Your Answer


By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.