Task: Aliquot sequence classifications








VB: Option Explicit

Private Type Aliquot
   Sequence() As Double
   Classification As String
End Type

Sub Main()
Dim result As Aliquot, i As Long, j As Double, temp As String

   For j = 1 To 10
      result = Aliq(j)
      temp = vbNullString
      For i = 0 To UBound(result.Sequence)
         temp = temp & result.Sequence(i) & ", "
      Next i
      Debug.Print "Aliquot seq of " & j & " : " & result.Classification & "   " & Left(temp, Len(temp) - 2)
   Next j

Dim a
   
   a = Array(11, 12, 28, 496, 220, 1184, 12496, 1264460, 790, 909, 562, 1064, 1488)
   For j = LBound(a) To UBound(a)
      result = Aliq(CDbl(a(j)))
      temp = vbNullString
      For i = 0 To UBound(result.Sequence)
         temp = temp & result.Sequence(i) & ", "
      Next i
      Debug.Print "Aliquot seq of " & a(j) & " : " & result.Classification & "   " & Left(temp, Len(temp) - 2)
   Next
End Sub

Private Function Aliq(Nb As Double) As Aliquot
Dim s() As Double, i As Long, temp, j As Long, cpt As Long
   temp = Array("non-terminating", "Terminate", "Perfect", "Amicable", "Sociable", "Aspiring", "Cyclic")
   ReDim s(0)
   s(0) = Nb
   For i = 1 To 15
      cpt = cpt + 1
      ReDim Preserve s(cpt)
      s(i) = SumPDiv(s(i - 1))
      If s(i) > 140737488355328# Then Exit For
      If s(i) = 0 Then j = 1
      If s(1) = s(0) Then j = 2
      If s(i) = s(0) And i > 1 And i <> 2 Then j = 4
      If s(i) = s(i - 1) And i > 1 Then j = 5
      If i >= 2 Then
         If s(2) = s(0) Then j = 3
         If s(i) = s(i - 2) And i <> 2 Then j = 6
      End If
      If j > 0 Then Exit For
   Next
   Aliq.Classification = temp(j)
   Aliq.Sequence = s
End Function

Private Function SumPDiv(n As Double) As Double

Dim j As Long, t As Long
    If n > 1 Then
        For j = 1 To n \ 2
            If n Mod j = 0 Then t = t + j
        Next
    End If
    SumPDiv = t
End Function



Fortran:       MODULE FACTORSTUFF	
Concocted by R.N.McLean, MMXV.
c       INTEGER*4 I4LIMIT
c       PARAMETER (I4LIMIT = 2147483647)
       INTEGER*8 TOOBIG		
       PARAMETER (TOOBIG = 2**47)	
       INTEGER LOTS			
       PARAMETER (LOTS = 10000)	
       INTEGER*8 KNOWNSUM(LOTS)	
       CONTAINS			
        INTEGER*8 FUNCTION SUMF(N)	
         INTEGER*8 N			
         INTEGER*8 F,F2		
         INTEGER*8 S,INC,BOOST		
          IF (N.LE.LOTS) THEN		
            SUMF = KNOWNSUM(N)			
           ELSE			
Could use SUMF in place of S, but some compilers have been confused by such usage.
            S = 1			
            F = 1			
            INC = 1			
            IF (MOD(N,2) .EQ. 1) INC = 2
    1       F = F + INC			
            F2 = F*F				
            IF (F2 .LT. N) THEN			
              IF (MOD(N,F) .EQ. 0) THEN		
                BOOST = F + N/F			
                IF (S .GT. TOOBIG - BOOST) GO TO 666	
                S = S + BOOST			
              END IF				
              GO TO 1				
            END IF			
            IF (F2 .EQ. N) THEN	
              IF (S .GT. TOOBIG - F) GO TO 666	
              S = S + F			
            END IF			
            SUMF = S			
          END IF			
         RETURN			
Cannot calculate the sum, because it exceeds the INTEGER*8 limit.
  666     SUMF = -666		
        END FUNCTION SUMF	
         SUBROUTINE PREPARESUMF	
Convert the Sieve of Eratoshenes to have each slot contain the sum of the proper divisors of its slot number.
Changes to instead count the number of factors, or prime factors, etc. would be simple enough.
         INTEGER*8 F		
          KNOWNSUM(1) = 0		
          KNOWNSUM(2:LOTS) = 1		
          DO F = 2,LOTS/2		
            FORALL(I = F + F:LOTS:F) KNOWNSUM(I) = KNOWNSUM(I) + F	
          END DO			
        END SUBROUTINE PREPARESUMF	
         SUBROUTINE CLASSIFY(N)	
         INTEGER*8 N		
         INTEGER ROPE		
         PARAMETER(ROPE = 16)	
         INTEGER*8 TRAIL(ROPE)	
         INTEGER*8 SF		
         INTEGER I,L		
         CHARACTER*28 THIS	
          L = 1		
          TRAIL(1) = N		
          SF = N		
   10     SF = SUMF(SF)		
          IF (SF .LT. 0) THEN		
            WRITE (THIS,11) L,"overflows
   11       FORMAT ("After ",I0,", ",A)		
            CALL REPORT(ADJUSTR(THIS))		
          ELSE IF (SF .EQ. 0) THEN		
            WRITE (THIS,11) L,"terminates
            CALL REPORT(ADJUSTR(THIS))		
          ELSE IF (ANY(TRAIL(1:L) .EQ. SF)) THEN	
            IF (L .EQ. 1) THEN				
              CALL REPORT("Perfect
            ELSE IF (L .EQ. 2) THEN			
              CALL REPORT("Amicable:")			
            ELSE					
              I = MINLOC(ABS(TRAIL(1:L) - SF),DIM=1)	
              IF (I .EQ. 1) THEN		
                WRITE (THIS,12) L		
   12           FORMAT ("Sociable ",I0,":")	
                CALL REPORT(ADJUSTR(THIS))	
              ELSE IF (I .EQ. L) THEN		
                CALL REPORT("Aspiring:")	
              ELSE				
                WRITE (THIS,13) L - I + 1,SF	
   13           FORMAT ("Cyclic end ",I0,", to ",I0,":")	
                CALL REPORT(ADJUSTR(THIS))	
              END IF				
            END IF			
          ELSE				
            IF (L .GE. ROPE) THEN		
              WRITE (THIS,11) L,"non-terminating?"	
              CALL REPORT(ADJUSTR(THIS))		
             ELSE				
              L = L + 1			
              TRAIL(L) = SF			
              GO TO 10				
            END IF			
          END IF		
         RETURN		
         CONTAINS		
          SUBROUTINE REPORT(WHAT)	
           CHARACTER*(*) WHAT		
            WRITE (6,1) WHAT,TRAIL(1:L)
    1       FORMAT (A28,1X,12(I0:","))	
          END SUBROUTINE REPORT	
        END SUBROUTINE CLASSIFY	
       END MODULE FACTORSTUFF	
       PROGRAM CLASSIFYTHEM	
       USE FACTORSTUFF		
       INTEGER*8 I,N		
       INTEGER*8 THIS(14)	
       DATA THIS/11,12,28,496,220,1184,12496,1264460,790,909,     
     1  562,1064,1488,15355717786080/	
         CALL PREPARESUMF		
         DO I = 1,10			
          CALL CLASSIFY(I)
        END DO
         DO I = 1,SIZE(THIS)		
          CALL CLASSIFY(THIS(I))
        END DO
       END