I am having strange results when verifying the SVD decomposition from Lapack. Those routines are usually robust so I believe the bug is on my side. Any help will be highly appreciated. My matrix is pentadiagonal, size n*n and the code looks like :
! Compute real bi-diag from complex pentadiag
call ZGBBRD('B', n, n, 0, 2, 2, ab, 5, &
d, e, q, n, pt, n, dummy_argc, 1, work, rwork, info)
if (info.ne.0) then
print *,'Call to *GBBRD failed, info : ',info
call exit(0)
endif
! Compute diagonal matrix from bi-diagonal one
call dbdsdc('U', 'I', n, d, e, u, n, vt, n, &
dummy_argr, 1, work_big, iwork, info)
if (info.ne.0) then
print *,'Call to *BDSDC failed, info : ',info
call exit(0)
endif
print *,'singular values min/max : ',minval(d),maxval(d)
do ii=1,n
do jj=1,n
tmpqu(ii,jj)=0.
do kk=1,n
tmpqu(ii,jj)=tmpqu(ii,jj)+q(ii,kk)*u(kk,jj) ! Q*U
enddo
enddo
enddo
do ii=1,n
do jj=1,n
tmpqu(ii,jj)=tmpqu(ii,jj)*d(jj) ! Q*U*sigma
enddo
enddo
do ii=1,n
do jj=1,n
tmptot(ii,jj)=0.
do kk=1,n
tmptot(ii,jj) = tmptot(ii,jj) + & ! Q*U*sigma*VT
tmpqu(ii,kk)*vt(kk,jj)
enddo
enddo
enddo
tmpqu=tmptot
do ii=1,n
do jj=1,n
tmptot(ii,jj)=0.
do kk=1,n
tmptot(ii,jj) = tmptot(ii,jj) + & ! Q*U*sigma*VT*P
tmpqu(ii,kk)*pt(kk,jj)
enddo
enddo
enddo
tmpa=0.
do ii=1,n
tmpa(ii,ii)=ab(3,ii) ! diag
enddo
do ii=2,n
tmpa(ii-1,ii)=ab(2,ii) ! diag+1
enddo
do ii=3,n
tmpa(ii-2,ii)=ab(1,ii) ! diag+2
enddo
do ii=1,n-1
tmpa(ii+1,ii)=ab(4,ii) ! diag-1
enddo
do ii=1,n-2
tmpa(ii+2,ii)=ab(5,ii) ! diag-2
enddo
print *, 'maxabs delta',maxval(abs(tmptot-tmpa)), maxloc(abs(tmptot-tmpa))
EDIT : add variable declaration :
! Local variables
integer :: i,j,k
integer :: info, info2, code
! From pentadiagonale to bi-diagonale
complex(mytype), dimension(5,n) :: ab ! matrice pentadiagonale
real(mytype), dimension(n) :: d ! diagonale matrice bidiagonale
real(mytype), dimension(n-1) :: e ! diag+1 matrice bidiagonale
complex(mytype), dimension(n,n) :: q ! unitary matrix Q
complex(mytype), dimension(n,n) :: pt ! Unitary matrix P'
complex(mytype) :: dummy_argc
complex(mytype), dimension(n) :: work
real(mytype), dimension(n) :: rwork
! From bi-diagonale to SVD
real(mytype), dimension(n,n) :: u ! Left singular vectors
real(mytype), dimension(n,n) :: vt ! Right singular vectors
real(mytype) :: dummy_argr
real(mytype), dimension(3*n*n+4*n) :: work_big
integer, dimension(8*n) :: iwork
! Temp verif sigma
integer :: ii,jj,kk
complex(mytype), dimension(n,n) :: tmpa, tmpqu, tmptot
Thanks
The routine ZGBBRD modify the input array AB. It should be saved in another array before calling the routine. Looks like it works perfectly using this precaution. Thanks.
Related
A Fortran code has two definitions of a subroutine within an if defined block, as shown below. If I manually remove of the definitions, the code can be compiled, but that's not what the author intended. Compiling with gfortran -c -cpp does not work. What is the right way to compile it?
#:if defined('SLICOT')
subroutine dlyap(TT, RQR, P0, ns, info)
! Computes the solution to the discrete Lyapunov equation,
! P0 = TT*P0*TT' + RQR
! where (inputs) TT, RQR and (output) P0 are ns x ns (real) matrices.
!--------------------------------------------------------------------------------
integer, intent(in) :: ns
real(wp), intent(in) :: TT(ns,ns), RQR(ns,ns)
integer, intent(out) :: info
real(wp), intent(out) :: P0(ns,ns)
! for slicot
real(wp) :: scale, U(ns,ns), UH(ns, ns), rcond, ferr, wr(ns), wi(ns), dwork(14*ns*ns*ns), sepd
integer :: iwork(ns*ns), ldwork
integer :: t
UH = TT
P0 = -1.0_wp*RQR
!call sb03md('D','X', 'N', 'T', ns, UH, ns, U, ns, P0, ns, &
! scale, sepd, ferr, wr, wi, iwork, dwork, 14*ns*ns*ns, info)
!if (ferr > 0.000001_wp) call dlyap_symm(TT, RQR, P0, ns, info)
if (info .ne. 0) then
print*,'SB03MD failed. (info = ', info, ')'
P0 = 0.0_wp
info = 1
do t = 1,ns
P0(t,t)=1.0_wp
end do
return
else
! P0 = 0.5_wp*P0 + 0.5_wp*transpose(P0)
info = 0
end if
end subroutine dlyap
#:else
! from elmar
SUBROUTINE DLYAP(A, QQ, Sigma, nx, status)
! doubling, calling DSYMM and DGEMM
! Sigma = A * Sigma * A' + B * B'
! output Sigma is symmetric
IMPLICIT NONE
integer, intent(in) :: nx
integer, intent(out) :: status
real(wp), intent(in) :: QQ(nx,nx), A(nx,nx)
real(wp), intent(out) :: Sigma(nx,nx)
INTEGER, PARAMETER :: maxiter = 100
DOUBLE PRECISION, PARAMETER :: tol = 1.0d-8
INTEGER :: iter, i
LOGICAL :: converged
DOUBLE PRECISION, DIMENSION(Nx,Nx) :: AA, AAA, AASigma, Sigma0
Sigma0 = QQ
! Sigma0 = B B'
! Sigma0 = 0.0d0
! call DSYRK('U','N',Nx,Nw,1.0d0,B,Nx,0.0d0,Sigma0,Nx)
! ! fill up lower triangular -- necessary for DGEMM below
! FORALL (i=2:Nx) Sigma0(i,1:i-1) = Sigma0(1:i-1,i)
converged = .false.
iter = 0
AA = A
DO
iter = iter + 1
! call sandwichplus(Sigma, AA, Nx, Sigma0, Nx)
! MANUAL SANDWICHPLUS: Sigma = AA * Sigma0 * AA' + Sigma
call DSYMM('R','U',Nx,Nx,1.0d0,Sigma0,Nx,AA,Nx,0.0d0,AASigma,Nx)
Sigma = Sigma0 ! this line requires Sigma0 to
call DGEMM('N','T',Nx,Nx,Nx,1.0d0,AASigma,Nx,AA,Nx,1.0d0,Sigma,Nx)
! balance for symmetry
Sigma = 0.5d0 * (Sigma + transpose(Sigma))
IF (abs(maxval(Sigma - Sigma0)) < tol) converged = .true.
! print *, iter, abs(maxval(Sigma - Sigma0)), tol
! Sigma = (Sigma + transpose(Sigma)) / dble(2)
IF (converged .OR. (iter > maxiter)) EXIT
! AAA = AA * AA
call DGEMM('N','N',Nx,Nx,Nx,1.0d0,AA,Nx,AA,Nx,0.0d0,AAA,Nx)
AA = AAA
Sigma0 = Sigma
END DO
IF (converged) THEN
status = 0
ELSE
status = -1
END IF
END SUBROUTINE DLYAP
#:endif
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
I'm trying to assign a polymorphic allocatable array ary which can take 2 extended types of baseType (extType1 and its extension extType2):
module mo
!$ use OMP_LIB
implicit none
type baseType
end type baseType
type, extends(baseType) :: extType1
real :: r1
end type extType1
type, extends(extType1) :: extType2
real :: r2
end type extType2
type arrayWrapper
class(extType1), allocatable :: w
end type arrayWrapper
contains
subroutine wrapExtType1(aExt1, a)!-----------------------------------------------------
type(extType1 ), dimension(:) , allocatable, intent(in ) :: aExt1 !
type(arrayWrapper), dimension(:) , allocatable, intent( out) :: a !
integer :: n, i !
!
n = size(aExt1) !
if (allocated(a)) deallocate(a); allocate(a(n)) !
do i = 1, n, 1; allocate(a(i)%w, source=aExt1(i)); end do !
end subroutine wrapExtType1!-----------------------------------------------------------
subroutine wrapExtType2(aExt2, a)!-----------------------------------------------------
type(extType2 ), dimension(:) , allocatable, intent(in ) :: aExt2 !
type(arrayWrapper), dimension(:) , allocatable, intent( out) :: a !
integer :: n, i !
!
n = size(aExt2) !
if (allocated(a)) deallocate(a); allocate(a(n)) !
do i = 1, n, 1; allocate(a(i)%w, source=aExt2(i)); end do !
end subroutine wrapExtType2!-----------------------------------------------------------
!-SEQUENTIAL VERSION :
subroutine aryPrintTypes(a)!-----------------------------------------------------------
type(arrayWrapper) , dimension(:), allocatable, intent(in ) :: a !
integer :: n, i !
!
n = size(a) !
do i = 1, n, 1; select type (this=>a(i)%w) !
type is (extType1) !
write(*,*) "Thread #", OMP_GET_THREAD_NUM(), "i =", i, & !
"type is extType1, r1 =", this%r1 !
type is (extType2) !
write(*,*) "Thread #", OMP_GET_THREAD_NUM(), "i =", i, & !
"type is extType2, r2 =", this%r2 !
end select; end do !
end subroutine aryPrintTypes!----------------------------------------------------------
end module mo
!=====================================MAIN_PROGRAM=====================================!
program PolyArray
!$ use OMP_LIB
use mo
implicit none
type(arrayWrapper), dimension(:), allocatable :: ary
type(extType1 ), dimension(:), allocatable :: aryExt1
type(extType2 ), dimension(:), allocatable :: aryExt2
integer :: n, i
n = 8
allocate (aryExt1(n))
allocate (aryExt2(n))
do i=1,n,1
aryExt1(i)%r1 = 1.*i
aryExt2(i)%r2 = 2.*i
end do
call wrapExtType1(aryExt1, ary)
call aryPrintTypes(ary)
write(*,*) " "
call wrapExtType2(aryExt2, ary)
call aryPrintTypes(ary)
end program PolyArray
To parallelize the aryPrintTypes subroutine, at first, I reckoned there would be a problem with the select type construct since the associated name this is created AFTER entering the !$OMP PARALLEL DO loop. Therefore I wrote the first parallelized version as follows :
!-FIRST PARALLELIZED VERSION :
subroutine aryPrintTypes(a)!-----------------------------------------------------------
type(arrayWrapper) , dimension(:), allocatable, intent(in ) :: a !
class(extType1 ) , pointer :: this !
integer :: n, i !
!
n = size(a) !
!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(SHARED) PRIVATE(i, this) !
do i = 1, n, 1; select type (this=>a(i)%w) !
type is (extType1) !
write(*,*) "Thread #", OMP_GET_THREAD_NUM(), "i =", i, & !
"type is extType1, r1 =", this%r1 !
type is (extType2) !
write(*,*) "Thread #", OMP_GET_THREAD_NUM(), "i =", i, & !
"type is extType2, r2 =", this%r2 !
end select; end do !
!$OMP END PARALLEL DO !
end subroutine aryPrintTypes!----------------------------------------------------------
The above code works fine as I expected. The output is the following using 8 threads:
Thread # 0 i = 1 type is extType1, r1 = 1.0000000000000000
Thread # 2 i = 3 type is extType1, r1 = 3.0000000000000000
Thread # 6 i = 7 type is extType1, r1 = 7.0000000000000000
Thread # 5 i = 6 type is extType1, r1 = 6.0000000000000000
Thread # 4 i = 5 type is extType1, r1 = 5.0000000000000000
Thread # 7 i = 8 type is extType1, r1 = 8.0000000000000000
Thread # 3 i = 4 type is extType1, r1 = 4.0000000000000000
Thread # 1 i = 2 type is extType1, r1 = 2.0000000000000000
Thread # 6 i = 7 type is extType2, r2 = 14.000000000000000
Thread # 2 i = 3 type is extType2, r2 = 6.0000000000000000
Thread # 0 i = 1 type is extType2, r2 = 2.0000000000000000
Thread # 5 i = 6 type is extType2, r2 = 12.000000000000000
Thread # 7 i = 8 type is extType2, r2 = 16.000000000000000
Thread # 1 i = 2 type is extType2, r2 = 4.0000000000000000
Thread # 3 i = 4 type is extType2, r2 = 8.0000000000000000
Thread # 4 i = 5 type is extType2, r2 = 10.000000000000000
However, I later tried a second parallelized version WITHOUT declaring this as a POINTER and, surprisingly, IT ALSO WORKS and gives the same result as the first version :
!-SECOND PARALLELIZED VERSION :
subroutine aryPrintTypes(a)!-----------------------------------------------------------
type(arrayWrapper) , dimension(:), allocatable, intent(in ) :: a !
integer :: n, i !
!
n = size(a) !
!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(PRIVATE) SHARED(a, n) !
do i = 1, n, 1; select type (this=>a(i)%w) !
type is (extType1) !
write(*,*) "Thread #", OMP_GET_THREAD_NUM(), "i =", i, & !
"type is extType1, r1 =", this%r1 !
type is (extType2) !
write(*,*) "Thread #", OMP_GET_THREAD_NUM(), "i =", i, & !
"type is extType2, r2 =", this%r2 !
end select; end do !
!$OMP END PARALLEL DO !
end subroutine aryPrintTypes!----------------------------------------------------------
I implemented both versions in a large in-house computation code, the first version works fine as always, but with the second version the type of the associated name this is NOT RECOGNIZED by the select type construct within the DO loop.
Compiler info:
GNU Fortran (Ubuntu 7.5.0-3ubuntu1~18.04) 7.5.0
Copyright (C) 2017 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.
EDIT :
One comment suggested that the this in select type construct has nothing to do with the this declared as POINTER in the FIRST parallelized version. Therefore I removed the POINTER declaration in the first version and it gives the same result :
!-FIRST PARALLELIZED VERSION **(EDITED)**:
subroutine aryPrintTypes(a)!-----------------------------------------------------------
type(arrayWrapper) , dimension(:), allocatable, intent(in ) :: a !
integer :: n, i !
!
n = size(a) !
!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(SHARED) PRIVATE(i) !
do i = 1, n, 1; select type (this=>a(i)%w) !
type is (extType1) !
write(*,*) "Thread #", OMP_GET_THREAD_NUM(), "i =", i, & !
"type is extType1, r1 =", this%r1 !
type is (extType2) !
write(*,*) "Thread #", OMP_GET_THREAD_NUM(), "i =", i, & !
"type is extType2, r2 =", this%r2 !
end select; end do !
!$OMP END PARALLEL DO !
end subroutine aryPrintTypes!----------------------------------------------------------
So the new question is raised : Is the associated name this in select type construct automatically privatized by OpenMP without the need to be declared as PRIVATE ?
It does not need to (and can not) be declared PRIVATE. The associate name is just a synonym for the thing nominated by the selector when the SELECT TYPE (or ASSOCIATE) statement was executed.
The OpenMP 5.0 specification states in s2.19.1.1:
An associate name preserves the association with the selector established at
the ASSOCIATE or SELECT TYPE statement.
The association between the associate name and the selector is specific to each thread.
Whether the thing associated with the name is private or shared depends on the data sharing attributes of the selector.
In the example code, the base object a of the selector is shared, but subsequent indexing ensures that different threads do not access the same element of that shared a.
I'm trying to solve a simple tridiagonal system of equations using LAPACK library. The code below explains it all.
I'm getting an array full of zeros (initialized ones), not the correct answer.
I checked the inputs, tried to compile with two compilers and everything seems fine. What is wrong?
The compilation line is:
ifort -L/usr/local/lib/ -llapack -lblas tLapack.f90 -o tlapack
gfortran -L/usr/local/lib/ -llapack -lblas tLapack.f90 -o tlapack
the code is:
program lapackT
implicit none
! dgtsv( integer(4) :: N,
! integer(4) :: NRHS,
! real(8) :: DL[],
! real(8) :: D [],
! real(8) :: DU[],
! real(8) :: B [],
! integer(4) :: LDB ,
! integer(4) :: info )
! [A][x] = [b]
! N - The order of matrix [A]
! NRHS - Number of coluns in [b]
! DL - Array with the subdiag.
! D - Main diagonal.
! DU - Upper Diagonal.
! B - Answer !!
! LDB - length of array [B].
! INFO - If = 0 .. Uhul !!.
real(8), dimension(3) :: mainDiag
real(8), dimension(2) :: lowerDiag
real(8), dimension(2) :: upperDiag
real(8), dimension(3) :: unknow
real(8), dimension(3) :: equalty
integer(4) :: info = 0
integer(4) :: i = 0
integer(4) :: N = 3
integer(4) :: NRHS = 1
integer(4) :: LDB = 3
mainDiag(1) = 2.0d0
mainDiag(2) = 2.0d0
mainDiag(3) = 2.0d0
upperDiag(1) = 3.0d0
upperDiag(2) = 3.0d0
lowerDiag(1) = 1.0d0
lowerDiag(2) = 1.0d0
equalty(1) = 1.0d0
equalty(2) = 1.0d0
equalty(3) = 1.0d0
unknow = 0.0d0 ! answer
call dgtsv(N,NRHS,lowerDiag,mainDiag,upperDiag,equalty,LDB,info)
write(*,*) info
do i = 1,size(unknow)
write(*,*) unknow(i)
end do
! Correct answer: unknow = (/-1,1,0/) ! real(8) values
! Answer Im getting: unknow = (/0,0,0/) ! real(8) values
end program lapackT
If you look at the documentation you'll see the answer is returned in your equalty argument (i.e. it overwrites the RHS) - as unknow is not passed how can it be affected by the call? And I agree, I'm bot convinced this is the greatest design ever ...
While I'm here please learn about kinds, some of what you are doing is so quarter of a century ago. Please look at Fortran 90 kind parameter . Anyway here's how I would write your program (which some would say it also slightly out of date nowadays), and the answer it gives:
ian-admin#agon ~/test/stack $ cat dt.f90
program lapackT
implicit none
Integer, Parameter :: wp = Selected_real_kind( 13, 70 )
real(wp), dimension(3) :: mainDiag
real(wp), dimension(2) :: lowerDiag
real(wp), dimension(2) :: upperDiag
real(wp), dimension(3) :: unknow
real(wp), dimension(3) :: equalty
integer :: info = 0
integer :: i = 0
integer :: N = 3
integer :: NRHS = 1
integer :: LDB = 3
mainDiag(1) = 2.0_wp
mainDiag(2) = 2.0_wp
mainDiag(3) = 2.0_wp
upperDiag(1) = 3.0_wp
upperDiag(2) = 3.0_wp
lowerDiag(1) = 1.0_wp
lowerDiag(2) = 1.0_wp
equalty(1) = 1.0_wp
equalty(2) = 1.0_wp
equalty(3) = 1.0_wp
unknow = 0.0_wp ! answer
call dgtsv(N,NRHS,lowerDiag,mainDiag,upperDiag,equalty,LDB,info)
write(*,*) info
do i = 1,size(unknow)
write(*,*) equalty(i)
end do
! Correct answer: unknow = (/-1,1,0/) ! real(8) values
! Answer Im getting: unknow = (/0,0,0/) ! real(8) values
end program lapackT
ian-admin#agon ~/test/stack $ gfortran -Wall -Wextra -fcheck=all -O -std=f95 dt.f90 -llapack
ian-admin#agon ~/test/stack $ ./a.out
0
-1.0000000000000000
1.0000000000000000
0.0000000000000000E+000
ian-admin#agon ~/test/stack $
Unless dgtsv operates through side-effects, this sequence of statements (your code, without empty lines):
unknow = 0.0d0 ! answer
call dgtsv(N,NRHS,lowerDiag,mainDiag,upperDiag,equalty,LDB,info)
write(*,*) info
do i = 1,size(unknow)
write(*,*) unknow(i)
end do
does not update unknow. How could it not be all 0.0s ?
Isn't the result returned through equalty in your call to dgtsv ?
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