Lowdin Orthoganalize for any non-singular R, let S=R RT P = S^(-1/2) R is orthogonal. MAT is NxN and is returned as an orthogal matrix R1 and R2 are NxN workspaces
| Type | Intent | Optional | Attributes | Name | ||
|---|---|---|---|---|---|---|
| real(kind=dp) | :: | MAT(N,N) | ||||
| integer | :: | N | ||||
| real(kind=dp) | :: | R1(N,N) | ||||
| real(kind=dp) | :: | R2(N,N) | ||||
| real(kind=dp) | :: | WORK(3*N) |
SUBROUTINE LOWDIN_ORTH(MAT, N, R1, R2, WORK) !! Lowdin Orthoganalize !! for any non-singular R, let S=R RT !! P = S^(-1/2) R is orthogonal. !! MAT is NxN and is returned as an orthogal matrix !! R1 and R2 are NxN workspaces INTEGER N HElement_t(dp) MAT(N, N), R1(N, N), R2(N, N) HElement_t(dp) WORK(3 * N) real(dp) L(N), LL, RWORK(3 * N) INTEGER I, J integer(sp) info character(*), parameter :: this_routine = 'LOWDIN_ORTH' !R=MAT !S= R1=1.0_dp * R * RT + 0.0_dp*R1 IF (HElement_t_size == 1) THEN CALL DGEMM('N', 'T', N, N, N, 1.0_dp, MAT, N, MAT, N, 0.0_dp, R1, N) ELSE CALL ZGEMM('N', 'C', N, N, N,(1.0_dp, 0.0_dp), MAT, N, MAT, N,(0.0_dp, 0.0_dp), R1, N) end if ! CALL Write_HEMatrix("R",N,N,R1) ! Diagonalize S=R1 into eigenvectors U=R1 and eigenvalues L IF (HElement_t_size == 1) THEN CALL DSYEV('V', 'U', N, R1, N, L, WORK, N * 3, INFO) ELSE CALL ZHEEV('V', 'U', N, R1, N, L, WORK, N * 3, RWORK, INFO) end if ! eigenvector 1 is given by R1(I,1) IF (INFO /= 0) THEN write(stdout, *) "INFO=", INFO, " on diag in LOWDIN_ORTH. Stopping" call stop_all(this_routine, 'Error in LOWDIN_ORTH.') end if ! Calculate P = S^(-1/2) R = U L^(-1/2) UT R. U=R1 ! First let R2=U R. U=R1. R=MAT ! R2=1.0_dp * R1 * MAT + 0.0_dp*R1 IF (HElement_t_size == 1) THEN CALL DGEMM('T', 'N', N, N, N, 1.0_dp, R1, N, MAT, N, 0.0_dp, R2, N) ELSE CALL ZGEMM('C', 'N', N, N, N,(1.0_dp, 0.0_dp), R1, N, MAT, N,(0.0_dp, 0.0_dp), R2, N) end if ! Now let R2=L^(-1/2) (U R) = L^(-1/2) R2 ! row I is multiplied by (L(I))^(-1/2) DO I = 1, N LL = L(I)**(-0.5_dp) DO J = 1, N R2(I, J) = R2(I, J) * (LL) end do end do ! Now let MAT = P = U (L^(-1/2) UT R) = U R2. U=R1 ! MAT=1.0_dp * U * R2 + 0.0_dp*MAT IF (HElement_t_size == 1) THEN CALL DGEMM('N', 'N', N, N, N, 1.0_dp, R1, N, R2, N, 0.0_dp, MAT, N) ELSE CALL ZGEMM('N', 'N', N, N, N,(1.0_dp, 0.0_dp), R1, N, R2, N,(0.0_dp, 0.0_dp), MAT, N) end if ! and we should be done, with an orthoganal matrix in MAT END SUBROUTINE LOWDIN_ORTH