WeixiangYan/CodeTransOcean huggingface dataset:
Task: Gauss-Jordan matrix inversion







Python: import numpy as np
from numpy.linalg import inv
a = np.array([[1., 2., 3.], [4., 1., 6.],[ 7., 8., 9.]])
ainv = inv(a)

print(a)
print(ainv)




Fortran: 












      SUBROUTINE GJINV (A, LDA, N, B, LDB, IERR)
       IMPLICIT NONE
       INTEGER LDA, N, LDB, IERR
       REAL A(LDA,N), B(LDB,N)

       REAL EPS                                  
       PARAMETER (EPS = 1.1920929E-07)
       INTEGER I, J, K, P                        
       REAL F, TOL




       IF (N < 1) THEN            
         IERR = -1
         RETURN
       ELSE IF (N > LDA .OR. N > LDB) THEN
         IERR = -2
         RETURN
       END IF
       IERR = 0

       F = 0.                     
       DO J = 1, N
         DO I = 1, N
           F = F + A(I,J)**2
         END DO
       END DO
       F = SQRT(F)
       TOL = F * EPS

       DO J = 1, N                
         DO I = 1, N
           IF (I .EQ. J) THEN
             B(I,J) = 1.
           ELSE
             B(I,J) = 0.
           END IF
         END DO
       END DO


       DO K = 1, N
         F = ABS(A(K,K))          
         P = K
         DO I = K+1, N
           IF (ABS(A(I,K)) > F) THEN
             F = ABS(A(I,K))
             P = I
           END IF
         END DO

         IF (F < TOL) THEN        
           IERR = 1
           RETURN
         END IF

         IF (P .NE. K) THEN       
           DO J = K, N
             F = A(K,J)
             A(K,J) = A(P,J)
             A(P,J) = F
           END DO
           DO J = 1, N
             F = B(K,J)
             B(K,J) = B(P,J)
             B(P,J) = F
           END DO
         END IF

         F = 1. / A(K,K)          
         DO J = K, N
           A(K,J) = A(K,J) * F
         END DO
         DO J = 1, N
           B(K,J) = B(K,J) * F
         END DO

         DO 10 I = 1, N           
           IF (I .EQ. K) GO TO 10
           F = A(I,K)
           DO J = K, N
             A(I,J) = A(I,J) - A(K,J) * F
           END DO
           DO J = 1, N
             B(I,J) = B(I,J) - B(K,J) * F
           END DO
  10     CONTINUE
       END DO

       RETURN
      END
Task: Welch's t-test







Python: import numpy as np
import scipy as sp
import scipy.stats

def welch_ttest(x1, x2):
    n1 = x1.size
    n2 = x2.size
    m1 = np.mean(x1)
    m2 = np.mean(x2)
    v1 = np.var(x1, ddof=1)
    v2 = np.var(x2, ddof=1)
    t = (m1 - m2) / np.sqrt(v1 / n1 + v2 / n2)
    df = (v1 / n1 + v2 / n2)**2 / (v1**2 / (n1**2 * (n1 - 1)) + v2**2 / (n2**2 * (n2 - 1)))
    p = 2 * sp.stats.t.cdf(-abs(t), df)
    return t, df, p

welch_ttest(np.array([3.0, 4.0, 1.0, 2.1]), np.array([490.2, 340.0, 433.9]))
(-9.559497721932658, 2.0008523488562844, 0.01075156114978449)




Fortran: subroutine welch_ttest(n1, x1, n2, x2, t, df, p)
    use tdf_int
    implicit none
    integer :: n1, n2
    double precision :: x1(n1), x2(n2)
    double precision :: m1, m2, v1, v2, t, df, p
    m1 = sum(x1) / n1
    m2 = sum(x2) / n2
    v1 = sum((x1 - m1)**2) / (n1 - 1)
    v2 = sum((x2 - m2)**2) / (n2 - 1)
    t = (m1 - m2) / sqrt(v1 / n1 + v2 / n2)
    df = (v1 / n1 + v2 / n2)**2 / &
         (v1**2 / (n1**2 * (n1 - 1)) + v2**2 / (n2**2 * (n2 - 1)))
    p = 2d0 * tdf(-abs(t), df)
end subroutine

