在 Visual Basic 中调用 NAG 函数
Visual Basic (VB) 4/5/6 版与 Visual Basic for Applications (VBA) 有许多相似之处，所以大部分
SUBROUTINE N_C05ADF(A,B,EPS,ETA,X,IFAIL)
DOUBLE PRECISION A
DOUBLE PRECISION B
DOUBLE PRECISION EPS
DOUBLE PRECISION ETA
DOUBLE PRECISION F
EXTERNAL F
DOUBLE PRECISION X
INTEGER IFAIL
CALL C05ADF (A,B,EPS,ETA,F,X,IFAIL)
END
VB 与 VBA 会透过另一个函数接口调用 NAG 函数，此函数与 NAG 函数会有相同的参数，但是会移除掉部分的参数。在此例中，用户提供的函数 F 将被移除。新的函数能够简单的调用原有 NAG 函数， 并会以固定的名称提供调用参数。我们以下列的例子进行说明：
第一步使用 CVF 编译器编译用户函数 F，第一步产生 F 的 DLL：
DF /c /Op /Ox /Tf F.FOR
链结函数：
LINK @F.LNK
其中 F.LNK 为文件
/DLL
/OUT:F.DLL
F.OBJ
/EXPORT:_F@4
/EXPORT:_F=_F@4
/EXPORT:F=_F@4
先忽略其他细节，除了 F.DLL 外，还会产生 F.IMP 与 F.LIB 两个文件。将会在之后使用到此档：
编译函数：
DF /c /Op /Ox /Tf N_C05ADF.FOR
链接函数：
LINK @NAG.LNK
其中 NAG.LNK 为文件：
/DLL
/OUT:NAG.DLL
f.lib
DLL20DDS.LIB
N_C05ADF.OBJ
/EXPORT:_N_C05ADF@24
/EXPORT:Alias=_N_C05ADF@24
请注意 /EXPORTS 所输出的算法库文件。其说明 DLL 中所使用的符号。此例中说明了在 DLL20DDS DLL 中的 C05ADF 函数，以及在 F.DLL 中的 F 函数。这些资讯是在被建立前就写到文件中的。 透过 /EXPORT 告诉 DLL 输出。请注意这些符号是以下底线构成的，函数名称会跟着 @ 符号以及数字。 此数字包含了被 CVF 编译器使用到的参数数量与型别。此称为 '装饰名'。也可使用公用程序 DUMPBIN 取得：
DUMPBIN /SYMBOLS N_C05ADF.OBJ
因为装饰名称可能在使用上相当繁琐，所以可以透过 /EXPORT 第二行指定的 'Alias' 来取代。
VB5 提供了传递函数参数的机制 - AddressOf。若您想要了解其如何运作，请参考以下示例，示例将说明如何在 VB5 中使用 E04UCF 函数：
Option Explicit
Private Sub Command1_Click( )
'Starting values of variables
x(1) = 1
x(2) = 5
x(3) = 5
x(4) = 1
'Bounds of the variables
bl(1) = 1: bu(1) = 5
bl(2) = 1: bu(2) = 5
bl(3) = 1: bu(3) = 5
bl(4) = 1: bu(4) = 5
'Coefficients of the general linear constraint
a(1, 1) = 1
a(1, 2) = 1
a(1, 3) = 1
a(1, 4) = 1
'Bounds of the general linear constraint
bl(n + 1) = -1E+21: bu(n + 1) = 20
'Bounds of the nonlinear constraints
bl(n + nclin + 1) = -1E+21: bu(n + nclin + 1) = 40
bl(n + nclin + 2) = 25: bu(n + nclin + 2) = 1E+21
'Solve the problem
Label1.Caption = ""
ifail = +1
mode=1
Call X04ACF(NOUT, "\results.lis", 12, mode, ifail)
'X04ACF opens the file \results.lis and saless it to Fortran channel 6
'Note that the "12" refers to the length of the string "\results.lis"
Call E04UEF("NoList", 6)
Call E04UEF("Major Print Level=9", 19)
Call E04UEF("Minor Print Level=9", 19)
Call E04UEF("Der=0", 5)
ifail = +1
Call E04UCF(n, nclin, ncnln, lda, ldcj, ldr, a(1, 1), bl(1), bu(1), _
AddressOf confun, AddressOf objfun, iter, istate(1), c(1), cjac(1, 1), _
clamda(1), objf, objgrd(1), r(1, 1), x(1), iwork(1), liwork, work(1), _
lwork, iuser, user, ifail)
Label1.Caption = "E04UCF Example Program Results" + Chr(13) + _
"------------------------------------------------------" + Chr(13) + _
"Value of objective function:"+Str(objf)+Chr(13)+"x1 = " + Str(x(1)) + _
Chr(13)+"x2 = "+Str(x(2)) + Chr(13) + "x3 = " + Str(x(3)) + Chr(13) + _
"x4 = " + Str(x(4)) + Chr(13) + "IFAIL = " + Str(ifail)
Call X04ADF(NOUT, ifail)
'X04ADF closes the file on channel 6 (NOUT)
End Sub
Option Explicit
Option Base 1
Global Const _
n As Long = 4, _
nclin As Long = 1, _
ncnln As Long = 2, _
NOUT = 6, _
ldr As Long = n, _
lda As Long = nclin, _
ldcj As Long = ncnln, _
liwork As Long = 100, _
lwork As Long = 1000
Public _
a(lda, n) As Double, _
bl(n + nclin + ncnln) As Double, _
bu(n + nclin + ncnln) As Double, _
iter As Long, _
istate(n + nclin + ncnln) As Long, _
c(ncnln) As Double, _
cjac(ldcj, n) As Double, _
clamda(n + nclin + ncnln) As Double, _
objf As Double, _
objgrd(n) As Double, _
r(ldr, n) As Double, _
x(n) As Double, _
iwork(liwork) As Long, _
work(lwork) As Double, _
iuser As Long, _
user As Double, _
ifail As Long, _
mode As Long
#If Win32 Then
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
ByRef hpvDest As Any, ByVal hpvSource As Any, ByVal cbCopy As Long)
#Else
Declare Sub CopyMemory Lib "KERNEL" Alias "hmemcpy" ( _
ByRef hpvDest As Any, ByVal hpvSource As Any, ByVal cbCopy As Long)
#End If
Declare Sub E04UCF Lib "DLL20DD.DLL" _
(n As Long, nclin As Long, ncnln As Long, lda As Long, ldcj As Long, _
ldr As Long, a As Double, bl As Double, bu As Double, ByVal confun As Any, _
ByVal objfun As Any, iter As Long, istate As Long, con As Double, _
cjac As Double, clamda As Double, objf As Double, objgrd As Double, _
r As Double, x As Double, iwork As Long, liwork As Long, work As Double, _
lwork As Long, iuser As Long, user As Double, ifail As Long)
Declare Sub E04UEF Lib "DLL20DD.DLL" (ByVal optparam As String, _
ByVal stringlength As Long)
Declare Sub X04ACF Lib "DLL20DD.DLL" (NOUT As Long, ByVal file As String, _
ByVal length_string As Long, mode As Long, ifail As Long)
Declare Sub X04ADF Lib "DLL20DD.DLL" (NOUT As Long, ifail As Long)
Sub objfun(mode As Long, nb As Long, ByVal ptr_x As Long, objf As Double, _
ByVal ptr_objgrd As Long, nstate As Long, iuser As Long, user As
Double)
'Routine to evaluate objective function and its 1st derivatives.
'..Local variables.
Dim x(n) As Double 'values for which the function is to be evaluated
Dim objgrd(n) As Double 'first derivatives of the function
Dim address As Long 'Address to fetch/store data
Dim i As Integer 'counter
'Copy elements pointed to by ptr_x into local array x.
For i = 1 To n
address = ptr_x + 8 * (i - 1)
Call CopyMemory(x(i), address, 8)
Next i
'Calculate value of objective function if necessary.
If mode = 0 Or mode = 2 Then objf = x(1)*x(4)*(x(1) + x(2) + x(3)) + x(3)
'Calculate values of 1st derivatives if necessary.
If mode = 1 Or mode = 2 Then
objgrd(1) = x(4) * (2 * x(1) + x(2) + x(3))
objgrd(2) = x(1) * x(4)
objgrd(3) = x(1) * x(4) + 1
objgrd(4) = x(1) * (x(1) + x(2) + x(3))
'Copy values to the memory pointed to by ptr_objgrd.
For i = 1 To n
address = ptr_objgrd + 8 * (i - 1)
Call CopyMemory(ByVal (address), VarPtr(objgrd(i)), 8)
Next i
End If
End Sub
Sub confun(mode As Long, ncnlnb As Long, nb As Long, ldcjb As Long, _
ByVal ptr_needc As Long, ByVal ptr_x As Long, ByVal ptr_c As Long, _
ByVal ptr_cjac As Long, nstate As Long, iuser As Long, user As Double)
'Routine to evaluate the nonlinear constraints and their 1st derivatives.
'..Local variables..
Dim x(n) As Double
'Values for which the constraints are to be evaluated.
Dim needc(ncnln) As Long
'If needc(i)>0 then data on the ith constraint is required.
Dim con As Double 'Value of a constraint.
Dim cjac(n) As Double 'First derivatives of a constraint.
Dim address As Long 'Address to fetch/store data.
Dim store As Double 'Data element to store.
Dim i, j As Integer 'Counters.
'copy elements pointed to by ptr_x into local array x
For i = 1 To n
address = ptr_x + 8 * (i - 1)
Call CopyMemory(x(i), ByVal address, 8)
Next i
'copy elements pointed to by ptr_needc into local array needc
For i = 1 To ncnln
address = ptr_needc + 4 * (i - 1)
Call CopyMemory(needc(i), address, 4)
Next i
If nstate = 1 Then
'First call to CONFUN. Set all Jacobian elements to zero.
'Note that this will only work when 'Derivative Level = 3'
'(the default; see Section 11.2).
store = 0
For i = 1 To ncnln
For j = 1 To n
address = ptr_cjac + 8 * ncnln * (j - 1) + 8 * (i - 1)
Call CopyMemory(ByVal (address), VarPtr(store), 8)
Next
Next
End If
If needc(1) > 0 Then
If mode = 0 Or mode = 2 Then
'Value of first constraint is required
con = x(1) * x(1) + x(2) * x(2) + x(3) * x(3) + x(4) * x(4)
Call CopyMemory(ByVal (ptr_c), VarPtr(con), 8)
End If
If mode = 1 Or mode = 2 Then
'Derivatives of first constraint required
cjac(1) = 2 * x(1)
cjac(2) = 2 * x(2)
cjac(3) = 2 * x(3)
cjac(4) = 2 * x(4)
For i = 1 To n
address = ptr_cjac + 8 * ncnln * (i - 1)
Call CopyMemory(ByVal (address), VarPtr(cjac(i)), 8)
Next
End If
End If
If needc(2) > 0 Then
If mode = 0 Or mode = 2 Then
'Value of second constraint is required
con = x(1) * x(2) * x(3) * x(4)
Call CopyMemory(ByVal (ptr_c + 8), VarPtr(con), 8)
End If
If mode = 1 Or mode = 2 Then
'Derivatives of second constraint required
cjac(1) = x(2) * x(3) * x(4)
cjac(2) = x(1) * x(3) * x(4)
cjac(3) = x(1) * x(2) * x(4)
cjac(4) = x(1) * x(2) * x(3)
For i = 1 To n
address = ptr_cjac + 8 * ncnln * (i - 1) + 8
Call CopyMemory(ByVal (address), VarPtr(cjac(i)), 8)
Next
End If
End If
End Sub
此处要特别注意的是用户提供的函数 CONFUN 与 OBJFUN 都是 VB 程序。是以 AddressOf 操作数传递给 DLL。 他们必须要以此方式构成，才可以让 Fortran DLL 取得相关资讯。API 函数 CopyMemory 也必须使用到。 第一个参数是目标地址，第二个参数是要被复制的来源地址，第三个参数是复制的位数。将 Fortran 函数的计算结果取回是需要取得 VB 变量的地址的。此需要透过 VB 未被载明的功能 - VarPtr 函数。 我们建议的这个方式广泛的被程序人员所使用，因此不太可能会移除。然而，我们无法保证此状况。