Related
How can overload operator(+) and assigment(-) for my class?
the compiler shows me the following message
Error: Component to the right of a part reference with nonzero rank must not have the ALLOCATABLE
attribute at (1).
For the assigment(=), I have no idea how to do it.
For c ++ it was easier. Return pointner this
function zmat_zmat_add(zmatrix1,zmatrix2) result(res_zmat_zmat)
type(zmatrix_type), dimension(:,:), intent(in) :: zmatrix1
type(zmatrix_type), dimension(:,:), intent(in) :: zmatrix2
type(zmatrix_type) :: res_zmat_zmat
integer :: rows
integer :: i,j ! liczniki pętli
rows=3
do i=1, rows
do j=1, rows
res_zmat_zmat%zmatrix_data(i,j)%realis= &
zmatrix1%zmatrix_data(i,j)%realis + zmatrix2%zmatrix_data(i,j)%realis
res_zmat_zmat%zmatrix_data(i,j)%imaginalis = &
zmatrix1%zmatrix_data(i,j)%imaginalis + &
zmatrix2%zmatrix_data(i,j)%imaginalis
enddo
enddo
end function zmat_zmat_add
rest code
module zmatrix_module
implicit none
type, public :: zcomplex_type
real :: realis
real :: imaginalis
end type zcomplex_type
type, extends(zcomplex_type), public :: zmatrix_type
type(zcomplex_type), dimension(:,:), allocatable, public :: zmatrix_data
end type zmatrix_type
public :: zmatrix_allocate
public :: zmatrix_free
public :: zmatrix_set
public :: zmatrix_print
interface operator(+)
procedure zzadd
procedure zmat_zmat_add
end interface
contains
function zzadd(z1,z2) result(res)
type(zcomplex_type), intent(in) :: z1
type(zcomplex_type), intent(in) :: z2
type(zcomplex_type) :: res
res%realis=z1%realis+z2%realis
res%imaginalis= z1%imaginalis +z2%imaginalis
end function zzadd
function zmat_zmat_add(zmatrix1,zmatrix2) result(res_zmat_zmat)
type(zmatrix_type), dimension(:,:), intent(in) :: zmatrix1
type(zmatrix_type), dimension(:,:), intent(in) :: zmatrix2
type(zmatrix_type) :: res_zmat_zmat
integer :: rows
integer :: i,j
rows=3
do i=1, rows
do j=1, rows
res_zmat_zmat%zmatrix_data(i,j)%realis= &
zmatrix1%zmatrix_data(i,j)%realis + zmatrix2%zmatrix_data(i,j)%realis
res_zmat_zmat%zmatrix_data(i,j)%imaginalis = &
zmatrix1%zmatrix_data(i,j)%imaginalis + &
zmatrix2%zmatrix_data(i,j)%imaginalis
enddo
enddo
end function zmat_zmat_add
subroutine zmatrix_allocate(zarray,rows)
type(zmatrix_type), intent(out) :: zarray
integer, intent(in) :: rows
allocate(zarray%zmatrix_data(1:rows, 1:rows))
end subroutine zmatrix_allocate
subroutine zmatrix_free(zarray)
type(zmatrix_type), intent(inout) :: zarray
deallocate(zarray%zmatrix_data)
end subroutine zmatrix_free
subroutine zmatrix_set(zarray, rows, re_values, im_values)
type(zmatrix_type), intent(inout) :: zarray
integer, intent(in) :: rows
real, intent(in) :: re_values, im_values
integer :: i,j
do i=1, rows
do j=1, rows
zarray%zmatrix_data(i,j)%realis = re_values
zarray%zmatrix_data(i,j)%imaginalis = im_values
enddo
enddo
end subroutine zmatrix_set
subroutine zmatrix_print(array,rows)
type(zmatrix_type), intent(in) :: array
integer, intent(in) :: rows
integer i,j
do i=1, rows
write(*,*) (array%zmatrix_data(i,j), j=1, rows)
enddo
write(*,*)
end subroutine zmatrix_print
end module zmatrix_module
Program main
use zmatrix_module
implicit none
type(zmatrix_type) :: mat1
type(zmatrix_type) :: mat2
type(zmatrix_type) :: mat3
type(zcomplex_type) :: z1
type(zcomplex_type) :: z2
type(zcomplex_type) :: z3
integer :: rows
rows=2
print *, " AAAAAAA"
call zmatrix_allocate(mat1,rows)
call zmatrix_set(mat1,rows,10.0,8.0)
call zmatrix_print(mat1,rows)
print *, "BBBBBBBB"
call zmatrix_allocate(mat2,rows)
call zmatrix_set(mat2,rows,1.0,2.0)
call zmatrix_print(mat2,rows)
print *, "CCCCCC"
call zmatrix_allocate(mat3,rows)
mat3=zmat_zmat_add(mat1,mat2)
mat3=mat1+mat2
call zmatrix_print(mat3,rows)
call zmatrix_free(mat1)
call zmatrix_free(mat2)
call zmatrix_free(mat3)
End Program main
The comments point out the immediate problem - you don't need the dimension attribute in the zmat_zmat_add routine - you are adding a single matrix to another matrix, not an array of matrix to another array of matrices. Thus you have a scalar of the appropriate type for each dummy argument.
However as the actual question indicates there is a second problem, how to allocate the result array for zmat_zmat_add. Well, you make the result allocatable and allocate it! I've shown in the first code below the most direct way to solve the problems you are showing. However the code you have written reads a bit like writing C++ as Fortran. This is not the best way to solve this problem, and so I have provided a second solution which is a much more Fortran way of doing things. This is below the first code. Anyway here the quick and dirty fix to your code:
ijb#ijb-Latitude-5410:~/work/stack$ cat zm1.f90
module zmatrix_module
implicit none
type, public :: zcomplex_type
real :: realis
real :: imaginalis
end type zcomplex_type
type, extends(zcomplex_type), public :: zmatrix_type
type(zcomplex_type), dimension(:,:), allocatable, public :: zmatrix_data
end type zmatrix_type
public :: zmatrix_allocate
public :: zmatrix_free
public :: zmatrix_set
public :: zmatrix_print
interface operator(+)
procedure zzadd
procedure zmat_zmat_add
end interface
contains
function zzadd(z1,z2) result(res)
type(zcomplex_type), intent(in) :: z1
type(zcomplex_type), intent(in) :: z2
type(zcomplex_type) :: res
res%realis=z1%realis+z2%realis
res%imaginalis= z1%imaginalis +z2%imaginalis
end function zzadd
function zmat_zmat_add(zmatrix1,zmatrix2) result(res_zmat_zmat)
type(zmatrix_type), intent(in) :: zmatrix1
type(zmatrix_type), intent(in) :: zmatrix2
type(zmatrix_type) :: res_zmat_zmat
integer :: cols, rows
integer :: i,j
rows = Size( zmatrix1%zmatrix_data, Dim = 1 )
cols = Size( zmatrix1%zmatrix_data, Dim = 2 )
Allocate( res_zmat_zmat%zmatrix_data( 1:rows, 1:cols ) )
do i=1, rows
do j=1, cols
res_zmat_zmat%zmatrix_data(i,j)%realis= &
zmatrix1%zmatrix_data(i,j)%realis + zmatrix2%zmatrix_data(i,j)%realis
res_zmat_zmat%zmatrix_data(i,j)%imaginalis = &
zmatrix1%zmatrix_data(i,j)%imaginalis + &
zmatrix2%zmatrix_data(i,j)%imaginalis
enddo
enddo
end function zmat_zmat_add
subroutine zmatrix_allocate(zarray,rows)
type(zmatrix_type), intent(out) :: zarray
integer, intent(in) :: rows
allocate(zarray%zmatrix_data(1:rows, 1:rows))
end subroutine zmatrix_allocate
subroutine zmatrix_free(zarray)
type(zmatrix_type), intent(inout) :: zarray
deallocate(zarray%zmatrix_data)
end subroutine zmatrix_free
subroutine zmatrix_set(zarray, rows, re_values, im_values)
type(zmatrix_type), intent(inout) :: zarray
integer, intent(in) :: rows
real, intent(in) :: re_values, im_values
integer :: i,j
do i=1, rows
do j=1, rows
zarray%zmatrix_data(i,j)%realis = re_values
zarray%zmatrix_data(i,j)%imaginalis = im_values
enddo
enddo
end subroutine zmatrix_set
subroutine zmatrix_print(array,rows)
type(zmatrix_type), intent(in) :: array
integer, intent(in) :: rows
integer i,j
do i=1, rows
write(*,*) (array%zmatrix_data(i,j), j=1, rows)
enddo
write(*,*)
end subroutine zmatrix_print
end module zmatrix_module
Program main
use zmatrix_module
implicit none
type(zmatrix_type) :: mat1
type(zmatrix_type) :: mat2
type(zmatrix_type) :: mat3
integer :: rows
rows=2
print *, " AAAAAAA"
call zmatrix_allocate(mat1,rows)
call zmatrix_set(mat1,rows,10.0,8.0)
call zmatrix_print(mat1,rows)
print *, "BBBBBBBB"
call zmatrix_allocate(mat2,rows)
call zmatrix_set(mat2,rows,1.0,2.0)
call zmatrix_print(mat2,rows)
print *, "CCCCCC"
call zmatrix_allocate(mat3,rows)
mat3=zmat_zmat_add(mat1,mat2)
mat3=mat1+mat2
call zmatrix_print(mat3,rows)
call zmatrix_free(mat1)
call zmatrix_free(mat2)
call zmatrix_free(mat3)
End Program main
ijb#ijb-Latitude-5410:~/work/stack$ gfortran --version
GNU Fortran (Ubuntu 9.3.0-17ubuntu1~20.04) 9.3.0
Copyright (C) 2019 Free Software Foundation, Inc.
This is free software; see the source for copying conditions. There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
ijb#ijb-Latitude-5410:~/work/stack$ gfortran -std=f2018 -Wall -Wextra -fcheck=all -O -Wuse-without-only zm1.f90 -o zm1
zm1.f90:99:4:
99 | use zmatrix_module
| 1
Warning: USE statement at (1) has no ONLY qualifier [-Wuse-without-only]
ijb#ijb-Latitude-5410:~/work/stack$ ./zm1
AAAAAAA
10.0000000 8.00000000 10.0000000 8.00000000
10.0000000 8.00000000 10.0000000 8.00000000
BBBBBBBB
1.00000000 2.00000000 1.00000000 2.00000000
1.00000000 2.00000000 1.00000000 2.00000000
CCCCCC
11.0000000 10.0000000 11.0000000 10.0000000
11.0000000 10.0000000 11.0000000 10.0000000
ijb#ijb-Latitude-5410:~/work/stack$
As I say this is not a very "Fortran" way of solving this. Here is what I would do. Note
The intrinsic Complex data type
Array syntax to simplify the code
Allocation of allocatable arrays when they are the result of a calculation, again simplifying the code
Use of intrinsics to find properties of arrays rather than carrying around extra variables which contain duplicate information
Type bound procedures
(Not really only Fortran but use of private for encapsulation and to minimise name space pollution)
Quite probably others
Anyway here goes
Module zmatrix_module
Implicit None
Type, Public :: zmatrix_type
Private
Complex, Dimension(:,:), Allocatable, Private :: zmatrix_data
Contains
Procedure, Public :: allocate => zmatrix_allocate
Procedure, Public :: free => zmatrix_free
Procedure, Public :: set => zmatrix_set
Procedure, Public :: print => zmatrix_print
Generic , Public :: Operator( + ) => add
Procedure, Private :: add => zmat_zmat_add
End Type zmatrix_type
Private
Contains
Function zmat_zmat_add(zmatrix1,zmatrix2) Result(res_zmat_zmat)
Class(zmatrix_type), Intent(in) :: zmatrix1
Type (zmatrix_type), Intent(in) :: zmatrix2
Type (zmatrix_type) :: res_zmat_zmat
! Uses allocation on assignment
! Also use array syntax to simplify code
res_zmat_zmat%zmatrix_data = zmatrix1%zmatrix_data + zmatrix2%zmatrix_data
End Function zmat_zmat_add
Subroutine zmatrix_allocate(zarray,rows)
! Note Intent(out) ensures the array is deallocate on entry to the routine
Class(zmatrix_type), Intent(out) :: zarray
Integer, Intent(in) :: rows
Allocate(zarray%zmatrix_data(1:rows, 1:rows))
End Subroutine zmatrix_allocate
Subroutine zmatrix_free(zarray)
Class(zmatrix_type), Intent(inout) :: zarray
Deallocate(zarray%zmatrix_data)
End Subroutine zmatrix_free
Subroutine zmatrix_set(zarray, values )
Class(zmatrix_type), Intent(inout) :: zarray
Complex, Intent(in) :: values
zarray%zmatrix_data = values
End Subroutine zmatrix_set
Subroutine zmatrix_print(array)
Class(zmatrix_type), Intent(in) :: array
Integer :: i
! Don't need to carry around extra data, just ask the array its size
Do i=1, Size( array%zmatrix_data, Dim = 1 )
Write(*,*) array%zmatrix_data(i,:)
Enddo
Write(*,*)
End Subroutine zmatrix_print
End Module zmatrix_module
Program main
Use zmatrix_module, Only : zmatrix_type
Implicit None
Type( zmatrix_type ) :: mat1
Type( zmatrix_type ) :: mat2
Type( zmatrix_type ) :: mat3
Integer :: rows
rows=2
Print *, " AAAAAAA"
Call mat1%allocate( rows )
Call mat1%set( ( 10.0, 8.0 ) )
Call mat1%print()
Print *, "BBBBBBBB"
Call mat2%allocate( rows )
Call mat2%set( ( 1.0, 2.0 ) )
Call mat2%print()
Print *, "CCCCCC"
! Note mat3 gets auto-allocated as a result of the operation
mat3 = mat1 + mat2
Call mat3%print()
Call mat3%free()
Call mat2%free()
Call mat1%free()
End Program main
ijb#ijb-Latitude-5410:~/work/stack$ gfortran --version
GNU Fortran (Ubuntu 9.3.0-17ubuntu1~20.04) 9.3.0
Copyright (C) 2019 Free Software Foundation, Inc.
This is free software; see the source for copying conditions. There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
ijb#ijb-Latitude-5410:~/work/stack$ gfortran -std=f2018 -Wall -Wextra -fcheck=all -O -Wuse-without-only zm2.f90 -o zm2
ijb#ijb-Latitude-5410:~/work/stack$ ./zm2
AAAAAAA
(10.0000000,8.00000000) (10.0000000,8.00000000)
(10.0000000,8.00000000) (10.0000000,8.00000000)
BBBBBBBB
(1.00000000,2.00000000) (1.00000000,2.00000000)
(1.00000000,2.00000000) (1.00000000,2.00000000)
CCCCCC
(11.0000000,10.0000000) (11.0000000,10.0000000)
(11.0000000,10.0000000) (11.0000000,10.0000000)
ijb#ijb-Latitude-5410:~/work/stack$
There is another way which would fit this nicely, namely parametrised derived types. But I have no experience here so I won't go into something I don't know.
#Ian Bush mentioned in his answer that another option is to use the feature called parameterized derived types.
I will show a sample implementation here using those type parameters. Here are some callouts, first:
With this you might reduce the need for allocatable variables, because you can specify the shape of your type-members at compile-time or runtime.
If you want to learn more about parameterized types, this article is a good starting point.
This was introduced in Fortran 2003. The availability of this feature depends on the compiler. Even some compilers that claim to be fully compliant with Fortran 2003 might fail to compile (for example, gfortran fails in several points of the following code).
Sample implementation:
module zmatrix_module
implicit none
private
! A parameterized-type is declared like this.
type, public :: zmatrix(rows)
! Delcare each parameter inside the type. In this case it is a len-type.
integer, len :: rows
private
! You can use a len-type parameter in initialization expressions.
complex :: data(rows, rows)
contains
! No need for `allocate` and `free` procedures anymore.
procedure, public :: set => zmat_set
procedure, public :: print => zmat_print
procedure :: add => zmat_add_zmat
generic, public :: operator(+) => add
end type
contains
function zmat_add_zmat(z1, z2) result(out)
class(zmatrix(*)), intent(in) :: z1
type(zmatrix(*)), intent(in) :: z2
! Match the len parameter of the output with the input.
type(zmatrix(z1%rows)) :: out
out%data = z1%data + z2%data
end
subroutine zmat_set(z, values)
class(zmatrix(*)), intent(inout) :: z
complex, intent(in) :: values
z%data = values
end
subroutine zmat_print(z)
class(zmatrix(*)), intent(in) :: z
integer :: i
! You can inquiry the type parameter with a syntax similar to structure field.
do i=1, z%rows
write(*,*) z%data(i,:)
end do
write(*,*)
end
end
Sample program using:
program main
use zmatrix_module, only : zmatrix
implicit None
integer, parameter :: rows = 2
! A constant or initialization expression are allowed as the len parameter.
type(zmatrix(rows)) :: mat1
type(zmatrix(rows)) :: mat2
! If you declare an allocatable, you might declare the len parameter as deferred.
type(zmatrix(:)), allocatable :: mat3(:)
call mat1%set((10.0, 8.0))
call mat2%set((1.0, 2.0))
! Note mat3 gets auto-allocated as a result of the operation.
mat3 = mat1 + mat2
! You can also allocate the object explicitly, or using a source/mold.
! allocate(zmatrix(2) :: mat3)
! allocate(mat3, source=mat1)
call mat3%print()
end
I am using a known code (CAMB) which generates values like this :
k(h/Mpc) Pk/s8^2(Mpc/h)^3
5.2781500000e-06 1.9477400000e+01
5.5479700000e-06 2.0432300000e+01
5.8315700000e-06 2.1434000000e+01
6.1296700000e-06 2.2484700000e+01
6.4430100000e-06 2.3587000000e+01
6.7723700000e-06 2.4743400000e+01
7.1185600000e-06 2.5956400000e+01
7.4824500000e-06 2.7228900000e+01
7.8649500000e-06 2.8563800000e+01
8.2669900000e-06 2.9964100000e+01
I would like to get more precision on the generated values, like this :
k(h/Mpc) Pk/s8^2(Mpc/h)^3
5.3594794736e-06 1.8529569626e+01
5.6332442000e-06 1.9437295914e+01
5.9209928622e-06 2.0389484405e+01
6.2234403231e-06 2.1388326645e+01
6.5413364609e-06 2.2436098099e+01
6.8754711720e-06 2.3535198212e+01
7.2266739153e-06 2.4688137054e+01
7.5958159869e-06 2.5897554398e+01
7.9838137026e-06 2.7166225433e+01
8.3916311269e-06 2.8497039795e+01
8.8202796178e-06 2.9893053055e+01
9.2708232842e-06 3.1357446670e+01
9.7443817140e-06 3.2893573761e+01
Here the section of code that produces the data :
I tried to do the following modifications in the declarations of variables at the beginning of code above :
1)First try :
!Export files of total matter power spectra in h^{-1} Mpc units, against k/h.
Type(MatterTransferData), intent(in) :: MTrans
Type(CAMBdata) :: State
character(LEN=Ini_max_string_len), intent(IN) :: FileNames(*)
character(LEN=name_tag_len) :: columns(3)
integer itf, i, unit
integer points
! Added : way of declaring double precision
integer, parameter :: wp = selected_real_kind(15,307)
real(wp), dimension(:,:), allocatable :: outpower
but it doesn't compile :
real(wp), dimension(:,:), allocatable :: outpower
1
Error: Symbol ‘wp’ at (1) has no IMPLICIT type
../results.f90:3660:25:
allocate(outpower(points,ncol))
1
Error: Allocate-object at (1) is neither a data pointer nor an allocatable variable
../results.f90:3676:16:
outpower(:,1) = exp(PK_data%matpower(:,1))
1
Error: Unclassifiable statement at (1)
../results.f90:3679:20:
outpower(:,3) = exp(PK_data%vvpower(:,1))
1
Error: Unclassifiable statement at (1)
compilation terminated due to -fmax-errors=4.
make[1]: *** [results.o] Error 1
make: *** [camb] Error 2
2) Also, I tried :
!Export files of total matter power spectra in h^{-1} Mpc units, against k/h.
Type(MatterTransferData), intent(in) :: MTrans
Type(CAMBdata) :: State
character(LEN=Ini_max_string_len), intent(IN) :: FileNames(*)
character(LEN=name_tag_len) :: columns(3)
integer itf, i, unit
integer points
! Added : way of declaring double precision
double precision, dimension(:,:), allocatable :: outpower
but same thing, no compilation succeeded
call Transfer_GetMatterPowerS(State, MTrans, outpower(1,1), itf, minkh,dlnkh, points)
1
Error: Type mismatch in argument ‘outpower’ at (1); passed REAL(8) to REAL(4)
make[1]: *** [results.o] Error 1
make: *** [camb] Error 2
UPDATE 1:
with -fmax-errors=1, I get the following :
call Transfer_GetMatterPowerS(State, MTrans, outpower(1,1), itf, minkh,dlnkh, points)
1
Error: Type mismatch in argument ‘outpower’ at (1); passed REAL(8) to REAL(4)
compilation terminated due to -fmax-errors=1.
Except the solution given by #Steve with compilation option -freal-4-real-8, isn't really there another solution that I could include directly into code, i.e the section that I have given ?
UPDATE 2: here below the 3 relevant subroutines Transfer_GetMatterPowerS , Transfer_GetMatterPowerData and Transfer_SaveMatterPower that produces the error when trying to get double precision :
subroutine Transfer_GetMatterPowerS(State, MTrans, outpower, itf, minkh, dlnkh, npoints, var1, var2)
class(CAMBdata) :: state
Type(MatterTransferData), intent(in) :: MTrans
integer, intent(in) :: itf, npoints
integer, intent(in), optional :: var1, var2
real, intent(out) :: outpower(*)
real, intent(in) :: minkh, dlnkh
real(dl) :: outpowerd(npoints)
real(dl):: minkhd, dlnkhd
minkhd = minkh; dlnkhd = dlnkh
call Transfer_GetMatterPowerD(State, MTrans, outpowerd, itf, minkhd, dlnkhd, npoints,var1, var2)
outpower(1:npoints) = outpowerd(1:npoints)
end subroutine Transfer_GetMatterPowerS
subroutine Transfer_GetMatterPowerData(State, MTrans, PK_data, itf_only, var1, var2)
!Does *NOT* include non-linear corrections
!Get total matter power spectrum in units of (h Mpc^{-1})^3 ready for interpolation.
!Here there definition is < Delta^2(x) > = 1/(2 pi)^3 int d^3k P_k(k)
!We are assuming that Cls are generated so any baryonic wiggles are well sampled and that matter power
!spectrum is generated to beyond the CMB k_max
class(CAMBdata) :: State
Type(MatterTransferData), intent(in) :: MTrans
Type(MatterPowerData) :: PK_data
integer, intent(in), optional :: itf_only
integer, intent(in), optional :: var1, var2
double precision :: h, kh, k, power
integer :: ik, nz, itf, itf_start, itf_end, s1, s2
s1 = PresentDefault (transfer_power_var, var1)
s2 = PresentDefault (transfer_power_var, var2)
if (present(itf_only)) then
itf_start=itf_only
itf_end = itf_only
nz = 1
else
itf_start=1
nz= size(MTrans%TransferData,3)
itf_end = nz
end if
PK_data%num_k = MTrans%num_q_trans
PK_Data%num_z = nz
allocate(PK_data%matpower(PK_data%num_k,nz))
allocate(PK_data%ddmat(PK_data%num_k,nz))
allocate(PK_data%nonlin_ratio(PK_data%num_k,nz))
allocate(PK_data%log_kh(PK_data%num_k))
allocate(PK_data%redshifts(nz))
PK_data%redshifts = State%Transfer_Redshifts(itf_start:itf_end)
h = State%CP%H0/100
do ik=1,MTrans%num_q_trans
kh = MTrans%TransferData(Transfer_kh,ik,1)
k = kh*h
PK_data%log_kh(ik) = log(kh)
power = State%CP%InitPower%ScalarPower(k)
if (global_error_flag/=0) then
call MatterPowerdata_Free(PK_data)
return
end if
do itf = 1, nz
PK_data%matpower(ik,itf) = &
log(MTrans%TransferData(s1,ik,itf_start+itf-1)*&
MTrans%TransferData(s2,ik,itf_start+itf-1)*k &
*const_pi*const_twopi*h**3*power)
end do
end do
call MatterPowerdata_getsplines(PK_data)
end subroutine Transfer_GetMatterPowerData
subroutine Transfer_SaveMatterPower(MTrans, State,FileNames, all21cm)
use constants
!Export files of total matter power spectra in h^{-1} Mpc units, against k/h.
Type(MatterTransferData), intent(in) :: MTrans
Type(CAMBdata) :: State
character(LEN=Ini_max_string_len), intent(IN) :: FileNames(*)
character(LEN=name_tag_len) :: columns(3)
integer itf, i, unit
integer points
! Added : way of declaring double precision
!integer, parameter :: wp = selected_real_kind(15,307)
!real(wp), dimension(:,:), allocatable :: outpower
double precision, dimension(:,:), allocatable :: outpower
real minkh,dlnkh
Type(MatterPowerData) :: PK_data
integer ncol
logical, intent(in), optional :: all21cm
logical all21
!JD 08/13 Changes in here to PK arrays and variables
integer itf_PK
all21 = DefaultFalse(all21cm)
if (all21) then
ncol = 3
else
ncol = 1
end if
do itf=1, State%CP%Transfer%PK_num_redshifts
if (FileNames(itf) /= '') then
if (.not. transfer_interp_matterpower ) then
itf_PK = State%PK_redshifts_index(itf)
points = MTrans%num_q_trans
allocate(outpower(points,ncol))
!Sources
if (all21) then
call Transfer_Get21cmPowerData(MTrans, State, PK_data, itf_PK)
else
call Transfer_GetMatterPowerData(State, MTrans, PK_data, itf_PK)
!JD 08/13 for nonlinear lensing of CMB + LSS compatibility
!Changed (CP%NonLinear/=NonLinear_None) to CP%NonLinear/=NonLinear_none .and. CP%NonLinear/=NonLinear_Lens)
if(State%CP%NonLinear/=NonLinear_none .and. State%CP%NonLinear/=NonLinear_Lens) then
call State%CP%NonLinearModel%GetNonLinRatios(State, PK_data)
PK_data%matpower = PK_data%matpower + 2*log(PK_data%nonlin_ratio)
call MatterPowerdata_getsplines(PK_data)
end if
end if
outpower(:,1) = exp(PK_data%matpower(:,1))
!Sources
if (all21) then
outpower(:,3) = exp(PK_data%vvpower(:,1))
outpower(:,2) = exp(PK_data%vdpower(:,1))
outpower(:,1) = outpower(:,1)/1d10*const_pi*const_twopi/MTrans%TransferData(Transfer_kh,:,1)**3
outpower(:,2) = outpower(:,2)/1d10*const_pi*const_twopi/MTrans%TransferData(Transfer_kh,:,1)**3
outpower(:,3) = outpower(:,3)/1d10*const_pi*const_twopi/MTrans%TransferData(Transfer_kh,:,1)**3
end if
call MatterPowerdata_Free(PK_Data)
columns = ['P ', 'P_vd','P_vv']
unit = open_file_header(FileNames(itf), 'k/h', columns(:ncol), 15)
do i=1,points
write (unit, '(*(E15.6))') MTrans%TransferData(Transfer_kh,i,1),outpower(i,:)
end do
close(unit)
else
if (all21) stop 'Transfer_SaveMatterPower: if output all assume not interpolated'
minkh = 1e-4
dlnkh = 0.02
points = log(MTrans%TransferData(Transfer_kh,MTrans%num_q_trans,itf)/minkh)/dlnkh+1
! dlnkh = log(MTrans%TransferData(Transfer_kh,MTrans%num_q_trans,itf)/minkh)/(points-0.999)
allocate(outpower(points,1))
call Transfer_GetMatterPowerS(State, MTrans, outpower(1,1), itf, minkh,dlnkh, points)
columns(1) = 'P'
unit = open_file_header(FileNames(itf), 'k/h', columns(:1), 15)
do i=1,points
write (unit, '(*(E15.6))') minkh*exp((i-1)*dlnkh),outpower(i,1)
end do
close(unit)
end if
deallocate(outpower)
end if
end do
end subroutine Transfer_SaveMatterPower
My problem is to pass the names of a series of functions contained in a module to a subroutine in a do loop.
I post part of my code. The modules are in two separate files compared to the main.
%%% FILE testKer_mod.f90
module kernel
implicit none
contains
! POLYNOMIAL
function poly(x, ts, ndim, a, param1, param2)
integer, intent (in) :: ndim
real*8, dimension(ndim), intent(in) :: x
real*8, dimension(ndim), intent(in) :: ts
real*8, intent(in) :: a, param1, param2
real*8 :: r
real*8 :: poly
r = (x(1:ndim) - ts(1:ndim))
poly = r**(.5*a)
end function poly
! GAUSSIAN
function gauss(x, ts, ndim, a, gamma, param2)
integer, intent (in) :: ndim
real*8, dimension(ndim), intent(in) :: x
real*8, dimension(ndim), intent(in) :: ts
real*8, intent(in) :: a, param2, gamma
real*8 :: r
real*8 :: gauss
r = (x(1:ndim) - ts(1:ndim))
gauss = exp(-(gamma*r)**a)
end function gauss
end module kernel
%%%
%%% FILE testSRBF_mod.f90
module srbf
implicit none
contains
subroutine weigth(nx, x, nts, ts, ndim, s, kernel, StocPar, param, coe, mat)
integer :: i,j,k,l,m,n
integer :: info
integer :: nx, nts, ndim
integer, dimension(nts) :: ipiv
real*8, dimension(nts) :: w
real*8, dimension(nts) :: s
real*8, dimension(2) :: param
real*8, dimension(nx,ndim) :: x
real*8, dimension(nts,ndim) :: ts
real*8, dimension(nx,nts) :: phi, mat
real*8, dimension(nts) :: coe
real*8 :: stocPar
interface
real*8 function kernel(x1, x2, n3, stov, p1, p2)
integer, intent (in) :: n3
real*8, dimension(n3), intent(in) :: x1
real*8, dimension(n3), intent(in) :: x2
real*8, intent(in) :: stov, p1, p2
end function kernel
end interface
do i = 1, nx
do j = 1, nts
phi(i,j) = kernel(x(i,1:ndim), ts(j,1:ndim), ndim, stocPar, param(1), param(2))
end do
end do
w = s
mat = phi
call DGESV(nts,1,mat,nts,ipiv,w,nts,info)
coe = w
end subroutine weigth
end module srbf
%%%
%%% MAIN PROGRAM test.f90
program MKRBF
use kernel
use srbf
implicit none
!real*8 :: SelKer
integer :: i,j,k
integer, parameter :: n = 3
integer, parameter :: nKer = 2
real*8, dimension(2,2) :: ParBound, auxpar
real*8, dimension(2) :: Bound
real*8, dimension(n) :: Var, func
real*8, dimension(n,nKer) :: coe
real*8, dimension(n,n) :: mat
!external SelKer
interface
real*8 function SelKer(ind)
integer, intent (in) :: ind
end function SelKer
end interface
Bound(1) = 0
Bound(2) = 5
ParBound(1,1) = 1
ParBound(1,2) = 5
ParBound(2,1) = 1
ParBound(2,2) = 5
auxpar(1,1) = 0
auxpar(1,2) = 0
auxpar(2,1) = 1
auxpar(2,2) = 1
var(:) = (/ 0., 2.5, 5. /)
do i = 1, n
func(i) = cos(3*Var(i)) * exp(-.25*Var(i));
end do
do i = 1, nKer
call weigth(n,Var,n,Var,1,func,SelKer(i),2.0D0,auxpar,coe,mat)
end do
end program MKRBF
function SelKer(indx)
integer, intent(in) :: indx
real*8 :: SelKer
select case (indx)
case (1)
SelKer = poly
case (2)
SelKer = gauss
end select
return
end function SelKer
%%%
I tried both with interface and with external but the program gives me the same error:
gfortran testKer_mod.f90 testSRBF_mod.f90 test.f90 -llapack -o test
test.f90:46:38:
call weigth(n,Var,n,Var,1,func,SelKer(i),2.0D0,auxpar,coe,mat)
1
Error: Expected a procedure for argument 'kernel' at (1)
How can I fix it?
Looking at the interface block in the main program
interface
real*8 function SelKer(ind)
integer, intent (in) :: ind
end function SelKer
end interface
SelKer is a function with real*8 result.1 SelKer(i) is such a function result. Crucially, SelKer(i) isn't a function with real*8 result, but such a real*8 value. weigth is expecting the argument for kernel to be a function (which is a procedure). This is the error message.
Coming to how the external function SelKer is implemented: we see such things as
SelKer = poly
In the function poly isn't the function poly in the module kernel but a local (default) real scalar variable (with undefined value). Note the lack of implicit none in the function.
Instead, you want to be looking to be using procedure pointers. This is a broad topic, so I'll just give an indication of the approach.
Move SelKer to be a procedure in the module kernel (removing the corresponding interface block from the main program).
Declare the function result SelKer to have type procedure(poly).
Use pointer assignment for the result, like SelKer => gauss.
There are other, perhaps better ways, to structure such a program. In particular, many would advise against using procedure pointer function results.
1 real*8 isn't standard Fortran.
First of all, I know Julia does have an svd intrinsic function, but it does not exactly do what I need. Instead, svdcmp from Numerical Recipes does.
So, the subroutine is this:
MODULE nrtype
INTEGER, PARAMETER :: I4B = SELECTED_INT_KIND(9)
INTEGER, PARAMETER :: I2B = SELECTED_INT_KIND(4)
INTEGER, PARAMETER :: I1B = SELECTED_INT_KIND(2)
INTEGER, PARAMETER :: SP = KIND(1.0)
INTEGER, PARAMETER :: DP = KIND(1.0D0)
INTEGER, PARAMETER :: SPC = KIND((1.0,1.0))
INTEGER, PARAMETER :: DPC = KIND((1.0D0,1.0D0))
INTEGER, PARAMETER :: LGT = KIND(.true.)
REAL(SP), PARAMETER :: PI=3.141592653589793238462643383279502884197_sp
REAL(SP), PARAMETER :: PIO2=1.57079632679489661923132169163975144209858_sp
REAL(SP), PARAMETER :: TWOPI=6.283185307179586476925286766559005768394_sp
REAL(SP), PARAMETER :: SQRT2=1.41421356237309504880168872420969807856967_sp
REAL(SP), PARAMETER :: EULER=0.5772156649015328606065120900824024310422_sp
REAL(DP), PARAMETER :: PI_D=3.141592653589793238462643383279502884197_dp
REAL(DP), PARAMETER :: PIO2_D=1.57079632679489661923132169163975144209858_dp
REAL(DP), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_dp
TYPE sprs2_sp
INTEGER(I4B) :: n,len
REAL(SP), DIMENSION(:), POINTER :: val
INTEGER(I4B), DIMENSION(:), POINTER :: irow
INTEGER(I4B), DIMENSION(:), POINTER :: jcol
END TYPE sprs2_sp
TYPE sprs2_dp
INTEGER(I4B) :: n,len
REAL(DP), DIMENSION(:), POINTER :: val
INTEGER(I4B), DIMENSION(:), POINTER :: irow
INTEGER(I4B), DIMENSION(:), POINTER :: jcol
END TYPE sprs2_dp
END MODULE nrtype
MODULE nrutil
USE nrtype
IMPLICIT NONE
INTEGER(I4B), PARAMETER :: NPAR_ARTH=16,NPAR2_ARTH=8
INTEGER(I4B), PARAMETER :: NPAR_GEOP=4,NPAR2_GEOP=2
INTEGER(I4B), PARAMETER :: NPAR_CUMSUM=16
INTEGER(I4B), PARAMETER :: NPAR_CUMPROD=8
INTEGER(I4B), PARAMETER :: NPAR_POLY=8
INTEGER(I4B), PARAMETER :: NPAR_POLYTERM=8
INTERFACE assert_eq
MODULE PROCEDURE assert_eq2,assert_eq3,assert_eq4,assert_eqn
END INTERFACE
INTERFACE outerprod
MODULE PROCEDURE outerprod_r,outerprod_d
END INTERFACE
CONTAINS
FUNCTION assert_eq2(n1,n2,string)
CHARACTER(LEN=*), INTENT(IN) :: string
INTEGER, INTENT(IN) :: n1,n2
INTEGER :: assert_eq2
if (n1 == n2) then
assert_eq2=n1
else
write (*,*) 'nrerror: an assert_eq failed with this tag:', &
string
STOP 'program terminated by assert_eq2'
end if
END FUNCTION assert_eq2
!BL
FUNCTION assert_eq3(n1,n2,n3,string)
CHARACTER(LEN=*), INTENT(IN) :: string
INTEGER, INTENT(IN) :: n1,n2,n3
INTEGER :: assert_eq3
if (n1 == n2 .and. n2 == n3) then
assert_eq3=n1
else
write (*,*) 'nrerror: an assert_eq failed with this tag:', &
string
STOP 'program terminated by assert_eq3'
end if
END FUNCTION assert_eq3
!BL
FUNCTION assert_eq4(n1,n2,n3,n4,string)
CHARACTER(LEN=*), INTENT(IN) :: string
INTEGER, INTENT(IN) :: n1,n2,n3,n4
INTEGER :: assert_eq4
if (n1 == n2 .and. n2 == n3 .and. n3 == n4) then
assert_eq4=n1
else
write (*,*) 'nrerror: an assert_eq failed with this tag:', &
string
STOP 'program terminated by assert_eq4'
end if
END FUNCTION assert_eq4
!BL
FUNCTION assert_eqn(nn,string)
CHARACTER(LEN=*), INTENT(IN) :: string
INTEGER, DIMENSION(:), INTENT(IN) :: nn
INTEGER :: assert_eqn
if (all(nn(2:) == nn(1))) then
assert_eqn=nn(1)
else
write (*,*) 'nrerror: an assert_eq failed with this tag:', &
string
STOP 'program terminated by assert_eqn'
end if
END FUNCTION assert_eqn
!BL
SUBROUTINE nrerror(string)
CHARACTER(LEN=*), INTENT(IN) :: string
write (*,*) 'nrerror: ',string
STOP 'program terminated by nrerror'
END SUBROUTINE nrerror
!BL
FUNCTION outerprod_r(a,b)
REAL(SP), DIMENSION(:), INTENT(IN) :: a,b
REAL(SP), DIMENSION(size(a),size(b)) :: outerprod_r
outerprod_r = spread(a,dim=2,ncopies=size(b)) * &
spread(b,dim=1,ncopies=size(a))
END FUNCTION outerprod_r
!BL
FUNCTION outerprod_d(a,b)
REAL(DP), DIMENSION(:), INTENT(IN) :: a,b
REAL(DP), DIMENSION(size(a),size(b)) :: outerprod_d
outerprod_d = spread(a,dim=2,ncopies=size(b)) * &
spread(b,dim=1,ncopies=size(a))
END FUNCTION outerprod_d
!BL
END MODULE nrutil
MODULE nr
INTERFACE pythag
FUNCTION pythag_dp(a,b)
USE nrtype
REAL(DP), INTENT(IN) :: a,b
REAL(DP) :: pythag_dp
END FUNCTION pythag_dp
!BL
FUNCTION pythag_sp(a,b)
USE nrtype
REAL(SP), INTENT(IN) :: a,b
REAL(SP) :: pythag_sp
END FUNCTION pythag_sp
END INTERFACE
END MODULE nr
SUBROUTINE svdcmp_dp(a,w,v)
USE nrtype; USE nrutil, ONLY : assert_eq,nrerror,outerprod
USE nr, ONLY : pythag
IMPLICIT NONE
REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: a
REAL(DP), DIMENSION(:), INTENT(OUT) :: w
REAL(DP), DIMENSION(:,:), INTENT(OUT) :: v
INTEGER(I4B) :: i,its,j,k,l,m,n,nm
REAL(DP) :: anorm,c,f,g,h,s,scale,x,y,z
REAL(DP), DIMENSION(size(a,1)) :: tempm
REAL(DP), DIMENSION(size(a,2)) :: rv1,tempn
m=size(a,1)
write(*,*)"size(a,1)= ",size(a,1)
write(*,*)"size(a,2)= ",size(a,2)
write(*,*)"size(v,1)= ",size(v,1)
write(*,*)"size(v,2)= ",size(v,2)
write(*,*)"size(w) = ",size(w)
n=assert_eq(size(a,2),size(v,1),size(v,2),size(w),'svdcmp_dp')
g=0.0
scale=0.0
do i=1,n
l=i+1
rv1(i)=scale*g
g=0.0
scale=0.0
if (i <= m) then
scale=sum(abs(a(i:m,i)))
if (scale /= 0.0) then
a(i:m,i)=a(i:m,i)/scale
s=dot_product(a(i:m,i),a(i:m,i))
f=a(i,i)
g=-sign(sqrt(s),f)
h=f*g-s
a(i,i)=f-g
tempn(l:n)=matmul(a(i:m,i),a(i:m,l:n))/h
a(i:m,l:n)=a(i:m,l:n)+outerprod(a(i:m,i),tempn(l:n))
a(i:m,i)=scale*a(i:m,i)
end if
end if
w(i)=scale*g
g=0.0
scale=0.0
if ((i <= m) .and. (i /= n)) then
scale=sum(abs(a(i,l:n)))
if (scale /= 0.0) then
a(i,l:n)=a(i,l:n)/scale
s=dot_product(a(i,l:n),a(i,l:n))
f=a(i,l)
g=-sign(sqrt(s),f)
h=f*g-s
a(i,l)=f-g
rv1(l:n)=a(i,l:n)/h
tempm(l:m)=matmul(a(l:m,l:n),a(i,l:n))
a(l:m,l:n)=a(l:m,l:n)+outerprod(tempm(l:m),rv1(l:n))
a(i,l:n)=scale*a(i,l:n)
end if
end if
end do
anorm=maxval(abs(w)+abs(rv1))
do i=n,1,-1
if (i < n) then
if (g /= 0.0) then
v(l:n,i)=(a(i,l:n)/a(i,l))/g
tempn(l:n)=matmul(a(i,l:n),v(l:n,l:n))
v(l:n,l:n)=v(l:n,l:n)+outerprod(v(l:n,i),tempn(l:n))
end if
v(i,l:n)=0.0
v(l:n,i)=0.0
end if
v(i,i)=1.0
g=rv1(i)
l=i
end do
do i=min(m,n),1,-1
l=i+1
g=w(i)
a(i,l:n)=0.0
if (g /= 0.0) then
g=1.0_dp/g
tempn(l:n)=(matmul(a(l:m,i),a(l:m,l:n))/a(i,i))*g
a(i:m,l:n)=a(i:m,l:n)+outerprod(a(i:m,i),tempn(l:n))
a(i:m,i)=a(i:m,i)*g
else
a(i:m,i)=0.0
end if
a(i,i)=a(i,i)+1.0_dp
end do
do k=n,1,-1
do its=1,30
do l=k,1,-1
nm=l-1
if ((abs(rv1(l))+anorm) == anorm) exit
if ((abs(w(nm))+anorm) == anorm) then
c=0.0
s=1.0
do i=l,k
f=s*rv1(i)
rv1(i)=c*rv1(i)
if ((abs(f)+anorm) == anorm) exit
g=w(i)
h=pythag(f,g)
w(i)=h
h=1.0_dp/h
c= (g*h)
s=-(f*h)
tempm(1:m)=a(1:m,nm)
a(1:m,nm)=a(1:m,nm)*c+a(1:m,i)*s
a(1:m,i)=-tempm(1:m)*s+a(1:m,i)*c
end do
exit
end if
end do
z=w(k)
if (l == k) then
if (z < 0.0) then
w(k)=-z
v(1:n,k)=-v(1:n,k)
end if
exit
end if
if (its == 30) call nrerror('svdcmp_dp: no convergence in svdcmp')
x=w(l)
nm=k-1
y=w(nm)
g=rv1(nm)
h=rv1(k)
f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0_dp*h*y)
g=pythag(f,1.0_dp)
f=((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x
c=1.0
s=1.0
do j=l,nm
i=j+1
g=rv1(i)
y=w(i)
h=s*g
g=c*g
z=pythag(f,h)
rv1(j)=z
c=f/z
s=h/z
f= (x*c)+(g*s)
g=-(x*s)+(g*c)
h=y*s
y=y*c
tempn(1:n)=v(1:n,j)
v(1:n,j)=v(1:n,j)*c+v(1:n,i)*s
v(1:n,i)=-tempn(1:n)*s+v(1:n,i)*c
z=pythag(f,h)
w(j)=z
if (z /= 0.0) then
z=1.0_dp/z
c=f*z
s=h*z
end if
f= (c*g)+(s*y)
x=-(s*g)+(c*y)
tempm(1:m)=a(1:m,j)
a(1:m,j)=a(1:m,j)*c+a(1:m,i)*s
a(1:m,i)=-tempm(1:m)*s+a(1:m,i)*c
end do
rv1(l)=0.0
rv1(k)=f
w(k)=x
end do
end do
END SUBROUTINE svdcmp_dp
Note that I include only the portions of the modules that I need (just for this case). then, I compile this into a shared library like:
gfortran -shared -fPIC svdcmp_dp.f90 -o svdcmp_dp.so
so far, so good.
The next thing I do is in Julia:
julia> M=5
julia> a=rand(M,M) #just to see if it works
julia> v=zeros(M,M)
julia> w=zeros(M)
julia> t=ccall((:svdcmp_dp_, "./svdcmp_dp.so")
, Void
, ( Ref{Float64} # array a(mp,np)
, Ref{Float64} # array w
, Ref{Float64} # array v
)
,a,w,v)
and I get:
julia> t=ccall((:svdcmp_dp_, "./svdcmp_dp.so")
, Void
, ( Ref{Float64} # array a(mp,np)
, Ref{Float64} # array w
, Ref{Float64} # array v
)
,a,w,v)
size(a,1)= 0
size(a,2)= 0
size(v,1)= 1
size(v,2)= 1
size(w) = 1
nrerror: an assert_eq failed with this tag:svdcmp_dp
STOP program terminated by assert_eq4
So, actually, my calling is OK, but apparently, the size intrinsic from Fortran 90 is NOT returning what I would expect. I say this because the first line in svdcmp_dp.f90 is calling the function assert_eq4 and determine that the dimensions are not compatible. This is not supposed to happen as I chose a[5 X 5], w[5], v[5,5], right?
I search about size in F90, and find out this:
Description:
Determine the extent of ARRAY along a specified dimension DIM, or the total number of elements in ARRAY if DIM is absent.
Standard:
Fortran 95 and later, with KIND argument Fortran 2003 and later
Class:
Inquiry function
Syntax:
RESULT = SIZE(ARRAY[, DIM [, KIND]])
Arguments:
ARRAY Shall be an array of any type. If ARRAY is a pointer
it must be associated and allocatable arrays must be allocated.
DIM (Optional) shall be a scalar of type INTEGER and its value shall
be in the range from 1 to n, where n equals the rank of ARRAY.
KIND (Optional) An INTEGER initialization expression indicating the
kind parameter of the result.
So, my guess is that the problem is related with the allocable property of a,v & w. Or the pointer issue (zero experience with pointers!)
I have actually solve this issue by replacing the declarations from:
SUBROUTINE svdcmp_dp(a,w,v)
USE nrtype; USE nrutil, ONLY : assert_eq,nrerror,outerprod
USE nr, ONLY : pythag
IMPLICIT NONE
REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: a
REAL(DP), DIMENSION(:), INTENT(OUT) :: w
REAL(DP), DIMENSION(:,:), INTENT(OUT) :: v
INTEGER(I4B) :: i,its,j,k,l,m,n,nm
REAL(DP) :: anorm,c,f,g,h,s,scale,x,y,z
REAL(DP), DIMENSION(size(a,1)) :: tempm
REAL(DP), DIMENSION(size(a,2)) :: rv1,tempn
m=size(a,1)
to :
SUBROUTINE svdcmp_dp(Ma,Na,a,w,v)
USE nrtype; USE nrutil, ONLY : assert_eq,nrerror,outerprod
USE nr, ONLY : pythag
IMPLICIT NONE
INTEGER(I4B) :: i,its,j,k,l,Ma,Na,m,n,nm
REAL(DP), DIMENSION(Ma,Na), INTENT(INOUT) :: a
REAL(DP), DIMENSION(Na), INTENT(INOUT) :: w
REAL(DP), DIMENSION(Na,Na), INTENT(INOUT) :: v
REAL(DP) :: anorm,c,f,g,h,s,scale,x,y,z
REAL(DP), DIMENSION(size(a,1)) :: tempm
REAL(DP), DIMENSION(size(a,2)) :: rv1,tempn
Note that the last one also incudes the dimentions of the input arrays!
PD:
Also, the code need the module(it was incomplete):
MODULE nr
INTERFACE pythag
MODULE PROCEDURE pythag_dp, pythag_sp
END INTERFACE
CONTAINS
FUNCTION pythag_dp(a,b)
USE nrtype
IMPLICIT NONE
REAL(DP), INTENT(IN) :: a,b
REAL(DP) :: pythag_dp
REAL(DP) :: absa,absb
absa=abs(a)
absb=abs(b)
if (absa > absb) then
pythag_dp=absa*sqrt(1.0_dp+(absb/absa)**2)
else
if (absb == 0.0) then
pythag_dp=0.0
else
pythag_dp=absb*sqrt(1.0_dp+(absa/absb)**2)
end if
end if
END FUNCTION pythag_dp
!BL
FUNCTION pythag_sp(a,b)
USE nrtype
IMPLICIT NONE
REAL(SP), INTENT(IN) :: a,b
REAL(SP) :: pythag_sp
REAL(SP) :: absa,absb
absa=abs(a)
absb=abs(b)
if (absa > absb) then
pythag_sp=absa*sqrt(1.0_sp+(absb/absa)**2)
else
if (absb == 0.0) then
pythag_sp=0.0
else
pythag_sp=absb*sqrt(1.0_sp+(absa/absb)**2)
end if
end if
END FUNCTION pythag_sp
END MODULE nr
to run it(first, compile as a library):
julia> Na = 10;
julia> Ma = 10;
julia> w = zeros(Na);
julia> v = zeros(Na,Na);
julia> a = rand(Ma,Na);
julia> t = ccall((:svdcmp_dp_, "./svdcmp_dp.so")
, Void
, ( Ref{Int64} # dim Ma
, Ref{Int64} # dim Na
, Ref{Float64} # array a(Ma,Na)
, Ref{Float64} # array w(Na)
, Ref{Float64} # array v(Na,Na)
)
,Ma,Na,a,w,v)
size(a,1)= 10
size(a,2)= 10
size(v,1)= 10
size(v,2)= 10
size(w) = 10
julia> a
10×10 Array{Float64,2}:
-0.345725 -0.152634 -0.308378 0.16358 -0.0320809 … -0.47387 0.429124 -0.45121
-0.262689 0.337605 -0.0870571 0.409442 -0.160302 -0.0551756 0.16718 0.612903
-0.269915 0.410518 -0.0546271 -0.251295 -0.465747 0.328763 -0.109375 -0.476041
-0.33862 -0.238028 0.3538 -0.110374 0.294611 0.052966 0.44796 -0.0296113
-0.327258 -0.432601 -0.250865 0.478916 -0.0284979 0.0839667 -0.557761 -0.0956028
-0.265429 -0.199584 -0.178273 -0.300575 -0.578186 … -0.0561654 0.164844 0.35431
-0.333577 0.588873 -0.0587738 0.213815 0.349599 0.0573156 0.00210332 -0.0764212
-0.358586 -0.246824 0.211746 0.0193308 0.0844788 0.64333 0.105043 0.0645999
-0.340235 0.0145761 -0.344321 -0.602982 0.422866 -0.15449 -0.309766 0.220315
-0.301303 0.051581 0.712463 -0.0297202 -0.162096 -0.458565 -0.360566 -0.00623828
julia> w
10-element Array{Float64,1}:
4.71084
1.47765
1.06096
0.911895
0.123196
0.235218
0.418629
0.611456
0.722386
0.688394
julia> v
10×10 Array{Float64,2}:
-0.252394 0.128972 -0.0839656 0.6905 … 0.357651 0.0759095 -0.0858018 -0.111576
-0.222082 -0.202181 -0.0485353 -0.217066 0.11651 -0.223779 0.780065 -0.288588
-0.237793 0.109989 0.473947 0.155364 0.0821913 -0.61879 0.119753 0.33927
-0.343341 -0.439985 -0.459649 -0.233768 0.0948844 -0.155143 -0.233945 0.53929
-0.24665 0.0670331 -0.108927 0.119793 -0.520865 0.454486 0.375191 0.226854
-0.194316 0.301428 0.236947 -0.118114 … -0.579563 -0.183961 -0.19942 0.0545692
-0.349481 -0.61546 0.475366 0.227209 -0.0975147 0.274104 -0.0994582 -0.0834197
-0.457956 0.349558 0.263727 -0.506634 0.418154 0.378996 -0.113577 -0.0262257
-0.451763 0.0283005 -0.328583 -0.0121005 -0.219985 -0.276867 -0.269783 -0.604697
-0.27929 0.373724 -0.288427 0.246083 0.0529508 0.0369404 0.197368 0.265678
cheers!
I want to apply three different methods, selected with the value of an integer switch. The first method uses two integers, the second a real array and an integer and the third a real 2D array. In my current implementation, I allocate and pass as parameters all the above data (2 int + real_array + int + real_2array). I could also use a module, but it would be similar. I'm searching for a method to define only the data that my method will use (i.e. only the matrix for method 3) and nothing else. Any suggestions?
Edit:
I have made a simplified version of what I described above.
A part of the main program:
INTEGER :: m, imeth
REAL*8 :: x, y
REAL*8, DIMENSION(:), ALLOCATABLE :: uu, wc
REAL*8, DIMENSION(:,:), ALLOCATABLE :: BCH
imeth = 0
m = 64
ALLOCATE(uu(m), uu_(m), wc(m))
ALLOCATE(BCH(m,m))
if (imeth .EQ. 0) then
x = 1.0d0
y = 2.0d0
elseif (imeth .EQ. 1) then
!Assign values to wc
else
!Assign values to BCH
endif
call subr(m,x,y,uu,uu_,imeth,BCH,wc)
STOP
END
and a subroutine
SUBROUTINE subr(n,a,b,u,u_,imeth,DCH,ws)
IMPLICIT NONE
INTEGER, INTENT(IN) :: n, imeth
REAL*8, INTENT(IN) :: u(n), DCH(n,n), ws(n)
REAL*8, INTENT(OUT) :: u_(n)
INTEGER :: i
if (imeth .EQ. 0) then
u_ = -u_ * 0.5d0 / (a+b)
elseif (imeth .EQ. 1) then
u_ = -u / ws
else
u_ = matmul(DCH,u)
endif
RETURN
END SUBROUTINE subr
I want the main program to have a form like
imeth = 0
m = 64
ALLOCATE(uu(m), uu_(m))
if (imeth .EQ. 0) then
a = 1.0d0
b = 2.0d0
elseif (imeth .EQ. 1) then
ALLOCATE(wc(m))
!Assign values to wc
else
ALLOCATE(BCH(m,m))
!Assign values to BCH
endif
if (imeth .EQ. 0) then
call subrA(m,x,y,uu,uu_)
elseif (imeth .EQ. 1) then
call subrB(m,wc,uu,uu_)
else
call subrC(m,BCH,uu,uu_)
endif
EDIT: After OP added the code I think that using optional arguments in conjunction with the present intrinsic might be better suited for this task. The subroutine could then read
SUBROUTINE subr(n,u_,a,b,u,DCH,ws)
IMPLICIT NONE
INTEGER, INTENT(IN) :: n
REAL*8, INTENT(OUT) :: u_(n)
REAL*8, INTENT(IN),OPTIONAL :: a(n)
REAL*8, INTENT(IN),OPTIONAL :: b(n)
REAL*8, INTENT(IN),OPTIONAL :: u(n)
REAL*8, INTENT(IN),OPTIONAL :: DCH(n,n)
REAL*8, INTENT(IN),OPTIONAL :: ws(n)
INTEGER :: i
if ( present(a) .and. present(b) ) then
u_ = -u_ * 0.5d0 / (a+b)
elseif ( present(u) .and. present(ws) ) then
u_ = -u / ws
elseif ( present(wch) .and. present(u) ) then
u_ = matmul(DCH,u)
else
stop 'invalid combination'
endif
END SUBROUTINE subr
Here is the old answer as it still might be helpful:
Maybe you could try interfaces:
module interface_test
implicit none
interface method
module procedure method1
module procedure method2
module procedure method3
end interface
contains
subroutine method1(int1, int2)
implicit none
integer,intent(in) :: int1
integer,intent(out) :: int2
int2 = 2*int1
end subroutine
subroutine method2(int, realArray)
implicit none
integer,intent(in) :: int
real,intent(out) :: realArray(:)
realArray = real(2*int)
end subroutine
subroutine method3(realArray)
implicit none
real,intent(inout) :: realArray(:,:)
realArray = 2*realArray
end subroutine
end module
program test
use interface_test, only: method
implicit none
integer :: int1, int2
real :: arr1D(10)
real :: arr2D(10,10)
int1 = 1
call method(int1, int2)
print *, int2
call method(int1,arr1D)
print *, arr1D(1)
arr2D = 1.
call method(arr2D)
print *, arr2D(1,1)
end program