Skip to content
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.

Commit bd15ecb

Browse files
awvwgkawvwgk
committedMar 5, 2022
Allow passing of user data for callback procedure
1 parent d5dbbaf commit bd15ecb

12 files changed

+110
-71
lines changed
 

‎examples/example_hybrd.f90

+2-1
Original file line numberDiff line numberDiff line change
@@ -70,13 +70,14 @@ program example_hybrd
7070
contains
7171

7272
!> Subroutine fcn for hybrd example.
73-
subroutine fcn(n, x, fvec, iflag)
73+
subroutine fcn(n, x, fvec, iflag, udata)
7474

7575
implicit none
7676
integer, intent(in) :: n
7777
integer, intent(inout) :: iflag
7878
double precision, intent(in) :: x(n)
7979
double precision, intent(out) :: fvec(n)
80+
class(*), intent(inout), optional :: udata
8081

8182
integer k
8283
double precision one, temp, temp1, temp2, three, two, zero

‎examples/example_hybrd1.f90

+2-1
Original file line numberDiff line numberDiff line change
@@ -54,13 +54,14 @@ program example_hybrd1
5454
contains
5555

5656
!> Subroutine fcn for hybrd1 example.
57-
subroutine fcn(n, x, fvec, iflag)
57+
subroutine fcn(n, x, fvec, iflag, udata)
5858

5959
implicit none
6060
integer, intent(in) :: n
6161
integer, intent(inout) :: iflag
6262
double precision, intent(in) :: x(n)
6363
double precision, intent(out) :: fvec(n)
64+
class(*), intent(inout), optional :: udata
6465

6566
integer k
6667
double precision one, temp, temp1, temp2, three, two, zero

‎examples/example_lmder1.f90

+2-1
Original file line numberDiff line numberDiff line change
@@ -7,11 +7,12 @@ module testmod_der1
77

88
contains
99

10-
subroutine fcn(m, n, x, fvec, fjac, ldfjac, iflag)
10+
subroutine fcn(m, n, x, fvec, fjac, ldfjac, iflag, udata)
1111
integer, intent(in) :: m, n, ldfjac
1212
integer, intent(inout) :: iflag
1313
real(dp), intent(in) :: x(n)
1414
real(dp), intent(inout) :: fvec(m), fjac(ldfjac, n)
15+
class(*), intent(inout), optional :: udata
1516

1617
integer :: i
1718
real(dp) :: tmp1, tmp2, tmp3, tmp4, y(15)

‎examples/example_lmdif1.f90

+2-1
Original file line numberDiff line numberDiff line change
@@ -7,11 +7,12 @@ module testmod_dif1
77

88
contains
99

10-
subroutine fcn(m, n, x, fvec, iflag)
10+
subroutine fcn(m, n, x, fvec, iflag, udata)
1111
integer, intent(in) :: m, n
1212
integer, intent(inout) :: iflag
1313
real(dp), intent(in) :: x(n)
1414
real(dp), intent(out) :: fvec(m)
15+
class(*), intent(inout), optional :: udata
1516

1617
integer :: i
1718
real(dp) :: tmp1, tmp2, tmp3, y(15)

‎examples/example_primes.f90

+2-1
Original file line numberDiff line numberDiff line change
@@ -50,11 +50,12 @@ function expr(x, pars) result(y)
5050

5151
contains
5252

53-
subroutine fcn(m, n, x, fvec, iflag)
53+
subroutine fcn(m, n, x, fvec, iflag, udata)
5454
integer, intent(in) :: m, n
5555
integer, intent(inout) :: iflag
5656
real(dp), intent(in) :: x(n)
5757
real(dp), intent(out) :: fvec(m)
58+
class(*), intent(inout), optional :: udata
5859
! Suppress compiler warning:
5960
fvec(1) = iflag
6061
fvec = data_y - expr(data_x, x)

‎src/minpack.f90

+69-50
Large diffs are not rendered by default.

‎src/minpack_capi.f90

+20-10
Original file line numberDiff line numberDiff line change
@@ -117,11 +117,12 @@ subroutine minpack_hybrd(fcn, n, x, fvec, xtol, maxfev, ml, mu, epsfcn, diag, mo
117117
& factor, nprint, info, nfev, fjac, ldfjac, r, lr, qtf, wa1, wa2, wa3, wa4)
118118

