How to avoid code duplication between 2D and 3D versions? - fortran

I am writing two programs (a 2D and a 3D version). Nowadays, they are becoming huge (5000 code lines). There are many duplications and it is becoming tedious and difficult to maintain. So I decided to have only one source code that it could be compiled to the 2D or the 3D version.
To sum up, my problem, I wrote very simple examples (2D and 3D) but very representative of my problem.
2D version :
module two_dim_m
implicit none
type :: int_2dim_t
integer :: x
integer :: y
end type int_2dim_t
end module two_dim_m
program main
use two_dim_m
implicit none
type(int_2dim_t) :: ii_curr, full_dim
full_dim%x = 5
full_dim%y = 3
associate (ii_x => ii_curr%x, ii_y => ii_curr%y)
do ii_x = 1, full_dim%x
do ii_y = 1, full_dim%y
call my_print(ii_curr)
enddo
enddo
end associate
contains
subroutine my_print(ii)
type(int_2dim_t), intent(in) :: ii
write (*,'(i6,3x,i6,3x,f12.5)') ii%x,ii%y,sqrt(real(ii%x**2+ii%y**2))
end subroutine my_print
end program main
3D version :
module three_dim_m
implicit none
type :: int_3dim_t
integer :: x
integer :: y
integer :: z
end type int_3dim_t
end module three_dim_m
program main
use three_dim_m
implicit none
type(int_3dim_t) :: ii_curr, full_dim
full_dim%x = 4
full_dim%y = 3
full_dim%z = 2
associate (ii_x => ii_curr%x, ii_y => ii_curr%y, ii_z => ii_curr%z)
do ii_x = 1, full_dim%x
do ii_y = 1, full_dim%y
do ii_z = 1, full_dim%z
call my_print(ii_curr)
enddo
enddo
enddo
end associate
contains
subroutine my_print(ii)
type(int_3dim_t), intent(in) :: ii
write (*,'(3(i6,3x),f12.5)') ii%x,ii%y,ii%z,sqrt(real(ii%x**2+ii%y**2+ii%z**2))
end subroutine my_print
end program main
As, you could remark many lines are duplicated. Thus, I decided to use the C preprocessor to try to have only one code version without many line duplication (perhaps, not the best idea).
After many tries (most of the ideas comes from stackoverflow answers), I wrote the following code :
! Just change dim_size to compile 2D or 3D version
#define cpp_dim_size 3
#if cpp_dim_size == 2
#define cpp_addDim(param) param%x, param%y
#define cpp_init_nLoop(currL,endL) \
associate (ii_x => currL%x, ii_y => currL%y) cpp_nl \
do ii_x = 1, endL%x cpp_nl \
do ii_y = 1, endL%y
#define cpp_end_nLoop \
enddo cpp_nl \
enddo cpp_nl \
end associate
#else if cpp_dim_size == 3
#define cpp_addDim(param) param%x, param%y, param%z
#define cpp_init_nLoop(currL,endL) \
associate (ii_x => currL%x, ii_y => currL%y, ii_z => currL%z) cpp_nl \
do ii_x = 1, endL%x cpp_nl \
do ii_y = 1, endL%y cpp_nl \
do ii_z = 1, endL%z
#define cpp_end_nLoop \
enddo cpp_nl \
enddo cpp_nl \
enddo cpp_nl \
end associate
#endif
module n_dim_m
implicit none
type :: int_ndim_t
integer :: x
integer :: y
#if cpp_dim_size == 3
integer :: z
#endif
end type int_ndim_t
end module n_dim_m
program main
use n_dim_m
implicit none
type(int_ndim_t) :: ii_curr, full_dim
full_dim%x = 4
full_dim%y = 3
#if cpp_dim_size == 3
full_dim%z = 2
#endif
cpp_init_nLoop(ii_curr,full_dim)
call my_print(ii_curr)
cpp_end_nLoop
contains
subroutine my_print(ii)
type(int_ndim_t), intent(in) :: ii
character (len=32) :: fmt_string
write (fmt_string,'(a,i1.1,a)') '(', cpp_dim_size, '(i6,3x),f12.5)'
write (*, fmt= fmt_string) cpp_addDim(ii), &
#if cpp_dim_size == 2
sqrt(real(ii%x**2+ii%y**2))
#else if cpp_dim_size == 3
sqrt(real(ii%x**2+ii%y**2+ii%z**2))
#endif
end subroutine my_print
end program main
To compile it :
gfortran -cpp -P -E fortran_cpp2.f90 | sed -e 's/cpp_nl/\n/g' >aaa.f90 ; gfortran aaa.f90
(Because of length line max size in fortran, sed is used to change cpp_nl to a line break)
It works, but I am not sure that it is the best solution. I tried to use OOP and polymorphism but I could not avoid line code duplication.

