A positive integer n is an arithmetic number if the average of its positive divisors is also an integer.

Task
Arithmetic numbers
You are encouraged to solve this task according to the task description, using any language you may know.
Definition

Clearly all odd primes p must be arithmetic numbers because their only divisors are 1 and p whose sum is even and hence their average must be an integer. However, the prime number 2 is not an arithmetic number because the average of its divisors is 1.5.

Example

30 is an arithmetic number because its 7 divisors are: [1, 2, 3, 5, 6, 10, 15, 30], their sum is 72 and average 9 which is an integer.

Task

Calculate and show here:

1. The first 100 arithmetic numbers.

2. The xth arithmetic number where x = 1,000 and x = 10,000.

3. How many of the first x arithmetic numbers are composite.

Note that, technically, the arithmetic number 1 is neither prime nor composite.

Stretch

Carry out the same exercise in 2. and 3. above for x = 100,000 and x = 1,000,000.

References




11l

Translation of: Python
F factors(Int n)
   V f = Set([1, n])
   V i = 2
   L
      V j = n I/ i
      I j < i
         L.break
      I i * j == n
         f.add(i)
         f.add(j)
      i++
   R f

V arithmetic_count = 0
V composite_count = 0
V n = 1
L arithmetic_count <= 1000000
   V f = factors(n)
   I sum(f) % f.len == 0
      arithmetic_count++
      I f.len > 2
         composite_count++
      I arithmetic_count <= 100
         print(f:‘{n:3} ’, end' ‘’)
         I arithmetic_count % 10 == 0
            print()
      I arithmetic_count C (1000, 10000, 100000, 1000000)
         print("\n"arithmetic_count‘th arithmetic number is ’n)
         print(‘Number of composite arithmetic numbers <= ’n‘: ’composite_count)
   n++
Output:
  1   3   5   6   7  11  13  14  15  17
 19  20  21  22  23  27  29  30  31  33
 35  37  38  39  41  42  43  44  45  46
 47  49  51  53  54  55  56  57  59  60
 61  62  65  66  67  68  69  70  71  73
 77  78  79  83  85  86  87  89  91  92
 93  94  95  96  97  99 101 102 103 105
107 109 110 111 113 114 115 116 118 119
123 125 126 127 129 131 132 133 134 135
137 138 139 140 141 142 143 145 147 149

1000th arithmetic number is 1361
Number of composite arithmetic numbers <= 1361: 782

10000th arithmetic number is 12953
Number of composite arithmetic numbers <= 12953: 8458

100000th arithmetic number is 125587
Number of composite arithmetic numbers <= 125587: 88219

1000000th arithmetic number is 1228663
Number of composite arithmetic numbers <= 1228663: 905043

Ada

with Ada.Text_IO;         use Ada.Text_IO;
with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;

procedure Main is
   procedure divisor_count_and_sum
     (n : Positive; divisor_count : out Natural; divisor_sum : out Natural)
   is
      I : Positive := 1;
      J : Natural;
   begin
      divisor_count := 0;
      divisor_sum   := 0;
      loop
         J := n / I;
         exit when J < I;
         if I * J = n then
            divisor_sum   := divisor_sum + I;
            divisor_count := divisor_count + 1;
            if I /= J then
               divisor_sum   := divisor_sum + J;
               divisor_count := divisor_count + 1;
            end if;
         end if;
         I := I + 1;
      end loop;
   end divisor_count_and_sum;

   arithmetic_count : Natural  := 0;
   composite_count  : Natural  := 0;
   div_count        : Natural;
   div_sum          : Natural;
   mean             : Natural;
   n                : Positive := 1;
begin

   while arithmetic_count <= 1_000_000 loop
      divisor_count_and_sum (n, div_count, div_sum);
      mean := div_sum / div_count;
      if mean * div_count = div_sum then
         arithmetic_count := arithmetic_count + 1;
         if div_count > 2 then
            composite_count := composite_count + 1;
         end if;
         if arithmetic_count <= 100 then
            Put (Item => n, Width => 4);
            if arithmetic_count mod 10 = 0 then
               New_Line;
            end if;
         end if;
         if arithmetic_count = 1_000 or else arithmetic_count = 10_000
           or else arithmetic_count = 100_000
           or else arithmetic_count = 1_000_000
         then
            New_Line;
            Put (Item => arithmetic_count, Width => 1);
            Put_Line ("th arithmetic number is" & n'Image);
            Put_Line
              ("Number of composite arithmetic numbers <=" & n'Image & ":" &
               composite_count'Image);
         end if;
      end if;
      n := n + 1;
   end loop;
end Main;
Output:
   1   3   5   6   7  11  13  14  15  17
  19  20  21  22  23  27  29  30  31  33
  35  37  38  39  41  42  43  44  45  46
  47  49  51  53  54  55  56  57  59  60
  61  62  65  66  67  68  69  70  71  73
  77  78  79  83  85  86  87  89  91  92
  93  94  95  96  97  99 101 102 103 105
 107 109 110 111 113 114 115 116 118 119
 123 125 126 127 129 131 132 133 134 135
 137 138 139 140 141 142 143 145 147 149

1000th arithmetic number is 1361
Number of composite arithmetic numbers <= 1361: 782

10000th arithmetic number is 12953
Number of composite arithmetic numbers <= 12953: 8458

100000th arithmetic number is 125587
Number of composite arithmetic numbers <= 125587: 88219

1000000th arithmetic number is 1228663
Number of composite arithmetic numbers <= 1228663: 905043

ALGOL 68

BEGIN # find arithmetic numbers - numbers whose average divisor is an integer #
      # i.e. sum of divisors MOD count of divisors = 0                        #
    INT max number            = 500 000;    # maximum number we will consider #
    [ 1 : max number ]INT d sum;
    [ 1 : max number ]INT d count;
    # all positive integers are divisible by 1 and so have at least 1 divisor #
    FOR i TO max number DO d sum[ i ] := d count[ i ] := 1 OD;
    # construct the divisor sums and counts                                   #
    FOR i FROM 2 TO max number DO
        FOR j FROM i BY i TO max number DO
            d count[ j ] +:= 1;
            d sum[   j ] +:= i
        OD
    OD;
    # count arithmetic numbers, and show the first 100, the 1 000th, 10 000th #
    # and the 100 000th and show how many are composite                       #
    INT max arithmetic = 100 000;
    INT a count       := 0;
    INT c count       := 0;
    FOR i TO max number WHILE a count < max arithmetic DO
        IF d sum[ i ] MOD d count[ i ] = 0 THEN
            # have an arithmetic number                                       #
            IF d count[ i ] > 2 THEN
                # the number is composite                                     #
                c count +:= 1
            FI;
            a count +:= 1;
            IF a count <= 100 THEN
                print( ( " ", whole( i, -3 ) ) );
                IF a count MOD 10 = 0 THEN print( ( newline ) ) FI
            ELIF a count =   1 000
              OR a count =  10 000
              OR a count = 100 000
            THEN
                print( ( newline ) );
                print( ( "The ", whole( a count, 0 )
                       , "th arithmetic number is: ", whole( i, 0 )
                       , newline
                       )
                     );
                print( ( "    There are ", whole( c count, 0 )
                       , " composite arithmetic numbers up to ", whole( i, 0 )
                       , newline
                       )
                     )
            FI
        FI
    OD
END
Output:
   1   3   5   6   7  11  13  14  15  17
  19  20  21  22  23  27  29  30  31  33
  35  37  38  39  41  42  43  44  45  46
  47  49  51  53  54  55  56  57  59  60
  61  62  65  66  67  68  69  70  71  73
  77  78  79  83  85  86  87  89  91  92
  93  94  95  96  97  99 101 102 103 105
 107 109 110 111 113 114 115 116 118 119
 123 125 126 127 129 131 132 133 134 135
 137 138 139 140 141 142 143 145 147 149

The 1000th arithmetic number is: 1361
    There are 782 composite arithmetic numbers up to 1361

The 10000th arithmetic number is: 12953
    There are 8458 composite arithmetic numbers up to 12953

The 100000th arithmetic number is: 125587
    There are 88219 composite arithmetic numbers up to 125587

APL

Works with: Dyalog APL
task{
    facs    0=⍳|⊢
    aritm   (0=≢|+/)facs
    comp    2<(facs)
    aritms  aritm¨15000

    'First 100 arithmetic numbers:'
    10 10aritms
    {
        ''
        'The ',(),'th arithmetic number: ',(aritms[])
        ncomps  +/comp¨aritms
        'Of the first ',(),' arithmetic numbers, ',(ncomps),' are composite.'
    }¨10*3 4
}
Output:
First 100 arithmetic numbers:
  1   3   5   6   7  11  13  14  15  17
 19  20  21  22  23  27  29  30  31  33
 35  37  38  39  41  42  43  44  45  46
 47  49  51  53  54  55  56  57  59  60
 61  62  65  66  67  68  69  70  71  73
 77  78  79  83  85  86  87  89  91  92
 93  94  95  96  97  99 101 102 103 105
107 109 110 111 113 114 115 116 118 119
123 125 126 127 129 131 132 133 134 135
137 138 139 140 141 142 143 145 147 149

The 1000th arithmetic number: 1361
Of the first 1000 arithmetic numbers, 782 are composite.

The 10000th arithmetic number: 12953
Of the first 10000 arithmetic numbers, 8458 are composite.

AppleScript

on isArithmetic(n)
    if (n < 4) then
        if (n < 0) then return {arithmetic:false, composite:missing value}
        return {arithmetic:(n mod 2 = 1), composite:false}
    end if
    set factorSum to 1 + n
    set factorCount to 2
    set sqrt to n ^ 0.5
    set limit to sqrt div 1
    if (limit = sqrt) then
        set factorSum to factorSum + limit
        set factorCount to 3
        set limit to limit - 1
    end if
    repeat with i from 2 to limit
        if (n mod i = 0) then
            set factorSum to factorSum + i + n div i
            set factorCount to factorCount + 2
        end if
    end repeat
    
    return {arithmetic:(factorSum mod factorCount = 0), composite:(factorCount > 2)}
end isArithmetic

on task()
    set output to {linefeed & "The first 100 arithmetic numbers are:"}
    set {n, hitCount, compositeCount, pad} to {0, 0, 0, "   "}
    repeat 10 times
        set row to {}
        set targetCount to hitCount + 10
        repeat until (hitCount = targetCount)
            set n to n + 1
            tell isArithmetic(n) to if (its arithmetic) then
                set hitCount to hitCount + 1
                if (its composite) then set compositeCount to compositeCount + 1
                set row's end to text -4 thru -1 of (pad & n)
            end if
        end repeat
        set output's end to join(row, "")
    end repeat
    repeat with targetCount in {1000, 10000, 100000, 1000000}
        repeat while (hitCount < targetCount)
            set n to n + 1
            tell isArithmetic(n) to if (its arithmetic) then
                set hitCount to hitCount + 1
                if (its composite) then set compositeCount to compositeCount + 1
            end if
        end repeat
        set output's end to (linefeed & "The " & targetCount & "th arithmetic number is " & n) & ¬
            (linefeed & "(" & compositeCount & " composite numbers up to here)")
    end repeat
    
    return join(output, linefeed)
end task

on join(lst, delim)
    set astid to AppleScript's text item delimiters
    set AppleScript's text item delimiters to delim
    set txt to lst as text
    set AppleScript's text item delimiters to astid
    return txt
end join

task()
Output:
"
The first 100 arithmetic numbers are:
   1   3   5   6   7  11  13  14  15  17
  19  20  21  22  23  27  29  30  31  33
  35  37  38  39  41  42  43  44  45  46
  47  49  51  53  54  55  56  57  59  60
  61  62  65  66  67  68  69  70  71  73
  77  78  79  83  85  86  87  89  91  92
  93  94  95  96  97  99 101 102 103 105
 107 109 110 111 113 114 115 116 118 119
 123 125 126 127 129 131 132 133 134 135
 137 138 139 140 141 142 143 145 147 149

The 1000th arithmetic number is 1361
(782 composite numbers up to here)

The 10000th arithmetic number is 12953
(8458 composite numbers up to here)

The 100000th arithmetic number is 125587
(88219 composite numbers up to here)

The 1000000th arithmetic number is 1228663
(905043 composite numbers up to here)"

ARM Assembly

Works with: as version Raspberry Pi
or android 32 bits with application Termux
/* ARM assembly Raspberry PI  */
/* program arithnumber.s   */

/************************************/
/* Constantes                       */
/************************************/
/* for this file see task include a file in language ARM assembly*/
.include "../constantes.inc"

.equ NBDIVISORS,             2000

//.include "../../ficmacros32.inc"        @ use for developper debugging
/*******************************************/
/* Initialized data                        */
/*******************************************/
.data
szMessStartPgm:          .asciz "Program 32 bits start. \n"
szMessEndPgm:            .asciz "Program normal end.\n"
szMessErrorArea:         .asciz "\033[31mError : area divisors too small.\n"
szMessError:             .asciz "\033[31mError  !!!\n"
szMessErrGen:            .asciz "Error end program.\n"
szMessResultFact:        .asciz "@ "

szCarriageReturn:        .asciz "\n"

szMessEntete:            .asciz "The first 150 arithmetic numbers are:\n"
szMessResult:            .asciz " @ "

szMessEntete1:           .asciz "The 1000 aritmetic number :"
szMessEntete2:           .asciz "The 10000 aritmetic number :"
szMessEntete3:           .asciz "The 100000 aritmetic number :"
szMessEntete4:           .asciz "The 1000000 aritmetic number :"
szMessComposite:         .asciz "Composite number : "
/*******************************************/
/* UnInitialized data                      */
/*******************************************/
.bss 
.align 4
sZoneConv:               .skip 24
tbZoneDecom:             .skip 4 * NBDIVISORS       // facteur 4 octets
/*******************************************/
/*  code section                           */
/*******************************************/
.text
.global main 
main:                               @ program start
    ldr r0,iAdrszMessStartPgm       @ display start message
    bl affichageMess

    ldr r0,iAdrszMessEntete         @ display result message
    bl affichageMess
    mov r2,#1                       @ start number
    mov r3,#0                       @ counter result
    mov r6,#0                       @ counter result by line
1:
    mov r0,r2                       @  number
    ldr r1,iAdrtbZoneDecom
    bl testNbArith                  @ test
    cmp r0,#1                       @ ok ? 
    bne 3f
    add r3,#1
    mov r0,r2                       @ number
    ldr r1,iAdrsZoneConv
    bl conversion10                 @ convert ascii string
    ldr r0,iAdrszMessResult
    ldr r1,iAdrsZoneConv
    bl strInsertAtCharInc           @ and put in message

    bl affichageMess
    add r6,r6,#1
    cmp r6,#6
    blt 3f
    mov r6,#0
    ldr r0,iAdrszCarriageReturn
    bl affichageMess
3:
    add r2,r2,#1
    cmp r3,#100
    blt 1b
    ldr r0,iAdrszCarriageReturn
    bl affichageMess
   
    /* count arithmetic number  */
    mov r2,#1
    mov r3,#0
    ldr r5,iN10P4
    ldr r6,iN10P5
    ldr r7,iN10P6
    mov r8,#0                       @ counter composite
4:
    mov r0,r2                       @  number
    ldr r1,iAdrtbZoneDecom
    bl testNbArith
    cmp r0,#1
    bne 6f
    cmp r1,#1
    bne 5f
    add r8,r8,#1
5:
    add r3,#1
6:
    cmp r3,#1000
    beq 7f
    cmp r3,r5                      @ 10000
    beq 8f
    cmp r3,r6                      @ 100000 
    beq 9f
    cmp r3,r7                      @ 1000000
    beq 10f
    b 11f

7:
    ldr r0,iAdrszMessEntete1
    bl affichageMess
    mov r0,r2
    mov r4,r1                        @ save sum
    ldr r1,iAdrsZoneConv
    bl conversion10                  @ convert ascii string
    mov r0,r1
    bl affichageMess
    ldr r0,iAdrszMessComposite
    bl affichageMess
    mov r0,r8
    ldr r1,iAdrsZoneConv
    bl conversion10                  @ convert ascii string
    mov r0,r1
    bl affichageMess
    ldr r0,iAdrszCarriageReturn
    bl affichageMess
    b 11f
8:
    ldr r0,iAdrszMessEntete2
    bl affichageMess
    mov r0,r2
    mov r4,r1                        @ save sum
    ldr r1,iAdrsZoneConv
    bl conversion10                  @ convert ascii string
    mov r0,r1
    bl affichageMess
    ldr r0,iAdrszMessComposite
    bl affichageMess
    mov r0,r8
    ldr r1,iAdrsZoneConv
    bl conversion10                  @ convert ascii string
    mov r0,r1
    bl affichageMess
    ldr r0,iAdrszCarriageReturn
    bl affichageMess
    b 11f
 9:
    ldr r0,iAdrszMessEntete3
    bl affichageMess
    mov r0,r2
    mov r4,r1                        @ save sum
    ldr r1,iAdrsZoneConv
    bl conversion10                  @ convert ascii string
    mov r0,r1
    bl affichageMess
    ldr r0,iAdrszMessComposite
    bl affichageMess
    mov r0,r8
    ldr r1,iAdrsZoneConv
    bl conversion10                  @ convert ascii string
    mov r0,r1
    bl affichageMess
    ldr r0,iAdrszCarriageReturn
    bl affichageMess
    b 11f
 10:
    ldr r0,iAdrszMessEntete4
    bl affichageMess
    mov r0,r2
    mov r4,r1                        @ save sum
    ldr r1,iAdrsZoneConv
    bl conversion10                  @ convert ascii string
    mov r0,r1
    bl affichageMess
    ldr r0,iAdrszMessComposite
    bl affichageMess
    mov r0,r8
    ldr r1,iAdrsZoneConv
    bl conversion10                  @ convert ascii string
    mov r0,r1
    bl affichageMess
    ldr r0,iAdrszCarriageReturn
    bl affichageMess
    b 12f
11:
    add r2,r2,#1
    b 4b
12:
    ldr r0,iAdrszMessEndPgm         @ display end message
    bl affichageMess
    b 100f
99:                                 @ display error message 
    ldr r0,iAdrszMessError
    bl affichageMess
100:                                @ standard end of the program
    mov r0, #0                      @ return code
    mov r7, #EXIT                   @ request to exit program
    svc 0                           @ perform system call
iAdrszMessStartPgm:        .int szMessStartPgm
iAdrszMessEndPgm:          .int szMessEndPgm
iAdrszMessError:           .int szMessError
iAdrszCarriageReturn:      .int szCarriageReturn
iAdrtbZoneDecom:           .int tbZoneDecom
iAdrszMessEntete:          .int szMessEntete
iAdrszMessEntete1:         .int szMessEntete1
iAdrszMessEntete2:         .int szMessEntete2
iAdrszMessEntete3:         .int szMessEntete3
iAdrszMessEntete4:         .int szMessEntete4
iAdrszMessResult:          .int szMessResult
iAdrszMessComposite:       .int szMessComposite
iAdrsZoneConv:             .int sZoneConv
iN10P4:                    .int 10000
iN10P5:                    .int 100000
iN10P6:                    .int 1000000


/******************************************************************/
/*     test if number is aritmetic number                                               */ 
/******************************************************************/
/* r0 contains number */
/* r1 contains address of divisors area */
/* r0 return 1 if ok else return 0 */
/* r1 return 1 if composite */
testNbArith:
    push {r2-r11,lr}             @ save  registers
    cmp r0,#1                    @ 1 is arithmetique
    moveq r0,#1
    moveq r1,#0
    beq 100f
    cmp r0,#2                    @ 2 is not aritmetic
    moveq r0,#0
    moveq r1,#0
    beq 100f
    mov r5,r1
    mov r8,r0                    @ save number
    bl isPrime                   @ prime ?
    cmp r0,#1
    moveq r0,#1                  @ yes is prime and arithmetic
    moveq r1,#0                  @ but not composite
    beq 100f                     @ end
    mov r1,#1
    str r1,[r5]                  @ first factor
    mov r11,#1                   @ divisors sum
    mov r4,#1                    @ indice divisors table
    mov r1,#2                    @ first divisor
    mov r6,#0                    @ previous divisor
    mov r7,#0                    @ number of same divisors
1:
    mov r0,r8                    @ dividende
    bl division                  @  r1 divisor r2 quotient r3 remainder
    cmp r3,#0
    bne 6f                       @ if remainder <> zero  -> no divisor
    mov r8,r2                    @ else quotient -> new dividende
    cmp r1,r6                    @ same divisor ?
    beq 3f                       @ yes
    mov r7,r4                    @ number factors in table
    mov r9,#0                    @ indice
2:                               @ for each new prime factor compute all factors of number
    ldr r10,[r5,r9,lsl #2 ]      @ load one factor
    mul r10,r1,r10               @ multiply 
    str r10,[r5,r7,lsl #2]       @ and store in the table
    add r11,r10                  @ sum of factors
    add r7,r7,#1                 @ and increment counter
    add r9,r9,#1                 @ increment index
    cmp r9,r4                    @ end array factors ?
    blt 2b
    mov r4,r7
    mov r6,r1                    @ new divisor
    b 7f
3:                               @ same divisor
    sub r9,r4,#1
    mov r7,r4
4:                               @ for each prime factor compute all factors of number
    ldr r10,[r5,r9,lsl #2 ]      @ this prime factor is in factor array  ?
    cmp r10,r1
    subne r9,#1
    bne 4b
    sub r9,r4,r9
5:
    ldr r10,[r5,r9,lsl #2 ]
    mul r10,r1,r10
    str r10,[r5,r7,lsl #2]       @ and store in the table
    add r11,r10
    add r7,r7,#1                 @ and increment counter
    add r9,r9,#1
    cmp r9,r4  
    blt 5b
    mov r4,r7
    b 7f                         @ and loop
    
    /* not divisor -> increment next divisor */
6:
    cmp r1,#2                    @ if divisor = 2 -> add 1 
    addeq r1,#1
    addne r1,#2                  @ else add 2
    b 1b                         @ and loop
    
    /* divisor -> test if new dividende is prime */
7: 
    mov r3,r1                    @ save divisor
    cmp r8,#1                    @ dividende = 1 ? -> end
    beq 13f
    mov r0,r8                    @ new dividende is prime ?
    mov r1,#0
    bl isPrime                   @ the new dividende is prime ?
    cmp r0,#1
    bne 12f                      @ the new dividende is not prime

    cmp r8,r6                    @ else new dividende prime is same divisor ?
    beq 9f                       @ yes
                                 @ no -> compute all factors 
    mov r7,r4                    @ number factors in table
    mov r9,#0                    @ indice
8:
    ldr r10,[r5,r9,lsl #2 ]      @ load one factor
    mul r10,r8,r10               @ multiply 
    str r10,[r5,r7,lsl #2]       @ and store in the table
    add r11,r10
    add r7,r7,#1                 @ and increment counter
    add r9,r9,#1
    cmp r9,r4  
    blt 8b
    mov r4,r7
    mov r7,#0
    b 13f
9:
    sub r9,r4,#1
    mov r7,r4
10:
    ldr r10,[r5,r9,lsl #2 ]
    cmp r10,r8
    subne r9,#1
    bne 10b
    sub r9,r4,r9
11:
    ldr  r10,[r5,r9,lsl #2 ]
    mul r10,r8,r10
    str r10,[r5,r7,lsl #2]       @ and store in the table
    add r11,r10
    add r7,r7,#1                 @ and increment counter
    add r9,r9,#1
    cmp r9,r4  
    blt 11b
    mov r4,r7
    b 13f
    
12:
    mov r1,r3                    @ current divisor = new divisor
    cmp r1,r8                    @ current divisor  > new dividende ?
    ble 1b                       @ no -> loop
    
    /* end decomposition */ 
13:
    mov r1,r4                    @ control if arithmetic
    mov r0,r11                   @ compute average
    bl division
    mov r1,#1
    cmp r3,#0                    @ no remainder
    moveq r0,#1                  @ average is integer                  
    beq 100f                     @ no -> end
    mov r0,#0
    mov r1,#0

100:
    pop {r2-r11,pc}              @ restaur registers
//iAdrszMessNbPrem:           .int szMessNbPrem

/******************************************************************/
/*     test if number is prime   trial test                       */ 
/******************************************************************/
/* r0 contains the number  */
/* r0 return 1 if prime else return 0 */
isPrime:
    push {r4,lr}                @ save  registers 
    cmp r0,#1                   @ <= 1 ?
    movls r0,#0                 @ not prime
    bls 100f
    cmp r0,#3                   @ 2 and 3 prime
    movls r0,#1
    bls 100f
    tst r0,#1                   @  even ?
    moveq r0,#0                 @ not prime
    beq 100f
    mov r4,r0                   @ save number
    mov r1,#3                   @ first divisor
1:
    mov r0,r4                   @ number
    bl division
    add r1,r1,#2                @ increment divisor
    cmp r3,#0                   @ remainder = zero ?
    moveq r0,#0                 @ not prime
    beq 100f   
    cmp r1,r2                   @ divisors<=quotient ?
    ble 1b                      @ loop
    mov r0,#1                   @ return prime

100:
    pop {r4,pc}                 @ restaur registers
/***************************************************/
/*      ROUTINES INCLUDE                 */
/***************************************************/
/* for this file see task include a file in language ARM assembly*/
.include "../affichage.inc"
Output:
Program 32 bits start.
The first 150 arithmetic numbers are:
 1            3            5            6            7            11
 13           14           15           17           19           20
 21           22           23           27           29           30
 31           33           35           37           38           39
 41           42           43           44           45           46
 47           49           51           53           54           55
 56           57           59           60           61           62
 65           66           67           68           69           70
 71           73           77           78           79           83
 85           86           87           89           91           92
 93           94           95           96           97           99
 101          102          103          105          107          109
 110          111          113          114          115          116
 118          119          123          125          126          127
 129          131          132          133          134          135
 137          138          139          140          141          142
 143          145          147          149
The 1000 aritmetic number :1361       Composite number : 782
The 10000 aritmetic number :12953      Composite number : 8458
The 100000 aritmetic number :125587     Composite number : 88219
The 1000000 aritmetic number :1228663    Composite number : 905043
Program normal end.

real    0m44.650s
user    0m18.050s
sys     0m0.000s

Arturo

arithmetic?: function [n][
    avg: average factors n
    zero? abs avg - to :integer avg
]

composite?: function [n]->
    not? prime? n

arithmeticsUpTo: function [lim][
    items: select.first: lim 1..∞ => arithmetic?
    print [(to :string lim)++"th" "arithmetic number:" last items]
    print ["Number of composite arithmetic numbers <= " last items ":" dec enumerate items => composite?]
    print ""
]

first100: select.first:100 1..∞ => arithmetic?

loop split.every: 10 first100 'x ->
    print map x 's -> pad to :string s 4

print "" 

arithmeticsUpTo 1000
arithmeticsUpTo 10000

; stretch goal
arithmeticsUpTo 100000
arithmeticsUpTo 1000000
Output:
   1    3    5    6    7   11   13   14   15   17 
  19   20   21   22   23   27   29   30   31   33 
  35   37   38   39   41   42   43   44   45   46 
  47   49   51   53   54   55   56   57   59   60 
  61   62   65   66   67   68   69   70   71   73 
  77   78   79   83   85   86   87   89   91   92 
  93   94   95   96   97   99  101  102  103  105 
 107  109  110  111  113  114  115  116  118  119 
 123  125  126  127  129  131  132  133  134  135 
 137  138  139  140  141  142  143  145  147  149 

1000th arithmetic number: 1361 
Number of composite arithmetic numbers <=  1361 : 782 

10000th arithmetic number: 12953 
Number of composite arithmetic numbers <=  12953 : 8458 

100000th arithmetic number: 125587 
Number of composite arithmetic numbers <=  125587 : 88219 

1000000th arithmetic number: 1228663 
Number of composite arithmetic numbers <=  1228663 : 905043 

AutoHotkey

ArithmeticNumbers(n, mx:=0){
    c := composite := 0
    loop
    {
        num := A_Index, sum := 0
        x := Factors(num)
        for i, v in x
            sum += v
        av := sum / x.Count()
        if (av = Floor(av))
        {
            res .= c++ <= 100 ? SubStr("  " num, -2) (mod(c, 25) ? " " : "`n") : ""
            composite += x.Count() > 2 ? 1 : 0
        }
        if (c = n) || (c = mx)
            break
    }
    return [n?num:res, composite]
}
Factors(n){  
	Loop, % floor(sqrt(n))
		v := A_Index = 1 ? 1 "," n : mod(n,A_Index) ? v : v "," A_Index "," n//A_Index
	Sort, v, N U D,
	Return StrSplit(v, ",")
}

Examples:

MsgBox % Result := "The first 100 arithmetic numbers:`n"
. ArithmeticNumbers(0, 100).1
. "`nThe  1000th arithmetic number: "
. ArithmeticNumbers(1000).1 
. "`tcomposites = "
. ArithmeticNumbers(1000).2
. "`nThe 10000th arithmetic number: "
. ArithmeticNumbers(10000).1 
. "`tcomposites = "
. ArithmeticNumbers(10000).2
Output:
The first 100 arithmetic numbers:
  1   3   5   6   7  11  13  14  15  17  19  20  21  22  23  27  29  30  31  33  35  37  38  39  41
 42  43  44  45  46  47  49  51  53  54  55  56  57  59  60  61  62  65  66  67  68  69  70  71  73
 77  78  79  83  85  86  87  89  91  92  93  94  95  96  97  99 101 102 103 105 107 109 110 111 113
114 115 116 118 119 123 125 126 127 129 131 132 133 134 135 137 138 139 140 141 142 143 145 147 149

The 1000th arithmetic number: 1361	composites = 782
The 10000th arithmetic number: 12953	composites = 8458

BASIC

True BASIC

Translation of: FreeBASIC
LET n = 1
DO
   LET div = 1
   LET divcnt = 0
   LET sum = 0
   DO
      LET quot = n/div
      IF quot < div THEN EXIT DO
      IF REMAINDER(n, div) = 0 THEN
         IF quot = div THEN            !n is a square
            LET sum = sum+quot
            LET divcnt = divcnt+1
            EXIT DO
         ELSE
            LET sum = sum+div+quot
            LET divcnt = divcnt+2
         END IF
      END IF
      LET div = div+1
   LOOP

   IF REMAINDER(sum, divcnt) = 0 THEN  !n is arithmetic
      LET arithcnt = arithcnt+1
      IF arithcnt <= 100 THEN
         PRINT  USING "####": n;
         IF REMAINDER(arithcnt, 20) = 0 THEN PRINT
      END IF
      IF divcnt > 2 THEN LET compcnt = compcnt+1
      SELECT CASE arithcnt
      CASE 1000
           PRINT
           PRINT  USING "The #######th arithmetic number is #####,### up to which ###,### are composite.": arithcnt, n, compcnt
      CASE 10000, 100000, 1000000
           PRINT  USING "The #######th arithmetic number is #####,### up to which ###,### are composite.": arithcnt, n, compcnt
      CASE ELSE
           REM
      END SELECT
   END IF
   LET n = n+1
LOOP UNTIL arithcnt >= 1000000
END
Output:
Same as FreeBASIC entry.

XBasic

Works with: Windows XBasic
Translation of: FreeBASIC
PROGRAM	"ArithmeticNum"

DECLARE FUNCTION  Entry ()

FUNCTION  Entry ()
N = 1 : ArithCnt = 0 : CompCnt = 0

PRINT "The first 100 arithmetic numbers are:"
DO
    Div = 1 : DivCnt = 0 : Sum = 0
    DO WHILE 1
        Quot = N / Div
        IF Quot < Div THEN EXIT DO
        IF N MOD Div = 0 THEN
            IF Quot = Div THEN  'N is a square
                Sum = Sum + Quot
                INC DivCnt
                EXIT DO
            ELSE
                Sum = Sum + Div + Quot
                DivCnt = DivCnt + 2
            END IF
        END IF
        INC Div
    LOOP

    IF Sum MOD DivCnt = 0 THEN  'N is arithmetic
        INC ArithCnt
        IF ArithCnt <= 100 THEN
            PRINT FORMAT$("####", N);
            IF ArithCnt MOD 20 = 0 THEN PRINT
        END IF
        IF DivCnt > 2 THEN INC CompCnt
        SELECT CASE ArithCnt
            CASE 1e3
                PRINT "\nThe "; FORMAT$("#######", ArithCnt); "th arithmetic number is"; FORMAT$("####,###", N); " up to which"; FORMAT$("###,###", CompCnt); " are composite."
            CASE 1e4, 1e5, 1e6
                PRINT "The "; FORMAT$("#######", ArithCnt); "th arithmetic number is"; FORMAT$("####,###", N); " up to which"; FORMAT$("###,###", CompCnt); " are composite."
        END SELECT
    END IF
    INC N
LOOP UNTIL ArithCnt >= 1e6

END FUNCTION
END PROGRAM
Output:
Same as FreeBASIC entry.

Yabasic

Translation of: FreeBASIC
// Rosetta Code problem: http://rosettacode.org/wiki/Arithmetic_numbers
// by Jjuanhdez, 06/2022

N = 1 : ArithCnt = 0 : CompCnt = 0

print "The first 100 arithmetic numbers are:"
repeat
    Div = 1 : DivCnt = 0 : Sum = 0
    while True
        Quot = int( N / Div)
        if Quot < Div  break
        if mod(N, Div) = 0 then
            if Quot = Div then    //N is a square
                Sum = Sum + Quot
                DivCnt = DivCnt + 1
                break
            else
                Sum = Sum + Div + Quot
                DivCnt = DivCnt + 2
            end if
        end if
        Div = Div + 1
    end while

    if mod(Sum, DivCnt) = 0 then  //N is arithmetic
        ArithCnt = ArithCnt + 1
        if ArithCnt <= 100 then
            print N using "####";
            if mod(ArithCnt, 20) = 0  print
        end if
        if DivCnt > 2  CompCnt = CompCnt + 1
        switch ArithCnt
            case 100
                print
            case 1000 : case 10000 : case 100000 : case 1e6
                print "The ", ArithCnt using "#######", "th arithmetic number is ", N using "####,###", " up to which ", CompCnt using "###,###", " are composite."
        end switch
    end if
    N = N + 1
until ArithCnt >= 1000000
Output:
Similar to FreeBASIC entry.

C

#include <stdio.h>

void divisor_count_and_sum(unsigned int n, unsigned int* pcount,
                           unsigned int* psum) {
    unsigned int divisor_count = 1;
    unsigned int divisor_sum = 1;
    unsigned int power = 2;
    for (; (n & 1) == 0; power <<= 1, n >>= 1) {
        ++divisor_count;
        divisor_sum += power;
    }
    for (unsigned int p = 3; p * p <= n; p += 2) {
        unsigned int count = 1, sum = 1;
        for (power = p; n % p == 0; power *= p, n /= p) {
            ++count;
            sum += power;
        }
        divisor_count *= count;
        divisor_sum *= sum;
    }
    if (n > 1) {
        divisor_count *= 2;
        divisor_sum *= n + 1;
    }
    *pcount = divisor_count;
    *psum = divisor_sum;
}

int main() {
    unsigned int arithmetic_count = 0;
    unsigned int composite_count = 0;

    for (unsigned int n = 1; arithmetic_count <= 1000000; ++n) {
        unsigned int divisor_count;
        unsigned int divisor_sum;
        divisor_count_and_sum(n, &divisor_count, &divisor_sum);
        if (divisor_sum % divisor_count != 0)
            continue;
        ++arithmetic_count;
        if (divisor_count > 2)
            ++composite_count;
        if (arithmetic_count <= 100) {
            printf("%3u ", n);
            if (arithmetic_count % 10 == 0)
                printf("\n");
        }
        if (arithmetic_count == 1000 || arithmetic_count == 10000 ||
            arithmetic_count == 100000 || arithmetic_count == 1000000) {
            printf("\n%uth arithmetic number is %u\n", arithmetic_count, n);
            printf("Number of composite arithmetic numbers <= %u: %u\n", n,
                   composite_count);
        }
    }
    return 0;
}
Output:
  1   3   5   6   7  11  13  14  15  17 
 19  20  21  22  23  27  29  30  31  33 
 35  37  38  39  41  42  43  44  45  46 
 47  49  51  53  54  55  56  57  59  60 
 61  62  65  66  67  68  69  70  71  73 
 77  78  79  83  85  86  87  89  91  92 
 93  94  95  96  97  99 101 102 103 105 
107 109 110 111 113 114 115 116 118 119 
123 125 126 127 129 131 132 133 134 135 
137 138 139 140 141 142 143 145 147 149 

1000th arithmetic number is 1361
Number of composite arithmetic numbers <= 1361: 782

10000th arithmetic number is 12953
Number of composite arithmetic numbers <= 12953: 8458

100000th arithmetic number is 125587
Number of composite arithmetic numbers <= 125587: 88219

1000000th arithmetic number is 1228663
Number of composite arithmetic numbers <= 1228663: 905043

C#

Translation of: Java
using System;
using System.Collections.Generic;
using System.Linq;

public class ArithmeticNumbers
{
    public static void Main(string[] args)
    {
        int arithmeticCount = 0;
        int compositeCount = 0;
        int n = 1;

        while (arithmeticCount <= 1_000_000)
        {
            var factors = Factors(n);
            int sum = factors.Sum();
            if (sum % factors.Count == 0)
            {
                arithmeticCount++;
                if (factors.Count > 2)
                {
                    compositeCount++;
                }
                if (arithmeticCount <= 100)
                {
                    Console.Write($"{n,3}{(arithmeticCount % 10 == 0 ? "\n" : " ")}");
                }
                if (new[] { 1_000, 10_000, 100_000, 1_000_000 }.Contains(arithmeticCount))
                {
                    Console.WriteLine();
                    Console.WriteLine($"{arithmeticCount}th arithmetic number is {n}");
                    Console.WriteLine($"Number of composite arithmetic numbers <= {n}: {compositeCount}");
                }
            }
            n++;
        }
    }

    private static HashSet<int> Factors(int number)
    {
        var result = new HashSet<int> { 1, number };
        int i = 2;
        int j;
        while ((j = number / i) >= i)
        {
            if (i * j == number)
            {
                result.Add(i);
                result.Add(j);
            }
            i++;
        }
        return result;
    }
}
Output:
  1   3   5   6   7  11  13  14  15  17
 19  20  21  22  23  27  29  30  31  33
 35  37  38  39  41  42  43  44  45  46
 47  49  51  53  54  55  56  57  59  60
 61  62  65  66  67  68  69  70  71  73
 77  78  79  83  85  86  87  89  91  92
 93  94  95  96  97  99 101 102 103 105
107 109 110 111 113 114 115 116 118 119
123 125 126 127 129 131 132 133 134 135
137 138 139 140 141 142 143 145 147 149

1000th arithmetic number is 1361
Number of composite arithmetic numbers <= 1361: 782

10000th arithmetic number is 12953
Number of composite arithmetic numbers <= 12953: 8458

100000th arithmetic number is 125587
Number of composite arithmetic numbers <= 125587: 88219

1000000th arithmetic number is 1228663
Number of composite arithmetic numbers <= 1228663: 905043


C++

#include <cstdio>

void divisor_count_and_sum(unsigned int n,
			   unsigned int& divisor_count,
			   unsigned int& divisor_sum)
{
  divisor_count = 0;
  divisor_sum = 0;
  for (unsigned int i = 1;; i++)
  {
    unsigned int j = n / i;
    if (j < i)
      break;
    if (i * j != n)
      continue;
    divisor_sum += i;
    divisor_count += 1;
    if (i != j)
    {
      divisor_sum += j;
      divisor_count += 1;
    }
  }
}

int main()
{
  unsigned int arithmetic_count = 0;
  unsigned int composite_count = 0;

  for (unsigned int n = 1; arithmetic_count <= 1000000; n++)
  {
    unsigned int divisor_count;
    unsigned int divisor_sum;
    divisor_count_and_sum(n, divisor_count, divisor_sum);
    unsigned int mean = divisor_sum / divisor_count;
    if (mean * divisor_count != divisor_sum)
      continue;
    arithmetic_count++;
    if (divisor_count > 2)
      composite_count++;
    if (arithmetic_count <= 100)
    {
      // would prefer to use <stream> and <format> in C++20
      std::printf("%3u ", n);
      if (arithmetic_count % 10 == 0)
	std::printf("\n");
    }
    if ((arithmetic_count == 1000) || (arithmetic_count == 10000) ||
	(arithmetic_count == 100000) || (arithmetic_count == 1000000))
    {
      std::printf("\n%uth arithmetic number is %u\n", arithmetic_count, n);
      std::printf("Number of composite arithmetic numbers <= %u: %u\n", n, composite_count);
    }
  }
  return 0;
}
Output:
  1   3   5   6   7  11  13  14  15  17 
 19  20  21  22  23  27  29  30  31  33 
 35  37  38  39  41  42  43  44  45  46 
 47  49  51  53  54  55  56  57  59  60 
 61  62  65  66  67  68  69  70  71  73 
 77  78  79  83  85  86  87  89  91  92 
 93  94  95  96  97  99 101 102 103 105 
107 109 110 111 113 114 115 116 118 119 
123 125 126 127 129 131 132 133 134 135 
137 138 139 140 141 142 143 145 147 149 

1000th arithmetic number is 1361
Number of composite arithmetic numbers <= 1361: 782

10000th arithmetic number is 12953
Number of composite arithmetic numbers <= 12953: 8458

100000th arithmetic number is 125587
Number of composite arithmetic numbers <= 125587: 88219

1000000th arithmetic number is 1228663
Number of composite arithmetic numbers <= 1228663: 905043

real	0m4.146s
user	0m4.116s
sys	0m0.003s

Cowgol

include "cowgol.coh";

const MAX := 13000;

var divisorSum: uint16[MAX+1];
var divisorCount: uint8[MAX+1];

sub CalculateDivisorSums() is
    MemZero(&divisorSum[0] as [uint8], @bytesof divisorSum);
    MemZero(&divisorCount[0] as [uint8], @bytesof divisorCount);

    var div: @indexof divisorSum := 1;
    while div <= MAX loop
        var num := div;
        while num <= MAX loop
            divisorSum[num] := divisorSum[num] + div;
            divisorCount[num] := divisorCount[num] + 1;
            num := num + div;
        end loop;
        div := div + 1;
    end loop;
end sub;

sub NextArithmetic(n: uint16): (r: uint16) is
    r := n + 1;
    while divisorSum[r] % divisorCount[r] as uint16 != 0 loop
        r := r + 1;
    end loop;
end sub;

sub Composite(n: uint16): (r: uint8) is
    r := 0;
    if n>1 and divisorSum[n] != n+1 then
        r := 1;
    end if;
end sub;

var current: uint16 := 0;
var nth: uint16 := 0;
var composites: uint16 := 0;

CalculateDivisorSums();

print("First 100 arithmetic numbers:\n");
while nth < 10000 loop
    current := NextArithmetic(current);
    nth := nth + 1;
    composites := composites + Composite(current) as uint16;

    if nth <= 100 then
        print_i16(current);
        if nth % 5 == 0 then
            print_nl();
        else
            print_char('\t');
        end if;
    end if;

    if nth == 1000 or nth == 10000 then
        print_nl();
        print_i16(nth);
        print(": ");
        print_i16(current);
        print("\t");
        print_i16(composites);
        print(" composites\n");
    end if;
end loop;
Output:
First 100 arithmetic numbers:
1       3       5       6       7
11      13      14      15      17
19      20      21      22      23
27      29      30      31      33
35      37      38      39      41
42      43      44      45      46
47      49      51      53      54
55      56      57      59      60
61      62      65      66      67
68      69      70      71      73
77      78      79      83      85
86      87      89      91      92
93      94      95      96      97
99      101     102     103     105
107     109     110     111     113
114     115     116     118     119
123     125     126     127     129
131     132     133     134     135
137     138     139     140     141
142     143     145     147     149

1000: 1361      782 composites

10000: 12953    8458 composites

Delphi

{{works with| Delphi-6 or better}}
program ArithmeiticNumbers;

{$APPTYPE CONSOLE}

procedure ArithmeticNumbers;
var N, ArithCnt, CompCnt, DDiv: integer;
var DivCnt, Sum, Quot, Rem: integer;
begin
N:= 1;  ArithCnt:= 0;  CompCnt:= 0;
repeat
	begin
	DDiv:= 1;  DivCnt:= 0;  Sum:= 0;
	while true do
		begin
		Quot:= N div DDiv;
		Rem:=N mod DDiv;
		if Quot < DDiv then break;
		if (Quot = DDiv) and (Rem = 0) then //N is a square
			begin
			Sum:= Sum+Quot;
			DivCnt:= DivCnt+1;
			break;
			end;
		if Rem = 0 then
			begin
			Sum:= Sum + DDiv + Quot;
			DivCnt:= DivCnt+2;
			end;
		DDiv:= DDiv+1;
		end;
	if (Sum mod DivCnt) = 0 then //N is arithmetic
		begin
		ArithCnt:= ArithCnt+1;
		if ArithCnt <= 100 then
			begin
			Write(N:4);
			if (ArithCnt mod 20) = 0 then WriteLn;
			end;
		if DivCnt > 2 then CompCnt:= CompCnt+1;
		case ArithCnt of 1000, 10000, 100000, 1000000:
			begin
			Writeln;
			Write(N, #9 {tab} );
			Write(CompCnt);
			end;
	 	 end;
	 	end;
        N:= N+1;
        end
until   ArithCnt >= 1000000;
WriteLn;
end;

begin
ArithmeticNumbers;
WriteLn('Hit Any Key');
ReadLn;
end.
Output:
   1   3   5   6   7  11  13  14  15  17  19  20  21  22  23  27  29  30  31  33
  35  37  38  39  41  42  43  44  45  46  47  49  51  53  54  55  56  57  59  60
  61  62  65  66  67  68  69  70  71  73  77  78  79  83  85  86  87  89  91  92
  93  94  95  96  97  99 101 102 103 105 107 109 110 111 113 114 115 116 118 119
 123 125 126 127 129 131 132 133 134 135 137 138 139 140 141 142 143 145 147 149

1361    782
12953   8458
125587  88219
1228663 905043
Hit Any Key

Draco

word MAX = 13000;

[MAX+1]word divisorSum;
[MAX+1]byte divisorCount;

proc calculateDivisorSums() void:
    word num, div;
    for div from 1 by 1 upto MAX do
        for num from div by div upto MAX do
            divisorSum[num] := divisorSum[num] + div;
            divisorCount[num] := divisorCount[num] + 1
        od
    od
corp

proc arithmetic(word n) bool:
    divisorSum[n] % divisorCount[n] = 0
corp

proc composite(word n) bool:
    n > 1 and divisorSum[n] /= n+1
corp

proc main() void:
    word num, nthArithm, composites;
    calculateDivisorSums();

    writeln("First 100 arithmetic numbers:");

    num := 0;
    composites := 0;
    for nthArithm from 1 upto 10000 do
        while num := num+1; not arithmetic(num) do od;
        if composite(num) then composites := composites + 1 fi;

        if nthArithm <= 100 then
            write(num:5);
            if nthArithm % 10 = 0 then writeln() fi
        fi;

        if nthArithm = 1000 or nthArithm = 10000 then
            writeln();
            writeln("The ",nthArithm,"th arithmetic number is ",num,".");
            writeln("Of the first ",nthArithm," arithmetic numbers, ",
                    composites," are composite.")
        fi
    od
corp
Output:
First 100 arithmetic numbers:
    1    3    5    6    7   11   13   14   15   17
   19   20   21   22   23   27   29   30   31   33
   35   37   38   39   41   42   43   44   45   46
   47   49   51   53   54   55   56   57   59   60
   61   62   65   66   67   68   69   70   71   73
   77   78   79   83   85   86   87   89   91   92
   93   94   95   96   97   99  101  102  103  105
  107  109  110  111  113  114  115  116  118  119
  123  125  126  127  129  131  132  133  134  135
  137  138  139  140  141  142  143  145  147  149

The 1000th arithmetic number is 1361.
Of the first 1000 arithmetic numbers, 782 are composite.

The 10000th arithmetic number is 12953.
Of the first 10000 arithmetic numbers, 8458 are composite.

EasyLang

Translation of: FreeBASIC
print "The first 100 arithmetic numbers are:"
numfmt 0 3
n = 1
while aricnt <= 1e5
   divi = 1 ; divcnt = 0 ; sum = 0
   repeat
      quot = n div divi
      until quot < divi
      if quot = divi and n mod divi = 0
         sum += quot
         divcnt += 1
         break 1
      .
      if n mod divi = 0
         sum += divi + quot
         divcnt += 2
      .
      divi += 1
   .
   if sum mod divcnt = 0
      aricnt += 1
      if aricnt <= 100
         write n & " "
         if aricnt mod 10 = 0
            print ""
         .
      .
      if divcnt > 2
         compcnt += 1
      .
      if aricnt = 1e3 or aricnt = 1e4 or aricnt = 1e5
         print ""
         print aricnt & "th arithmetic number: " & n
         print "Composite arithmetic numbers: " & compcnt
      .
   .
   n += 1
.

Factor

Works with: Factor version 0.99 2022-04-03
USING: combinators formatting grouping io kernel lists
lists.lazy math math.functions math.primes math.primes.factors
math.statistics math.text.english prettyprint sequences
tools.memory.private ;

: arith? ( n -- ? ) divisors mean integer? ;
: larith ( -- list ) 1 lfrom [ arith? ] lfilter ;
: arith ( m -- seq ) larith ltake list>array ;
: composite? ( n -- ? ) dup 1 > swap prime? not and ;
: ordinal ( n -- str ) [ commas ] keep ordinal-suffix append ;

: info. ( n -- )
    {
        [ ordinal "%s arithmetic number: " printf ]
        [ arith dup last commas print ]
        [ commas "Number of composite arithmetic numbers <= %s: " printf ]
        [ drop [ composite? ] count commas print nl ]
    } cleave ;


"First 100 arithmetic numbers:" print
100 arith 10 group simple-table. nl
{ 3 4 5 6 } [ 10^ info. ] each
Output:
First 100 arithmetic numbers:
1   3   5   6   7   11  13  14  15  17
19  20  21  22  23  27  29  30  31  33
35  37  38  39  41  42  43  44  45  46
47  49  51  53  54  55  56  57  59  60
61  62  65  66  67  68  69  70  71  73
77  78  79  83  85  86  87  89  91  92
93  94  95  96  97  99  101 102 103 105
107 109 110 111 113 114 115 116 118 119
123 125 126 127 129 131 132 133 134 135
137 138 139 140 141 142 143 145 147 149

1,000th arithmetic number: 1,361
Number of composite arithmetic numbers <= 1,000: 782

10,000th arithmetic number: 12,953
Number of composite arithmetic numbers <= 10,000: 8,458

100,000th arithmetic number: 125,587
Number of composite arithmetic numbers <= 100,000: 88,219

1,000,000th arithmetic number: 1,228,663
Number of composite arithmetic numbers <= 1,000,000: 905,043

FreeBASIC

Translation of: Delphi
' Rosetta Code problem: https://rosettacode.org/wiki/Arithmetic_numbers
' by Jjuanhdez, 06/2022

Dim As Double t0 = Timer
Dim As Integer N = 1, ArithCnt = 0, CompCnt = 0
Dim As Integer Div, DivCnt, Sum, Quot

Print "The first 100 arithmetic numbers are:"
Do
    Div = 1 : DivCnt = 0 : Sum = 0
    Do
        Quot = N / Div
        If Quot < Div Then Exit Do
        If Quot = Div AndAlso (N Mod Div) = 0 Then 'N is a square
            Sum += Quot 
            DivCnt += 1 
            Exit Do
        End If
        If (N Mod Div) = 0 Then
            Sum += Div + Quot
            DivCnt += 2
        End If
        Div += 1
    Loop
    
    If (Sum Mod DivCnt) = 0 Then                   'N is arithmetic
        ArithCnt += 1
        If ArithCnt <= 100 Then
            Print Using "####"; N;
            If (ArithCnt Mod 20) = 0 Then Print
        End If
        If DivCnt > 2 Then CompCnt += 1
        Select Case ArithCnt
        Case 1e3 
            Print Using !"\nThe #######th arithmetic number is #####,### up to which ###,### are composite."; ArithCnt; N; CompCnt
        Case 1e4, 1e5, 1e6
            Print Using "The #######th arithmetic number is #####,### up to which ###,### are composite."; ArithCnt; N; CompCnt
        End Select
    End If
    N += 1
Loop Until ArithCnt >= 1e6
Print !"\nTook"; Timer - t0; " seconds on i5 @3.20 GHz"
Sleep
Output:
The first 100 arithmetic numbers are:
   1   3   5   6   7  11  13  14  15  17  19  20  21  22  23  27  29  30  31  33
  35  37  38  39  41  42  43  44  45  46  47  49  51  53  54  55  56  57  59  60
  61  62  65  66  67  68  69  70  71  73  77  78  79  83  85  86  87  89  91  92
  93  94  95  96  97  99 101 102 103 105 107 109 110 111 113 114 115 116 118 119
 123 125 126 127 129 131 132 133 134 135 137 138 139 140 141 142 143 145 147 149

The    1000th arithmetic number is     1,361 up to which     782 are composite.
The   10000th arithmetic number is    12,953 up to which   8,458 are composite.
The  100000th arithmetic number is   125,587 up to which  88,219 are composite.
The 1000000th arithmetic number is 1,228,663 up to which 905,043 are composite.

Took 38.42344779999985 seconds on i5 @3.20 GHz

FutureBasic

' Rosetta Code problem: https://rosettacode.org/wiki/Arithmetic_numbers
' by Rich Love, 9/21/22
' FutureBasic 7.0.14

output file "Arithmetic numbers.app"
Dim As long N = 1, ArithCnt = 0, CompCnt = 0
Dim As long Div, DivCnt, Sum, Quot

toolbox Microseconds( UnsignedWide * microTickCount )
dim as UnsignedWide   Time1, Time2

window 1, @"Arithmetic numbers",(0,0,600,200)

Print "The first 100 arithmetic numbers are:"

Microseconds( @Time1 )  //start time

for N = 1 to 2000000)
  
  Div = 1 : DivCnt = 0 : Sum = 0
  
  while 1
    
    Quot = N / Div
    If Quot < Div Then Exit while
    If Quot = Div And (N Mod Div) = 0 'N is a square
      Sum += Quot
      DivCnt += 1
      Exit while
    End If
    If (N Mod Div) = 0
      Sum += Div + Quot
      DivCnt += 2
    End If
    Div ++
    
  wend
  
  
  
  If (Sum Mod DivCnt) = 0                   'N is arithmetic
    ArithCnt ++
    
    If ArithCnt <= 100
      Print Using "####"; N;
      If (ArithCnt Mod 20) = 0 Then PRINT
    End If
    
    If DivCnt > 2 Then CompCnt ++
    
    Select Case ArithCnt
      Case 1e3
        PRINT
        PRINT  USING "The #######th arithmetic number is";ArithCnt;
        PRINT  USING "#####,### up to which ";N;
        PRINT  USING "###,### are composite. ";compcnt
      Case 1e4, 1e5, 1e6
        PRINT  USING "The #######th arithmetic number is";ArithCnt;
        PRINT  USING "#####,### up to which ";N;
        PRINT  USING "###,### are composite. ";compcnt
    End Select
    
    if ArithCnt = 1e6 then exit next
  End If
  
  
next N

Microseconds( @Time2 )  //end time

float TimeTaken
TimeTaken = (Time2.lo-Time1.lo)/1000/100/10
print
print "It took " + str$(TimeTaken) + " seconds to complete." // Approx 1.2 seconds on a M1 Mac Mini ( Macmini9,1 )


handleevents
Output:
The first 100 arithmetic numbers are:
   1   3   5   6   7  11  13  14  15  17  19  20  21  22  23  27  29  30  31  33
  35  37  38  39  41  42  43  44  45  46  47  49  51  53  54  55  56  57  59  60
  61  62  65  66  67  68  69  70  71  73  77  78  79  83  85  86  87  89  91  92
  93  94  95  96  97  99 101 102 103 105 107 109 110 111 113 114 115 116 118 119
 123 125 126 127 129 131 132 133 134 135 137 138 139 140 141 142 143 145 147 149

The    1000th arithmetic number is     1,361 up to which     782 are composite.
The   10000th arithmetic number is    12,953 up to which   8,458 are composite.
The  100000th arithmetic number is   125,587 up to which  88,219 are composite.
The 1000000th arithmetic number is 1,228,663 up to which 905,043 are composite.

Took 1.2245190144 seconds on a M1 Mac Mini * Macmini19,1 )

Go

Translation of: Wren
package main

import (
    "fmt"
    "math"
    "rcu"
    "sort"
)

func main() {
    arithmetic := []int{1}
    primes := []int{}
    limit := int(1e6)
    for n := 3; len(arithmetic) < limit; n++ {
        divs := rcu.Divisors(n)
        if len(divs) == 2 {
            primes = append(primes, n)
            arithmetic = append(arithmetic, n)
        } else {
            mean := float64(rcu.SumInts(divs)) / float64(len(divs))
            if mean == math.Trunc(mean) {
                arithmetic = append(arithmetic, n)
            }
        }
    }
    fmt.Println("The first 100 arithmetic numbers are:")
    rcu.PrintTable(arithmetic[0:100], 10, 3, false)

    for _, x := range []int{1e3, 1e4, 1e5, 1e6} {
        last := arithmetic[x-1]
        lastc := rcu.Commatize(last)
        fmt.Printf("\nThe %sth arithmetic number is: %s\n", rcu.Commatize(x), lastc)
        pcount := sort.SearchInts(primes, last) + 1
        if !rcu.IsPrime(last) {
            pcount--
        }
        comp := x - pcount - 1 // 1 is not composite
        compc := rcu.Commatize(comp)
        fmt.Printf("The count of such numbers <= %s which are composite is %s.\n", lastc, compc)
    }
}
Output:
Same as Wren example.

J

factors=: {{ */@>,{(^ [:i.1+])&.>/__ q:y}}
isArith=: {{ (= <.) (+/%#) factors|y}}"0

Task examples:

   examples=: 1+I.isArith 1+i.2e6
   10 10$examples
  1   3   5   6   7  11  13  14  15  17
 19  20  21  22  23  27  29  30  31  33
 35  37  38  39  41  42  43  44  45  46
 47  49  51  53  54  55  56  57  59  60
 61  62  65  66  67  68  69  70  71  73
 77  78  79  83  85  86  87  89  91  92
 93  94  95  96  97  99 101 102 103 105
107 109 110 111 113 114 115 116 118 119
123 125 126 127 129 131 132 133 134 135
137 138 139 140 141 142 143 145 147 149
   (1e3-1){examples NB. 0 is first
1361
   (1e4-1){examples
12953
   +/0=1 p: (1e3 {. examples) -. 1
782
   +/0=1 p: (1e4 {. examples) -. 1
8458
   +/0=1 p: (1e5 {. examples) -. 1
88219
   +/0=1 p: (1e6 {. examples) -. 1
905043

Java

import java.util.HashSet;
import java.util.List;
import java.util.Set;
import java.util.stream.Collectors;
import java.util.stream.Stream;

public final class ArithmeticNumbers {

	public static void main(String[] aArgs) {
		int arithmeticCount = 0;
		int compositeCount = 0;
		int n = 1;
		
		while ( arithmeticCount <= 1_000_000 ) {
		    Set<Integer> factors = factors(n);
		    final int sum = factors.stream().mapToInt(Integer::intValue).sum();
		    if ( sum % factors.size() == 0 ) {
		        arithmeticCount += 1;
		        if ( factors.size() > 2 ) {
		            compositeCount += 1;
		        }
		        if ( arithmeticCount <= 100 ) {
		        	System.out.print(String.format("%3d%s", n, ( arithmeticCount % 10 == 0 ) ? "\n" : " "));
		        }
		        if ( List.of( 1_000, 10_000, 100_000, 1_000_000 ).contains(arithmeticCount) ) {
		        	System.out.println();
		            System.out.println(arithmeticCount + "th arithmetic number is " + n);
		            System.out.println("Number of composite arithmetic numbers <= " + n + ": " + compositeCount);
		        }
		    }
		    n += 1;
		}
	}
	
	private static Set<Integer> factors(int aNumber) {
		Set<Integer> result = Stream.of(1, aNumber).collect(Collectors.toCollection(HashSet::new));
	    int i = 2;
	    int j;
	    while ( ( j = aNumber / i ) >= i ) {
	        if ( i * j == aNumber ) {
	            result.add(i);
	            result.add(j);
	        }
	        i += 1;
	    }
	    return result;
	}

}
Output:
  1   3   5   6   7  11  13  14  15  17
 19  20  21  22  23  27  29  30  31  33
 35  37  38  39  41  42  43  44  45  46
 47  49  51  53  54  55  56  57  59  60
 61  62  65  66  67  68  69  70  71  73
 77  78  79  83  85  86  87  89  91  92
 93  94  95  96  97  99 101 102 103 105
107 109 110 111 113 114 115 116 118 119
123 125 126 127 129 131 132 133 134 135
137 138 139 140 141 142 143 145 147 149

1000th arithmetic number is 1361
Number of composite arithmetic numbers <= 1361: 782

10000th arithmetic number is 12953
Number of composite arithmetic numbers <= 12953: 8458

100000th arithmetic number is 125587
Number of composite arithmetic numbers <= 125587: 88219

1000000th arithmetic number is 1228663
Number of composite arithmetic numbers <= 1228663: 905043

jq

Works with: jq

Also works with gojq, the Go implementation of jq

A point of interest in the following is that the approach is entirely stream-oriented and thus very economical with memory. In particular, `arithmetic_integers` produces an unbounded stream of arithmetic integers.

Generic utilities

# For the sake of gojq
def _nwise($n):
  def nw: if length <= $n then . else .[0:$n] , (.[$n:] | nw) end;
  nw;

def lpad($len): tostring | ($len - length) as $l | (" " * $l)[:$l] + .;

Arithmetic

# proper_divisors returns a stream of unordered proper divisors of the input integer.
def proper_divisors:
  . as $n
  | if $n > 1 then 1,
      ( range(2; 1 + (sqrt|floor)) as $i
        | if ($n % $i) == 0 then $i,
            (($n / $i) | if . == $i then empty else . end)
         else empty
	 end)
    else empty
    end;

def composite:
  [limit(2; proper_divisors)] | length == 2;

def arithmetic_numbers:
  def average_is_integral(s):
    reduce s as $_ ({}; .sum += $_ | .n += 1)
    | (.sum % .n) == 0;

  1, (range(2; infinite) | select(average_is_integral(., proper_divisors)));

The tasks

def task1($limit):
  [limit($limit; arithmetic_numbers)] | _nwise(10) | map(lpad(4)) | join(" ");

# $points should be a stream of integers, in order, specifying the reporting points
def task2($points):
  last($points) as $last
  | label $out
  | foreach arithmetic_numbers as $n ({count:0};
      .count += 1
      | if $n | composite  then .composite += 1 else . end;
      (select( .count | IN( $points) ) | .n = $n),
      if .count == $last then break $out else empty end );
  
task1(100),
"",
(task2( 1000, 10000, 100000, 1000000 )
 | "The \(.count)th arithmetic number is \(.n);",
   "there are \(.composite) composite arithmetic numbers up to \(.n).\n")

Invocation: jq -ncr -f -arithmetic-numbers.jq

Output:
   1    3    5    6    7   11   13   14   15   17
  19   20   21   22   23   27   29   30   31   33
  35   37   38   39   41   42   43   44   45   46
  47   49   51   53   54   55   56   57   59   60
  61   62   65   66   67   68   69   70   71   73
  77   78   79   83   85   86   87   89   91   92
  93   94   95   96   97   99  101  102  103  105
 107  109  110  111  113  114  115  116  118  119
 123  125  126  127  129  131  132  133  134  135
 137  138  139  140  141  142  143  145  147  149

The 1000th arithmetic number is 1361;
there are 782 composite arithmetic numbers up to 1361.

The 10000th arithmetic number is 12953;
there are 8458 composite arithmetic numbers up to 12953.

The 100000th arithmetic number is 125587;
there are 88219 composite arithmetic numbers up to 125587.

The 1000000th arithmetic number is 1228663;
there are 905043 composite arithmetic numbers up to 1228663.

Julia

using Primes

function isarithmetic(n)
    f = [one(n)]
    for (p,e) in factor(n)
        f = reduce(vcat, [f*p^j for j in 1:e], init=f)
    end
    return rem(sum(f), length(f)) == 0
end

function arithmetic(n)
    i, arr = 1, Int[]
    while length(arr) < n
        isarithmetic(i) && push!(arr, i)
        i += 1
    end
    return arr
end

a1M = arithmetic(1_000_000)
composites = [!isprime(i) for i in a1M]

println("The first 100 arithmetic numbers are:")
foreach(p -> print(lpad(p[2], 5), p[1] % 20 == 0 ? "\n" : ""), enumerate(a1M[1:100]))

println("\n        X    Xth in Series  Composite")
for n in [1000, 10_000, 100_000, 1_000_000]
    println(lpad(n, 9), lpad(a1M[n], 12), lpad(sum(composites[2:n]), 14))
end
Output:
The first 100 arithmetic numbers are:
    1    3    5    6    7   11   13   14   15   17   19   20   21   22   23   27   29   30   31   33
   35   37   38   39   41   42   43   44   45   46   47   49   51   53   54   55   56   57   59   60
   61   62   65   66   67   68   69   70   71   73   77   78   79   83   85   86   87   89   91   92
   93   94   95   96   97   99  101  102  103  105  107  109  110  111  113  114  115  116  118  119
  123  125  126  127  129  131  132  133  134  135  137  138  139  140  141  142  143  145  147  149

        X    Xth in Series  Composite
     1000        1361           782
    10000       12953          8458
   100000      125587         88219
  1000000     1228663        905043

Lua

Translated from Python

local function factors (n)
	local f, i = {1, n}, 2
	while true do
		local j = n//i -- floor division by Lua 5.3
		if j < i then 
			break
		elseif j == i and i * j == n then 
			table.insert (f, i)
			break
		elseif i * j == n then
			table.insert (f, i)
			table.insert (f, j)
		end
		i = i + 1
	end
	return f
end

local function sum (f)
	local s = 0
	for i, value in ipairs (f) do
		s = s + value
	end
	return s
end

local arithmetic_count = 1
local composite_count = 0
local hundr = {1}

for n = 2, 1228663 do
	local f = factors (n)
	local s = sum (f)
	local l = #f
	if (s/l)%1 == 0 then
		arithmetic_count = arithmetic_count + 1
		if l > 2 then
			composite_count = composite_count + 1
		end
		if arithmetic_count <= 100 then
			table.insert (hundr, n)
		end
		if arithmetic_count == 100 then
			for i = 0, 9 do
				print (table.concat(hundr, ',	', 10*i+1, 10*i+10))
			end
		elseif arithmetic_count == 1000 
			or arithmetic_count == 10000 
			or arithmetic_count == 100000 then
			print (arithmetic_count..'th arithmetic number is '..(n))
			print ('Number of composite arithmetic numbers <= '..(n)..': '..composite_count)
		elseif arithmetic_count == 1000000 then
			print (arithmetic_count..'th arithmetic number is '..(n))
			print ('Number of composite arithmetic numbers <= '..(n)..': '..composite_count)
			return
		end
	end
end
Output:
1,	3,	5,	6,	7,	11,	13,	14,	15,	17
19,	20,	21,	22,	23,	27,	29,	30,	31,	33
35,	37,	38,	39,	41,	42,	43,	44,	45,	46
47,	49,	51,	53,	54,	55,	56,	57,	59,	60
61,	62,	65,	66,	67,	68,	69,	70,	71,	73
77,	78,	79,	83,	85,	86,	87,	89,	91,	92
93,	94,	95,	96,	97,	99,	101,	102,	103,	105
107,	109,	110,	111,	113,	114,	115,	116,	118,	119
123,	125,	126,	127,	129,	131,	132,	133,	134,	135
137,	138,	139,	140,	141,	142,	143,	145,	147,	149
1000th arithmetic number is 1361
Number of composite arithmetic numbers <= 1361: 782
10000th arithmetic number is 12953
Number of composite arithmetic numbers <= 12953: 8458
100000th arithmetic number is 125587
Number of composite arithmetic numbers <= 125587: 88219
1000000th arithmetic number is 1228663
Number of composite arithmetic numbers <= 1228663: 905043

(Done in 56.17 seconds)

M2000 Interpreter

 


Write code in a module: From M2000 console: Edit a (press ender, then paste the code, press Esc, write a and press enter).

n=1361 run for 1s

n=12953 run for 10s

n=125587 run for 120.6s

n=1228663 run for 1369.4s

M2000 is an interpreter with no intermediate code generation.

set fast !
profiler
form 80, 50
const msg$="The {0::-7}th arithmetic number is {1:-9} up to which {2:-7} are composite."
const f1$="#####,###"
const f2$="###,###"
print "The first 100 arithmetic numbers are:"
C=0&
D=0&: t=0&
mm=1000&
mm1=1000000&
n=1228663 ' 125587 ' 12953 ' 1361
dim L(2 to n)=1, M(2 to n)=1 : c++: Print 1,
for i=2 to n {for j=i to n step i {L(j)+=i:M(j)++}:if L(i) mod M(i) = 0& then {if M(i)>2 then D++
C++:if C<=100& then print i, else i++: goto exit1
}}
exit1:
refresh
for i=i to n {for j=i to n step i {L(j)+=i:M(j)++}:if L(i) mod M(i) = 0& then {if M(i)>2 then D++
C++:if C=mm then ? format$(msg$, c, str$(i,f1$), str$(d,f2$)):refresh:mm*=10&:if mm>mm1 then goto exit2
}}
exit2:
print
print round(timecount/1000, 1);"s"

Mathematica/Wolfram Language

ClearAll[ArithmeticNumberQ]
ArithmeticNumberQ[n_Integer] := IntegerQ[Mean[Divisors[n]]]
ArithmeticNumberQ[30]

an = {};
PrintTemporary[Dynamic[{i, Length[an]}]];
Do[
  If[ArithmeticNumberQ[i],
   AppendTo[an, i];
   If[Length[an] >= 100, Break[]]
   ]
  ,
  {i, 1, \[Infinity]}
  ];
an

an = {};
Do[
  If[ArithmeticNumberQ[i],
   AppendTo[an, i];
   If[Length[an] >= 1000, Break[]]
   ]
  ,
  {i, 1, \[Infinity]}
  ];
a1 = {Length[an], Last[an], Count[CompositeQ[an], True]};

an = {};
Do[
  If[ArithmeticNumberQ[i],
   AppendTo[an, i];
   If[Length[an] >= 10000, Break[]]
   ]
  ,
  {i, 1, \[Infinity]}
  ];
a2 = {Length[an], Last[an], Count[CompositeQ[an], True]};

an = {};
Do[
  If[ArithmeticNumberQ[i],
   AppendTo[an, i];
   If[Length[an] >= 100000, Break[]]
   ]
  ,
  {i, 1, \[Infinity]}
  ];
a3 = {Length[an], Last[an], Count[CompositeQ[an], True]};

TableForm[{a1, a2, a3}, TableHeadings -> {None, {"X", "Xth in series", "composite"}}]
Output:
{1, 3, 5, 6, 7, 11, 13, 14, 15, 17, 19, 20, 21, 22, 23, 27, 29, 30, 31, 33, 35, 37, 38, 39, 41, 42, 43, 44, 45, 46, 47, 49, 51, 53, 54, 55, 56, 57, 59, 60, 61, 62, 65, 66, 67, 68, 69, 70, 71, 73, 77, 78, 79, 83, 85, 86, 87, 89, 91, 92, 93, 94, 95, 96, 97, 99, 101, 102, 103, 105, 107, 109, 110, 111, 113, 114, 115, 116, 118, 119, 123, 125, 126, 127, 129, 131, 132, 133, 134, 135, 137, 138, 139, 140, 141, 142, 143, 145, 147, 149}

X	Xth in series	composite
1000	1361	782
10000	12953	8458
100000	125587	88219

Maxima

/* Predicate function that checks wether a positive integer is arithmetic or not */
arith_nump(n):=block(listify(divisors(n)),apply("+",%%)/length(%%),if integerp(%%) then true)$

/* Function that returns a list of the first len arithmetic numbers */
arith_num_count(len):=block(
    [i:1,count:0,result:[]],
    while count<len do (if arith_nump(i) then (result:endcons(i,result),count:count+1),i:i+1),
    result)$

/* Test cases */
/* First 100 arithmetic numbers */
arith_num_count(100);

/* The 1000th arithmetic number */
last(arith_num_count(1000));

/* The 10000th arithmetic number */
last(arith_num_count(10000));

/* Number of composites among the first 1000 arithmetic numbers */
block(rest(arith_num_count(1000)),sublist(%%,lambda([x],primep(x)=false)),length(%%));

/* Number of composites among the first 10000 arithmetic numbers */
block(rest(arith_num_count(10000)),sublist(%%,lambda([x],primep(x)=false)),length(%%));
Output:
[1,3,5,6,7,11,13,14,15,17,19,20,21,22,23,27,29,30,31,33,35,37,38,39,41,42,43,44,45,46,47,49,51,53,54,55,56,57,59,60,61,62,65,66,67,68,69,70,71,73,77,78,79,83,85,86,87,89,91,92,93,94,95,96,97,99,101,102,103,105,107,109,110,111,113,114,115,116,118,119,123,125,126,127,129,131,132,133,134,135,137,138,139,140,141,142,143,145,147,149]

1361

12953

782

8458

Modula-2

MODULE ArithmeticNumbers;
FROM InOut IMPORT WriteString, WriteCard, WriteLn;

CONST
    Max = 13000;

VAR
    divSum: ARRAY [1..Max] OF CARDINAL;
    divCount: ARRAY [1..Max] OF CHAR;
    current, count, composites: CARDINAL;

PROCEDURE CalculateDivisorSums;
VAR div, num: CARDINAL;
BEGIN
    FOR num := 1 TO Max DO
        divSum[num] := 0;
        divCount[num] := CHR(0)
    END;

    FOR div := 1 TO Max DO
        num := div;
        WHILE num <= Max DO
            INC(divSum[num], div);
            INC(divCount[num]);
            INC(num, div)
        END
    END
END CalculateDivisorSums;

PROCEDURE Next(n: CARDINAL): CARDINAL;
BEGIN
    REPEAT INC(n) UNTIL (divSum[n] MOD ORD(divCount[n])) = 0;
    RETURN n
END Next;

PROCEDURE Composite(n: CARDINAL): BOOLEAN;
BEGIN
    RETURN (n>1) AND (divSum[n] # n+1)
END Composite;

BEGIN
    CalculateDivisorSums;
    WriteString("First 100 arithmetic numbers:");
    WriteLn;

    current := 0;
    FOR count := 1 TO 10000 DO
        current := Next(current);
        IF Composite(current) THEN INC(composites) END;
        IF count <= 100 THEN
            WriteCard(current, 5);
            IF count MOD 10 = 0 THEN WriteLn END
        END;

        IF (count = 1000) OR (count = 10000) THEN
            WriteCard(count, 5);
            WriteString(": ");
            WriteCard(current, 5);
            WriteString(", ");
            WriteCard(composites, 5);
            WriteString(" composites");
            WriteLn
        END;
    END
END ArithmeticNumbers.
Output:
First 100 arithmetic numbers:
    1    3    5    6    7   11   13   14   15   17
   19   20   21   22   23   27   29   30   31   33
   35   37   38   39   41   42   43   44   45   46
   47   49   51   53   54   55   56   57   59   60
   61   62   65   66   67   68   69   70   71   73
   77   78   79   83   85   86   87   89   91   92
   93   94   95   96   97   99  101  102  103  105
  107  109  110  111  113  114  115  116  118  119
  123  125  126  127  129  131  132  133  134  135
  137  138  139  140  141  142  143  145  147  149
 1000:  1361,   782 composites
10000: 12953,  8458 composites

Nim

import std/strformat

func status(n: int): tuple[isArithmetic, isComposite: bool] =
  ## Return the status of "n", i.e. whether it is an arithmetic number
  ## and whether it is composite.
  var count = 0
  var sum = 0
  for d in 1..n:
    let q = n div d
    if q < d: break
    if n mod d == 0:
      sum += d
      inc count
      if q != d:
        sum += q
        inc count
  result = (isArithmetic: sum mod count == 0, isComposite: count > 2)

iterator arithmeticNumbers(): tuple[val: int, isComposite: bool] =
  ## Yield the successive arithmetic numbers with their composite status.
  var n = 1
  while true:
    let status = n.status
    if status.isArithmetic:
      yield (n, status.isComposite)
    inc n

echo "First 100 arithmetic numbers:"
var arithmeticCount, compositeCount = 0
for (n, isComposite) in arithmeticNumbers():
  inc arithmeticCount
  inc compositeCount, ord(isComposite)
  if arithmeticCount <= 100:
    stdout.write &"{n:>3}"
    stdout.write if arithmeticCount mod 10 == 0: '\n' else: ' '
  elif arithmeticCount in [1_000, 10_000, 100_000, 1_000_000]:
    echo &"\n{arithmeticCount}th arithmetic number: {n}"
    echo &"Number of composite arithmetic numbers ⩽ {n}: {compositeCount}"
    if arithmeticCount == 1_000_000: break
Output:
First 100 arithmetic numbers:
  1   3   5   6   7  11  13  14  15  17
 19  20  21  22  23  27  29  30  31  33
 35  37  38  39  41  42  43  44  45  46
 47  49  51  53  54  55  56  57  59  60
 61  62  65  66  67  68  69  70  71  73
 77  78  79  83  85  86  87  89  91  92
 93  94  95  96  97  99 101 102 103 105
107 109 110 111 113 114 115 116 118 119
123 125 126 127 129 131 132 133 134 135
137 138 139 140 141 142 143 145 147 149

1000th arithmetic number: 1361
Number of composite arithmetic numbers ⩽ 1361: 782

10000th arithmetic number: 12953
Number of composite arithmetic numbers ⩽ 12953: 8458

100000th arithmetic number: 125587
Number of composite arithmetic numbers ⩽ 125587: 88219

1000000th arithmetic number: 1228663
Number of composite arithmetic numbers ⩽ 1228663: 905043

Oberon-07

Translation of: Modula-2
MODULE ArithmeticNumbers;
IMPORT Out;

CONST
    Max = 130000;

VAR divSum:   ARRAY Max + 1 OF INTEGER;
    divCount: ARRAY Max + 1 OF CHAR;
    current, count, composites: INTEGER;

PROCEDURE CalculateDivisorSums;
    VAR div, num: INTEGER;
    BEGIN
        FOR num := 1 TO Max DO
            divSum[num] := 0;
            divCount[num] := CHR(0)
        END;

        FOR div := 1 TO Max DO
            num := div;
            WHILE num <= Max DO
                divSum[num] := divSum[num] + div;
                divCount[num] := CHR(ORD(divCount[num]) + 1);
                num := num + div
            END
        END
    END CalculateDivisorSums;

PROCEDURE Next(n: INTEGER): INTEGER;
    BEGIN
        REPEAT n := n + 1 UNTIL (divSum[n] MOD ORD(divCount[n])) = 0;
    RETURN n
    END Next;

PROCEDURE Composite(n: INTEGER): BOOLEAN;
    BEGIN
    RETURN (n>1) & (divSum[n] # n+1)
    END Composite;

BEGIN
    CalculateDivisorSums;
    Out.String("First 100 arithmetic numbers:");
    Out.Ln;

    current := 0;
    FOR count := 1 TO 100000 DO
        current := Next(current);
        IF Composite(current) THEN composites := composites + 1 END;
        IF count <= 100 THEN
            Out.Int(current, 5);
            IF count MOD 10 = 0 THEN Out.Ln END
        END;

        IF (count = 1000) OR (count = 10000) OR (count = 100000) THEN
            Out.Int(count, 6);
            Out.String("th: ");
            Out.Int(current, 6);
            Out.String(", ");
            Out.Int(composites, 6);
            Out.String(" composites");
            Out.Ln
        END;
    END
END ArithmeticNumbers.
Output:
First 100 arithmetic numbers:
    1    3    5    6    7   11   13   14   15   17
   19   20   21   22   23   27   29   30   31   33
   35   37   38   39   41   42   43   44   45   46
   47   49   51   53   54   55   56   57   59   60
   61   62   65   66   67   68   69   70   71   73
   77   78   79   83   85   86   87   89   91   92
   93   94   95   96   97   99  101  102  103  105
  107  109  110  111  113  114  115  116  118  119
  123  125  126  127  129  131  132  133  134  135
  137  138  139  140  141  142  143  145  147  149
  1000th:   1361,    782 composites
 10000th:  12953,   8458 composites
100000th: 125587,  88219 composites

Pascal

Works with: GNU Pascal

and Free Pascal too.

program ArithmeiticNumbers;

procedure ArithmeticNumbers;
var N, ArithCnt, CompCnt, DDiv: longint;
var DivCnt, Sum, Quot, Rem: longint;
begin
N:= 1;  ArithCnt:= 0;  CompCnt:= 0;
repeat
	begin
	DDiv:= 1;  DivCnt:= 0;  Sum:= 0;
	while true do
		begin
		Quot:= N div DDiv;
		Rem:=N mod DDiv;
		if Quot < DDiv then break;
		if (Quot = DDiv) and (Rem = 0) then //N is a square
			begin
			Sum:= Sum+Quot;
			DivCnt:= DivCnt+1;
			break;
			end;
		if Rem = 0 then
			begin
			Sum:= Sum + DDiv + Quot;
			DivCnt:= DivCnt+2;
			end;
		DDiv:= DDiv+1;
		end;
	if (Sum mod DivCnt) = 0 then //N is arithmetic
		begin
		ArithCnt:= ArithCnt+1;
		if ArithCnt <= 100 then
			begin
			Write(N:4);
			if (ArithCnt mod 20) = 0 then WriteLn;
			end;
		if DivCnt > 2 then CompCnt:= CompCnt+1;
		case ArithCnt of 1000, 10000, 100000, 1000000:
			begin
			Writeln;
			Write(N, #9 {tab} );
			Write(CompCnt);
			end;
	 	 end;
	 	end;
        N:= N+1;
        end
until   ArithCnt >= 1000000;
WriteLn;
end;

begin
ArithmeticNumbers;
WriteLn('Hit Any Key');
{$IFDEF WINDOWS}ReadLn;{$ENDIF}
end.
@TIO.RUN:
   1   3   5   6   7  11  13  14  15  17  19  20  21  22  23  27  29  30  31  33
  35  37  38  39  41  42  43  44  45  46  47  49  51  53  54  55  56  57  59  60
  61  62  65  66  67  68  69  70  71  73  77  78  79  83  85  86  87  89  91  92
  93  94  95  96  97  99 101 102 103 105 107 109 110 111 113 114 115 116 118 119
 123 125 126 127 129 131 132 133 134 135 137 138 139 140 141 142 143 145 147 149

1361    782
12953   8458
125587  88219
1228663 905043
Hit Any Key

Real time: 19.847 s CPU share: 99.36 %

Free Pascal

using prime decomposition is lengthy, but much faster.
Change last lines of Factors_of_an_integer#using_Prime_decomposition even more.

program ArithmeticNumbers;
{$OPTIMIZATION ON,ALL}
type
  tPrimeFact = packed record
                 pfSumOfDivs,
                 pfRemain  : Uint64;
                 pfDivCnt  : Uint32;
                 pfMaxIdx  : Uint32;
                 pfpotPrimIdx : array[0..9] of word;
                 pfpotMax  : array[0..11] of byte;//11 instead of 9 for alignment 
               end;
var
  SmallPrimes : array[0..6541] of word;

procedure InitSmallPrimes;
var
  testPrime,j,p,idx:Uint32;
begin
  SmallPrimes[0] := 2;
  SmallPrimes[1] := 3;
  idx := 1;
  testPrime := 5;
  repeat
    For j := 1 to idx do
    begin
      p := SmallPrimes[j];
      if p*p>testPrime then
        BREAK;
      if testPrime mod p = 0 then
      Begin
        p := 0;
        BREAK;
      end;
    end;
    if p <> 0 then
    begin
      inc(idx);
      SmallPrimes[idx]:= testPrime;
    end;
    inc(testPrime,2);
  until testPrime >= 65535;
end;

procedure smplPrimeDecomp(var PrimeFact:tPrimeFact;n:Uint32);
var
  pr,i,pot,fac,q :NativeUInt;
Begin
  with PrimeFact do
  Begin
    pfDivCnt := 1;
    pfSumOfDivs := 1;
    pfRemain := n;
    pfMaxIdx := 0;
    pfpotPrimIdx[0] := 1;
    pfpotMax[0] := 0;

    i := 0;
    while i < High(SmallPrimes) do
    begin
      pr := SmallPrimes[i];
      q := n DIV pr;
      //if n < pr*pr
      if pr > q then
         BREAK;
      if n = pr*q then
      Begin
        pfpotPrimIdx[pfMaxIdx] := i;
        pot := 0;
        fac := pr;
        repeat
          n := q;
          q := n div pr;
          pot+=1;
          fac *= pr;
        until n <> pr*q;
        pfpotMax[pfMaxIdx] := pot;
        pfDivCnt *= pot+1;
        pfSumOfDivs *= (fac-1)DIV(pr-1);
        inc(pfMaxIdx);
      end;
      inc(i);
    end;
    pfRemain := n;
    if n > 1 then
    Begin
      pfDivCnt *= 2;
      pfSumOfDivs *= n+1
    end;
  end;
end;

function IsArithmetic(const PrimeFact:tPrimeFact):boolean;inline;
begin
  with PrimeFact do
    IsArithmetic := pfSumOfDivs mod pfDivCnt = 0;
end;

var
  pF :TPrimeFact;
  i,cnt,primeCnt,lmt : Uint32;
begin
  InitSmallPrimes;

  writeln('First 100 arithemetic numbers');
  cnt := 0;
  i := 1;
  repeat
    smplPrimeDecomp(pF,i);
    if IsArithmetic(pF) then
    begin
      write(i:4);
      inc(cnt);
      if cnt MOD 20 =0 then
        writeln;
    end;
    inc(i);
  until cnt = 100;
  writeln;

  writeln('   Arithemetic numbers');
  writeln('   Index   number composite');
  cnt := 0;
  primeCnt := 0;
  lmt := 10;
  i := 1;
  repeat
    smplPrimeDecomp(pF,i);
    if IsArithmetic(pF) then
    begin
      inc(cnt);
      if pF.pfRemain = i then
        inc(primeCnt);
    end;
    if cnt = lmt then
    begin
      writeln(lmt:8,i:9,lmt-primeCnt:10);
      lmt := lmt*10;
    end;
    inc(i);
  until lmt>1000000;
  {$IFdef WINDOWS}
  WriteLn('Hit <ENTER>');ReadLn;
  {$ENDIF}
end.
@TIO.RUN:

First 100 arithemetic numbers
   1   3   5   6   7  11  13  14  15  17  19  20  21  22  23  27  29  30  31  33
  35  37  38  39  41  42  43  44  45  46  47  49  51  53  54  55  56  57  59  60
  61  62  65  66  67  68  69  70  71  73  77  78  79  83  85  86  87  89  91  92
  93  94  95  96  97  99 101 102 103 105 107 109 110 111 113 114 115 116 118 119
 123 125 126 127 129 131 132 133 134 135 137 138 139 140 141 142 143 145 147 149

   Arithemetic numbers
   Index   number composite
      10       17         3
     100      149        65
    1000     1361       782
   10000    12953      8458
  100000   125587     88219
 1000000  1228663    905043
Real time: 0.678 s CPU share: 99.40 %

Factors_of_an_integer#using_Prime_decomposition added function and change main routine.

const
  //make size of sieve using 11 MB of 16MB Level III cache
  SizePrDeFe = 192*1024;
.....
function IsArithmetic(const PrimeFact:tPrimeFac):boolean;inline;
begin
  with PrimeFact do
    IsArithmetic := pfSumOfDivs mod pfDivCnt = 0;
end;

var
  pPrimeDecomp :tpPrimeFac;
  T0:Int64;
  n,lmt,cnt,primeCnt : NativeUInt;
Begin
  InitSmallPrimes;

  T0 := GetTickCount64;
  cnt := 1;
  primeCnt := 1;
  lmt := 10;
  n := 2;
  Init_Sieve(n);
  repeat
    pPrimeDecomp:= GetNextPrimeDecomp;
    if IsArithmetic(pPrimeDecomp^) then
    begin
      inc(cnt);
      if pPrimeDecomp^.pfDivCnt = 2 then
        inc(primeCnt);
    end;
    if cnt = lmt then
    begin
      writeln(lmt:14,n:14,lmt-primeCnt:14);
      lmt := lmt*10;
    end;
    inc(n);
  until lmt>1000*1000*1000;
  T0 := GetTickCount64-T0;
  writeln;
end.
@Home AMD 5600G:
            10            17             3
           100           149            65
          1000          1361           782
         10000         12953          8458
        100000        125587         88219
       1000000       1228663        905043
      10000000      12088243       9206547
     100000000     119360473      93192812
    1000000000    1181451167     940432725
20.78user 0.00 system 0:20.79 elapsed 99%CPU 

Perl

Translation of: Raku
Library: ntheory
use strict;
use warnings;
use feature 'say';

use List::Util <max sum>;
use ntheory <is_prime divisors>;
use Lingua::EN::Numbers qw(num2en num2en_ordinal);

sub comma { reverse ((reverse shift) =~ s/(.{3})/$1,/gr) =~ s/^,//r }
sub table { my $t = 10 * (my $c = 1 + length max @_); ( sprintf( ('%'.$c.'d')x@_, @_) ) =~ s/.{1,$t}\K/\n/gr }

my @A = 0;
for my $n (1..2E6)  {
    my @div = divisors $n;
    push @A, $n if 0 == sum(@div) % @div;
}

say "The first @{[num2en 100]} arithmetic numbers:";
say table @A[1..100];

for my $x (1E3, 1E4, 1E5, 1E6) {
    say "\nThe @{[num2en_ordinal $x]}: " . comma($A[$x]) .
        "\nComposite arithmetic numbers ≤ @{[comma $A[$x]]}: " . comma -1 + grep { not is_prime($_) } @A[1..$x];
}
Output:
The first one hundred arithmetic numbers:
   1   3   5   6   7  11  13  14  15  17
  19  20  21  22  23  27  29  30  31  33
  35  37  38  39  41  42  43  44  45  46
  47  49  51  53  54  55  56  57  59  60
  61  62  65  66  67  68  69  70  71  73
  77  78  79  83  85  86  87  89  91  92
  93  94  95  96  97  99 101 102 103 105
 107 109 110 111 113 114 115 116 118 119
 123 125 126 127 129 131 132 133 134 135
 137 138 139 140 141 142 143 145 147 149

The one thousandth: 1,361
Composite arithmetic numbers ≤ 1,361: 782

The ten thousandth: 12,953
Composite arithmetic numbers ≤ 12,953: 8,458

The one hundred thousandth: 125,587
Composite arithmetic numbers ≤ 125,587: 88,219

The one millionth: 1,228,663
Composite arithmetic numbers ≤ 1,228,663: 905,043

Phix

with javascript_semantics
sequence arithmetic = {1}
integer composite = 0

function get_arithmetic(integer nth)
    integer n = arithmetic[$]+1
    while length(arithmetic)<nth do
        sequence divs = factors(n,1)
        if remainder(sum(divs),length(divs))=0 then
            composite += length(divs)>2
            arithmetic &= n
        end if
        n += 1
    end while
    return arithmetic[nth]
end function

{} = get_arithmetic(100)
printf(1,"The first 100 arithmetic numbers are:\n%s\n",
         {join_by(arithmetic,1,10," ",fmt:="%3d")})
constant fmt = "The %,dth arithmetic number is %,d up to which %,d are composite.\n"
for n in {1e3,1e4,1e5,1e6} do
    integer nth = get_arithmetic(n)
    printf(1,fmt,{n,nth,composite})
end for

Aside: You could inline the get_arithmetic() call inside the printf() call, however the formal language specification does not actually guarantee that the value of composite won't be output as it was before such a function call is made, or in other words, whether parameters are constructed left-to-right or right-to-left is simply unspecified. You certainly would not expect get_arithmetic(n,composite) to do anything other than pass the prior value into the function, so for your own sanity you should in general avoid using the visually rather similar get_arithmetic(n),composite, and suchlike, in order to collect/output the completely different post-invocation value. Or and perhaps even better, just simply avoid writing functions with side-effects, or make it a function that returns everything in a guaranteed consistent manner, and of course were get_arithmetic() a procedure [with side-effects] rather than a function, you would not be tempted to invoke it inline or use any other form of doubtful execution order anyway.

Output:
The first 100 arithmetic numbers are:
  1   3   5   6   7  11  13  14  15  17
 19  20  21  22  23  27  29  30  31  33
 35  37  38  39  41  42  43  44  45  46
 47  49  51  53  54  55  56  57  59  60
 61  62  65  66  67  68  69  70  71  73
 77  78  79  83  85  86  87  89  91  92
 93  94  95  96  97  99 101 102 103 105
107 109 110 111 113 114 115 116 118 119
123 125 126 127 129 131 132 133 134 135
137 138 139 140 141 142 143 145 147 149

The 1,000th arithmetic number is 1,361 up to which 782 are composite.
The 10,000th arithmetic number is 12,953 up to which 8,458 are composite.
The 100,000th arithmetic number is 125,587 up to which 88,219 are composite.
The 1,000,000th arithmetic number is 1,228,663 up to which 905,043 are composite.

PL/M

Translation of: ALGOL 68

The original PL/M compiler only supports unsigned integers up to 65535, so this sample doesn't consider arithmetic numbers above the 10 000th.
As machines running CP/M probably didn't have large memories, the tables of divisor counts and sums are restricted to 4000 elements each and the next 4000 values are calculated when the previous 4000 have been examined.

Works with: 8080 PL/M Compiler

... under CP/M (or an emulator)

100H: /* FIND SOME ARITHMETIC NUMBERS: NUMBERS WHOSE AVERAGE DIVISOR IS AN   */
      /* IS AN INTEGER - I.E. DIVISOR SUM MOD DIVISOR COUNT = 0              */
  
   /* CP/M BDOS SYSTEM CALL, IGNORE THE RETURN VALUE                         */
   BDOS: PROCEDURE( FN, ARG ); DECLARE FN BYTE, ARG ADDRESS; GOTO 5; END;
   PR$CHAR:   PROCEDURE( C ); DECLARE C BYTE;    CALL BDOS( 2, C );  END;
   PR$STRING: PROCEDURE( S ); DECLARE S ADDRESS; CALL BDOS( 9, S );  END;
   PR$NL:     PROCEDURE;      CALL PR$STRING( .( 0AH, 0DH, '$' ) );  END;
   PR$NUMBER: PROCEDURE( N ); /* PRINTS A NUMBER IN THE MINIMUN FIELD WIDTH  */
      DECLARE N ADDRESS;
      DECLARE V ADDRESS, N$STR ( 6 )BYTE, W BYTE;
      V = N;
      W = LAST( N$STR );
      N$STR( W ) = '$';
      N$STR( W := W - 1 ) = '0' + ( V MOD 10 );
      DO WHILE( ( V := V / 10 ) > 0 );
         N$STR( W := W - 1 ) = '0' + ( V MOD 10 );
      END;
      CALL PR$STRING( .N$STR( W ) );
   END PR$NUMBER;
   PR$NUMBER4: PROCEDURE( N ); /* PRINT A NUMBER IN AT LEAST 4 CHARACTERS    */
      DECLARE N ADDRESS;
      IF N <   10 THEN CALL PR$CHAR( ' ' );
      IF N <  100 THEN CALL PR$CHAR( ' ' );
      IF N < 1000 THEN CALL PR$CHAR( ' ' );
      CALL PR$NUMBER( N );
   END PR$NUMBER4;

   DECLARE ( D$COUNT, D$SUM ) ( 4001 )ADDRESS;
   DECLARE ( I, J, D$POS, I$POS, J$POS ) ADDRESS;
   /* SHOW THE FIRST 100TH ARITHMETIC NUMBER AND THE 1000TH AND THE 10000TH  */
   /* ALSO SHOW HOW MANY ARE COMPOSITE                                       */
   DECLARE ( DIVISOR$START, DIVISOR$END ) ADDRESS;
   DECLARE ( A$COUNT, C$COUNT ) ADDRESS;
   A$COUNT, C$COUNT, DIVISOR$START, DIVISOR$END = 0;
   I, D$POS = 1;
   DO WHILE( I <= 60000 AND A$COUNT < 10000 );
      IF I > DIVISOR$END THEN DO;
         /* PAST THE END OF THE DIGIT SUMS AND COUNTS - GET THE NEXT BATCH   */
         DIVISOR$START = DIVISOR$END   + 1;
         DIVISOR$END   = DIVISOR$START + ( LAST( D$COUNT ) ) - 1;
         DO I$POS = 1 TO LAST( D$COUNT );
            D$COUNT( I$POS ), D$SUM( I$POS ) = 1;
         END;
         DO I = 2 TO DIVISOR$END;
            DO J = I TO DIVISOR$END BY I;
               IF J >= DIVISOR$START AND J <= DIVISOR$END THEN DO;
                  J$POS            = J - ( DIVISOR$START - 1 );
                  D$COUNT( J$POS ) = D$COUNT( J$POS ) + 1;
                  D$SUM(   J$POS ) = D$SUM(   J$POS ) + I;
               END;
            END;
         END;
         I     = DIVISOR$START;
         D$POS = 1;
      END;
      IF D$SUM( D$POS ) MOD D$COUNT( D$POS ) = 0 THEN DO; /* I IS ARITHMETIC */
         IF D$COUNT( D$POS ) > 2 THEN DO;                 /* I IS COMPOSITE  */
            C$COUNT = C$COUNT + 1;
         END;
         A$COUNT = A$COUNT + 1;
         IF A$COUNT <= 100 THEN DO;
            CALL PR$NUMBER4( I );
            IF A$COUNT MOD 10 = 0 THEN CALL PR$NL;
            END;
         ELSE IF A$COUNT = 1000 OR A$COUNT = 10000 THEN DO;
            CALL PR$NL;
            CALL PR$STRING( .'THE $' );
            CALL PR$NUMBER( A$COUNT );
            CALL PR$STRING( .'TH ARITHMETIC NUMBER IS: $' );
            CALL PR$NUMBER( I );
            CALL PR$NL;
            CALL PR$STRING( .'    THERE ARE $' );
            CALL PR$NUMBER( C$COUNT );
            CALL PR$STRING( .' COMPOSITE NUMBERS UP TO $' );
            CALL PR$NUMBER( I );
            CALL PR$NL;
         END;
      END;
      I     = I + 1;
      D$POS = D$POS + 1;
   END;

EOF
Output:
   1   3   5   6   7  11  13  14  15  17
  19  20  21  22  23  27  29  30  31  33
  35  37  38  39  41  42  43  44  45  46
  47  49  51  53  54  55  56  57  59  60
  61  62  65  66  67  68  69  70  71  73
  77  78  79  83  85  86  87  89  91  92
  93  94  95  96  97  99 101 102 103 105
 107 109 110 111 113 114 115 116 118 119
 123 125 126 127 129 131 132 133 134 135
 137 138 139 140 141 142 143 145 147 149

THE 1000TH ARITHMETIC NUMBER IS: 1361
    THERE ARE 782 COMPOSITE NUMBERS UP TO 1361

THE 10000TH ARITHMETIC NUMBER IS: 12953
    THERE ARE 8458 COMPOSITE NUMBERS UP TO 12953

Python

def factors(n: int):
    f = set([1, n])
    i = 2
    while True:
        j = n // i
        if j < i:
            break
        if i * j == n:
            f.add(i)
            f.add(j)
        i += 1
    return f

arithmetic_count = 0
composite_count = 0
n = 1
while arithmetic_count <= 1000000:
    f = factors(n)
    if (sum(f)/len(f)).is_integer():
        arithmetic_count += 1
        if len(f) > 2:
            composite_count += 1
        if arithmetic_count <= 100:
            print(f'{n:3d} ', end='')
            if arithmetic_count % 10 == 0:
                print()
        if arithmetic_count in (1000, 10000, 100000, 1000000):
            print(f'\n{arithmetic_count}th arithmetic number is {n}')
            print(f'Number of composite arithmetic numbers <= {n}: {composite_count}')
    n += 1

Output:

  1   3   5   6   7  11  13  14  15  17 
 19  20  21  22  23  27  29  30  31  33 
 35  37  38  39  41  42  43  44  45  46 
 47  49  51  53  54  55  56  57  59  60 
 61  62  65  66  67  68  69  70  71  73 
 77  78  79  83  85  86  87  89  91  92 
 93  94  95  96  97  99 101 102 103 105 
107 109 110 111 113 114 115 116 118 119 
123 125 126 127 129 131 132 133 134 135 
137 138 139 140 141 142 143 145 147 149 

1000th arithmetic number is 1361
Number of composite arithmetic numbers <= 1361: 782

10000th arithmetic number is 12953
Number of composite arithmetic numbers <= 12953: 8458

100000th arithmetic number is 125587
Number of composite arithmetic numbers <= 125587: 88219

1000000th arithmetic number is 1228663
Number of composite arithmetic numbers <= 1228663: 905043

real	1m14.220s
user	1m13.952s
sys	0m0.005s

Quackery

factors is defined at Factors of an integer#Quackery. isprime is defined at Primality by trial division#Quackery.

 [ factors
   0 over witheach +
   swap size mod 0 = ]            is arithmetic  ( n --> b )

 [ temp put [] 1
   [ over size temp share < while
     dup arithmetic if
       [ tuck join swap ]
     1+
     again ]
   drop
   temp release ]                 is arithmetics ( n --> [ )

  say "First 100 arithmetic numbers:"
  cr
  100 arithmetics echo
  cr cr
  say "1000th arithmetic number: "
  1000 arithmetics
  dup -1 peek
  echo cr
  say "Composites in first 1000: "
  behead drop
  0 swap witheach
     [ isprime not + ]
  echo
  cr cr
  say "10000th arithmetic number: "
  10000 arithmetics
  dup -1 peek
  echo cr
  say "Composites in first 10000: "
  behead drop
  0 swap witheach
     [ isprime not + ]
  echo
  cr
Output:
First 100 arithmetic numbers:
[ 1 3 5 6 7 11 13 14 15 17 19 20 21 22 23 27 29 30 31 33 35 37 38 39 41 42 43 44 45 46 47 49 51 53 54 55 56 57 59 60 61 62 65 66 67 68 69 70 71 73 77 78 79 83 85 86 87 89 91 92 93 94 95 96 97 99 101 102 103 105 107 109 110 111 113 114 115 116 118 119 123 125 126 127 129 131 132 133 134 135 137 138 139 140 141 142 143 145 147 149 ]

1000th arithmetic number: 1361
Composites in first 1000: 782

10000th arithmetic number: 12953
Composites in first 10000: 8458


Raku

use Prime::Factor;
use Lingua::EN::Numbers;

my @arithmetic = lazy (1..∞).hyper.grep: { my @div = .&divisors; @div.sum %% @div }

say "The first { .Int.&cardinal } arithmetic numbers:\n", @arithmetic[^$_].batch(10)».fmt("%{.chars}d").join: "\n" given 1e2;

for 1e3, 1e4, 1e5, 1e6 {
    say "\nThe { .Int.&ordinal }: { comma @arithmetic[$_-1] }";
    say "Composite arithmetic numbers ≤ { comma @arithmetic[$_-1] }: { comma +@arithmetic[^$_].grep({!.is-prime}) - 1 }";
}
The first one hundred arithmetic numbers:
  1   3   5   6   7  11  13  14  15  17
 19  20  21  22  23  27  29  30  31  33
 35  37  38  39  41  42  43  44  45  46
 47  49  51  53  54  55  56  57  59  60
 61  62  65  66  67  68  69  70  71  73
 77  78  79  83  85  86  87  89  91  92
 93  94  95  96  97  99 101 102 103 105
107 109 110 111 113 114 115 116 118 119
123 125 126 127 129 131 132 133 134 135
137 138 139 140 141 142 143 145 147 149

The one thousandth: 1,361
Composite arithmetic numbers ≤ 1,361: 782

The ten thousandth: 12,953
Composite arithmetic numbers ≤ 12,953: 8,458

The one hundred thousandth: 125,587
Composite arithmetic numbers ≤ 125,587: 88,219

The one millionth: 1,228,663
Composite arithmetic numbers ≤ 1,228,663: 905,043

Ring

// Author: Gal Zsolt - 2023.02.26.
see "works..." + nl
divisors = []
divSum = 0
limit = 20000
counta = 0
countb = 0
countCompa = 0
countCompb = 0
for n = 1 to limit
    num = 0
    divSum = 0
    for m = 1 to n
        if n%m = 0
           num++
           divSum = divSum + m
        ok
    next
    for x = 1 to n
        if divSum/num = x
           add(divisors,n)
           counta++
           countb++
           if counta < 1001
              if not isPrime(n) and n!=1
                 countCompa++
              ok
           ok
           if counta = 1000
              countNuma = n
           ok
           if countb < 10001
              if not isPrime(n) and n!=1
                 countCompb++
              ok
           ok
           if countb = 10000
              countNumb = n
              exit 2
           ok
        ok
    next
next

see "The first 100 arithmetic numbers are:" + nl + nl

row = 0
for n = 1 to 100
    row++
    see "" + divisors[n] + " "
    if row%10=0
       see nl
    ok
next

see nl
see "1000th arithmetic number is " + countNuma + nl
see "Number of composite arithmetic numbers <= " + countNuma + ":" + countCompa + nl+nl

see "10000th arithmetic number is " + countNumb + nl
see "Number of composite arithmetic numbers <= " + countNumb + ":" + countCompb + nl
see "done..." + nl

func isPrime num
     if (num <= 1) return 0 ok
     if (num % 2 = 0 and num != 2) return 0 ok
     for i = 3 to floor(num / 2) -1 step 2
         if (num % i = 0) return 0 ok
     next
     return 1
Output:
works...
The first 100 arithmetic numbers are:

   1   3   5   6   7  11  13  14  15  17
  19  20  21  22  23  27  29  30  31  33
  35  37  38  39  41  42  43  44  45  46
  47  49  51  53  54  55  56  57  59  60
  61  62  65  66  67  68  69  70  71  73
  77  78  79  83  85  86  87  89  91  92
  93  94  95  96  97  99 101 102 103 105
 107 109 110 111 113 114 115 116 118 119
 123 125 126 127 129 131 132 133 134 135
 137 138 139 140 141 142 143 145 147 149

1000th arithmetic number is 1361
Number of composite arithmetic numbers <= 1361: 782

10000th arithmetic number is 12953
Number of composite arithmetic numbers <= 12953: 8458
done...

RPL

Works with: HP version 49g
≪ 
   DIVIS ∑LIST LASTARG SIZE DUP UNROT MOD NOT 
   SWAP 2 > R→C
≫ 'ARITHM' STO     @   ( n → (arithmetic?,composite?) )  

≪ { 1 } 1
   DO
      1 +
      IF DUP ARITHM RE THEN SWAP OVER + SWAP END
   UNTIL OVER SIZE 100 ≥ END DROP
≫ 'TASK1' STO

≪ → x
  ≪ (1,0) 1
     DO
        1 +
        DUP ARITHM
        IF DUP RE THEN ROT + SWAP ELSE DROP END
     UNTIL OVER RE x ≥ END 
     " o/w comp.= " + SWAP IM +
≫ ≫ 'TASK23' STO
1000 TASK1 1000 TASK23
Output:
3: {  1   3   5   6   7  11  13  14  15  17 19  20  21  22  23  27  29  30  31  33 35  37  38  39  41  42  43  44  45  46 47  49  51  53  54  55  56  57  59  60 61  62  65  66  67  68  69  70  71  73 77  78  79  83  85  86  87  89  91  92 93  94  95  96  97  99 101 102 103 105107 109 110 111 113 114 115 116 118 119 123 125 126 127 129 131 132 133 134 135 137 138 139 140 141 142 143 145 147 149 }
2: "1361 o/w comp.= 782."
1: "12953 o/w comp.= 8458."

Rust

Translation of: C
fn divisor_count_and_sum(mut n: u32) -> (u32, u32) {
    let mut divisor_count = 1;
    let mut divisor_sum = 1;
    let mut power = 2;
    while (n & 1) == 0 {
        divisor_count += 1;
        divisor_sum += power;
        power <<= 1;
        n >>= 1;
    }
    let mut p = 3;
    while p * p <= n {
        let mut count = 1;
        let mut sum = 1;
        power = p;
        while n % p == 0 {
            count += 1;
            sum += power;
            power *= p;
            n /= p;
        }
        divisor_count *= count;
        divisor_sum *= sum;
        p += 2;
    }
    if n > 1 {
        divisor_count *= 2;
        divisor_sum *= n + 1;
    }
    (divisor_count, divisor_sum)
}

fn main() {
    let mut arithmetic_count = 0;
    let mut composite_count = 0;
    let mut n = 1;
    while arithmetic_count <= 1000000 {
        let (divisor_count, divisor_sum) = divisor_count_and_sum(n);
        if divisor_sum % divisor_count != 0 {
            n += 1;
            continue;
        }
        arithmetic_count += 1;
        if divisor_count > 2 {
            composite_count += 1;
        }
        if arithmetic_count <= 100 {
            print!("{:3} ", n);
            if arithmetic_count % 10 == 0 {
                println!();
            }
        }
        if arithmetic_count == 1000
            || arithmetic_count == 10000
            || arithmetic_count == 100000
            || arithmetic_count == 1000000
        {
            println!("\n{}th arithmetic number is {}", arithmetic_count, n);
            println!(
                "Number of composite arithmetic numbers <= {}: {}",
                n, composite_count
            );
        }
        n += 1;
    }
}
Output:
  1   3   5   6   7  11  13  14  15  17 
 19  20  21  22  23  27  29  30  31  33 
 35  37  38  39  41  42  43  44  45  46 
 47  49  51  53  54  55  56  57  59  60 
 61  62  65  66  67  68  69  70  71  73 
 77  78  79  83  85  86  87  89  91  92 
 93  94  95  96  97  99 101 102 103 105 
107 109 110 111 113 114 115 116 118 119 
123 125 126 127 129 131 132 133 134 135 
137 138 139 140 141 142 143 145 147 149 

1000th arithmetic number is 1361
Number of composite arithmetic numbers <= 1361: 782

10000th arithmetic number is 12953
Number of composite arithmetic numbers <= 12953: 8458

100000th arithmetic number is 125587
Number of composite arithmetic numbers <= 125587: 88219

1000000th arithmetic number is 1228663
Number of composite arithmetic numbers <= 1228663: 905043

Scala

Translation of: Java
object ArithmeticNumbers extends App {
  var arithmeticCount = 0
  var compositeCount = 0
  var n = 1

  while (arithmeticCount <= 1_000_000) {
    val factors = findFactors(n)
    val sum = factors.sum
    if (sum % factors.size == 0) {
      arithmeticCount += 1
      if (factors.size > 2) compositeCount += 1
      if (arithmeticCount <= 100) {
        print(f"$n%3d" + (if (arithmeticCount % 10 == 0) "\n" else " "))
      }
      if (List(1_000, 10_000, 100_000, 1_000_000).contains(arithmeticCount)) {
        println()
        println(s"${arithmeticCount}th arithmetic number is $n")
        println(s"Number of composite arithmetic numbers <= $n: $compositeCount")
      }
    }
    n += 1
  }

  def findFactors(number: Int): Set[Int] = {
    (1 to number).filter(number % _ == 0).toSet
  }
}
Output:
  1   3   5   6   7  11  13  14  15  17
 19  20  21  22  23  27  29  30  31  33
 35  37  38  39  41  42  43  44  45  46
 47  49  51  53  54  55  56  57  59  60
 61  62  65  66  67  68  69  70  71  73
 77  78  79  83  85  86  87  89  91  92
 93  94  95  96  97  99 101 102 103 105
107 109 110 111 113 114 115 116 118 119
123 125 126 127 129 131 132 133 134 135
137 138 139 140 141 142 143 145 147 149

1000th arithmetic number is 1361
Number of composite arithmetic numbers <= 1361: 782

10000th arithmetic number is 12953
Number of composite arithmetic numbers <= 12953: 8458

100000th arithmetic number is 125587
Number of composite arithmetic numbers <= 125587: 88219

1000000th arithmetic number is 1228663
Number of composite arithmetic numbers <= 1228663: 905043

SETL

program arithmetic_numbers;
    [divsum, divcount] := calcdivsums(130000);

    print("First 100 arithmetic numbers:");

    loop for nth in [1..100000] do
        loop until divsum(num) mod divcount(num) = 0 do num +:= 1; end loop;
        comp +:= if num>1 and divsum(num) /= num+1 then 1 else 0 end if;

        if nth <= 100 then
            putchar(rpad(str num, 5));
            if nth mod 10 = 0 then print(); end if;
        end if;

        if nth in [1000, 10000, 100000] then
            print("The " + nth + "th arithmetic number is " + num + ".");
            print("Of the first " + nth + " arithmetic numbers, " +
                  comp + " are composite.");
        end if;
    end loop;

    proc calcdivsums(m);
        sums := [];
        counts := [];
        loop for d in [1..m] do
            loop for n in [d, d*2..m] do
                sums(n) +:= d;
                counts(n) +:= 1;
            end loop;
        end loop;
        return [sums, counts];
    end proc;
end program;
Output:
First 100 arithmetic numbers:
1    3    5    6    7    11   13   14   15   17
19   20   21   22   23   27   29   30   31   33
35   37   38   39   41   42   43   44   45   46
47   49   51   53   54   55   56   57   59   60
61   62   65   66   67   68   69   70   71   73
77   78   79   83   85   86   87   89   91   92
93   94   95   96   97   99   101  102  103  105
107  109  110  111  113  114  115  116  118  119
123  125  126  127  129  131  132  133  134  135
137  138  139  140  141  142  143  145  147  149
The 1000th arithmetic number is 1361.
Of the first 1000 arithmetic numbers, 782 are composite.
The 10000th arithmetic number is 12953.
Of the first 10000 arithmetic numbers, 8458 are composite.
The 100000th arithmetic number is 125587.
Of the first 100000 arithmetic numbers, 88219 are composite.

VBScript

'arithmetic numbers
'run with CScript

function isarit_compo(i)
     cnt=0
     sum=0
     for j=1 to sqr(i)
       if (i mod j)=0 then 
          k=i\j 
             
         if k=j then 
            cnt=cnt+1:sum=sum+j 
         else  
            cnt=cnt+2:sum=sum+j+k 
         end if
       end if
     next
   avg= sum/cnt
   isarit_compo= array((fix(avg)=avg),-(cnt>2))
end function

function rpad(a,n) rpad=right(space(n)&a,n) :end function

dim s1
sub print(s) 
  s1=s1& rpad(s,4)
  if len(s1)=40 then wscript.stdout.writeline s1:s1=""
end sub

'main program
cntr=0
cntcompo=0
i=1
wscript.stdout.writeline "the first 100 arithmetic numbers are:"
do
  a=isarit_compo(i)
  if a(0) then  
    cntcompo=cntcompo+a(1)
    cntr=cntr+1
    if cntr<=100 then print i
    if cntr=1000 then wscript.stdout.writeline vbcrlf&"1000th   : "&rpad(i,6) & " nr composites " &rpad(cntcompo,6)
    if cntr=10000 then wscript.stdout.writeline vbcrlf& "10000th  : "&rpad(i,6) & " nr composites " &rpad(cntcompo,6)
    if cntr=100000 then wscript.stdout.writeline vbcrlf &"100000th : "&rpad(i,6) & " nr composites " &rpad(cntcompo,6):exit do
  end if 
  i=i+1
loop
Output:

the first 100 arithmetic numbers are:
   1   3   5   6   7  11  13  14  15  17
  19  20  21  22  23  27  29  30  31  33
  35  37  38  39  41  42  43  44  45  46
  47  49  51  53  54  55  56  57  59  60
  61  62  65  66  67  68  69  70  71  73
  77  78  79  83  85  86  87  89  91  92
  93  94  95  96  97  99 101 102 103 105
 107 109 110 111 113 114 115 116 118 119
 123 125 126 127 129 131 132 133 134 135
 137 138 139 140 141 142 143 145 147 149

1000th   :   1361 nr composites    782

10000th  :  12953 nr composites   8458

100000th : 125587 nr composites  88219

Wren

Library: Wren-math
Library: Wren-fmt
Library: Wren-sort
import "./math" for Int, Nums
import "./fmt" for Fmt
import "./sort" for Find

var arithmetic = [1]
var primes = []
var limit = 1e6
var n = 3
while (arithmetic.count < limit) {
    var divs = Int.divisors(n)
    if (divs.count == 2) {
        primes.add(n)
        arithmetic.add(n)
    } else {
        var mean = Nums.mean(divs)
        if (mean.isInteger) arithmetic.add(n)
    }
    n = n + 1
}
System.print("The first 100 arithmetic numbers are:")
Fmt.tprint("$3d", arithmetic[0..99], 10)

for (x in [1e3, 1e4, 1e5, 1e6]) {
    var last = arithmetic[x-1]
    Fmt.print("\nThe $,dth arithmetic number is: $,d", x, last)
    var pcount = Find.nearest(primes, last) + 1
    if (!Int.isPrime(last)) pcount = pcount - 1
    var comp = x - pcount - 1 // 1 is not composite
    Fmt.print("The count of such numbers <= $,d which are composite is $,d.", last, comp)
}
Output:
The first 100 arithmetic numbers are:
  1   3   5   6   7  11  13  14  15  17 
 19  20  21  22  23  27  29  30  31  33 
 35  37  38  39  41  42  43  44  45  46 
 47  49  51  53  54  55  56  57  59  60 
 61  62  65  66  67  68  69  70  71  73 
 77  78  79  83  85  86  87  89  91  92 
 93  94  95  96  97  99 101 102 103 105 
107 109 110 111 113 114 115 116 118 119 
123 125 126 127 129 131 132 133 134 135 
137 138 139 140 141 142 143 145 147 149 

The 1,000th arithmetic number is: 1,361
The count of such numbers <= 1,361 which are composite is 782.

The 10,000th arithmetic number is: 12,953
The count of such numbers <= 12,953 which are composite is 8,458.

The 100,000th arithmetic number is: 125,587
The count of such numbers <= 125,587 which are composite is 88,219.

The 1,000,000th arithmetic number is: 1,228,663
The count of such numbers <= 1,228,663 which are composite is 905,043.

XPL0

int N, ArithCnt, CompCnt, Div, DivCnt, Sum, Quot;
[Format(4, 0);
N:= 1;  ArithCnt:= 0;  CompCnt:= 0;
repeat  Div:= 1;  DivCnt:= 0;  Sum:= 0;
        loop    [Quot:= N/Div;
                if Quot < Div then quit;
                if Quot = Div and rem(0) = 0 then \N is a square
                    [Sum:= Sum+Quot;  DivCnt:= DivCnt+1;  quit];
                if rem(0) = 0 then
                    [Sum:= Sum + Div + Quot;
                    DivCnt:= DivCnt+2;
                    ];
                Div:= Div+1;
                ];
        if rem(Sum/DivCnt) = 0 then \N is arithmetic
            [ArithCnt:= ArithCnt+1;
            if ArithCnt <= 100 then
                [RlOut(0, float(N));
                if rem(ArithCnt/20) = 0 then CrLf(0);
                ];
            if DivCnt > 2 then CompCnt:= CompCnt+1;
            case ArithCnt of 1000, 10_000, 100_000, 1_000_000:
                [CrLf(0);
                IntOut(0, N);  ChOut(0, 9\tab\);
                IntOut(0, CompCnt);
                ]
            other;
            ];
        N:= N+1;
until   ArithCnt >= 1_000_000;
]
Output:
   1   3   5   6   7  11  13  14  15  17  19  20  21  22  23  27  29  30  31  33
  35  37  38  39  41  42  43  44  45  46  47  49  51  53  54  55  56  57  59  60
  61  62  65  66  67  68  69  70  71  73  77  78  79  83  85  86  87  89  91  92
  93  94  95  96  97  99 101 102 103 105 107 109 110 111 113 114 115 116 118 119
 123 125 126 127 129 131 132 133 134 135 137 138 139 140 141 142 143 145 147 149

1361    782
12953   8458
125587  88219
1228663 905043