119119
contains
120-
subroutine wrap_fcn(n, x, fvec, iflag)
120+
subroutine wrap_fcn(n, x, fvec, iflag, user_data)
121121
integer, intent(in) :: n
122122
real(wp), intent(in) :: x(n)
123123
real(wp), intent(out) :: fvec(n)
124124
integer, intent(inout) :: iflag
125+
class(*), intent(inout), optional :: user_data
125126

126127
call fcn(n, x, fvec, iflag, udata)
127128
end subroutine wrap_fcn
@@ -142,11 +143,12 @@ subroutine minpack_hybrd1(fcn, n, x, Fvec, Tol, Info, Wa, Lwa, udata) &
142143
call hybrd1(wrap_fcn, n, x, fvec, tol, info, Wa, Lwa)
143144

144145
contains
145-
subroutine wrap_fcn(n, x, fvec, iflag)
146+
subroutine wrap_fcn(n, x, fvec, iflag, user_data)
146147
integer, intent(in) :: n
147148
real(wp), intent(in) :: x(n)
148149
real(wp), intent(out) :: fvec(n)
149150
integer, intent(inout) :: iflag
151+
class(*), intent(inout), optional :: user_data
150152

151153
call fcn(n, x, fvec, iflag, udata)
152154
end subroutine wrap_fcn
@@ -183,13 +185,14 @@ subroutine minpack_hybrj(fcn, n, x, fvec, fjac, ldfjac, xtol, maxfev, diag, mode
183185
& factor, nprint, info, nfev, njev, r, lr, qtf, wa1, wa2, wa3, wa4)
184186

185187
contains
186-
subroutine wrap_fcn(n, x, fvec, fjac, ldfjac, iflag)
188+
subroutine wrap_fcn(n, x, fvec, fjac, ldfjac, iflag, user_data)
187189
integer, intent(in) :: n
188190
real(wp), intent(in) :: x(n)
189191
integer, intent(in) :: ldfjac
190192
real(wp), intent(out) :: fvec(n)
191193
real(wp), intent(out) :: fjac(ldfjac, n)
192194
integer, intent(inout) :: iflag
195+
class(*), intent(inout), optional :: user_data
193196