program pvalue
    use betai_int
    implicit none
    double precision :: x(4) = [3d0, 4d0, 1d0, 2.1d0]
    double precision :: y(3) = [490.2d0, 340.0d0, 433.9d0]
    double precision :: t, df, p
    call welch_ttest(4, x, 3, y, t, df, p)
    print *, t, df, p
    print *, betai(df / (t**2 + df), 0.5d0 * df, 0.5d0)
end program
Task: Ormiston pairs




Go: package main

import (
    "fmt"
    "rcu"
)

func main() {
    const limit = 1e9
    primes := rcu.Primes(limit)
    var orm30 [][2]int
    j := int(1e5)
    count := 0
    var counts []int
    for i := 0; i < len(primes)-1; i++ {
        p1 := primes[i]
        p2 := primes[i+1]
        if (p2-p1)%18 != 0 {
            continue
        }
        key1 := 1
        for _, dig := range rcu.Digits(p1, 10) {
            key1 *= primes[dig]
        }
        key2 := 1
        for _, dig := range rcu.Digits(p2, 10) {
            key2 *= primes[dig]
        }
        if key1 == key2 {
            if count < 30 {
                orm30 = append(orm30, [2]int{p1, p2})
            }
            if p1 >= j {
                counts = append(counts, count)
                j *= 10
            }
            count++
        }
    }
    counts = append(counts, count)
    fmt.Println("First 30 Ormiston pairs:")
    for i := 0; i < 30; i++ {
        fmt.Printf("%5v ", orm30[i])
        if (i+1)%3 == 0 {
            fmt.Println()
        }
    }
    fmt.Println()
    j = int(1e5)
    for i := 0; i < len(counts); i++ {
        fmt.Printf("%s Ormiston pairs before %s\n", rcu.Commatize(counts[i]), rcu.Commatize(j))
        j *= 10
    }
}
Task: Anaprimes




Go: package main

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

func main() {
    const limit = int(1e10)
    const maxIndex = 9
    primes := rcu.Primes(limit)
    anaprimes := make(map[int][]int)
    for _, p := range primes {
        digs := rcu.Digits(p, 10)
        key := 1
        for _, dig := range digs {
            key *= primes[dig]
        }
        if _, ok := anaprimes[key]; ok {
            anaprimes[key] = append(anaprimes[key], p)
        } else {
            anaprimes[key] = []int{p}
        }
    }
    largest := make([]int, maxIndex+1)
    groups := make([][][]int, maxIndex+1)
    for key := range anaprimes {
        v := anaprimes[key]
        nd := len(rcu.Digits(v[0], 10))
        c := len(v)
        if c > largest[nd-1] {
            largest[nd-1] = c
            groups[nd-1] = [][]int{v}
        } else if c == largest[nd-1] {
            groups[nd-1] = append(groups[nd-1], v)
        }
    }
    j := 1000
    for i := 2; i <= maxIndex; i++ {
        js := rcu.Commatize(j)
        ls := rcu.Commatize(largest[i])
        fmt.Printf("Largest group(s) of anaprimes before %s: %s members:\n", js, ls)
        sort.Slice(groups[i], func(k, l int) bool {
            return groups[i][k][0] < groups[i][l][0]
        })
        for _, g := range groups[i] {
            fmt.Printf("  First: %s  Last: %s\n", rcu.Commatize(g[0]), rcu.Commatize(g[len(g)-1]))
        }
        j *= 10
        fmt.Println()
    }
}
Task: Copy a string








VB: Sub copystring()
    a = "Hello World!"
    b = a
    a = "I
    Debug.Print b
    Debug.Print a
End Sub



Fortran: str2 = str1
Task: Keyboard input_Obtain a Y or N response








VB: 



GraphicsWindow.DrawText(10, 10, "Hit any key to dump.")
GraphicsWindow.KeyDown = OnKeyDown
Sub OnKeyDown
  TextWindow.WriteLine(GraphicsWindow.LastKey)
EndSub



Fortran:       CHARACTER*120 FUNCTION REPLY(QUERY)    
Concocted by R.N.McLean (whom God preserve), December MM.
       CHARACTER*(*) QUERY	
       CHARACTER*120 TEXT	
       INTEGER MSG,KEYS,LSTNB	
       COMMON /IOUNITS/ MSG,KEYS
        WRITE (MSG,1) QUERY(1:LSTNB(QUERY)),"?"
    1   FORMAT (2A,$)		
        READ (KEYS,1) TEXT	
        REPLY = TEXT		
       RETURN			
      END 			

      REAL*8 FUNCTION REPLYN(QUERY)	
