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]
  • $\begingroup$ Have you seen DivisorSigma[] already? $\endgroup$ Commented May 25, 2013 at 19:21
  • $\begingroup$ @ 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. $\endgroup$
    – asd
    Commented May 25, 2013 at 20:13
  • $\begingroup$ Could you give an example for f and k ? $\endgroup$ Commented May 28, 2013 at 13:49
  • $\begingroup$ @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 $\endgroup$
    – asd
    Commented May 28, 2013 at 13:56

1 Answer 1


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}] ]

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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