1 SUBROUTINE SGELSS1_F95( A, B, RANK, S, RCOND, INFO ) 2! 3! -- LAPACK95 interface driver routine (version 3.0) -- 4! UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK 5! September, 2000 6! 7! .. USE STATEMENTS .. 8 USE LA_PRECISION, ONLY: WP => SP 9 USE LA_AUXMOD, ONLY: ERINFO, LA_WS_GELSS 10 USE F77_LAPACK, ONLY: GELSS_F77 => LA_GELSS 11! .. IMPLICIT STATEMENT .. 12 IMPLICIT NONE 13! .. SCALAR ARGUMENTS .. 14 INTEGER, INTENT(OUT), OPTIONAL :: RANK 15 INTEGER, INTENT(OUT), OPTIONAL :: INFO 16 REAL(WP), INTENT(IN), OPTIONAL :: RCOND 17! .. ARRAY ARGUMENTS .. 18 REAL(WP), INTENT(INOUT) :: A(:,:), B(:) 19 REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: S(:) 20! .. PARAMETERS .. 21 CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_GELSS' 22 CHARACTER(LEN=1), PARAMETER :: VER = 'S' 23! .. LOCAL SCALARS .. 24 INTEGER :: LINFO, ISTAT, ISTAT1, LWORK, N, M, MN, NRHS, LRANK, SS 25 REAL(WP) :: LRCOND 26! .. LOCAL POINTERS .. 27 REAL(WP), POINTER :: WORK(:), LS(:) 28! .. INTRINSIC FUNCTIONS .. 29 INTRINSIC SIZE, PRESENT, MAX, MIN, EPSILON 30! .. EXECUTABLE STATEMENTS .. 31 LINFO = 0; ISTAT = 0; M = SIZE(A,1); N = SIZE(A,2); NRHS = 1; MN = MIN(M,N) 32 IF( PRESENT(RCOND) )THEN; LRCOND = RCOND; ELSE 33 LRCOND = 100*EPSILON(1.0_WP) ; ENDIF 34 IF( PRESENT(S) )THEN; SS = SIZE(S); ELSE; SS =MN; ENDIF 35! .. TEST THE ARGUMENTS 36 IF( M < 0 .OR. N < 0 ) THEN; LINFO = -1 37 ELSE IF( SIZE( B ) /= MAX(1,M,N) ) THEN; LINFO = -2 38 ELSE IF( SS /= MN ) THEN; LINFO = -4 39 ELSE IF( LRCOND <= 0.0_WP ) THEN; LINFO = -5 40 ELSE 41 IF( PRESENT(S) )THEN; LS => S 42 ELSE; ALLOCATE( LS(MN), STAT = ISTAT ); END IF 43 IF( ISTAT == 0 ) THEN 44 LWORK = LA_WS_GELSS( VER, M, N, NRHS ) 45 ALLOCATE( WORK(LWORK), STAT = ISTAT ) 46 IF( ISTAT /= 0 ) THEN 47 DEALLOCATE( WORK, STAT=ISTAT1 ) 48 LWORK = MAX( 1, 3*MIN(M,N) + MAX( 2*MIN(M,N), MAX(M,N), NRHS ) ) 49 ALLOCATE( WORK(LWORK), STAT = ISTAT ) 50 IF( ISTAT /= 0 ) CALL ERINFO( -200, SRNAME, LINFO ) 51 END IF 52 END IF 53 IF ( ISTAT == 0 ) THEN 54! .. CALL LAPACK77 ROUTINE 55 CALL GELSS_F77( M, N, NRHS, A, MAX(1,M), B, MAX(1,M,N), & 56 LS, LRCOND, LRANK, WORK, LWORK, LINFO ) 57 ELSE; LINFO = -100; END IF 58 IF( PRESENT(RANK) ) RANK = LRANK 59 DEALLOCATE(WORK, STAT = ISTAT1 ) 60 END IF 61 CALL ERINFO( LINFO, SRNAME, INFO, ISTAT ) 62 END SUBROUTINE SGELSS1_F95 63