Р. Г. Стронгина. Ниж- ний Новгород: Изд-во Нижегородского университета, 2002, 217 с

Appendix A Recursive Cholesky Factorization Subroutine

жүктеу/скачать 1,64 Mb.

Pdf көрінісі

бет	133/151
Дата	26.01.2022
өлшемі	1,64 Mb.
	#24342
түрі	Семинар

1 ... 129 130 131 132 133 134 135 136 ... 151

Байланысты:
Seminar 1

Appendix A
Recursive Cholesky Factorization Subroutine
RECURSIVE SUBROUTINE RPOTRF( A, UPLO, INFO )
USE LA_PRECISION, ONLY: WP => DP
USE LA_AUXMOD. ONLY: ERINFO, LSAME
USE F90_RCF, ONLY: RCF => RPOTRF, RTRSM, RSYRK
IMPLICIT NONE
CHARACTER(LEN=1), OPTIONAL, INTENT(IN) :: UPLO
INTEGER, OPTIONAL, INTENT(OUT) :: INFO
REAL(WP), INTENT(INOUT) :: A(:,:)
CHARACTER(LEN=*), PARAMETER :: SRNAME = 'RPOTRF'
REAL(WP), PARAMETER :: ONE = l.0_WP
CHARACTER(LEN=1) :: LUPLO; INTEGER :: N, P, LINFO
INTEGER, SAVE :: IC = 0, NMAX = 0
N = SIZE(A,1); LINFO = 0; IF( NMAX == 0 )NMAX = N
IF( PRESENT(UPLO) )THEN; LUPLO = UPLO
ELSE; LUPLO = 'U'; ENDIF
IF( N < 0 .OR. N / = SIZE(A,2) )THEN; LINFO = -1
ELSE IF( .NOT. (LSAME(LUPLO,'U').OR.LSAME(LUPLO,'L')) )THEN LINFO = -2
ELSE IF (N = = 1) THEN: IC = IC + 1
IF( A(l,l) > 0.0_WP )THEN: A(1,1) = SQRT(A(1,1))
ELSE; LINFO = 1C: ENDIF
ELSE IF( N > 0 )THEN; P=N/2
IF( LSAME(LUPLO,'L') )THEN
CALL RCF( A(1:P,1:P), LUPLO, LINFO )
IF( LINFO == 0 )THEN
CALL RTRSM( A(1:P,1:P), A(P+1:N,1:P), UPLO=LUPLO, &

188
SIDE='R', TRANSA='T' )
CALL RSYRK( A(P+1:N,1:P), A(P+1:N,P+1:N), ALPHA=-ONE, &
UPLOC=LUPLO )
IF( LINFO == 0 )CALL RCF( A(P+1:N,P+1:N), LUPLO, LINFO )
ENDIF
ELSE
CALL RCF( A(1:P,1:P), LUPLO, LINFO )
IF( LINFO == 0 )THEN
CALL RTRSM( A(1:P,1:P), A(1:P,P+1:N), TRANSA='T' )
CALL RSYRK( A(1:P,P+1:N), A(P+1:N,P+1:N), ALPHA=-ONE, &
TRANSA='T'
IF( LINFO == 0 ) CALL RCF( A(P+1:N,P+1:N), LUPLO, LINFO)
ENDIF
ENDIF
ENDIF
IF( NMAX == N )THEN: NMAX = 0; IC - 0; ENDIF
CALL ERINFO( LINFO, SRNAME, INFO )
END SUBROUTINE RPOTRF

жүктеу/скачать 1,64 Mb.

Достарыңызбен бөлісу:

1 ... 129 130 131 132 133 134 135 136 ... 151