Concocted by R.N.McLean (whom God preserve), December MM.
       CHARACTER*(*) QUERY	
       REAL X			
       INTEGER MSG,KEYS,LSTNB	
       COMMON /IOUNITS/ MSG,KEYS
    1   WRITE (MSG,2) QUERY(1:LSTNB(QUERY))	
    2   FORMAT (A,$)		
        READ (KEYS,*,ERR = 3) X	
        REPLYN = X		
       RETURN			
    3   WRITE (MSG,4)		
    4   FORMAT ('Distasteful number. Try again...')	
        GO TO 1			
      END			

      LOGICAL FUNCTION YEA(QUERY)	
Concocted by R.N.McLean (whom God preserve), December MM.
       CHARACTER*(*) QUERY	
       CHARACTER*120 WHAT,REPLY	
       CHARACTER*1 C		
       INTEGER MSG,KEYS		
       COMMON /IOUNITS/ MSG,KEYS
       INTEGER L		
    1   WHAT = REPLY(QUERY)	
        DO L = 1,LEN(WHAT)	
          C = WHAT(L:L)		
          IF (C .NE. ' ') GO TO 10	
        END DO			
        WRITE (MSG,2)		
    2   FORMAT ('All blank?')	
    3   WRITE (MSG,4) 		
    4   FORMAT ('I dig it not. Try Yes/Si/Da/Oui/Ja, or No')
        GO TO 1			
   10   IF (INDEX('YySsDdOoJj',C) .GT. 0) THEN	
          YEA = .TRUE.		
        ELSE IF (INDEX('Nn',C) .GT. 0) THEN	
          YEA = .FALSE.		
        ELSE			
          GO TO 3		
        END IF			
       RETURN			
      END			
      LOGICAL FUNCTION NAY(QUERY)	
Concocted by R.N.McLean (whom God preserve), December MM.
       CHARACTER*(*) QUERY	
       LOGICAL YEA		
        NAY = .NOT.YEA(QUERY)	
       RETURN			
      END
Task: Verify distribution uniformity_Naive








VB: Option Explicit

