Skip to content

Commit

Permalink
Avoid 0**0 #890, follow up to #892 (#907)
Browse files Browse the repository at this point in the history 
* Avoid 0**0 #890, follow up to #892

* Correct paranthesis
  • Loading branch information
@juerghutter
juerghutter committed May 8, 2020
1 parent e214989 commit 36d56ed
Showing 1 changed file with 63 additions and 21 deletions.
84 changes: 63 additions & 21 deletions src/xas_tdp_atom.F
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1476,20 +1476,34 @@ SUBROUTINE put_density_on_other_grid(rho_set, ri_dcoeff, source_iat, source_ikin
!$OMP DO COLLAPSE(2) SCHEDULE(STATIC)
DO ir = sr, er
DO ia = 1, na
dco(ia, ir, 1, start + ico) = -2.0_dp*pos(ia, ir, 1)*zet(ipgf, iset) &
*pos(ia, ir, 2)**ly*pos(ia, ir, 3)**lz &
*EXP(-zet(ipgf, iset)*pos(ia, ir, 4))
rmom = -2.0_dp*pos(ia, ir, 1)*zet(ipgf, iset)*EXP(-zet(ipgf, iset)*pos(ia, ir, 4))
IF (ly /= 0) rmom = rmom*pos(ia, ir, 2)**ly
IF (lz /= 0) rmom = rmom*pos(ia, ir, 3)**lz
dco(ia, ir, 1, start + ico) = rmom
! dco(ia, ir, 1, start + ico) = -2.0_dp*pos(ia, ir, 1)*zet(ipgf, iset) &
! *pos(ia, ir, 2)**ly*pos(ia, ir, 3)**lz &
! *EXP(-zet(ipgf, iset)*pos(ia, ir, 4))
END DO
END DO
!$OMP END DO NOWAIT
ELSE
!$OMP DO COLLAPSE(2) SCHEDULE(STATIC)
DO ir = sr, er
DO ia = 1, na
dco(ia, ir, 1, start + ico) = (lx*pos(ia, ir, 1)**(lx - 1) &
- 2.0_dp*pos(ia, ir, 1)**(lx + 1)*zet(ipgf, iset)) &
*pos(ia, ir, 2)**ly*pos(ia, ir, 3)**lz &
*EXP(-zet(ipgf, iset)*pos(ia, ir, 4))
IF (lx /= 1) THEN
rmom = (lx*pos(ia, ir, 1)**(lx - 1) - 2.0_dp*pos(ia, ir, 1)**(lx + 1)* &
zet(ipgf, iset))*EXP(-zet(ipgf, iset)*pos(ia, ir, 4))
ELSE
rmom = (1.0_dp - 2.0_dp*pos(ia, ir, 1)**2*zet(ipgf, iset))* &
EXP(-zet(ipgf, iset)*pos(ia, ir, 4))
END IF
IF (ly /= 0) rmom = rmom*pos(ia, ir, 2)**ly
IF (lz /= 0) rmom = rmom*pos(ia, ir, 3)**lz
dco(ia, ir, 1, start + ico) = rmom
! dco(ia, ir, 1, start + ico) = (lx*pos(ia, ir, 1)**(lx - 1) &
! - 2.0_dp*pos(ia, ir, 1)**(lx + 1)*zet(ipgf, iset)) &
! *pos(ia, ir, 2)**ly*pos(ia, ir, 3)**lz &
! *EXP(-zet(ipgf, iset)*pos(ia, ir, 4))
END DO
END DO
!$OMP END DO NOWAIT
Expand All @@ -1500,20 +1514,34 @@ SUBROUTINE put_density_on_other_grid(rho_set, ri_dcoeff, source_iat, source_ikin
!$OMP DO COLLAPSE(2) SCHEDULE(STATIC)
DO ir = sr, er
DO ia = 1, na
dco(ia, ir, 2, start + ico) = -2.0_dp*pos(ia, ir, 2)*zet(ipgf, iset) &
*pos(ia, ir, 1)**lx*pos(ia, ir, 3)**lz &
*EXP(-zet(ipgf, iset)*pos(ia, ir, 4))
rmom = -2.0_dp*pos(ia, ir, 2)*zet(ipgf, iset)*EXP(-zet(ipgf, iset)*pos(ia, ir, 4))
IF (lx /= 0) rmom = rmom*pos(ia, ir, 1)**lx
IF (lz /= 0) rmom = rmom*pos(ia, ir, 3)**lz
dco(ia, ir, 2, start + ico) = rmom
! dco(ia, ir, 2, start + ico) = -2.0_dp*pos(ia, ir, 2)*zet(ipgf, iset) &
! *pos(ia, ir, 1)**lx*pos(ia, ir, 3)**lz &
! *EXP(-zet(ipgf, iset)*pos(ia, ir, 4))
END DO
END DO
!$OMP END DO NOWAIT
ELSE
!$OMP DO COLLAPSE(2) SCHEDULE(STATIC)
DO ir = sr, er
DO ia = 1, na
dco(ia, ir, 2, start + ico) = (ly*pos(ia, ir, 2)**(ly - 1) &
- 2.0_dp*pos(ia, ir, 2)**(ly + 1)*zet(ipgf, iset)) &
*pos(ia, ir, 1)**lx*pos(ia, ir, 3)**lz &
*EXP(-zet(ipgf, iset)*pos(ia, ir, 4))
IF (ly /= 1) THEN
rmom = (ly*pos(ia, ir, 2)**(ly - 1) - 2.0_dp*pos(ia, ir, 2)**(ly + 1)*zet(ipgf, iset)) &
*EXP(-zet(ipgf, iset)*pos(ia, ir, 4))
ELSE
rmom = (1.0_dp - 2.0_dp*pos(ia, ir, 2)**2*zet(ipgf, iset)) &
*EXP(-zet(ipgf, iset)*pos(ia, ir, 4))
END IF
IF (lx /= 0) rmom = rmom*pos(ia, ir, 1)**lx
IF (lz /= 0) rmom = rmom*pos(ia, ir, 3)**lz
dco(ia, ir, 2, start + ico) = rmom
! dco(ia, ir, 2, start + ico) = (ly*pos(ia, ir, 2)**(ly - 1) &
! - 2.0_dp*pos(ia, ir, 2)**(ly + 1)*zet(ipgf, iset)) &
! *pos(ia, ir, 1)**lx*pos(ia, ir, 3)**lz &
! *EXP(-zet(ipgf, iset)*pos(ia, ir, 4))
END DO
END DO
!$OMP END DO NOWAIT
Expand All @@ -1524,20 +1552,34 @@ SUBROUTINE put_density_on_other_grid(rho_set, ri_dcoeff, source_iat, source_ikin
!$OMP DO COLLAPSE(2) SCHEDULE(STATIC)
DO ir = sr, er
DO ia = 1, na
dco(ia, ir, 3, start + ico) = -2.0_dp*pos(ia, ir, 3)*zet(ipgf, iset) &
*pos(ia, ir, 1)**lx*pos(ia, ir, 2)**ly &
*EXP(-zet(ipgf, iset)*pos(ia, ir, 4))
rmom = -2.0_dp*pos(ia, ir, 3)*zet(ipgf, iset)*EXP(-zet(ipgf, iset)*pos(ia, ir, 4))
IF (lx /= 0) rmom = rmom*pos(ia, ir, 1)**lx
IF (ly /= 0) rmom = rmom*pos(ia, ir, 2)**ly
dco(ia, ir, 3, start + ico) = rmom
! dco(ia, ir, 3, start + ico) = -2.0_dp*pos(ia, ir, 3)*zet(ipgf, iset) &
! *pos(ia, ir, 1)**lx*pos(ia, ir, 2)**ly &
! *EXP(-zet(ipgf, iset)*pos(ia, ir, 4))
END DO
END DO
!$OMP END DO NOWAIT
ELSE
!$OMP DO COLLAPSE(2) SCHEDULE(STATIC)
DO ir = sr, er
DO ia = 1, na
dco(ia, ir, 3, start + ico) = (lz*pos(ia, ir, 3)**(lz - 1) &
- 2.0_dp*pos(ia, ir, 3)**(lz + 1)*zet(ipgf, iset)) &
*pos(ia, ir, 1)**lx*pos(ia, ir, 2)**ly &
*EXP(-zet(ipgf, iset)*pos(ia, ir, 4))
IF (lz /= 1) THEN
rmom = (lz*pos(ia, ir, 3)**(lz - 1) - 2.0_dp*pos(ia, ir, 3)**(lz + 1)* &
zet(ipgf, iset))*EXP(-zet(ipgf, iset)*pos(ia, ir, 4))
ELSE
rmom = (1.0_dp - 2.0_dp*pos(ia, ir, 3)**2*zet(ipgf, iset))* &
EXP(-zet(ipgf, iset)*pos(ia, ir, 4))
END IF
IF (lx /= 0) rmom = rmom*pos(ia, ir, 1)**lx
IF (ly /= 0) rmom = rmom*pos(ia, ir, 2)**ly
dco(ia, ir, 3, start + ico) = rmom
! dco(ia, ir, 3, start + ico) = (lz*pos(ia, ir, 3)**(lz - 1) &
! - 2.0_dp*pos(ia, ir, 3)**(lz + 1)*zet(ipgf, iset)) &
! *pos(ia, ir, 1)**lx*pos(ia, ir, 2)**ly &
! *EXP(-zet(ipgf, iset)*pos(ia, ir, 4))
END DO
END DO
!$OMP END DO NOWAIT
Expand Down

0 comments on commit 36d56ed

Please sign in to comment.