Hi:

I'm trying to call AS62 algorithm from VBA. I have done everything I can think of, but I still fail.

This is the FORTRAN CODE:

SUBROUTINE UDIST(M, N, FRQNCY, LFR, WORK, LWRK, IFAULT)

!dec$ attributes stdcall, alias:'UDIST', dllexport :: UDIST

!dec$ attributes reference :: M, N, FRQNCY, LFR, WORK, LWRK, IFAULT

INTEGER M, N, LFR, LWRK, IFAULT

REAL FRQNCY(*), WORK(*)

INTEGER MINMN, MN1, MAXMN, N1, I, IN, L, K, J

REAL ZERO, ONE, SUM

DATA ZERO /0.0/, ONE /1.0/

IFAULT = 1

MINMN = MIN(M, N)

IF (MINMN .LT. 1) RETURN

IFAULT = 2

MN1 = M * N + 1

IF (LFR .LT. MN1) RETURN

MAXMN = MAX(M, N)

N1 = MAXMN + 1

DO 1 I = 1, N1

1 FRQNCY(I) = ONE

IF (MINMN .EQ. 1) GO TO 4

IFAULT = 3

IF (LWRK .LT. (MN1 + 1) / 2 + MINMN) RETURN

N1 = N1 + 1

DO 2 I = N1, MN1

2 FRQNCY(I) = ZERO

WORK(1) = ZERO

IN = MAXMN

DO 3 I = 2, MINMN

WORK(I) = ZERO

IN = IN + MAXMN

N1 = IN + 2

L = 1 + IN / 2

K = I

DO 3 J = 1, L

K = K + 1

N1 = N1 - 1

SUM = FRQNCY(J) + WORK(J)

FRQNCY(J) = SUM

WORK(K) = SUM - FRQNCY(N1)

FRQNCY(N1) = SUM

3 CONTINUE

SUM = ZERO

DO 10 I = 1, MN1

SUM = SUM + FRQNCY(I)

FRQNCY(I) = SUM

10 END DO

4 IFAULT = 0

DO 20 I = 1, MN1

20 FRQNCY(I) = FRQNCY(I) / SUM

RETURN

END

It compiled without ny errors/warnings.

This is the VBA code:

Option Base 1

Option Explicit

Public Declare Sub UDIST Lib "E:\\Prueba Fortran\\Compilado\\AS62.dll" _

(ByRef m As Integer, ByRef n As Integer, ByRef frqncy As Long, ByRef lfr As Integer, ByRef work As Long, ByRef lwrk As Integer, ByRef ifault As Integer)

Public Function UPROB(m As Integer, n As Integer, U As Single) As Double

Dim lfr As Integer, minmn As Integer, lwrk As Integer, work() As Long, frqncy() As Long, ifault As Integer

lfr = m * n + 1

minmn = Application.WorksheetFunction.Min(m, n)

lwrk = 1 + minmn + (lfr + 1) / 2

ReDim work(lwrk)

ReDim frqncy(lfr)

Call UDIST(m, n, frqncy(1), lfr, work(1), lwrk, ifault)

' Reads the frequency for given U --> gives error, disabled for the moment

'UPROB = frqncy(U + 1)

'Reads IFAULT value to check if the call is correct --> still gives error

UPROB = ifault

End Function

I really don't know what I'm doing wrong

Thanks in advance,

Marta