sub verifydistribution(calledfunction, samples, delta)
	Dim i, n, maxdiff
	
	Dim d : Set d = CreateObject("Scripting.Dictionary")
	wscript.echo "Running """ & calledfunction & """ " & samples & " times..."
	for i = 1 to samples
		Execute "n = " & calledfunction
		d(n) = d(n) + 1
	next
	n = d.Count
	maxdiff = 0
	wscript.echo "Expected average count is " & Int(samples/n) & " across " & n & " buckets."
	for each i in d.Keys
		dim diff : diff = abs(1 - d(i) / (samples/n))
		if diff > maxdiff then maxdiff = diff
		wscript.echo "Bucket " & i & " had " & d(i) & " occurences" _
		& vbTab & " difference from expected=" & FormatPercent(diff, 2)
	next
	wscript.echo "Maximum found variation is " & FormatPercent(maxdiff, 2) _
		& ", desired limit is " & FormatPercent(delta, 2) & "."
	if maxdiff > delta then wscript.echo "Skewed!" else wscript.echo "Smooth!"
end sub



Fortran: subroutine distcheck(randgen, n, delta)

  interface
    function randgen
      integer :: randgen 
    end function randgen
  end interface
  
  real, intent(in) :: delta
  integer, intent(in) :: n
  integer :: i, mval, lolim, hilim
  integer, allocatable :: buckets(:)
  integer, allocatable :: rnums(:)
  logical :: skewed = .false.
     
  allocate(rnums(n))
  
  do i = 1, n
    rnums(i) = randgen()
  end do

  mval = maxval(rnums)
  allocate(buckets(mval))
  buckets = 0
  
  do i = 1, n
    buckets(rnums(i)) = buckets(rnums(i)) + 1
  end do

  lolim = n/mval - n/mval*delta
  hilim = n/mval + n/mval*delta
  
  do i = 1, mval  
    if(buckets(i) < lolim .or. buckets(i) > hilim) then
      write(*,"(a,i0,a,i0,a,i0)") "Distribution potentially skewed for bucket ", i, "   Expected: ", &
                                   n/mval, "   Actual: ", buckets(i)
      skewed = .true.
    end if
  end do 

  if (.not. skewed) write(*,"(a)") "Distribution uniform"
  
  deallocate(rnums)
  deallocate(buckets)
    
end subroutine
Task: Ray-casting algorithm








VB: Imports System.Math

Module RayCasting

    Private square As Integer()() = {New Integer() {0, 0}, New Integer() {20, 0}, New Integer() {20, 20}, New Integer() {0, 20}}
    Private squareHole As Integer()() = {New Integer() {0, 0}, New Integer() {20, 0}, New Integer() {20, 20}, New Integer() {0, 20}, New Integer() {5, 5}, New Integer() {15, 5}, New Integer() {15, 15}, New Integer() {5, 15}}
    Private strange As Integer()() = {New Integer() {0, 0}, New Integer() {5, 5}, New Integer() {0, 20}, New Integer() {5, 15}, New Integer() {15, 15}, New Integer() {20, 20}, New Integer() {20, 0}}
    Private hexagon As Integer()() = {New Integer() {6, 0}, New Integer() {14, 0}, New Integer() {20, 10}, New Integer() {14, 20}, New Integer() {6, 20}, New Integer() {0, 10}}
    Private shapes As Integer()()() = {square, squareHole, strange, hexagon}

    Public Sub Main()
        Dim testPoints As Double()() = {New Double() {10, 10}, New Double() {10, 16}, New Double() {-20, 10}, New Double() {0, 10}, New Double() {20, 10}, New Double() {16, 10}, New Double() {20, 20}}

        For Each shape As Integer()() In shapes
            For Each point As Double() In testPoints
                Console.Write(String.Format("{0} ", Contains(shape, point).ToString.PadLeft(7)))
            Next
            Console.WriteLine()
        Next
    End Sub

    Private Function Contains(shape As Integer()(), point As Double()) As Boolean

        Dim inside As Boolean = False
        Dim length As Integer = shape.Length

        For i As Integer = 0 To length - 1
            If Intersects(shape(i), shape((i + 1) Mod length), point) Then
                inside = Not inside
            End If
        Next

        Return inside
    End Function

    Private Function Intersects(a As Integer(), b As Integer(), p As Double()) As Boolean

        If a(1) > b(1) Then Return Intersects(b, a, p)
        If p(1) = a(1) Or p(1) = b(1) Then p(1) += 0.0001
        If p(1) > b(1) Or p(1) < a(1) Or p(0) >= Max(a(0), b(0)) Then Return False
        If p(0) < Min(a(0), b(0)) Then Return True
        Dim red As Double = (p(1) - a(1)) / (p(0) - a(0))
        Dim blue As Double = (b(1) - a(1)) / (b(0) - a(0))

        Return red >= blue
    End Function
End Module



Fortran: module Polygons
  use Points_Module
  implicit none

  type polygon
     type(point), dimension(:), allocatable :: points
     integer, dimension(:), allocatable :: vertices
  end type polygon

contains

  function create_polygon(pts, vt)
    type(polygon) :: create_polygon
    type(point), dimension(:), intent(in) :: pts
    integer, dimension(:), intent(in) :: vt

    integer :: np, nv

    np = size(pts,1)
    nv = size(vt,1)

    allocate(create_polygon%points(np), create_polygon%vertices(nv))
    create_polygon%points = pts
    create_polygon%vertices = vt

  end function create_polygon

  subroutine free_polygon(pol)
    type(polygon), intent(inout) :: pol

    deallocate(pol%points, pol%vertices)

  end subroutine free_polygon

end module Polygons
Task: Hofstadter Q sequence








VB: Public Q(100000) As Long
Public Sub HofstadterQ()
    Dim n As Long, smaller As Long
    Q(1) = 1
    Q(2) = 1
    For n = 3 To 100000
        Q(n) = Q(n - Q(n - 1)) + Q(n - Q(n - 2))
        If Q(n) < Q(n - 1) Then smaller = smaller + 1
    Next n
    Debug.Print "First ten terms:"
    For i = 1 To 10
        Debug.Print Q(i);
    Next i
    Debug.print
    Debug.Print "The 1000th term is:"; Q(1000)
    Debug.Print "Number of times smaller:"; smaller
End Sub



Fortran: Calculate the Hofstadter Q-sequence, using a big array rather than recursion.
      INTEGER ENUFF
      PARAMETER (ENUFF = 100000)
      INTEGER Q(ENUFF)	

      Q(1) = 1		
      Q(2) = 1
      Q(3:) = -123456789
      DO I = 3,ENUFF	
        Q(I) = Q(I - Q(I - 1)) + Q(I - Q(I - 2))	
      END DO
Cast forth results as per the specification.
      WRITE (6,1) Q(1:10)		
    1 FORMAT ("First ten values:",10I2)	
      WRITE (6,*) "Q(1000) =",Q(1000)	
      WRITE (6,3) ENUFF,COUNT(Q(2:ENUFF) < Q(1:ENUFF - 1))	
    3 FORMAT ("Count of those elements 2:",I0,
     1 " which are less than their predecessor: ",I0)	
Curry favour by allowing enquiries.
   10 WRITE (6,11) ENUFF
   11 FORMAT ("Nominate an index (in 1:",I0,"): ",$)	
      READ (5,*,END = 999, ERR = 999) I	
      IF (I.GT.0 .AND. I.LE.ENUFF) THEN	
        WRITE (6,12) I,Q(I)		
   12   FORMAT ("Q(",I0,") = ",I0)	
        GO TO 10			
      END IF		
Closedown.
  999 WRITE (6,*) "Bye."
      END
Task: Count occurrences of a substring








VB: Public Sub Main() 
  
  Print countSubstring("the three truths", "th") 
  Print countSubstring("ababababab", "abab") 
  Print countSubString("zzzzzzzzzzzzzzz", "z")

End 

Function countSubstring(s As String, search As String) As Integer 

  If s = "" Or search = "" Then Return 0 
  Dim count As Integer = 0, length As Integer = Len(search) 
  For i As Integer = 1 To Len(s) 
    If Mid(s, i, length) = Search Then 
      count += 1 
      i += length - 1 
    End If 
  Next 
  Return count 

End Function



Fortran: program Example
  implicit none
  integer :: n
  
  n = countsubstring("the three truths", "th")
  write(*,*) n
  n = countsubstring("ababababab", "abab")
  write(*,*) n
  n = countsubstring("abaabba*bbaba*bbab", "a*b")
  write(*,*) n
 
contains

function countsubstring(s1, s2) result(c)
  character(*), intent(in) :: s1, s2
  integer :: c, p, posn
 
  c = 0
  if(len(s2) == 0) return
  p = 1
  do 
    posn = index(s1(p:), s2)
    if(posn == 0) return
    c = c + 1
    p = p + posn + len(s2) - 1
  end do
end function
end program
Task: Carmichael 3 strong pseudoprimes








VB: max_sieve = 1e7
dim isprime(max_sieve)

//set up sieve
for i = 3 to max_sieve step 2
  isprime(i) = 1
next i

isprime(2) = 1
for i = 3 to sqrt(max_sieve) step 2
  if isprime(i) = 1 then
    for j = i * i to max_sieve step i * 2
      isprime(j) = 0
    next j
  fi
next i

for i = 2 to 61
  carmichael3(i)
next i
end
 
sub carmichael3(p1) 
  local h3, d, p2, p3, t1, t2

  if isprime(p1) = 0  return
  for h3 = 1 to p1 -1
    t1 = (h3 + p1) * (p1 -1)
    t2 = mod((-p1 * p1), h3)
    if t2 < 0   t2 = t2 + h3
    for d = 1 to h3 + p1 -1
      if mod(t1, d) = 0 and t2 = mod(d, h3) then
        p2 = 1 + int(t1 / d)
        if isprime(p2) = 0  continue
        p3 = 1 + int(p1 * p2 / h3)
        if isprime(p3) = 0 or mod((p2 * p3), (p1 -1)) <> 1  continue
        print p1 using ("###"), " * ", p2 using ("####"), " * ", p3 using ("#####")
      fi
    next d
  next h3
end sub



Fortran:       LOGICAL FUNCTION ISPRIME(N)	
       INTEGER N			
       INTEGER F			
        ISPRIME = .FALSE.		
        DO F = 2,SQRT(DFLOAT(N))	
          IF (MOD(N,F).EQ.0) RETURN	
        END DO				
        ISPRIME = .TRUE.		
      END FUNCTION ISPRIME		

      PROGRAM CHASE
      INTEGER P1,P2,P3	
      INTEGER H3,D	
      INTEGER MSG	
      MSG = 6		
      WRITE (MSG,1)	
    1 FORMAT ("Carmichael numbers that are the product of three primes:"
     & /"    P1  x P2  x P3 =",9X,"C")
      DO P1 = 2,61	
        IF (ISPRIME(P1)) THEN	
          DO H3 = 2,P1 - 1		
            DO D = 1,H3 + P1 - 1		
              IF (MOD((H3 + P1)*(P1 - 1),D).EQ.0	
     &        .AND. (MOD(H3 + MOD(-P1**2,H3),H3) .EQ. MOD(D,H3))) THEN	
                P2 = 1 + (P1 - 1)*(H3 + P1)/D	
                IF (ISPRIME(P2)) THEN		
                  P3 = 1 + P1*P2/H3			
                  IF (ISPRIME(P3)) THEN			
                    IF (MOD(P2*P3,P1 - 1).EQ.1) THEN		
                      WRITE (MSG,2) P1,P2,P3, INT8(P1)*P2*P3		
    2                 FORMAT (3I6,I12)
                    END IF
                  END IF
                END IF
              END IF
            END DO
          END DO
        END IF
      END DO
      END
Task: Benford's law








VB: Sub BenfordLaw()

Dim BenResult(1 To 9) As Long

BENref = "30,1%|17,6%|12,5%|9,7%|7,9%|6,7%|5,8%|5,1%|4,6%"

For Each c In Selection.Cells
  If InStr(1, "-0123456789", Left(c, 1)) > 0 Then
    For i = 1 To 9
      If CInt(Left(Abs(c), 1)) = i Then BenResult(i) = BenResult(i) + 1: Exit For
    Next
  End If
Next
Total= Application.Sum(BenResult)
biggest= Len(CStr(BenResult(1)))

txt = "#   |   Values    |     Real     |  Expected   " & vbCrLf
For i = 1 To 9
  If BenResult(i) > 0 Then
    txt = txt & "#" & i & " | " & vbTab
    txt = txt & String((biggest - Len(CStr(BenResult(i)))) * 2, " ") & Format(BenResult(i), "0") & " | " & vbTab
    txt = txt & String((Len(CStr(Format(BenResult(1) / Total, "##0.0%"))) - Len(CStr(Format(BenResult(i) / Total, "##0.0%")))) * 2, " ") & Format(BenResult(i) / Total, "##0.0%") & " | " & vbTab
    txt = txt & Format(Split(BENref, "|")(i - 1), "     ##0.0%") & vbCrLf
  End If
Next

MsgBox txt, vbOKOnly, "Finish"

End Sub

}



Fortran: -*- mode: compilation; default-directory: "/tmp/" -*-
Compilation started at Sat May 18 01:13:00

a=./f && make $a && $a
f95 -Wall -ffree-form f.F -o f
  0.301030010      0.176091254      0.124938756       9.69100147E-02   7.91812614E-02   6.69467747E-02   5.79919666E-02   5.11525236E-02   4.57575098E-02 THE LAW
  0.300999999      0.177000001      0.125000000       9.60000008E-02   7.99999982E-02   6.70000017E-02   5.70000000E-02   5.29999994E-02   4.50000018E-02 LEADING FIBONACCI DIGIT

Compilation finished at Sat May 18 01:13:00
Task: Case-sensitivity of identifiers








VB: Public Sub case_sensitivity()
    
    
    
    Dim DOG As String
    DOG = "Benjamin"
    DOG = "Samba"
    DOG = "Bernie"
    Debug.Print "There is just one dog named " & DOG
End Sub



Fortran: program Example
  implicit none

  character(8) :: dog, Dog, DOG

  dog = "Benjamin"
  Dog = "Samba"
  DOG = "Bernie"

  if (dog == DOG) then
    write(*,*) "There is just one dog named ", dog
  else
    write(*,*) "The three dogs are named ", dog, Dog, " and ", DOG
  end if

end program Example
Task: Truncate a file








VB: Sub truncate(fpath,n)
	
	Set objfso = CreateObject("Scripting.FileSystemObject")
	If objfso.FileExists(fpath) = False Then
		WScript.Echo fpath & " does not exist"
		Exit Sub
	End If
	content = ""
	
	Set objinstream = CreateObject("Adodb.Stream")
	With objinstream
		.Type = 1
		.Open
		.LoadFromFile(fpath)
		
		If n <= .Size Then
			content = .Read(n)
		Else
			WScript.Echo "The specified size is larger than the file content"
			Exit Sub
		End If
		.Close
	End With
	
	Set objoutstream = CreateObject("Adodb.Stream")
	With objoutstream
		.Type = 1
		.Open
		.Write content
		.SaveToFile fpath,2
		.Close
	End With
	Set objinstream = Nothing
	Set objoutstream = Nothing
	Set objfso = Nothing
End Sub


Call truncate("C:\temp\test.txt",30)



Fortran:       SUBROUTINE CROAK(GASP)	
       CHARACTER*(*) GASP	
        WRITE (6,*) "Oh dear. ",GASP	
        STOP "++ungood."	
      END			

      SUBROUTINE FILEHACK(FNAME,NB)
       CHARACTER*(*) FNAME	
       INTEGER NB		
       INTEGER L		
       INTEGER F,T		
       PARAMETER (F=66,T=67)	
       LOGICAL EXIST		
       CHARACTER*1 B		
        IF (FNAME.EQ."") CALL CROAK("Blank file name
        IF (NB.LE.0)     CALL CROAK("Chop must be positive
        INQUIRE(FILE = FNAME, EXIST = EXIST)	
        IF (.NOT.EXIST) CALL CROAK("Can't find a file called "//FNAME)	
        OPEN (F,FILE=FNAME,STATUS="OLD",ACTION="READWRITE",	
     1   FORM="UNFORMATTED",RECL=1,ACCESS="DIRECT")		
        OPEN (T,STATUS="SCRATCH",FORM="UNFORMATTED",RECL=1)	

Copy the desired "records" to the temporary file.
   10   DO L = 1,NB	
          READ  (F,REC = L,ERR = 20) B	
          WRITE (T) B			
        END DO		
   20   IF (L.LE.NB) CALL CROAK("Short file
Convert from input to output...
        REWIND T		
        CLOSE(F)		
        OPEN (F,FILE=FNAME,FORM="FORMATTED",	
     1   ACTION="WRITE",STATUS="REPLACE")	
Copy from the temporary file.
        DO L = 1,NB	
          READ  (T) B		
          WRITE (F,"(A1,$)") B	
        END DO		
Completed.
   30   CLOSE(T)	
        CLOSE(F)	
      END		

      PROGRAM CHOPPER
       CALL FILEHACK("foobar.txt",12)
      END
Task: Sorting algorithms_Shell sort








VB: Sub arrShellSort(ByVal arrData As Variant)
  Dim lngHold, lngGap As Long
  Dim lngCount, lngMin, lngMax As Long
  Dim varItem As Variant
  
  lngMin = LBound(arrData)
  lngMax = UBound(arrData)
  lngGap = lngMin
  Do While (lngGap < lngMax)
    lngGap = 3 * lngGap + 1
  Loop
  Do While (lngGap > 1)
    lngGap = lngGap \ 3
    For lngCount = lngGap + lngMin To lngMax
      varItem = arrData(lngCount)
      lngHold = lngCount
      Do While ((arrData(lngHold - lngGap) > varItem))
        arrData(lngHold) = arrData(lngHold - lngGap)
        lngHold = lngHold - lngGap
        If (lngHold < lngMin + lngGap) Then Exit Do
      Loop
      arrData(lngHold) = varItem
    Next
  Loop
  arrShellSort = arrData
End Sub



Fortran: MODULE sort

CONTAINS

SUBROUTINE Shell_Sort(a)

  IMPLICIT NONE
  INTEGER :: i, j, increment
  REAL :: temp
  REAL, INTENT(in out) :: a(:)
	
  increment = SIZE(a) / 2
  DO WHILE (increment > 0)
      DO i = increment+1, SIZE(a)
         j = i
         temp = a(i)
         DO WHILE (j >= increment+1 .AND. a(j-increment) > temp)
            a(j) = a(j-increment)
            j = j - increment
         END DO
         a(j) = temp
      END DO
      IF (increment == 2) THEN
   	  increment = 1
      ELSE
         increment = increment * 5 / 11
      END IF      
  END DO
 
END SUBROUTINE Shell_Sort

END MODULE sort

PROGRAM Shellsort

USE sort

  IMPLICIT NONE
  REAL :: array(1000)
     
  CALL RANDOM_SEED
  CALL RANDOM_NUMBER(array)
 
  WRITE (*,*) "Unsorted array"
  WRITE (*,*) array
  WRITE (*,*) 
  CALL Shell_Sort(array)
  WRITE (*,*) "Sorted array"
  WRITE (*,*) array
  
END PROGRAM Shellsort