If you just need 2D and 3D code (i.e. you don't need to go higher than 3D), then the simplest solution is probably to store everything using 3D arrays, but to have the final dimension of these arrays be of size 1 for the 2D case.
Something like
module m
implicit none
type :: int_t
integer, allocatable :: point(3)
end type int_t
end module m
program main
use m
implicit none
type(int_t) :: ii_curr, full_dim
! You might want a 2D constructor, to save you having to write the `1`s.
full_dim%point = [5, 3, 1]
associate (ii_x => ii_curr%point(1), &
&ii_y => ii_curr%point(2), &
&ii_z => ii_curr%point(3))
do ii_x = 1, full_dim%x
do ii_y = 1, full_dim%y
do ii_z = 1, full_dim%z
call my_print(ii_curr)
enddo
enddo
enddo
end associate
contains
subroutine my_print(ii)
type(int_t), intent(in) :: ii
write (*,'(i6,3x,i6,3x,i6,3x,f12.5)') ii%x,ii%y,ii%z,sqrt(real(ii%x**2+ii%y**2+ii%z**2))
end subroutine my_print
end program main
The triple loop there would be in the wrong order if z was always going to be of size 1, so you'd probably want to transpose it.
You probably also want to keep a flag around telling you what your dimension actually is, to avoid the performance costs of the third dimension (but only where those performance costs actually appear - no point complicating your code for optimisations which don't speed your code up).

Related

How to choose a desired code for a Subroutine among various options during the start of a run

Let's say I want to perform an operation in my main program (in Fortran). And lets say that operation is finding minimum number in a 1D array. I wish to do so by passing the array into the call subroutine and the subroutine will print the minimum value on the screen. There are different ways or algorithms to find minimum value in an array. Lets say I have 100 different methods: Method1, Method2..... Method100. Now I want to try using each one of these methods separately (I don't want to try all of them at once, but one method in each run). I don't want to create 100 different subroutines and change the code every time to decide which one to call, rather I want to mention in the input file which one I want to choose. So basically, the computer has to read the input file (to know which method to use) and perform the task using the specified method amongst different methods available.
I can write a Subroutine dump all the methods into that subroutine and put an IF condition to choose among various methods. But IF conditions are in efficient particularly on GPUs, I want to know the most efficient way of doing this.
MAIN PROGRAM
INTEGER Method !will be read from input file
Array = [12,5,3,4,1,7,4,3]
call print_Minimum(Array)
END PROGRAM
SUBROUTINE print_Minimum(Array)
IF (METHOD == 1)
<method 1 code>
ELSE IF (METHOD == 2)
<method 2 code>
:
:
:
:
ELSE IF (METHOD == 100)
<method100 code>
END IF
END SUBROUTINE
Thanks in advance.
This is probably best done using a function pointer and/or functions as arguments.
You can set a function pointer to a certain function and do this in your nested ifs and you can pass functions as arguments.
Both methods are implemented in the following example.
module minimum_mod
implicit none
private
public :: get_min_t, naive_min, time_min_function
abstract interface
integer pure function get_min_t(X)
integer, intent(in) :: X(:)
end function
end interface
contains
subroutine time_min_function(f, X)
procedure(get_min_t) :: f
integer, intent(in) :: X(:)
integer :: res
res = f(X)
write(*, *) res
end subroutine
integer pure function naive_min(X)
integer, intent(in) :: X(:)
integer :: i
naive_min = huge(naive_min)
do i = 1, size(X)
naive_min = min(naive_min, X(i))
end do
end function
end module
program time_min_finders
use minimum_mod, only: get_min_t, naive_min, time_min_function
implicit none
integer, parameter :: test_set(5) = [1, 10, 3, 5, 7]
procedure(get_min_t), pointer :: f
f => naive_min
call time_min_function(f, test_set)
end program
PS: Note that you can now do all the timinig logic inside time_min_function.
You can create an array of a derived type that contains a function pointer, effectively an array of function pointers. Then in principle you could initialize the function pointers to point at all of your test functions so that you could refer to each function by its index without having to test with a SELECT CASE of IF block: this is the typical Fortran way. However, either I've got the syntax for initialization wrong or my old version of gfortran just isn't capable, so I had to initialize one at a time. Sigh.
module minfuncs
implicit none
abstract interface
function func(array)
integer, intent(in) :: array(:)
integer func
end function func
end interface
type func_node
procedure(func), NOPASS, pointer :: f
end type func_node
! type(func_node) :: method(5) = [func_node(min_1),func_node(min_2), &
! func_node(min_3),func_node(min_4),func_node(min_5)]
contains
function min_1(array)
integer, intent(in) :: array(:)
integer min_1
integer i
min_1 = array(1)
do i = 2, size(array)
min_1 = min(min_1,array(i))
end do
end function min_1
function min_2(array)
integer, intent(in) :: array(:)
integer min_2
integer i
min_2 = array(1)
do i = 8, size(array), 7
min_2 = min(min_2,array(i-6),array(i-5),array(i-4), &
array(i-3),array(i-2),array(i-1),array(i))
end do
do i = i-6, size(array)
min_2 = min(min_2, array(i))
end do
end function min_2
function min_3(array)
integer, intent(in) :: array(:)
integer min_3
integer i
min_3 = array(1)
do i = 2, size(array)
min_3 = min_3-dim(min_3,array(i))
end do
end function min_3
function min_4(array)
integer, intent(in) :: array(:)
integer min_4
integer ymm(8)
integer i
if(size(array) >= 8) then
ymm = array(1:8)
do i = 16, size(array), 8
ymm = min(ymm,array(i-7:i))
end do
min_4 = minval([ymm,array(i-7:size(array))])
else
min_4 = minval(array)
end if
end function min_4
function min_5(array)
integer, intent(in) :: array(:)
integer min_5
min_5 = minval(array)
end function min_5
end module minfuncs
program test
use minfuncs
implicit none
integer, parameter :: N = 75
integer i
integer :: A(N) = modulo(5*[(i,i=1,N)]**2,163)
! type(func_node) :: method(5) = [func_node(min_1),func_node(min_2), &
! func_node(min_3),func_node(min_4),func_node(min_5)]
type(func_node) method(5)
method(1)%f => min_1
method(2)%f => min_2
method(3)%f => min_3
method(4)%f => min_4
method(5)%f => min_5
do i = 1, size(method)
write(*,*) method(i)%f(A)
end do
end program test
Output:
2
2
2
2
2

OpenACC routine vector with intent out argument

I am currently accelerating a Fortran code where I have a main accelerated loop in subroutine sub. In the loop, I want to call subroutine subsub on the device with acc routine. The subroutine has an intent(out) argument val, which is private in the loop. As subsub has a loop itself, I want to use the vector clause:
module calc
implicit none
public :: sub
private
contains
subroutine sub()
integer :: i
integer :: array(10)
integer :: val
!$acc kernels loop independent private(val)
do i = 1, 10
call subsub(val)
array(i) = val
enddo
print "(10(i0, x))", array
endsubroutine
subroutine subsub(val)
!$acc routine vector
integer, intent(out) :: val
integer :: i
val = 0
!$acc loop independent reduction(+:val)
do i = 1, 10
val = val + 1
enddo
endsubroutine
endmodule
program test
use calc, only: sub
implicit none
call sub()
endprogram
When compiling with the PGI compiler version 20.9-0 and running the program, I get gibberish values in variable array. When I simply use acc routine for subsub, I get the correct behavior (10 in all values of array). What is wrong in my approach to parallelize this subroutine?
It does look like a compiler code generation issue on how val is getting handled in the main loop. Luckily the workaround is easy, just add the installation of val in the main loop.
% cat test.f90
module calc
implicit none
public :: sub
private
contains
subroutine sub()
integer :: i
integer :: array(10)
integer :: val
!$acc kernels loop independent private(val)
do i = 1, 10
val = 0
call subsub(val)
array(i) = val
enddo
print "(10(i0, x))", array
endsubroutine
subroutine subsub(val)
!$acc routine vector
integer, intent(out) :: val
integer :: i
val = 0
!$acc loop independent reduction(+:val)
do i = 1, 10
val = val + 1
enddo
endsubroutine
endmodule
program test
use calc, only: sub
implicit none
call sub()
endprogram
% nvfortran -acc -Minfo=accel test.f90 -V20.9 ; a.out
sub:
10, Generating implicit copyout(array(:)) [if not already present]
11, Loop is parallelizable
Generating Tesla code
11, !$acc loop gang ! blockidx%x
subsub:
18, Generating Tesla code
24, !$acc loop vector ! threadidx%x
Generating reduction(+:val)
Vector barrier inserted for vector loop reduction
24, Loop is parallelizable
10 10 10 10 10 10 10 10 10 10

How to READ data starting from a pattern-matched line with Fortran?

I have a file pos.xyz with the following format, where i = 6,etc represent the frame indices. (Here, the first frame has i = 6. In general, the first frame's index can be i = 0,i = 1, or i = 2,...)
I want to implement a function: For any two given integers a and b,( a<b, e.g., 7 and 9), read
the data from the frame index 7 to 9 into an array. Could you give me a suggestion on how to implement this idea?
4
i = 6, time = 3.000, E = -205.1846561900
O 2.6028572470 4.1666579520 12.7865910725
O 6.5415232423 8.8963227363 17.7533721708
O 15.6020396800 11.9022808314 15.2930838049
O 11.2843786793 13.2653367176 13.8186352548
4
i = 7, time = 3.500, E = -205.1845561905
O 5.1072569275 11.9945026418 4.1254340934
O 2.5299942732 11.4124710424 9.5495912455
O 14.8837181647 12.6571252157 7.8905997802
O 15.1684493877 10.7315923081 2.6631494700
4
i = 8, time = 4.000, E = -205.1846261900
O 2.6028572470 4.1666579520 12.7865910725
O 6.5415232423 8.8963227363 17.7533721708
O 15.6020396800 11.9922808314 15.2930838049
O 11.2843786793 13.2653367176 13.8186352548
4
i = 9, time = 4.500, E = -205.1846561805
O 5.1072569375 11.9945026418 4.1258340934
O 2.5299942732 11.4124710424 9.5495912455
O 14.8837181647 12.6570252157 7.8905997802
O 15.1684493877 10.7310923081 2.6630494700
4
i = 10, time = 5.000, E = -205.1846551805
O 5.1072569275 11.9945026418 4.1254340934
O 2.5299932732 11.4129710424 9.5495912455
O 14.8837181647 12.6571252157 7.8905997802
O 15.1684473877 10.7313923081 2.6631494700
what I did: for the special case with i = 0 as the first frame. For example, If I want to read from the 3rd frame, I can first skip (m+2)*(3-1) lines and then READ the data,m=4. The function is as follows.
SUBROUTINE skip_lines(indx, i_input)
! Purpose:
! To skip lines when read data from the input
IMPLICIT NONE
INTEGER :: i
INTEGER,INTENT(IN) :: i_input,indx
do i=1,i_input
read(indx,*) !Neglect (nat+2)*(ns-1) lines
enddo
END SUBROUTINE skip_lines
But for general case, if the first frame has a frame non-zero number,this idea is not efficient. I hope to find a better way to implement it.
Thanks to #francescalus 's and #High Performance Mark 's suggestions. I use a DO WHILE loop and I have implemented my idea. I put one simplified version of my subroutine here. It include some types defined in modules, which are not the important thing here. Now, it can
(1) Read a trajectory file from any step a to any step b, where a and b are given by user;
(2) Read data every ns steps.
SUBROUTINE read_traj(indx,nmo_start,nmo_end,ns,nat,n_samples)
! goal:
! read info from the trajectory file (format: ***.xyz)
! read data from frame a to frame b
USE atom_module
USE parameter_shared
INTEGER :: iatom, i_sample
INTEGER, PARAMETER:: nat = 4
INTEGER :: n_samples !n_samples = INT((a-b)/ns)
INTEGER, PARAMETER :: indx = 10
INTEGER, PARAMETER :: ns = 2 ! read one sample from the trajectory every ns step.
INTEGER, PARAMETER :: a =7
INTEGER, PARAMETER :: b=10
CHARACTER(LEN=4) :: x
INTEGER :: y
allocate(atom_info(nat,n_samples))
i_sample = 1
DO WHILE (i_sample < n_samples)
read(indx, '(A3,I5)') x, y
CHECK: IF (head_char=="i = " .AND. (y>a-1 .and. y<b+1) .AND. MOD(y-(a-1),ns) == 1) THEN
WRITE(*,*)"head_char and y:", x, y
BACKSPACE(UNIT=indx) ! we have to read the whole line with ' i = ' line.
read(indx,120) sampled_movie(i_sample), sampled_time(i_sample), sampled_energy(i_sample)
120 FORMAT (3X,I5,8X,F9.3,5X,F20.10)
inner: do iatom= 1,nat
read (indx,*) atom_info(iatom, i_sample)%atom_name, atom_info(iatom,i_sample)%coord(1), &
atom_info(iatom,i_sample)%coord(2), atom_info(iatom,i_sample)%coord(3)
enddo inner
i_sample = i_sample + 1
ENDIF CHECK
END DO
END SUBROUTINE read_traj
gfortran -Wall -fcheck=all parameter_shared.f95 atom_module.f95 traj.f95 sample.f95 test.f95 -o test.x
! test.f95
PROGRAM test
! Purpose: To read data starting from any block.
USE atom_module
IMPLICIT NONE
!==========
!parameters
!==========
INTEGER :: ns ! Get one sample from the trajectory every ns step.
INTEGER :: nmo_start
INTEGER :: nmo_end
INTEGER :: nat ! number of atoms
REAL(kind=4) :: delta_t0 ! For reading data
character(LEN=200) :: pos_filename
!===============
! Initialization
delta_t0 = 0.0005; ns = 2
nmo_start = 7; nmo_end = 10
nat = 4; pos_filename="pos.xyz"
!========================
! Sampling the trajectory
CALL sample(pos_filename,nmo_start,nmo_end,nat,ns)
END PROGRAM test
! sample.f95
SUBROUTINE sample(pos_filename,nmo_start,nmo_end,nat,ns)
USE parameter_shared
USE atom_module, ONLY: atom_info
USE traj
IMPLICIT NONE
!==========
!Parameters
!==========
character(LEN=*), INTENT(IN) :: pos_filename
INTEGER, INTENT(IN) :: nmo_start
INTEGER, INTENT(IN) :: nmo_end
INTEGER, INTENT(IN) :: nat ! number of atoms
INTEGER, INTENT(IN) :: ns ! Get one sample from the trajectory every ns step.
!Local varables
INTEGER :: n_samples !n_samples = INT(nmo/ns)
INTEGER :: iatom,imovie,i
!Initialization
iatom = 0; imovie =0; i =0
! Obatin n_samples
n_samples = sampling_number(nmo_start,nmo_end,ns)
allocate(sampled_movie(n_samples))
allocate(sampled_time(n_samples))
allocate(sampled_energy(n_samples))
!=======================
!read in trajectory file
!=======================
open(10,file=trim(pos_filename))
CALL read_traj(10,nmo_start,nmo_end,ns,nat,n_samples)
close(10)
write(6,*) 'End of trajectory reading.'
!=============
!write in file
!=============
sampled_pos_filename = 'pos_sampled.xyz'
open(10,file=sampled_pos_filename)
do i =1,n_samples
write (10,'(I8)') nat
WRITE(10,100) 'i =',i-1,', time =',sampled_time(i),', E =',sampled_energy(i)
100 FORMAT (1X,A3,I10,A8,F10.3,A5,F20.10)
DO iatom = 1, nat
WRITE(10,*) TRIM(atom_info(iatom, i)%atom_name), &
atom_info(iatom,i)%coord(1), &
atom_info(iatom,i)%coord(2), &
atom_info(iatom,i)%coord(3)
ENDDO
enddo
write(6,*)'Sampled trajectory is written in: ', sampled_pos_filename
close(10)
deallocate(sampled_movie, sampled_time,sampled_energy)
END SUBROUTINE sample
MODULE traj
IMPLICIT NONE
CONTAINS
INTEGER FUNCTION sampling_number(nmo_start,nmo_end,ns)
!To calculate the total numbers of samples one want to include
INTEGER,INTENT(IN) :: ns ! Get one sample from the trajectory every ns step.
INTEGER,INTENT(IN) :: nmo_start, nmo_end
write(*,*) 'In function sampling_number: nmo_end = ', nmo_end
positive: IF (nmo_end <0 .OR. nmo_start < 0 .OR. ns <0) THEN
write(*,*) 'Please enter non-negative values for the ns, starting step and ending step.'
ELSE IF (nmo_end < nmo_start) THEN
write(*,*) 'Please note that starting step shoud not larger than ending step.'
ELSE IF (ns ==0) THEN
sampling_number = nmo_end-(nmo_start-1)
ELSE IF (nmo_end-(nmo_start-1) <= ns) THEN
sampling_number = INT((nmo_end-(nmo_start-1))/ns + 1)
ELSE IF (nmo_end-(nmo_start-1) > ns) THEN
sampling_number = INT((nmo_end-(nmo_start-1))/ns)
END IF positive
END FUNCTION sampling_number
SUBROUTINE read_traj(indx,nmo_start,nmo_end,ns,nat,n_samples)
! Purpose: to READ data starting from a pattern-matched line.
USE atom_module, ONLY: atom_info
USE parameter_shared, ONLY: sampled_movie, sampled_time, sampled_energy
INTEGER :: iatom,i_sample
INTEGER, INTENT(IN) :: nat
INTEGER, INTENT(IN) :: n_samples !n_samples = INT(nmo/ns)
INTEGER, INTENT(IN) :: indx
INTEGER, INTENT(IN) :: ns ! Get one sample from the trajectory every ns step.
INTEGER, INTENT(IN) :: nmo_start, nmo_end ! To get the total number of moves
CHARACTER(LEN=4) :: head_char
INTEGER :: y
allocate(atom_info(nat,n_samples))
i_sample = 1
write(*,*) "read_traj(): New total time steps (n_samples):", n_samples
DO WHILE (i_sample < n_samples+1) ! +1 means i_sample can take the value of n_samples
read(indx, '(A4)') head_char
PRE_CHECK:IF (head_char=="i = ") THEN
BACKSPACE(UNIT=indx) ! Because I am not able to read other lines with the format '(A4,I8)', and have not find any good way, so I try to read it in '(A4)' first
read(indx, '(A4,I8)') head_char, y
CHECK_HEAD:IF (head_char=="i = " .AND. (y>nmo_start-1 .and. y<nmo_end+1) .AND. MOD(y-(nmo_start-1),ns) == 1) THEN
WRITE(*,*)"read_traj():", head_char, y
BACKSPACE(UNIT=indx) ! Because we have to read the whole line with ' i = ' line.
read(indx,130) sampled_movie(i_sample), sampled_time(i_sample), sampled_energy(i_sample)
130 FORMAT (4X,I8,9X,F12.3,6X,F20.10)
131 FORMAT (A4,3F20.10)
inner: do iatom= 1,nat
read (indx,131) atom_info(iatom, i_sample)%atom_name, atom_info(iatom,i_sample)%coord(1), &
atom_info(iatom,i_sample)%coord(2), atom_info(iatom,i_sample)%coord(3)
enddo inner
i_sample = i_sample + 1
ENDIF CHECK_HEAD
ENDIF PRE_CHECK
END DO
END SUBROUTINE read_traj
END MODULE traj
MODULE atom_module
! To define the derived data type for atom
IMPLICIT NONE
TYPE :: atom
CHARACTER(LEN=2) :: atom_name
INTEGER :: atom_id
INTEGER :: host_id ! For O atom in water, host_id = atom_id
REAL :: mass
REAL, DIMENSION(3) :: coord
END TYPE atom
! The array atom_info can be shared by subroutines
TYPE(atom), ALLOCATABLE, DIMENSION(:,:) :: atom_info
END MODULE atom_module
MODULE parameter_shared
!
! Purpose:
! To declare data to share between routines.
IMPLICIT NONE
!SAVE
character(LEN=200) :: sampled_pos_filename
INTEGER, ALLOCATABLE, DIMENSION(:) :: sampled_movie
REAL, ALLOCATABLE, DIMENSION(:) :: sampled_time, sampled_energy
END MODULE parameter_shared

Rank 1 Transposition in Fortran-95 - Recursive I/O Operation Error [duplicate]

I'm trying to learn Fortran (unfortunately a necessity for my research group) - one of the tasks I set myself was to package one of the necessary functions (Associated Legendre polynomials) from the Numerical Recipes book into a fortran 03 compliant module. The original program (f77) has some error handling in the form of the following:
if(m.lt.0.or.m.gt.1.or.abs(x).gt.1)pause 'bad arguments in plgndr'
Pause seems to have been deprecated since f77 as using this line gives me a compiling error, so I tried the following:
module sha_helper
implicit none
public :: plgndr, factorial!, ylm
contains
! numerical recipes Associated Legendre Polynomials rewritten for f03
function plgndr(l,m,x) result(res_plgndr)
integer, intent(in) :: l, m
real, intent(in) :: x
real :: res_plgndr, fact, pll, pmm, pmmp1, somx2
integer :: i,ll
if (m.lt.0.or.m.gt.l.or.abs(x).gt.1) then
write (*, *) "bad arguments to plgndr, aborting", m, x
res_plgndr=-10e6 !return a ridiculous value
else
pmm = 1.
if (m.gt.0) then
somx2 = sqrt((1.-x)*(1.+x))
fact = 1.
do i = 1, m
pmm = -pmm*fact*somx2
fact = fact+2
end do
end if
if (l.eq.m) then
res_plgndr = pmm
else
pmmp1 = x*(2*m+1)*pmm
if(l.eq.m+1) then
res_plgndr = pmmp1
else
do ll = m+2, l
pll = (x*(2*ll-1)*pmmp1-(ll+m-1)*pmm)/(ll-m)
pmm = pmmp1
pmmp1 = pll
end do
res_plgndr = pll
end if
end if
end if
end function plgndr
recursive function factorial(n) result(factorial_result)
integer, intent(in) :: n
integer, parameter :: RegInt_K = selected_int_kind(20) !should be enough for the factorials I am using
integer (kind = RegInt_K) :: factorial_result
if (n <= 0) then
factorial_result = 1
else
factorial_result = n * factorial(n-1)
end if
end function factorial
! function ylm(l,m,theta,phi) result(res_ylm)
! integer, intent(in) :: l, m
! real, intent(in) :: theta, phi
! real :: res_ylm, front_block
! real, parameter :: pi = 3.1415926536
! front_block = sqrt((2*l+1)*factorial(l-abs(m))/(4*pi*))
! end function ylm
end module sha_helper
The main code after the else works, but if I execute my main program and call the function with bad values, the program freezes before executing the print statement. I know that the print statement is the problem, as commenting it out allows the function to execute normally, returning -10e6 as the value. Ideally, I would like the program to crash after giving a user readable error message, as giving bad values to the plgndr function is a fatal error for the program. The function plgndr is being used by the program sha_lmc. Currently all this does is read some arrays and then print a value of plgndr for testing (early days). The function ylm in the module sha_helper is also not finished, hence it is commented out. The code compiles using gfortran sha_helper.f03 sha_lmc.f03 -o sha_lmc, and
gfortran --version
GNU Fortran (GCC) 4.8.2
!Spherical Harmonic Bayesian Analysis testbed for Lagrangian Dynamical Monte Carlo
program sha_analysis
use sha_helper
implicit none
!Analysis Parameters
integer, parameter :: harm_order = 6
integer, parameter :: harm_array_length = (harm_order+1)**2
real, parameter :: coeff_lo = -0.1, coeff_hi = 0.1, data_err = 0.01 !for now, data_err fixed rather than heirarchical
!Monte Carlo Parameters
integer, parameter :: run = 100000, burn = 50000, thin = 100
real, parameter :: L = 1.0, e = 1.0
!Variables needed by the program
integer :: points, r, h, p, counter = 1
real, dimension(:), allocatable :: x, y, z
real, dimension(harm_array_length) :: l_index_list, m_index_list
real, dimension(:,:), allocatable :: g_matrix
!Open the file, allocate the x,y,z arrays and read the file
open(1, file = 'Average_H_M_C_PcP_boschi_1200.xyz', status = 'old')
read(1,*) points
allocate(x(points))
allocate(y(points))
allocate(z(points))
print *, "Number of Points: ", points
readloop: do r = 1, points
read(1,*) x(r), y(r), z(r)
end do readloop
!Set up the forwards model
allocate(g_matrix(harm_array_length,points))
!Generate the l and m values of spherical harmonics
hloop: do h = 0, harm_order
ploop: do p = -h,h
l_index_list(counter) = h
m_index_list(counter) = p
counter = counter + 1
end do ploop
end do hloop
print *, plgndr(1,2,0.1)
!print *, ylm(1,1,0.1,0.1)
end program sha_analysis
Your program does what is known as recursive IO - the initial call to plgndr is in the output item list of an IO statement (a print statement) [directing output to the console] - inside that function you then also attempt to execute another IO statement [that outputs to the console]. This is not permitted - see 9.11p2 and p3 of F2003 or 9.12p2 of F2008.
A solution is to separate the function invocation from the io statement in the main program, i.e.
REAL :: a_temporary
...
a_temporary = plgndr(1,2,0.1)
PRINT *, a_temporary
Other alternatives in F2008 (but not F2003 - hence the [ ] parts in the first paragraph) include directing the output from the function to a different logical unit (note that WRITE (*, ... and PRINT ... reference the same unit).
In F2008 you could also replace the WRITE statement with a STOP statement with a message (the message must be a constant - which wouldn't let you report the problematic values).
The potential for inadvertently invoking recursive IO is part of the reason that some programming styles discourage conducting IO in functions.
Try:
if (m.lt.0.or.m.gt.l.or.abs(x).gt.1) then
write (*, *) "bad arguments to plgndr, aborting", m, x
stop
else
...
end if

Print to standard output from a function defined in an Fortran module

I'm trying to learn Fortran (unfortunately a necessity for my research group) - one of the tasks I set myself was to package one of the necessary functions (Associated Legendre polynomials) from the Numerical Recipes book into a fortran 03 compliant module. The original program (f77) has some error handling in the form of the following:
if(m.lt.0.or.m.gt.1.or.abs(x).gt.1)pause 'bad arguments in plgndr'
Pause seems to have been deprecated since f77 as using this line gives me a compiling error, so I tried the following:
module sha_helper
implicit none
public :: plgndr, factorial!, ylm
contains
! numerical recipes Associated Legendre Polynomials rewritten for f03
function plgndr(l,m,x) result(res_plgndr)
integer, intent(in) :: l, m
real, intent(in) :: x
real :: res_plgndr, fact, pll, pmm, pmmp1, somx2
integer :: i,ll
if (m.lt.0.or.m.gt.l.or.abs(x).gt.1) then
write (*, *) "bad arguments to plgndr, aborting", m, x
res_plgndr=-10e6 !return a ridiculous value
else
pmm = 1.
if (m.gt.0) then
somx2 = sqrt((1.-x)*(1.+x))
fact = 1.
do i = 1, m
pmm = -pmm*fact*somx2
fact = fact+2
end do
end if
if (l.eq.m) then
res_plgndr = pmm
else
pmmp1 = x*(2*m+1)*pmm
if(l.eq.m+1) then
res_plgndr = pmmp1
else
do ll = m+2, l
pll = (x*(2*ll-1)*pmmp1-(ll+m-1)*pmm)/(ll-m)
pmm = pmmp1
pmmp1 = pll
end do
res_plgndr = pll
end if
end if
end if
end function plgndr
recursive function factorial(n) result(factorial_result)
integer, intent(in) :: n
integer, parameter :: RegInt_K = selected_int_kind(20) !should be enough for the factorials I am using
integer (kind = RegInt_K) :: factorial_result
if (n <= 0) then
factorial_result = 1
else
factorial_result = n * factorial(n-1)
end if
end function factorial
! function ylm(l,m,theta,phi) result(res_ylm)
! integer, intent(in) :: l, m
! real, intent(in) :: theta, phi
! real :: res_ylm, front_block
! real, parameter :: pi = 3.1415926536
! front_block = sqrt((2*l+1)*factorial(l-abs(m))/(4*pi*))
! end function ylm
end module sha_helper
The main code after the else works, but if I execute my main program and call the function with bad values, the program freezes before executing the print statement. I know that the print statement is the problem, as commenting it out allows the function to execute normally, returning -10e6 as the value. Ideally, I would like the program to crash after giving a user readable error message, as giving bad values to the plgndr function is a fatal error for the program. The function plgndr is being used by the program sha_lmc. Currently all this does is read some arrays and then print a value of plgndr for testing (early days). The function ylm in the module sha_helper is also not finished, hence it is commented out. The code compiles using gfortran sha_helper.f03 sha_lmc.f03 -o sha_lmc, and
gfortran --version
GNU Fortran (GCC) 4.8.2
!Spherical Harmonic Bayesian Analysis testbed for Lagrangian Dynamical Monte Carlo
program sha_analysis
use sha_helper
implicit none
!Analysis Parameters
integer, parameter :: harm_order = 6
integer, parameter :: harm_array_length = (harm_order+1)**2
real, parameter :: coeff_lo = -0.1, coeff_hi = 0.1, data_err = 0.01 !for now, data_err fixed rather than heirarchical
!Monte Carlo Parameters
integer, parameter :: run = 100000, burn = 50000, thin = 100
real, parameter :: L = 1.0, e = 1.0
!Variables needed by the program
integer :: points, r, h, p, counter = 1
real, dimension(:), allocatable :: x, y, z
real, dimension(harm_array_length) :: l_index_list, m_index_list
real, dimension(:,:), allocatable :: g_matrix
!Open the file, allocate the x,y,z arrays and read the file
open(1, file = 'Average_H_M_C_PcP_boschi_1200.xyz', status = 'old')
read(1,*) points
allocate(x(points))
allocate(y(points))
allocate(z(points))
print *, "Number of Points: ", points
readloop: do r = 1, points
read(1,*) x(r), y(r), z(r)
end do readloop
!Set up the forwards model
allocate(g_matrix(harm_array_length,points))
!Generate the l and m values of spherical harmonics
hloop: do h = 0, harm_order
ploop: do p = -h,h
l_index_list(counter) = h
m_index_list(counter) = p
counter = counter + 1
end do ploop
end do hloop
print *, plgndr(1,2,0.1)
!print *, ylm(1,1,0.1,0.1)
end program sha_analysis
Your program does what is known as recursive IO - the initial call to plgndr is in the output item list of an IO statement (a print statement) [directing output to the console] - inside that function you then also attempt to execute another IO statement [that outputs to the console]. This is not permitted - see 9.11p2 and p3 of F2003 or 9.12p2 of F2008.
A solution is to separate the function invocation from the io statement in the main program, i.e.
REAL :: a_temporary
...
a_temporary = plgndr(1,2,0.1)
PRINT *, a_temporary
Other alternatives in F2008 (but not F2003 - hence the [ ] parts in the first paragraph) include directing the output from the function to a different logical unit (note that WRITE (*, ... and PRINT ... reference the same unit).
In F2008 you could also replace the WRITE statement with a STOP statement with a message (the message must be a constant - which wouldn't let you report the problematic values).
The potential for inadvertently invoking recursive IO is part of the reason that some programming styles discourage conducting IO in functions.
Try:
if (m.lt.0.or.m.gt.l.or.abs(x).gt.1) then
write (*, *) "bad arguments to plgndr, aborting", m, x
stop
else
...
end if