194197
call fcn(n, x, fvec, fjac, ldfjac, iflag, udata)
195198
end subroutine wrap_fcn
@@ -212,13 +215,14 @@ subroutine minpack_hybrj1(fcn, n, x, fvec, fjac, ldfjac, tol, info, wa, lwa, uda
212215
call hybrj1(wrap_fcn, n, x, fvec, fjac, ldfjac, tol, info, wa, lwa)
213216

214217
contains
215-
subroutine wrap_fcn(n, x, fvec, fjac, ldfjac, iflag)
218+
subroutine wrap_fcn(n, x, fvec, fjac, ldfjac, iflag, user_data)
216219
integer, intent(in) :: n
217220
real(wp), intent(in) :: x(n)
218221
integer, intent(in) :: ldfjac
219222
real(wp), intent(out) :: fvec(n)
220223
real(wp), intent(out) :: fjac(ldfjac, n)
221224
integer, intent(inout) :: iflag
225+
class(*), intent(inout), optional :: user_data
222226

223227
call fcn(n, x, fvec, fjac, ldfjac, iflag, udata)
224228
end subroutine wrap_fcn
@@ -258,12 +262,13 @@ subroutine minpack_lmdif(fcn, m, n, x, fvec, ftol, xtol, gtol, maxfev, epsfcn, d
258262
& mode, factor, nprint, info, nfev, fjac, ldfjac, ipvt, qtf, wa1, wa2, wa3, wa4)
259263

260264
contains
261-
subroutine wrap_fcn(m, n, x, fvec, iflag)
265+
subroutine wrap_fcn(m, n, x, fvec, iflag, user_data)
262266
integer, intent(in) :: m
263267
integer, intent(in) :: n
264268
real(wp), intent(in) :: x(n)
265269
real(wp), intent(out) :: fvec(m)
266270
integer, intent(inout) :: iflag
271+
class(*), intent(inout), optional :: user_data
267272

268273
call fcn(m, n, x, fvec, iflag, udata)
269274
end subroutine wrap_fcn
@@ -286,12 +291,13 @@ subroutine minpack_lmdif1(fcn, m, n, x, fvec, tol, info, iwa, wa, lwa, udata) &
286291
call lmdif1(wrap_fcn, m, n, x, fvec, tol, info, iwa, wa, lwa)
287292

288293
contains
289-
subroutine wrap_fcn(m, n, x, fvec, iflag)
294+
subroutine wrap_fcn(m, n, x, fvec, iflag, user_data)
290295
integer, intent(in) :: m
291296
integer, intent(in) :: n
292297
real(wp), intent(in) :: x(n)
293298
real(wp), intent(out) :: fvec(m)
294299
integer, intent(inout) :: iflag
300+
class(*), intent(inout), optional :: user_data
295301

296302
call fcn(m, n, x, fvec, iflag, udata)
297303
end subroutine wrap_fcn
@@ -331,14 +337,15 @@ subroutine minpack_lmder(fcn, m, n, x, fvec, fjac, ldfjac, ftol, xtol, gtol, max
331337
& diag, mode, factor, nprint, info, nfev, njev, ipvt, qtf, wa1, wa2, wa3, wa4)
332338

333339
contains
334-
subroutine wrap_fcn(m, n, x, fvec, fjac, ldfjac, iflag)
340+
subroutine wrap_fcn(m, n, x, fvec, fjac, ldfjac, iflag, user_data)
335341
integer, intent(in) :: m
336342
integer, intent(in) :: n
337343
integer, intent(in) :: ldfjac
338344
integer, intent(inout) :: iflag
339345
real(wp), intent(in) :: x(n)
340346
real(wp), intent(inout) :: fvec(m)
341347
real(wp), intent(inout) :: fjac(ldfjac, n)
348+
class(*), intent(inout), optional :: user_data
342349

343350
call fcn(m, n, x, fvec, fjac, ldfjac, iflag, udata)
344351
end subroutine wrap_fcn
@@ -364,14 +371,15 @@ subroutine minpack_lmder1(fcn, m, n, x, Fvec, Fjac, Ldfjac, Tol, Info, Ipvt, Wa,
364371
call lmder1(wrap_fcn, m, n, x, Fvec, Fjac, Ldfjac, Tol, Info, Ipvt, Wa, Lwa)
365372

366373
contains
367-
subroutine wrap_fcn(m, n, x, fvec, fjac, ldfjac, iflag)
374+
subroutine wrap_fcn(m, n, x, fvec, fjac, ldfjac, iflag, user_data)
368375
integer, intent(in) :: m
369376
integer, intent(in) :: n
370377
integer, intent(in) :: ldfjac
371378
integer, intent(inout) :: iflag
372379
real(wp), intent(in) :: x(n)
373380
real(wp), intent(inout) :: fvec(m)
374381
real(wp), intent(inout) :: fjac(ldfjac, n)
382+
class(*), intent(inout), optional :: user_data
375383

376384
call fcn(m, n, x, fvec, fjac, ldfjac, iflag, udata)
377385
end subroutine wrap_fcn
@@ -410,13 +418,14 @@ subroutine minpack_lmstr(fcn, m, n, x, fvec, fjac, ldfjac, ftol, xtol, gtol, max
410418
call lmstr(wrap_fcn, m, n, x, fvec, fjac, ldfjac, ftol, xtol, gtol, maxfev, &
411419
& diag, mode, factor, nprint, info, nfev, njev, ipvt, qtf, wa1, wa2, wa3, wa4)
412420
contains
413-
subroutine wrap_fcn(m, n, x, fvec, fjrow, iflag)
421+
subroutine wrap_fcn(m, n, x, fvec, fjrow, iflag, user_data)
414422
integer, intent(in) :: m
415423
integer, intent(in) :: n
416424
integer, intent(inout) :: iflag
417425
real(wp), intent(in) :: x(n)
418426
real(wp), intent(inout) :: fvec(m)
419427
real(wp), intent(inout) :: fjrow(n)
428+
class(*), intent(inout), optional :: user_data
420429

421430
call fcn(m, n, x, fvec, fjrow, iflag, udata)
422431
end subroutine wrap_fcn
@@ -441,13 +450,14 @@ subroutine minpack_lmstr1(fcn, m, n, x, fvec, fjac, ldfjac, tol, info, ipvt, wa,
441450

442451
call lmstr1(wrap_fcn, m, n, x, fvec, fjac, ldfjac, tol, info, ipvt, wa, lwa)
443452
contains
444-
subroutine wrap_fcn(m, n, x, fvec, fjrow, iflag)
453+
subroutine wrap_fcn(m, n, x, fvec, fjrow, iflag, user_data)
445454
integer, intent(in) :: m
446455
integer, intent(in) :: n
447456
integer, intent(inout) :: iflag
448457
real(wp), intent(in) :: x(n)
449458
real(wp), intent(inout) :: fvec(m)
450459
real(wp), intent(inout) :: fjrow(n)
460+
class(*), intent(inout), optional :: user_data
451461

452462
call fcn(m, n, x, fvec, fjrow, iflag, udata)
453463
end subroutine wrap_fcn

‎test/test_hybrd.f90

+2-1
Original file line numberDiff line numberDiff line change
@@ -87,11 +87,12 @@ program test
8787
end do
8888
end program test
8989

90-
subroutine fcn(n,x,Fvec,Iflag)
90+
subroutine fcn(n,x,Fvec,Iflag,udata)
9191
implicit none
9292

9393
integer n , Iflag
9494
double precision x(n) , Fvec(n)
95+
class(*), optional :: udata
9596
! **********
9697
!
9798
! THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE

‎test/test_hybrj.f90

+2-1
Original file line numberDiff line numberDiff line change
@@ -93,11 +93,12 @@ program test
9393
end do
9494
end program test
9595

96-
subroutine fcn(n,x,Fvec,Fjac,Ldfjac,Iflag)
96+
subroutine fcn(n,x,Fvec,Fjac,Ldfjac,Iflag,udata)
9797
implicit none
9898

9999
integer n , Ldfjac , Iflag
100100
double precision x(n) , Fvec(n) , Fjac(Ldfjac,n)
101+
class(*), optional :: udata
101102
! **********
102103
!
103104
! THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE

‎test/test_lmder.f90

+3-2
Original file line numberDiff line numberDiff line change
@@ -94,7 +94,7 @@ program test
9494
! FUNCTION AND JACOBIAN SUBROUTINES SSQFCN AND SSQJAC WITH
9595
! THE APPROPRIATE VALUE OF PROBLEM NUMBER (NPROB).
9696

97-
subroutine fcn(m, n, x, Fvec, Fjac, Ldfjac, Iflag)
97+
subroutine fcn(m, n, x, Fvec, Fjac, Ldfjac, Iflag, udata)
9898

9999
implicit none
100100

@@ -112,6 +112,7 @@ subroutine fcn(m, n, x, Fvec, Fjac, Ldfjac, Iflag)
112112
real(wp), intent(in) :: x(n) !! independant variable vector
113113
real(wp), intent(inout) :: fvec(m) !! value of function at `x`
114114
real(wp), intent(inout) :: fjac(ldfjac, n) !! jacobian matrix at `x`
115+
class(*), intent(inout), optional :: udata
115116

116117
select case (iflag)
117118
case (1)
@@ -994,4 +995,4 @@ end subroutine ssqfcn
994995

995996
!*****************************************************************************************
996997
end program test
997-
!*****************************************************************************************
998+
!*****************************************************************************************

‎test/test_lmdif.f90

+2-1
Original file line numberDiff line numberDiff line change
@@ -96,11 +96,12 @@ program test
9696
end do
9797
end program test
9898

99-
subroutine fcn(m,n,x,Fvec,Iflag)
99+
subroutine fcn(m,n,x,Fvec,Iflag,udata)
100100
implicit none
101101

102102
integer m , n , Iflag
103103
double precision x(n) , Fvec(m)
104+
class(*), optional :: udata
104105
! **********
105106
!
106107
! THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE

‎test/test_lmstr.f90

+2-1
Original file line numberDiff line numberDiff line change
@@ -103,11 +103,12 @@ program test
103103
end program test
104104

105105

106-
subroutine fcn(m,n,x,Fvec,Fjrow,Iflag)
106+
subroutine fcn(m,n,x,Fvec,Fjrow,Iflag,udata)
107107
implicit none
108108

109109
integer m , n , Iflag
110110
double precision x(n) , Fvec(m) , Fjrow(n)
111+
class(*), optional :: udata
111112
! **********
112113
!
113114
! THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE

0 commit comments

Comments
 (0)
Please sign in to comment.