#! /bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh 'README' <<'END_OF_FILE' X *************************************************************************** X * All the software contained in this library is protected by copyright. * X * Permission to use, copy, modify, and distribute this software for any * X * purpose without fee is hereby granted, provided that this entire notice * X * is included in all copies of any software which is or includes a copy * X * or modification of this software and in all copies of the supporting * X * documentation for such software. * X *************************************************************************** X * THIS SOFTWARE IS BEING PROVIDED "AS IS", WITHOUT ANY EXPRESS OR IMPLIED * X * WARRANTY. IN NO EVENT, NEITHER THE AUTHORS, NOR THE PUBLISHER, NOR ANY * X * MEMBER OF THE EDITORIAL BOARD OF THE JOURNAL "NUMERICAL ALGORITHMS", * X * NOR ITS EDITOR-IN-CHIEF, BE LIABLE FOR ANY ERROR IN THE SOFTWARE, ANY * X * MISUSE OF IT OR ANY DAMAGE ARISING OUT OF ITS USE. THE ENTIRE RISK OF * X * USING THE SOFTWARE LIES WITH THE PARTY DOING SO. * X *************************************************************************** X * ANY USE OF THE SOFTWARE CONSTITUTES ACCEPTANCE OF THE TERMS OF THE * X * ABOVE STATEMENT. * X *************************************************************************** X X AUTHOR: X X DARIO ANDREA BINI AND BEATRICE MEINI X UNIVERSITY OF PISA, ITALY X E-MAIL: bini@dm.unipi.it meini@dm.unipi.it X X REFERENCE: X X - IMPROVED CYCLIC REDUCTION FOR SOLVING QUEUING PROBLEMS X NUMERICAL ALGORITHMS, 15 (1997), PP. 57-74 X X SOFTWARE REVISION DATE: X X JANUARY 30, 1997 X X SOFTWARE LANGUAGE: X X FORTRAN 90 X X!=========================================================================! X! file README ! X!=========================================================================! X! IMPROVED CYCLIC REDUCTION FOR SOLVING QUEUEING PROBLEMS ! X! by D.A. Bini and B. Meini ! X! (bini@dm.unipi.it meini@dm.unipi.it) ! X! Fortran 90 Program version 1.0, January 30 1997 ! X! README FILE ! X!=========================================================================! X XThis package contains Fortran 90 programs for the numerical solution Xof the matrix equation: X X A_1+X A_2+X^2 A_3+....X^(m-1) A_m-X=O (1) X Xwhere X is the (nb x nb) unknown matrix and the (nb x nb) nonnegative Xmatrices A_i, i=1,2,..., are such that A_1+A_2+...+A_m is column Xstochastic. X X X XThe package contains the following files: X XREADME : this file Xpwcr_drv.f90 : driver program Xpwcr_sub.f90 : main subroutines Xpwcr_int.f90 : interfaces Xpwcr_fft.f90 : fft subroutines Xfft_int.f90 : fft interfaces Xkgesv1.f90 : Lapack fortran 90 subroutines Xlaauxmod.f90 : Lapack interfaces Xlaf90mod.f90 : Lapack interfaces Xlaf77mod.f90 : Lapack interfaces Xsolve.f : Lapack fortran 77 subroutines XMakefile : make file Xdata : input data file Xresults : output file generated by the driver X X-------------------------------------------------------------------------- X XIn order to create the executable file pwcr (Point-Wise Cyclic Reduction), Xit is sufficient to type `make' X XDuring the compilation of the file Xsolve.f, you could receive some warning messages, like: X XWarning: solve.f, line 1324: Unused dummy argument N3 X detected at END@ XWarning: solve.f, line 1324: Unused dummy argument OPTS X detected at END@ XExtension: solve.f, line xxxx: Byte count on numeric data type X detected at *@16 X XThese warning messages, originated from the Lapack fortran 77 subroutines, Xdo not affect the correctness of the compilation. X XOnce compilation has been performed, the user may remove the files *.o Xand *.mod. X XIn order to check the correct installation of the package Xrun the executable `pwcr'. XAt the request `input file name' type `data'. XIn this way the file data.out will be created. This file, up to within Xsmall numerical differences due to a possibly different floating point Xarithmetic, should coincide with the file `results'. X X------------------------------------------------------------------ X XIn order to use the program `pwcr' with different input file, the Xuser should create her/his own file, say, `my_file' organized Xin the following way: X XEach row must contain the following data: X X1-st row: the dimension of the blocks ( integer ) X2-nd row: the number of blocks A_i ( integer ) X3-rd row: the precision level ( real(kind(0.d0)) ), say, 1.d0d-12 XThe subsequent rows: the values L, I, J, VAL, where X L : (integer) is the index of the block A_L X I,J : (integers) are the indices of the (I,J)-th X entry of the block A_L X VAL : ( real(kind(0.d0)) ) is the value of the X (I,J)-th entry of the block A_L XThe last row: the quartuple 0,0,0,0.0d0 that denotes X the end of the file X XFor the values L, I, J, VAL, that are not reported in this file it is Xassumed VAL=0.d0. X X XThe file `my_file.out' created by the program contains the output Xorganized in the following way: X X --The residual error ||A_1+G A_2+G^2 A_3+....G^(m-1) A_m-G ||_1, where X G is the computed approximation of the solution of (1) and X ||.||_1 denotes the 1-norm. X --The entries of the matrix G arranged row-wise X X----------------------------------------------------------------------- X END_OF_FILE if test 5932 -ne `wc -c <'README'`; then echo shar: \"'README'\" unpacked with wrong size! fi # end of 'README' fi if test -f 'Makefile' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'Makefile'\" else echo shar: Extracting \"'Makefile'\" \(1448 characters\) sed "s/^X//" >'Makefile' <<'END_OF_FILE' X#=========================================================================# X# file Makefile # X#=========================================================================# X# IMPROVED CYCLIC REDUCTION FOR SOLVING QUEUEING PROBLEMS # X# by D.A. Bini and B. Meini # X# (bini@dm.unipi.it meini@dm.unipi.it) # X# Fortran 90 Program version 1.0, January 30, 1997 # X# Makefile # X#=========================================================================# X XF90 = f90 XFFLAGS = -O X XOBJ = pwcr_int.o fft_int.o laauxmod.o laf77mod.o laf90mod.o pwcr_sub.o pwcr_fft.o kgesv1.o solve.o pwcr_drv.o X Xall: pwcr X Xpwcr:$(OBJ) X $(F90) $(OBJ) -o pwcr X Xpwcr_int.o:pwcr_int.f90 X $(F90) $(FFLAGS) -c pwcr_int.f90 X Xfft_int.o:fft_int.f90 X $(F90) $(FFLAGS) -c fft_int.f90 X Xlaf77mod.o:laf77mod.f90 X $(F90) $(FFLAGS) -c laf77mod.f90 X Xlaf90mod.o:laf90mod.f90 X $(F90) $(FFLAGS) -c laf90mod.f90 X Xlaauxmod.o:laauxmod.f90 X $(F90) $(FFLAGS) -c laauxmod.f90 X Xpwcr_drv.o:pwcr_drv.f90 X $(F90) $(FFLAGS) -c pwcr_drv.f90 X Xpwcr_sub.o:pwcr_sub.f90 X $(F90) $(FFLAGS) -c pwcr_sub.f90 X Xpwcr_fft.o:pwcr_fft.f90 X $(F90) $(FFLAGS) -c pwcr_fft.f90 X Xkgesv1.o:kgesv1.f90 X $(F90) $(FFLAGS) -c kgesv1.f90 X Xsolve.o:solve.f X $(F90) $(FFLAGS) -c solve.f X X X X X X X X X X END_OF_FILE if test 1448 -ne `wc -c <'Makefile'`; then echo shar: \"'Makefile'\" unpacked with wrong size! fi # end of 'Makefile' fi if test -f 'fft_int.f90' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'fft_int.f90'\" else echo shar: Extracting \"'fft_int.f90'\" \(5452 characters\) sed "s/^X//" >'fft_int.f90' <<'END_OF_FILE' X!=========================================================================! X! file fft_int.f90 ! X!=========================================================================! X! IMPROVED CYCLIC REDUCTION FOR SOLVING QUEUEING PROBLEMS ! X! by D.A. Bini and B. Meini ! X! (bini@dm.unipi.it meini@dm.unipi.it) ! X! Fortran 90 Program version 1.0, January 30 1997 ! X! Interface File for FFT subroutines ! X!=========================================================================! X! Interface file for the following FFT subroutines: ! X! iffts1 ! X! ffts2 ! X! iffts2 ! X! ffts1 ! X! fillroots ! X! fft1 ! X! ifft1 ! X! ftb1 ! X! ftb2 ! X! iftb2 ! X! iftb1 ! X! twiddle ! X! itwiddle ! X!=========================================================================! XMODULE fft_interface X INTERFACE X SUBROUTINE iffts1(u,v) X IMPLICIT NONE X REAL(KIND(0.d0)),DIMENSION(:),POINTER :: u, v X REAL(KIND(0.d0)),DIMENSION(:),POINTER :: wr, wi X COMMON wr, wi X END SUBROUTINE iffts1 X END INTERFACE X !================================================================= X X INTERFACE X SUBROUTINE ffts2(u,v) X IMPLICIT NONE X REAL(KIND(0.d0)),DIMENSION(:),POINTER :: u, v X REAL(KIND(0.d0)),DIMENSION(:),POINTER :: wr, wi X COMMON wr, wi X END SUBROUTINE ffts2 X END INTERFACE X !================================================================= X X INTERFACE X SUBROUTINE iffts2(u,v,t) X IMPLICIT NONE X REAL(KIND(0.d0)),DIMENSION(:),POINTER :: u, v,t X REAL(KIND(0.d0)),DIMENSION(:),POINTER :: wr, wi X COMMON wr, wi X END SUBROUTINE iffts2 X END INTERFACE X !================================================================= X X INTERFACE X SUBROUTINE ffts1(u,v) X IMPLICIT NONE X REAL(KIND(0.d0)),DIMENSION(:),POINTER :: u, v X REAL(KIND(0.d0)),DIMENSION(:),POINTER :: wr, wi X COMMON wr, wi X END SUBROUTINE ffts1 X END INTERFACE X !================================================================= X X INTERFACE X SUBROUTINE fillroots(n) X IMPLICIT NONE X REAL(KIND(0.d0)),DIMENSION(:),ALLOCATABLE,SAVE :: wwr, wwi X REAL(KIND(0.d0)),DIMENSION(:),POINTER :: wr, wi X INTEGER :: n X COMMON wr, wi X END SUBROUTINE fillroots X END INTERFACE X !================================================================= X X INTERFACE X SUBROUTINE fft1(x,y) X IMPLICIT NONE X REAL(KIND(0.d0)),DIMENSION(:),POINTER :: x,y X REAL(KIND(0.d0)),DIMENSION(:),POINTER :: wr, wi X COMMON wr, wi X END SUBROUTINE FFT1 X END INTERFACE X !================================================================= X X INTERFACE X SUBROUTINE ifft1(x,y) X IMPLICIT NONE X REAL(KIND(0.d0)),DIMENSION(:),POINTER :: x,y X REAL(KIND(0.d0)),DIMENSION(:),POINTER :: wr, wi X COMMON wr, wi X END SUBROUTINE ifft1 X END INTERFACE X !================================================= X X INTERFACE X SUBROUTINE ftb1(a,ta) X IMPLICIT NONE X REAL(KIND(0.d0)),DIMENSION(:,:,:),POINTER :: a, ta X END SUBROUTINE ftb1 X END INTERFACE X !===================================================== X X INTERFACE X SUBROUTINE ftb2(a,ta) X IMPLICIT NONE X REAL(KIND(0.d0)),DIMENSION(:,:,:),POINTER :: a, ta X END SUBROUTINE ftb2 X END INTERFACE X !===================================================== X X INTERFACE X SUBROUTINE iftb2(ta,a) X IMPLICIT NONE X REAL(KIND(0.d0)),DIMENSION(:,:,:),POINTER :: a,ta X END SUBROUTINE iftb2 X END INTERFACE X !===================================================== X X INTERFACE X SUBROUTINE iftb1(ta,a) X IMPLICIT NONE X REAL(KIND(0.d0)),DIMENSION(:,:,:),POINTER :: a, ta X END SUBROUTINE iftb1 X END INTERFACE X !===================================================== X X INTERFACE X SUBROUTINE twiddle(zr,zi) X IMPLICIT NONE X REAL(KIND(0.d0)),DIMENSION(:),POINTER :: zr,zi X REAL(KIND(0.d0)),DIMENSION(:),POINTER :: wr, wi X COMMON wr, wi X END SUBROUTINE twiddle X END INTERFACE X !=================================================== X X INTERFACE X SUBROUTINE itwiddle(zr,zi) X IMPLICIT NONE X REAL(KIND(0.d0)),DIMENSION(:),POINTER :: zr, zi X REAL(KIND(0.d0)),DIMENSION(:),POINTER :: wr, wi X COMMON wr, wi X END SUBROUTINE itwiddle X END INTERFACE X XEND MODULE fft_interface X X X X X X X X X X X X END_OF_FILE if test 5452 -ne `wc -c <'fft_int.f90'`; then echo shar: \"'fft_int.f90'\" unpacked with wrong size! fi # end of 'fft_int.f90' fi if test -f 'kgesv1.f90' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'kgesv1.f90'\" else echo shar: Extracting \"'kgesv1.f90'\" \(6241 characters\) sed "s/^X//" >'kgesv1.f90' <<'END_OF_FILE' X!================================================================ X! file kgesv1.f90 X!================================================================ X! /netlib/lapack90 Preliminary version November, 1996 X! X! file: kgesv.f90 X! for: Fortran 90 wrapper for LAPACK routines xGESV X!================================================================ X X SUBROUTINE DGESV_f90(A,B,IPIV,INFO) X! .. Use Statements .. X USE LA_PRECISION, ONLY: WP => DP X USE LA_AUX, ONLY: ERINFO X USE LAPACK77_INTERFACES, ONLY: GESV_F77 => DGESV X! .. Implicit Statement .. X IMPLICIT NONE X! .. Scalar Arguments .. X INTEGER, INTENT(OUT), OPTIONAL :: INFO X! .. Array Arguments .. X INTEGER, INTENT(OUT), OPTIONAL, TARGET :: IPIV(:) X REAL(WP), INTENT(INOUT) :: A(:,:), B(:,:) X! .. Parameters .. X CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_GESV' X! .. Local Scalars .. X INTEGER :: LD, LINFO, NRHS, N X! .. Local Pointers .. X INTEGER, POINTER :: LPIV(:) X! .. Intrinsic Functions .. X! INTRINSIC ALLOCATE, DEALLOCATE, MAX, PRESENT, SIZE X INTRINSIC MAX, PRESENT, SIZE X! X! .. Executable Statements .. X LINFO = 0 X N = SIZE(A, 1) X IF( SIZE( A, 2 ) /= N ) THEN X LINFO = -1 X ELSE IF( SIZE( B, 1 ) /= N ) THEN X LINFO = -2 X ELSE X IF( PRESENT( IPIV ) )THEN X IF( SIZE( IPIV ) /= N ) LINFO = -3 X END IF X END IF X! X IF ( LINFO == 0 ) THEN X LD = MAX( 1, N ) X NRHS = SIZE(B,2) X IF( PRESENT( IPIV ) )THEN X LPIV => IPIV X ELSE X ALLOCATE(LPIV(N)) X END IF X CALL GESV_F77( N, NRHS, A, LD, LPIV, B, LD, LINFO ) X IF(.NOT.PRESENT(IPIV)) DEALLOCATE(LPIV) X END IF X CALL ERINFO(LINFO,SRNAME,INFO) X! X END SUBROUTINE DGESV_F90 X X SUBROUTINE ZGESV_f90(A,B,IPIV,INFO) X! .. Use Statements .. X USE LA_PRECISION, ONLY: WP => DP X USE LA_AUX, ONLY: ERINFO X USE LAPACK77_INTERFACES, ONLY: GESV_F77 => ZGESV X! .. Implicit Statement .. X IMPLICIT NONE X! .. Scalar Arguments .. X INTEGER, INTENT(OUT), OPTIONAL :: INFO X! .. Array Arguments .. X INTEGER, INTENT(OUT), OPTIONAL, TARGET :: IPIV(:) X COMPLEX(WP), INTENT(INOUT) :: A(:,:), B(:,:) X! .. Parameters .. X CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_GESV' X! .. Local Scalars .. X INTEGER :: LD, LINFO, NRHS, N X! .. Local Pointers .. X INTEGER, POINTER :: LPIV(:) X! .. Intrinsic Functions .. X! INTRINSIC ALLOCATE, DEALLOCATE, MAX, PRESENT, SIZE X INTRINSIC MAX, PRESENT, SIZE X! X! .. Executable Statements .. X LINFO = 0 X N = SIZE(A, 1) X IF( SIZE( A, 2 ) /= N ) THEN X LINFO = -1 X ELSE IF( SIZE( B, 1 ) /= N ) THEN X LINFO = -2 X ELSE X IF( PRESENT( IPIV ) )THEN X IF( SIZE( IPIV ) /= N ) LINFO = -3 X END IF X END IF X IF ( LINFO == 0 ) THEN X LD = MAX( 1, N ) X NRHS = SIZE(B,2) X IF( PRESENT( IPIV ) )THEN X LPIV => IPIV X ELSE X ALLOCATE(LPIV(N)) X END IF X CALL GESV_F77( N, NRHS, A, LD, LPIV, B, LD, LINFO ) X IF(.NOT.PRESENT(IPIV)) DEALLOCATE(LPIV) X END IF X CALL ERINFO(LINFO,SRNAME,INFO) X END SUBROUTINE ZGESV_F90 X X SUBROUTINE D1GESV_f90(A,B,IPIV,INFO) X! .. Use Statements .. X USE LA_PRECISION, ONLY: WP => DP X USE LA_AUX, ONLY: ERINFO X USE LAPACK77_INTERFACES, ONLY: GESV_F77 => DGESV X! .. Implicit Statement .. X IMPLICIT NONE X! .. Scalar Arguments .. X INTEGER, INTENT(OUT), OPTIONAL :: INFO X! .. Array Arguments .. X INTEGER, INTENT(OUT), OPTIONAL, TARGET :: IPIV(:) X REAL(WP), INTENT(INOUT) :: A(:,:), B(:) X! .. Parameters .. X CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_GESV' X! .. Local Scalars .. X INTEGER :: LD, LINFO, NRHS, N X! .. Local Pointers .. X INTEGER, POINTER :: LPIV(:) X! .. Intrinsic Functions .. X! INTRINSIC ALLOCATE, DEALLOCATE, MAX, PRESENT, SIZE X INTRINSIC MAX, PRESENT, SIZE X! X! .. Executable Statements .. X LINFO = 0 X N = SIZE(A, 1) X IF( SIZE( A, 2 ) /= N ) THEN X LINFO = -1 X ELSE IF( SIZE( B ) /= N ) THEN X LINFO = -2 X ELSE X IF( PRESENT( IPIV ) )THEN X IF( SIZE( IPIV ) /= N ) LINFO = -3 X END IF X END IF X IF ( LINFO == 0 ) THEN X LD = MAX( 1, N ) X NRHS = 1 X IF( PRESENT( IPIV ) )THEN X LPIV => IPIV X ELSE X ALLOCATE(LPIV(N)) X END IF X CALL GESV_F77( N, NRHS, A, LD, LPIV, B, LD, LINFO ) X IF(.NOT.PRESENT(IPIV)) DEALLOCATE(LPIV) X END IF X CALL ERINFO(LINFO,SRNAME,INFO) X END SUBROUTINE D1GESV_F90 X X SUBROUTINE Z1GESV_f90(A,B,IPIV,INFO) X! .. Use Statements .. X USE LA_PRECISION, ONLY: WP => DP X USE LA_AUX, ONLY: ERINFO X USE LAPACK77_INTERFACES, ONLY: GESV_F77 => ZGESV X! .. Implicit Statement .. X IMPLICIT NONE X! .. Scalar Arguments .. X INTEGER, INTENT(OUT), OPTIONAL :: INFO X! .. Array Arguments .. X INTEGER, INTENT(OUT), OPTIONAL, TARGET :: IPIV(:) X COMPLEX(WP), INTENT(INOUT) :: A(:,:), B(:) X! .. Parameters .. X CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_GESV' X! .. Local Scalars .. X INTEGER :: LD, LINFO, NRHS, N X! .. Local Pointers .. X INTEGER, POINTER :: LPIV(:) X! .. Intrinsic Functions .. X! INTRINSIC ALLOCATE, DEALLOCATE, MAX, PRESENT, SIZE X INTRINSIC MAX, PRESENT, SIZE X! X! .. Executable Statements .. X LINFO = 0 X N = SIZE(A, 1) X IF( SIZE( A, 2 ) /= N ) THEN X LINFO = -1 X ELSE IF( SIZE( B ) /= N ) THEN X LINFO = -2 X ELSE X IF( PRESENT( IPIV ) )THEN X IF( SIZE( IPIV ) /= N ) LINFO = -3 X END IF X END IF X IF ( LINFO == 0 ) THEN X LD = MAX( 1, N ) X NRHS = 1 X IF( PRESENT( IPIV ) )THEN X LPIV => IPIV X ELSE X ALLOCATE(LPIV(N)) X END IF X CALL GESV_F77( N, NRHS, A, LD, LPIV, B, LD, LINFO ) X IF(.NOT.PRESENT(IPIV)) DEALLOCATE(LPIV) X END IF X CALL ERINFO(LINFO,SRNAME,INFO) X END SUBROUTINE Z1GESV_F90 END_OF_FILE if test 6241 -ne `wc -c <'kgesv1.f90'`; then echo shar: \"'kgesv1.f90'\" unpacked with wrong size! fi # end of 'kgesv1.f90' fi if test -f 'laauxmod.f90' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'laauxmod.f90'\" else echo shar: Extracting \"'laauxmod.f90'\" \(3407 characters\) sed "s/^X//" >'laauxmod.f90' <<'END_OF_FILE' X!================================================================ X! file laauxmod.f90 X!================================================================ X! /netlib/lapack90 Preliminary version November, 1996 X! X! file: laauxmod.f90 X! for: auxiliary routines X!================================================================ X X XMODULE LA_PRECISION X! X! Defines single and double precision parameters, sp and dp. X! These values are compiler dependent. X! X INTEGER, PARAMETER :: SP=KIND(1.0), DP=KIND(1.0D0) X! XEND MODULE LA_PRECISION X XMODULE LA_AUX X! XCONTAINS X! XLOGICAL FUNCTION LSAME( CA, CB ) X! X! -- LAPACK auxiliary routine (version 2.0) -- X! Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X! Courant Institute, Argonne National Lab, and Rice University X! September 30, 1994 X! X! Purpose X! ======= X! X! LSAME tests if CA is the same letter as CB regardless of case. X! X! Parameters X! ========== X! X! CA (input) CHARACTER*1 X! CB (input) CHARACTER*1 X! Characters to be compared. X! X! .. Scalar Arguments .. X CHARACTER*1, INTENT(IN) :: CA, CB X! .. Parameters .. X INTEGER, PARAMETER :: IOFF=32 X! .. Local Scalars .. X INTEGER :: INTA, INTB, ZCODE X! .. Intrinsic Functions .. X INTRINSIC ICHAR X! X! .. Executable Statements .. X! X! Test if the characters are equal X! X LSAME = CA == CB X! X! Now test for equivalence X! X IF ( .NOT.LSAME ) THEN X! X! Use 'Z' rather than 'A' so that ASCII can be detected on Prime X! machines, on which ICHAR returns a value with bit 8 set. X! ICHAR('A') on Prime machines returns 193 which is the same as X! ICHAR('A') on an EBCDIC machine. X! X ZCODE = ICHAR( 'Z' ) X! X INTA = ICHAR( CA ) X INTB = ICHAR( CB ) X! X IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN X! X! ASCII is assumed - ZCODE is the ASCII code of either lower or X! upper case 'Z'. X! X IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 X IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 X! X ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN X! X! EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or X! upper case 'Z'. X! X IF( INTA.GE.129 .AND. INTA.LE.137 .OR. & X! INTA.GE.145 .AND. INTA.LE.153 .OR. & X INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 X IF( INTB.GE.129 .AND. INTB.LE.137 .OR. & X INTB.GE.145 .AND. INTB.LE.153 .OR. & X INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 X! X ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN X! X! ASCII is assumed, on Prime machines - ZCODE is the ASCII code X! plus 128 of either lower or upper case 'Z'. X! X IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 X IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 X END IF X LSAME = INTA == INTB X END IF XEND FUNCTION LSAME X XSUBROUTINE ERINFO(LINFO, SRNAME, INFO) X! .. Scalar Arguments .. X CHARACTER( LEN = * ), INTENT(IN) :: SRNAME X INTEGER , INTENT(IN) :: LINFO X INTEGER , INTENT(INOUT), OPTIONAL :: INFO X! X! .. Executable Statements .. X! X IF( PRESENT(INFO) ) INFO = LINFO X IF( LINFO < 0 .OR. LINFO>0 .AND. .NOT.PRESENT(INFO) )THEN X WRITE (*,*) 'Program terminated in LAPACK_90 subroutine ', SRNAME X WRITE (*,*) 'Error indicator, INFO = ', LINFO X STOP X END IF XEND SUBROUTINE ERINFO X! XEND MODULE LA_AUX END_OF_FILE if test 3407 -ne `wc -c <'laauxmod.f90'`; then echo shar: \"'laauxmod.f90'\" unpacked with wrong size! fi # end of 'laauxmod.f90' fi if test -f 'laf77mod.f90' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'laf77mod.f90'\" else echo shar: Extracting \"'laf77mod.f90'\" \(16245 characters\) sed "s/^X//" >'laf77mod.f90' <<'END_OF_FILE' X!================================================================ X! file laf77mod.f90 X!================================================================ X! /netlib/lapack90 Preliminary version November, 1996 X! X! file: laf77mod.f90 X! for: Interface module for the LAPACK Fortran 77 routines X!================================================================ X XMODULE LAPACK77_INTERFACES X INTERFACE X! X SUBROUTINE SGESV( N, NRHS, A, LDA, PIV, B, LDB, INFO ) X USE LA_PRECISION, ONLY: SP X INTEGER, INTENT(IN) :: LDA, LDB, NRHS, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT(OUT) :: PIV(*) X REAL(SP), INTENT(INOUT) :: A(LDA,*), B(LDB,NRHS) X END SUBROUTINE SGESV X SUBROUTINE DGESV( N, NRHS, A, LDA, PIV, B, LDB, INFO ) X USE LA_PRECISION, ONLY: DP X INTEGER, INTENT(IN) :: LDA, LDB, NRHS, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT(OUT) :: PIV(*) X REAL(DP), INTENT(INOUT) :: A(LDA,*), B(LDB,NRHS) X END SUBROUTINE DGESV X SUBROUTINE CGESV( N, NRHS, A, LDA, PIV, B, LDB, INFO ) X USE LA_PRECISION, ONLY: SP X INTEGER, INTENT(IN) :: LDA, LDB, NRHS, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT(OUT) :: PIV(*) X COMPLEX(SP), INTENT(INOUT) :: A(LDA,*), B(LDB,NRHS) X END SUBROUTINE CGESV X SUBROUTINE ZGESV( N, NRHS, A, LDA, PIV, B, LDB, INFO ) X USE LA_PRECISION, ONLY: DP X INTEGER, INTENT(IN) :: LDA, LDB, NRHS, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT(OUT) :: PIV(*) X COMPLEX(DP), INTENT(INOUT) :: A(LDA,*), B(LDB,NRHS) X END SUBROUTINE ZGESV X! X SUBROUTINE SGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, & X PIV, EQUED, R, C, B, LDB, X, LDX, & X RCOND, FERR, BERR, WORK, IWORK, INFO ) X USE LA_PRECISION, ONLY: WP => SP X CHARACTER(LEN=1), INTENT(IN) :: TRANS, FACT X CHARACTER(LEN=1), INTENT(INOUT) :: EQUED X INTEGER, INTENT(IN) :: LDA, LDAF, LDB, LDX, NRHS, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT(OUT) :: IWORK(*) X INTEGER, INTENT(INOUT) :: PIV(*) X REAL(WP), INTENT(OUT) :: RCOND X REAL(WP), INTENT(OUT) :: FERR(*), BERR(*) X REAL(WP), INTENT(OUT) :: X(LDX,*), WORK(*) X REAL(WP), INTENT(INOUT) :: R(*), C(*) X REAL(WP), INTENT(INOUT) :: A(LDA,*), AF(LDAF,*), B(LDB,*) X END SUBROUTINE SGESVX X SUBROUTINE DGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, & X PIV, EQUED, R, C, B, LDB, X, LDX, & X RCOND, FERR, BERR, WORK, IWORK, INFO ) X USE LA_PRECISION, ONLY: WP => DP X CHARACTER(LEN=1), INTENT(IN) :: TRANS, FACT X CHARACTER(LEN=1), INTENT(INOUT) :: EQUED X INTEGER, INTENT(IN) :: LDA, LDAF, LDB, LDX, NRHS, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT(OUT) :: IWORK(*) X INTEGER, INTENT(INOUT) :: PIV(*) X REAL(WP), INTENT(OUT) :: RCOND X REAL(WP), INTENT(OUT) :: FERR(*), BERR(*) X REAL(WP), INTENT(OUT) :: X(LDX,*), WORK(*) X REAL(WP), INTENT(INOUT) :: R(*), C(*) X REAL(WP), INTENT(INOUT) :: A(LDA,*), AF(LDAF,*), B(LDB,*) X END SUBROUTINE DGESVX X SUBROUTINE CGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, & X PIV, EQUED, R, C, B, LDB, X, LDX, & X RCOND, FERR, BERR, WORK, RWORK, INFO ) X USE LA_PRECISION, ONLY: WP => SP X CHARACTER(LEN=1), INTENT(IN) :: TRANS, FACT X CHARACTER(LEN=1), INTENT(INOUT) :: EQUED X INTEGER, INTENT(IN) :: LDA, LDAF, LDB, LDX, NRHS, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT(INOUT) :: PIV(*) X REAL(WP), INTENT(OUT) :: RCOND X REAL(WP), INTENT(OUT) :: FERR(*), BERR(*), RWORK(*) X REAL(WP), INTENT(INOUT) :: R(*), C(*) X COMPLEX(WP), INTENT(OUT) :: X(LDX,*), WORK(*) X COMPLEX(WP), INTENT(INOUT) :: A(LDA,*), AF(LDAF,*), B(LDB,*) X END SUBROUTINE CGESVX X SUBROUTINE ZGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, & X PIV, EQUED, R, C, B, LDB, X, LDX, & X RCOND, FERR, BERR, WORK, RWORK, INFO ) X USE LA_PRECISION, ONLY: WP => DP X CHARACTER(LEN=1), INTENT(IN) :: TRANS, FACT X CHARACTER(LEN=1), INTENT(INOUT) :: EQUED X INTEGER, INTENT(IN) :: LDA, LDAF, LDB, LDX, NRHS, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT(INOUT) :: PIV(*) X REAL(WP), INTENT(OUT) :: RCOND X REAL(WP), INTENT(OUT) :: FERR(*), BERR(*), RWORK(*) X REAL(WP), INTENT(INOUT) :: R(*), C(*) X COMPLEX(WP), INTENT(OUT) :: X(LDX,*), WORK(*) X COMPLEX(WP), INTENT(INOUT) :: A(LDA,*), AF(LDAF,*), B(LDB,*) X END SUBROUTINE ZGESVX X! X SUBROUTINE SGETRF( M, N, A, LDA, PIV, INFO ) X USE LA_PRECISION, ONLY: SP X INTEGER, INTENT(IN) :: LDA, M, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT( OUT ) :: PIV( * ) X REAL(SP), INTENT( INOUT ) :: A( LDA, * ) X END SUBROUTINE SGETRF X SUBROUTINE DGETRF( M, N, A, LDA, PIV, INFO ) X USE LA_PRECISION, ONLY: DP X INTEGER, INTENT(IN) :: LDA, M, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT( OUT ) :: PIV( * ) X REAL(DP), INTENT( INOUT ) :: A( LDA, * ) X END SUBROUTINE DGETRF X SUBROUTINE CGETRF( M, N, A, LDA, PIV, INFO ) X USE LA_PRECISION, ONLY: SP X INTEGER, INTENT(IN) :: LDA, M, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT( OUT ) :: PIV( * ) X COMPLEX(SP), INTENT( INOUT ) :: A( LDA, * ) X END SUBROUTINE CGETRF X SUBROUTINE ZGETRF( M, N, A, LDA, PIV, INFO ) X USE LA_PRECISION, ONLY: DP X INTEGER, INTENT(IN) :: LDA, M, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT( OUT ) :: PIV( * ) X COMPLEX(DP), INTENT( INOUT ) :: A( LDA, * ) X END SUBROUTINE ZGETRF X! X SUBROUTINE SGETRS( TRANS, N, NRHS, A, LDA, PIV, B, LDB, INFO ) X USE LA_PRECISION, ONLY: SP X CHARACTER(LEN=1), INTENT(IN) :: TRANS X INTEGER, INTENT(IN) :: LDA, LDB, NRHS, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT(IN) :: PIV(*) X REAL(SP), INTENT(IN) :: A(LDA,*) X REAL(SP), INTENT(INOUT) :: B(LDB,NRHS) X END SUBROUTINE SGETRS X SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, PIV, B, LDB, INFO ) X USE LA_PRECISION, ONLY: DP X CHARACTER(LEN=1), INTENT(IN) :: TRANS X INTEGER, INTENT(IN) :: LDA, LDB, NRHS, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT(IN) :: PIV(*) X REAL(DP), INTENT(IN) :: A(LDA,*) X REAL(DP), INTENT(INOUT) :: B(LDB,NRHS) X END SUBROUTINE DGETRS X SUBROUTINE CGETRS( TRANS, N, NRHS, A, LDA, PIV, B, LDB, INFO ) X USE LA_PRECISION, ONLY: SP X CHARACTER(LEN=1), INTENT(IN) :: TRANS X INTEGER, INTENT(IN) :: LDA, LDB, NRHS, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT(IN) :: PIV(*) X COMPLEX(SP), INTENT(IN) :: A(LDA,*) X COMPLEX(SP), INTENT(INOUT) :: B(LDB,NRHS) X END SUBROUTINE CGETRS X SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, PIV, B, LDB, INFO ) X USE LA_PRECISION, ONLY: DP X CHARACTER(LEN=1), INTENT(IN) :: TRANS X INTEGER, INTENT(IN) :: LDA, LDB, NRHS, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT(IN) :: PIV(*) X COMPLEX(DP), INTENT(IN) :: A(LDA,*) X COMPLEX(DP), INTENT(INOUT) :: B(LDB,NRHS) X END SUBROUTINE ZGETRS X! X SUBROUTINE SGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) X USE LA_PRECISION, ONLY: SP X INTEGER, INTENT(IN) :: LDA, LWORK, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT(IN) :: IPIV(*) X REAL(SP), INTENT(OUT) :: WORK(*) X REAL(SP), INTENT(INOUT) :: A(LDA,*) X END SUBROUTINE SGETRI X SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) X USE LA_PRECISION, ONLY: DP X INTEGER, INTENT(IN) :: LDA, LWORK, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT(IN) :: IPIV(*) X REAL(DP), INTENT(OUT) :: WORK(*) X REAL(DP), INTENT(INOUT) :: A(LDA,*) X END SUBROUTINE DGETRI X SUBROUTINE CGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) X USE LA_PRECISION, ONLY: SP X INTEGER, INTENT(IN) :: LDA, LWORK, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT(IN) :: IPIV(*) X COMPLEX(SP), INTENT(OUT) :: WORK(*) X COMPLEX(SP), INTENT(INOUT) :: A(LDA,*) X END SUBROUTINE CGETRI X SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) X USE LA_PRECISION, ONLY: DP X INTEGER, INTENT(IN) :: LDA, LWORK, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT(IN) :: IPIV(*) X COMPLEX(DP), INTENT(OUT) :: WORK(*) X COMPLEX(DP), INTENT(INOUT) :: A(LDA,*) X END SUBROUTINE ZGETRI X! X SUBROUTINE SGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, PIV, B, & X LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) X USE LA_PRECISION, ONLY: WP => SP X CHARACTER(LEN=1), INTENT(IN) :: TRANS X INTEGER, INTENT(IN) :: LDA, LDAF, LDB, LDX, NRHS, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT(IN) :: PIV(*) X INTEGER, INTENT(OUT) :: IWORK(*) X REAL(WP), INTENT(OUT) :: FERR(*), BERR(*), WORK(*) X REAL(WP), INTENT(IN) :: A(LDA,*), AF(LDAF,*), B(LDB,*) X REAL(WP), INTENT(INOUT) :: X(LDX,*) X END SUBROUTINE SGERFS X SUBROUTINE DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, PIV, B, & X LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) X USE LA_PRECISION, ONLY: WP => DP X CHARACTER(LEN=1), INTENT(IN) :: TRANS X INTEGER, INTENT(IN) :: LDA, LDAF, LDB, LDX, NRHS, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT(IN) :: PIV(*) X INTEGER, INTENT(OUT) :: IWORK(*) X REAL(WP), INTENT(OUT) :: FERR(*), BERR(*), WORK(*) X REAL(WP), INTENT(IN) :: A(LDA,*), AF(LDAF,*), B(LDB,*) X REAL(WP), INTENT(INOUT) :: X(LDX,*) X END SUBROUTINE DGERFS X SUBROUTINE CGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, PIV, B, & X LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO ) X USE LA_PRECISION, ONLY: WP => SP X CHARACTER(LEN=1), INTENT(IN) :: TRANS X INTEGER, INTENT(IN) :: LDA, LDAF, LDB, LDX, NRHS, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT(IN) :: PIV(*) X REAL(WP), INTENT(OUT) :: FERR(*), BERR(*), RWORK(*) X COMPLEX(WP), INTENT(OUT) :: WORK(*) X COMPLEX(WP), INTENT(IN) :: A(LDA,*), AF(LDAF,*), B(LDB,*) X COMPLEX(WP), INTENT(INOUT) :: X(LDX,*) X END SUBROUTINE CGERFS X SUBROUTINE ZGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, PIV, B, & X LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO ) X USE LA_PRECISION, ONLY: WP => DP X CHARACTER(LEN=1), INTENT(IN) :: TRANS X INTEGER, INTENT(IN) :: LDA, LDAF, LDB, LDX, NRHS, N X INTEGER, INTENT(OUT) :: INFO X INTEGER, INTENT(IN) :: PIV(*) X REAL(WP), INTENT(OUT) :: FERR(*), BERR(*), RWORK(*) X COMPLEX(WP), INTENT(OUT) :: WORK(*) X COMPLEX(WP), INTENT(IN) :: A(LDA,*), AF(LDAF,*), B(LDB,*) X COMPLEX(WP), INTENT(INOUT) :: X(LDX,*) X END SUBROUTINE ZGERFS X! X SUBROUTINE SGEEQU( M,N,A,LDA,R,C,ROWCND,COLCND,AMAX,INFO ) X USE LA_PRECISION, ONLY: WP => SP X INTEGER, INTENT(IN) :: LDA, M, N X INTEGER, INTENT(OUT) :: INFO X REAL(WP), INTENT(OUT) :: AMAX, COLCND, ROWCND X REAL(WP), INTENT(IN) :: A( LDA, * ) X REAL(WP), INTENT(OUT) :: C( * ), R( * ) X END SUBROUTINE SGEEQU X SUBROUTINE DGEEQU( M,N,A,LDA,R,C,ROWCND,COLCND,AMAX,INFO ) X USE LA_PRECISION, ONLY: WP => DP X INTEGER, INTENT(IN) :: LDA, M, N X INTEGER, INTENT(OUT) :: INFO X REAL(WP), INTENT(OUT) :: AMAX, COLCND, ROWCND X REAL(WP), INTENT(IN) :: A( LDA, * ) X REAL(WP), INTENT(OUT) :: C( * ), R( * ) X END SUBROUTINE DGEEQU X SUBROUTINE CGEEQU( M,N,A,LDA,R,C,ROWCND,COLCND,AMAX,INFO ) X USE LA_PRECISION, ONLY: WP => SP X INTEGER, INTENT(IN) :: LDA, M, N X INTEGER, INTENT(OUT) :: INFO X REAL(WP), INTENT(OUT) :: AMAX, COLCND, ROWCND X COMPLEX(WP), INTENT(IN) :: A( LDA, * ) X REAL(WP), INTENT(OUT) :: C( * ), R( * ) X END SUBROUTINE CGEEQU X SUBROUTINE ZGEEQU( M,N,A,LDA,R,C,ROWCND,COLCND,AMAX,INFO ) X USE LA_PRECISION, ONLY: WP => DP X INTEGER, INTENT(IN) :: LDA, M, N X INTEGER, INTENT(OUT) :: INFO X REAL(WP), INTENT(OUT) :: AMAX, COLCND, ROWCND X COMPLEX(WP), INTENT(IN) :: A( LDA, * ) X REAL(WP), INTENT(OUT) :: C( * ), R( * ) X END SUBROUTINE ZGEEQU X! X FUNCTION SLANGE( NORM, M, N, A, LDA, WORK ) X USE LA_PRECISION, ONLY: WP => SP X REAL(WP) :: SLANGE X CHARACTER(LEN=1), INTENT(IN) :: NORM X INTEGER, INTENT(IN) :: LDA, M, N X REAL(WP), INTENT(IN) :: A( LDA, * ) X REAL(WP), INTENT(OUT) :: WORK( * ) X END FUNCTION SLANGE X FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) X USE LA_PRECISION, ONLY: WP => DP X REAL(WP) DLANGE X CHARACTER(LEN=1), INTENT(IN) :: NORM X INTEGER, INTENT(IN) :: LDA, M, N X REAL(WP), INTENT(IN) :: A( LDA, * ) X REAL(WP), INTENT(OUT) :: WORK( * ) X END FUNCTION DLANGE X FUNCTION CLANGE( NORM, M, N, A, LDA, WORK ) X USE LA_PRECISION, ONLY: WP => SP X REAL(WP) CLANGE X CHARACTER(LEN=1), INTENT(IN) :: NORM X INTEGER, INTENT(IN) :: LDA, M, N X COMPLEX(WP), INTENT(IN) :: A( LDA, * ) X REAL(WP), INTENT(OUT) :: WORK( * ) X END FUNCTION CLANGE X FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) X USE LA_PRECISION, ONLY: WP => DP X REAL(WP) ZLANGE X CHARACTER(LEN=1), INTENT(IN) :: NORM X INTEGER, INTENT(IN) :: LDA, M, N X COMPLEX(WP), INTENT(IN) :: A( LDA, * ) X REAL(WP), INTENT(OUT) :: WORK( * ) X END FUNCTION ZLANGE X! X SUBROUTINE SGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, & X IWORK, INFO ) X USE LA_PRECISION, ONLY: WP => SP X CHARACTER(LEN=1), INTENT(IN) :: NORM X INTEGER, INTENT(IN) :: LDA, N X INTEGER, INTENT(OUT) :: INFO X REAL(WP), INTENT(IN) :: ANORM X REAL(WP), INTENT(OUT) :: RCOND X INTEGER, INTENT(OUT) :: IWORK( * ) X REAL(WP), INTENT(IN) :: A( LDA, * ) X REAL(WP), INTENT(OUT) :: WORK( * ) X END SUBROUTINE SGECON X SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, & X IWORK, INFO ) X USE LA_PRECISION, ONLY: WP => DP X CHARACTER(LEN=1), INTENT(IN) :: NORM X INTEGER, INTENT(IN) :: LDA, N X INTEGER, INTENT(OUT) :: INFO X REAL(WP), INTENT(IN) :: ANORM X REAL(WP), INTENT(OUT) :: RCOND X INTEGER, INTENT(OUT) :: IWORK( * ) X REAL(WP), INTENT(IN) :: A( LDA, * ) X REAL(WP), INTENT(OUT) :: WORK( * ) X END SUBROUTINE DGECON X SUBROUTINE CGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, & X RWORK, INFO ) X USE LA_PRECISION, ONLY: WP => SP X CHARACTER(LEN=1), INTENT(IN) :: NORM X INTEGER, INTENT(IN) :: LDA, N X INTEGER, INTENT(OUT) :: INFO X REAL(WP), INTENT(IN) :: ANORM X REAL(WP), INTENT(OUT) :: RCOND X REAL(WP), INTENT(OUT) :: RWORK( * ) X COMPLEX(WP), INTENT(IN) :: A( LDA, * ) X COMPLEX(WP), INTENT(OUT) :: WORK( * ) X END SUBROUTINE CGECON X SUBROUTINE ZGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, & X RWORK, INFO ) X USE LA_PRECISION, ONLY: WP => DP X CHARACTER(LEN=1), INTENT(IN) :: NORM X INTEGER, INTENT(IN) :: LDA, N X INTEGER, INTENT(OUT) :: INFO X REAL(WP), INTENT(IN) :: ANORM X REAL(WP), INTENT(OUT) :: RCOND X REAL(WP), INTENT(OUT) :: RWORK( * ) X COMPLEX(WP), INTENT(IN) :: A( LDA, * ) X COMPLEX(WP), INTENT(OUT) :: WORK( * ) X END SUBROUTINE ZGECON X! X END INTERFACE XEND MODULE LAPACK77_INTERFACES END_OF_FILE if test 16245 -ne `wc -c <'laf77mod.f90'`; then echo shar: \"'laf77mod.f90'\" unpacked with wrong size! fi # end of 'laf77mod.f90' fi if test -f 'laf90mod.f90' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'laf90mod.f90'\" else echo shar: Extracting \"'laf90mod.f90'\" \(45546 characters\) sed "s/^X//" >'laf90mod.f90' <<'END_OF_FILE' X!================================================================ X! file laf90mod.f90 X!================================================================ X! /netlib/lapack90 Preliminary version November, 1996 X! X! file: laf90mod.f90 X! for: Interface module for the LAPACK Fortran 90 routines X!================================================================ X X XMODULE LAPACK90_INTERFACES X! X INTERFACE LA_GESV X! X! Purpose X! ======= X! X! LA_GESV computes the solution to either a real or complex system of X! linear equations AX = B, X! where A is a square matrix and X and B are either rectangular X! matrices or vectors. X! X! The LU decomposition with partial pivoting and row interchanges is X! used to factor A as A = PLU, X! where P is a permutation matrix, L is unit lower triangular, and U is X! upper triangular. The factored form of A is then used to solve the X! system of equations AX = B. X! X! Arguments X! ========= X! X! SUBROUTINE LA_GESV ( A, B, IPIV, INFO ) X! (), INTENT(INOUT) :: A(:,:), X! INTEGER, INTENT(OUT), OPTIONAL :: IPIV(:) X! INTEGER, INTENT(OUT), OPTIONAL :: INFO X! where X! ::= REAL | COMPLEX X! ::= KIND(1.0) | KIND(1.0D0) X! ::= B(:,:) | B(:) X! X! ===================== X! X! A (input/output) either REAL or COMPLEX square array, X! shape (:,:), size(A,1) == size(A,2). X! On entry, the matrix A. X! On exit, the factors L and U from the factorization A = PLU; X! the unit diagonal elements of L are not stored. X! X! B (input/output) either REAL or COMPLEX rectangular array, X! shape either (:,:) or (:), size(B,1) or size(B) == size(A,1). X! On entry, the right hand side vector(s) of matrix B for the X! system of equations AX = B. X! On exit, if there is no error, the matrix of solution X! vector(s) X. X! X! IPIV Optional (output) INTEGER array, shape (:), X! size(IPIV) == size(A,1). If IPIV is present it indices that X! define the permutation matrix P; row i of the matrix was X! interchanged with row IPIV(i). X! X! INFO Optional (output) INTEGER. X! If INFO is present X! = 0: successful exit X! < 0: if INFO = -k, the k-th argument had an illegal value X! > 0: if INFO = k, U(k,k) is exactly zero. The factorization X! has been completed, but the factor U is exactly X! singular, so the solution could not be computed. X! If INFO is not present and an error occurs, then the program is X! terminated with an error message. X! X! ===================================================================== X X SUBROUTINE SGESV_F90(A,B,IPIV,INFO) X USE LA_PRECISION, ONLY: SP X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(OUT), OPTIONAL :: IPIV(:) X REAL(SP), INTENT(INOUT) :: A(:,:), B(:,:) X END SUBROUTINE SGESV_F90 X SUBROUTINE S1GESV_F90(A,B,IPIV,INFO) X USE LA_PRECISION, ONLY: SP X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(OUT), OPTIONAL :: IPIV(:) X REAL(SP), INTENT(INOUT) :: A(:,:), B(:) X END SUBROUTINE S1GESV_F90 X SUBROUTINE DGESV_F90(A,B,IPIV,INFO) X USE LA_PRECISION, ONLY: DP X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(OUT), OPTIONAL :: IPIV(:) X REAL(DP), INTENT(INOUT) :: A(:,:), B(:,:) X END SUBROUTINE DGESV_F90 X SUBROUTINE D1GESV_F90(A,B,IPIV,INFO) X USE LA_PRECISION, ONLY: DP X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(OUT), OPTIONAL :: IPIV(:) X REAL(DP), INTENT(INOUT) :: A(:,:), B(:) X END SUBROUTINE D1GESV_F90 X SUBROUTINE CGESV_F90(A,B,IPIV,INFO) X USE LA_PRECISION, ONLY: SP X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(OUT), OPTIONAL :: IPIV(:) X COMPLEX(SP), INTENT(INOUT) :: A(:,:), B(:,:) X END SUBROUTINE CGESV_F90 X SUBROUTINE C1GESV_F90(A,B,IPIV,INFO) X USE LA_PRECISION, ONLY: SP X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(OUT), OPTIONAL :: IPIV(:) X COMPLEX(SP), INTENT(INOUT) :: A(:,:), B(:) X END SUBROUTINE C1GESV_F90 X SUBROUTINE ZGESV_F90(A,B,IPIV,INFO) X USE LA_PRECISION, ONLY: DP X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(OUT), OPTIONAL :: IPIV(:) X COMPLEX(DP), INTENT(INOUT) :: A(:,:), B(:,:) X END SUBROUTINE ZGESV_F90 X SUBROUTINE Z1GESV_F90(A,B,IPIV,INFO) X USE LA_PRECISION, ONLY: DP X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(OUT), OPTIONAL :: IPIV(:) X COMPLEX(DP), INTENT(INOUT) :: A(:,:), B(:) X END SUBROUTINE Z1GESV_F90 X END INTERFACE X! X INTERFACE LA_GESVX X! X! Purpose X! ======= X! X! LA_GESVX computes the solution to a either real or complex system of X! linear equations AX = B, X! where A is a square matrix and X and B are either rectangular X! matrices or vectors. X! LA_GESVX is an expert driver routine, which can also perform the X! following functions: X! - solve A^T X = B or A^H X = B, X! - estimate the condition number of A, X! - return the pivot growth factor, X! - refine the solution and computes forward and backward error X! bounds, X! - equilibrate the system if A is poorly scaled. X! X! Arguments X! ========= X! SUBROUTINE LA_GESVX (A, B, X, AF, IPIV, FACT, TRANS, EQUED, R, C, X! FERR, BERR, RCOND, RPVGRW, INFO) X! (), INTENT(INOUT) :: A(:,:), X! (), INTENT(OUT) :: X! (), INTENT(INOUT), OPTIONAL :: AF(:,:) X! INTEGER, INTENT(INOUT), OPTIONAL :: IPIV(:) X! CHARACTER(LEN=1), INTENT(INOUT), OPTIONAL :: EQUED X! REAL(), INTENT(INOUT), OPTIONAL :: R(:), C(:) X! REAL(), INTENT(OUT), OPTIONAL :: , RCOND, RPVGRW X! CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: FACT, TRANS X! INTEGER, INTENT(OUT), OPTIONAL :: INFO X! where X! ::= REAL | COMPLEX X! ::= KIND(1.0) | KIND(1.0D0) X! ::= B(:,:) | B(:) X! ::= X(:,:) | X(:) X! ::= FERR(:), BERR(:) | FERR, BERR X! X! Description X! =========== X! X! The following steps are performed: X! X! 1. If FACT is not present or FACT = 'N', and EQUED is present, X! real scaling factors are computed to equilibrate the system: X! TRANS = 'N': diag(R) A diag(C) inv(diag(C)) X = diag(R) B X! TRANS = 'T': (diag(R) A diag(C))^T inv(diag(R)) X = diag(C) B X! TRANS = 'C': (diag(R) A diag(C))^H inv(diag(R)) X = diag(C) B X! Whether or not the system will be equilibrated depends on the X! scaling of the matrix A, but if equilibration is used, A is X! overwritten by diag(R) A diag(C) and B by diag(R) B (if TRANS='N') X! or diag(C) B (if TRANS = 'T' or 'C'). X! X! 2. If FACT = 'N', the LU decomposition is used to factor the X! matrix A (after equilibration if EQUED is present) as A = PLU, X! where P is a permutation matrix, L is a unit lower triangular X! matrix, and U is upper triangular. X! X! 3. The factored form of A is used to estimate the condition number X! of the matrix A. If the reciprocal of the condition number is X! less than machine precision, steps 4-6 are skipped. X! X! 4. The system of equations is solved for X using the factored form X! of A. X! X! 5. Iterative refinement is applied to improve the computed solution X! matrix and calculate error bounds and backward error estimates X! for it. X! X! 6. If equilibration was used, the matrix X is premultiplied by X! diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so X! that it solves the original system before equilibration. X! X! Arguments X! ========= X! X! A (input/output) either REAL or COMPLEX square array, X! shape (:,:), size(A,1) == size(A,2). X! If FACT is not present or FACT = 'N', X! On entry, the matrix A. X! On exit, if EQUED is present, the matrix A may have been X! overwritten by the equilibrated matrix (see EQUED). X! If FACT is present and FACT = 'F', X! On entry, the matrix A, possibly equilibrated in a previous X! call to LA_GESVX (see EQUED). X! On exit, A is unchanged. X! X! B (input/output) either REAL or COMPLEX rectangular array, X! shape either (:,:) or (:), size(B,1) or size(B) == size(A,1). X! On entry, the right hand side vector(s) of matrix B for the X! system of equations AX = B. X! On exit, if EQUED is present, B may have been scaled in X! accordance with the equilibration of A (see EQUED); X! otherwise, B is unchanged. X! X! X (output) either REAL or COMPLEX rectangular array, X! shape either (:,:) or (:), size(X,1) or size(X) == size(A,1). X! If INFO = 0, the solution matrix X to the original X! system of equations. Note that X always returns the solution X! to the original system of equations; if equilibration has been X! performed (EQUED is present and EQUED /= 'N'), this does not X! correspond to the scaled A and B. X! X! AF Optional (input/output) either REAL or COMPLEX square array, X! shape (:,:), size(AF,1) == size(AF,2) == size(A,1). X! If FACT is not present or FACT = 'N', then AF is an output X! argument and returns the factors L and U from the factorization X! A = PLU of the original matrix A, possibly equilibrated if X! EQUED is present. X! If FACT is present and FACT = 'F', then AF is an input argument X! (and must be present); on entry, it must contain the factors X! L and U of A (possibly equilibrated if EQUED is present), X! returned by a previous call to LA_GESVX. X! X! IPIV Optional (input/output) INTEGER array, shape (:), X! size(IPIV) == size(A,1). X! If FACT is not present or FACT = 'N', then IPIV is an output X! argument and returns the pivot indices from the factorization X! A = PLU of the original matrix A, possibly equilibrated if X! EQUED is present. X! If FACT is present and FACT = 'F', then IPIV is an input argument X! (and must be present); on entry, it must contain the pivot X! indices from the factorization of A (possibly equilibrated X! if EQUED is present), returned by a previous call to LA_GESVX. X! X! TRANS Optional (input) CHARACTER*1 X! If TRANS is present, it specifies the form of the system X! of equations: X! = 'N': A X = B (No transpose) X! = 'T': A^T X = B (Transpose) X! = 'C': A^H X = B (Conjugate transpose = Transpose) X! otherwise TRANS = 'N' is assumed. X! X! FACT Optional (input) CHARACTER*1 X! Specifies whether or not the factored form of the matrix A is X! supplied on entry. X! If FACT is present then: X! = 'N': the matrix A will be equilibrated if EQUED is present, X! then copied to AF and factored. X! = 'F': on entry, AF and IPIV must contain the factored form X! of A (possibly equilibrated if EQUED is present). X! otherwise FACT = 'N' is assumed. X! X! EQUED Optional (input/output) CHARACTER*1 X! If FACT is not present or FACT = 'N', then EQUED is an output X! argument. If it is present, then the matrix is equilibrated, X! and on exit EQUED specifies the scaling of A which has X! actually been performed: X! = 'N': No equilibration. X! = 'R': Row equilibration, i.e., A has been premultiplied X! by diag(R); also B has been premultiplied by diag(R) X! if TRANS = 'N'. X! = 'C': Column equilibration, i.e., A has been postmultiplied X! by diag(C); also B has been postmultiplied by diag(C) X! if TRANS = 'T' or 'C'. X! = 'B': Both row and column equilibration: combines the X! effects of EQUED = 'R' and EQUED = 'C'. X! If FACT is present and FACT = 'F', then EQUED is an input X! argument; if it is present, it specifies the equilibration X! of A which was performed in a previous call to LA_GESVX with X! FACT not present or FACT = 'N'. X! X! R Optional (input/output) REAL array, shape (:), X! size(R) == size(A,1). X! R must be present if EQUED is present and EQUED = 'R' or 'B'; X! R is not referenced if EQUED = 'N' or 'C'. X! If FACT is not present or FACT = 'N', then R is an output X! argument. If EQUED = 'R' or 'B', R returns the row scale X! factors for equilibrating A. X! If FACT is present and FACT = 'F', then R is an input X! argument. If EQUED = 'R' or 'B', R must contain the row scale X! factors for equilibrating A, returned by a previous call to X! LA_GESVX; each element of R must be positive. X! X! C Optional (input/output) REAL array, shape (:), X! size(C) == size(A,1). X! C must be present if EQUED is present and EQUED = 'C' or 'B'; X! C is not referenced if EQUED = 'N' or 'R'. X! If FACT is not present or FACT = 'N', then C is an output X! argument. If EQUED = 'C' or 'B', C returns the column scale X! factors for equilibrating A. X! If FACT is present and FACT = 'F', then C is an input X! argument. If EQUED = 'C' or 'B', C must contain the column X! scale factors for equilibrating A, returned by a previous X! call to LA_GESVX; each element of C must be positive. X! X! FERR Optional (output) either REAL array of shape (:) or REAL X! scalar. If it is an array, size(FERR) == size(X,2). X! The estimated forward error bound for each solution vector X! X(j) (the j-th column of the solution matrix X). X! If XTRUE is the true solution corresponding to X(j), FERR(j) X! is an estimated upper bound for the magnitude of the largest X! element in (X(j) - XTRUE) divided by the magnitude of the X! largest element in X(j). The estimate is as reliable as X! the estimate for RCOND, and is almost always a slight X! overestimate of the true error. X! X! BERR Optional (output) either REAL array of shape (:) or REAL X! scalar. If it is an array, size(BERR) == size(X,2). X! The componentwise relative backward error of each solution X! vector X(j) (i.e., the smallest relative change in X! any element of A or B that makes X(j) an exact solution). X! X! RCOND Optional (output) REAL X! The estimate of the reciprocal condition number of the matrix X! A after equilibration (if done). If RCOND is less than the X! machine precision (in particular, if RCOND = 0), the matrix X! is singular to working precision. This condition is X! indicated by a return code of INFO > 0, and the solution and X! error bounds are not computed. X! X! RPVGRW Optional (output) REAL. X! The reciprocal pivot growth factor norm(A)/norm(U). X! If RPVGRW is much less than 1, then the stability X! of the LU factorization of the (equilibrated) matrix A X! could be poor. This also means that the solution X, condition X! estimator RCOND, and forward error bound FERR could be X! unreliable. If factorization fails with 0 0: if INFO = k, and k is X! <= N: U(k,k) is exactly zero. The factorization has X! been completed, but the factor U is exactly X! singular, so the solution and error bounds X! could not be computed. X! = N+1: RCOND is less than machine precision. The X! factorization has been completed, but the X! matrix is singular to working precision, and X! the solution and error bounds have not been X! computed. X! If INFO is not present and an error occurs, then the program is X! terminated with an error message. X! X! ===================================================================== X! X SUBROUTINE SGESVX_F90(A, B, X, AF, IPIV, FACT, TRANS, & X EQUED, R, C, FERR, BERR, RCOND, RPVGRW, INFO) X USE LA_PRECISION, ONLY: WP => SP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS, FACT X CHARACTER(LEN=1), INTENT(INOUT), OPTIONAL :: EQUED X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(INOUT), OPTIONAL :: IPIV(:) X REAL(WP), INTENT(OUT), OPTIONAL :: RCOND, RPVGRW X REAL(WP), INTENT(OUT), OPTIONAL :: FERR(:), BERR(:) X REAL(WP), INTENT(INOUT), OPTIONAL :: AF(:,:), C(:), R(:) X REAL(WP), INTENT(INOUT) :: A(:,:), B(:,:) X REAL(WP), INTENT(OUT) :: X(:,:) X END SUBROUTINE SGESVX_F90 X SUBROUTINE S1GESVX_F90(A, B, X, AF, IPIV, FACT, TRANS, & X EQUED, R, C, FERR, BERR, RCOND, RPVGRW, INFO) X USE LA_PRECISION, ONLY: WP => SP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS, FACT X CHARACTER(LEN=1), INTENT(INOUT), OPTIONAL :: EQUED X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(INOUT), OPTIONAL :: IPIV(:) X REAL(WP), INTENT(OUT), OPTIONAL :: RCOND, FERR, BERR, RPVGRW X REAL(WP), INTENT(INOUT), OPTIONAL :: AF(:,:), C(:), R(:) X REAL(WP), INTENT(INOUT) :: A(:,:), B(:) X REAL(WP), INTENT(OUT) :: X(:) X END SUBROUTINE S1GESVX_F90 X SUBROUTINE DGESVX_F90(A, B, X, AF, IPIV, FACT, TRANS, & X EQUED, R, C, FERR, BERR, RCOND, RPVGRW, INFO) X USE LA_PRECISION, ONLY: WP => DP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS, FACT X CHARACTER(LEN=1), INTENT(INOUT), OPTIONAL :: EQUED X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(INOUT), OPTIONAL :: IPIV(:) X REAL(WP), INTENT(OUT), OPTIONAL :: RCOND, RPVGRW X REAL(WP), INTENT(OUT), OPTIONAL :: FERR(:), BERR(:) X REAL(WP), INTENT(INOUT), OPTIONAL :: AF(:,:), C(:), R(:) X REAL(WP), INTENT(INOUT) :: A(:,:), B(:,:) X REAL(WP), INTENT(OUT) :: X(:,:) X END SUBROUTINE DGESVX_F90 X SUBROUTINE D1GESVX_F90(A, B, X, AF, IPIV, FACT, TRANS, & X EQUED, R, C, FERR, BERR, RCOND, RPVGRW, INFO) X USE LA_PRECISION, ONLY: WP => DP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS, FACT X CHARACTER(LEN=1), INTENT(INOUT), OPTIONAL :: EQUED X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(INOUT), OPTIONAL :: IPIV(:) X REAL(WP), INTENT(OUT), OPTIONAL :: RCOND, FERR, BERR, RPVGRW X REAL(WP), INTENT(INOUT), OPTIONAL :: AF(:,:), C(:), R(:) X REAL(WP), INTENT(INOUT) :: A(:,:), B(:) X REAL(WP), INTENT(OUT) :: X(:) X END SUBROUTINE D1GESVX_F90 X SUBROUTINE CGESVX_F90(A, B, X, AF, IPIV, FACT, TRANS, & X EQUED, R, C, FERR, BERR, RCOND, RPVGRW, INFO) X USE LA_PRECISION, ONLY: WP => SP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS, FACT X CHARACTER(LEN=1), INTENT(INOUT), OPTIONAL :: EQUED X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(INOUT), OPTIONAL :: IPIV(:) X REAL(WP), INTENT(OUT), OPTIONAL :: RCOND, RPVGRW X REAL(WP), INTENT(OUT), OPTIONAL :: FERR(:), BERR(:) X REAL(WP), INTENT(INOUT), OPTIONAL :: C(:), R(:) X COMPLEX(WP), INTENT(INOUT), OPTIONAL :: AF(:,:) X COMPLEX(WP), INTENT(INOUT) :: A(:,:), B(:,:) X COMPLEX(WP), INTENT(OUT) :: X(:,:) X END SUBROUTINE CGESVX_F90 X SUBROUTINE C1GESVX_F90(A, B, X, AF, IPIV, FACT, TRANS, & X EQUED, R, C, FERR, BERR, RCOND, RPVGRW, INFO) X USE LA_PRECISION, ONLY: WP => SP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS, FACT X CHARACTER(LEN=1), INTENT(INOUT), OPTIONAL :: EQUED X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(INOUT), OPTIONAL :: IPIV(:) X REAL(WP), INTENT(OUT), OPTIONAL :: RCOND, FERR, BERR, RPVGRW X REAL(WP), INTENT(INOUT), OPTIONAL :: C(:), R(:) X COMPLEX(WP), INTENT(INOUT), OPTIONAL :: AF(:,:) X COMPLEX(WP), INTENT(INOUT) :: A(:,:), B(:) X COMPLEX(WP), INTENT(OUT) :: X(:) X END SUBROUTINE C1GESVX_F90 X SUBROUTINE ZGESVX_F90(A, B, X, AF, IPIV, FACT, TRANS, & X EQUED, R, C, FERR, BERR, RCOND, RPVGRW, INFO) X USE LA_PRECISION, ONLY: WP => DP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS, FACT X CHARACTER(LEN=1), INTENT(INOUT), OPTIONAL :: EQUED X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(INOUT), OPTIONAL :: IPIV(:) X REAL(WP), INTENT(OUT), OPTIONAL :: RCOND, RPVGRW X REAL(WP), INTENT(OUT), OPTIONAL :: FERR(:), BERR(:) X REAL(WP), INTENT(INOUT), OPTIONAL :: C(:), R(:) X COMPLEX(WP), INTENT(INOUT), OPTIONAL :: AF(:,:) X COMPLEX(WP), INTENT(INOUT) :: A(:,:), B(:,:) X COMPLEX(WP), INTENT(OUT) :: X(:,:) X END SUBROUTINE ZGESVX_F90 X SUBROUTINE Z1GESVX_F90(A, B, X, AF, IPIV, FACT, TRANS, & X EQUED, R, C, FERR, BERR, RCOND, RPVGRW, INFO) X USE LA_PRECISION, ONLY: WP => DP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS, FACT X CHARACTER(LEN=1), INTENT(INOUT), OPTIONAL :: EQUED X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(INOUT), OPTIONAL :: IPIV(:) X REAL(WP), INTENT(OUT), OPTIONAL :: RCOND, FERR, BERR, RPVGRW X REAL(WP), INTENT(INOUT), OPTIONAL :: C(:), R(:) X COMPLEX(WP), INTENT(INOUT), OPTIONAL :: AF(:,:) X COMPLEX(WP), INTENT(INOUT) :: A(:,:), B(:) X COMPLEX(WP), INTENT(OUT) :: X(:) X END SUBROUTINE Z1GESVX_F90 X END INTERFACE X! X INTERFACE LA_GETRF X! X! Purpose X! ======= X! X! LA_GETRF computes an LU factorization of a general regtangle X! matrix A using partial pivoting with row interchanges. X! X! The factorization has the form A = PLU X! where P is a permutation matrix, L is lower triangular X! with unit diagonal elements (lower trapezoidal if m > n), X! and U is upper triangular (upper trapezoidal if m < n), X! where m=size(A,1) and n=size(A,2). X! X! When A is square (m = n), LA_GETRF optionally estimates the X! reciprocal of the condition number of a general matrix A, in either X! the 1-norm or the infinity-norm. X! An estimate is obtained for norm(inv(A)), and the reciprocal of the X! condition number is computed as RCOND = 1 / (norm(A) * norm(inv(A))). X! X! Arguments X! ========= X! X! SUBROUTINE LA_GETRF ( A, IPIV, RCOND, NORM, INFO ) X! (), INTENT(INOUT) :: A(:,:) X! INTEGER, INTENT( OUT ) :: IPIV( : ) X! REAL(), INTENT( OUT ), OPTIONAL :: RCOND X! CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: NORM X! INTEGER, INTENT(OUT), OPTIONAL :: INFO X! where X! ::= REAL | COMPLEX X! ::= KIND(1.0) | KIND(1.0D0) X! X! ==================== X! X! A (input/output) either REAL or COMPLEX array, shape (:,:). X! On entry, the matrix A. X! On exit, the factors L and U from the factorization A = PLU; X! the unit diagonal elements of L are not stored. X! X! IPIV (output) INTEGER array, shape (:), X! size(IPIV) == min(size(A,1),size(A,2)). X! IPIV indices that define the permutation matrix P; X! row i of the matrix A was interchanged with row IPIV(i). X! X! RCOND Optional (output) REAL X! The reciprocal of the condition number of the matrix A for X! the case m = n, computed as RCOND = 1/(norm(A) * norm(inv(A))). X! RCOND should be present if NORM is present. X! If m /= n then RCOND is returned as zero. X! X! NORM Optional (input) CHARACTER*1 X! Specifies whether the 1-norm condition number or the X! infinity-norm condition number is required: X! = '1', 'O' or 'o': 1-norm; X! = 'I', 'i': infinity-norm. X! If NORM is not present, the 1-norm is used. X! X! INFO Optional (output) INTEGER. X! If INFO is present X! = 0: successful exit X! < 0: if INFO = -k, the k-th argument had an illegal value X! > 0: if INFO = k, U(k,k) is exactly zero. The factorization X! has been completed, but the factor U is exactly X! singular, so the solution could not be computed. X! If INFO is not present and an error occurs, then the program is X! terminated with an error message. X! X! ===================================================================== X! X SUBROUTINE SGETRF_F90( A,IPIV,RCOND,NORM,INFO ) X USE LA_PRECISION, ONLY: WP => SP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: NORM X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT( OUT ) :: IPIV( : ) X REAL(WP), INTENT( INOUT ) :: A( :, : ) X REAL(WP), INTENT( OUT ), OPTIONAL :: RCOND X END SUBROUTINE SGETRF_F90 X SUBROUTINE DGETRF_F90( A,IPIV,RCOND,NORM,INFO ) X USE LA_PRECISION, ONLY: WP => DP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: NORM X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT( OUT ) :: IPIV( : ) X REAL(WP), INTENT( INOUT ) :: A( :, : ) X REAL(WP), INTENT( OUT ), OPTIONAL :: RCOND X END SUBROUTINE DGETRF_F90 X SUBROUTINE CGETRF_F90( A,IPIV,RCOND,NORM,INFO ) X USE LA_PRECISION, ONLY: WP => SP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: NORM X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT( OUT ) :: IPIV( : ) X COMPLEX(WP), INTENT( INOUT ) :: A( :, : ) X REAL(WP), INTENT( OUT ), OPTIONAL :: RCOND X END SUBROUTINE CGETRF_F90 X SUBROUTINE ZGETRF_F90( A,IPIV,RCOND,NORM,INFO ) X USE LA_PRECISION, ONLY: WP => DP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: NORM X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT( OUT ) :: IPIV( : ) X COMPLEX(WP), INTENT( INOUT ) :: A( :, : ) X REAL(WP), INTENT( OUT ), OPTIONAL :: RCOND X END SUBROUTINE ZGETRF_F90 X END INTERFACE X! X INTERFACE LA_GETRS X! X! Purpose X! ======= X! X! LA_GETRS solves a system of linear equations X! A X = B, A^T X = B or A^H X = B X! with a general square matrix A using the LU factorization computed X! by LA_GETRF. X! X! Arguments X! ========= X! SUBROUTINE LA_GETRS (A, IPIV, B, TRANS, INFO) X! (), INTENT(IN) :: A(:,:) X! (), INTENT(INOUT) :: X! INTEGER, INTENT(IN) :: IPIV(:) X! CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS X! INTEGER, INTENT(OUT), OPTIONAL :: INFO X! where X! ::= REAL | COMPLEX X! ::= KIND(1.0) | KIND(1.0D0) X! ::= B(:,:) | B(:) X! X! ===================== X! X! A (input) either REAL or COMPLEX square array, X! shape (:,:), size(A,1) == size(A,2). X! The factors L and U from the factorization A = PLU as computed X! by LA_GETRF. X! X! IPIV (input) INTEGER array, shape (:), size(IPIV) == size(A,1). X! The pivot indices from LA_GETRF; for 1<=i<=size(A,1), row i X! of the matrix was interchanged with row IPIV(i). X! X! B (input/output) either REAL or COMPLEX rectangular array, X! shape either (:,:) or (:), size(B,1) or size(B) == size(A,1). X! On entry, the right hand side vector(s) of matrix B for X! the system of equations AX = B. X! On exit, if there is no error, the matrix of solution X! vector(s) X. X! X! TRANS Optional (input) CHARACTER*1 X! If TRANS is present, it specifies the form of the system X! of equations: X! = 'N': A X = B (No transpose) X! = 'T': A^T X = B (Transpose) X! = 'C': A^H X = B (Conjugate transpose = Transpose) X! otherwise TRANS = 'N' is assumed. X! X! INFO Optional (output) INTEGER. X! If INFO is present X! = 0: successful exit X! < 0: if INFO = -k, the k-th argument had an illegal value X! If INFO is not present and an error occurs, then the program is X! terminated with an error message. X! X! ===================================================================== X! X SUBROUTINE SGETRS_F90(A,IPIV,B,TRANS,INFO) X USE LA_PRECISION, ONLY: SP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(IN) :: IPIV(:) X REAL(SP), INTENT(IN) :: A(:,:) X REAL(SP), INTENT(INOUT) :: B(:,:) X END SUBROUTINE SGETRS_F90 X SUBROUTINE DGETRS_F90(A,IPIV,B,TRANS,INFO) X USE LA_PRECISION, ONLY: DP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(IN) :: IPIV(:) X REAL(DP), INTENT(IN) :: A(:,:) X REAL(DP), INTENT(INOUT) :: B(:,:) X END SUBROUTINE DGETRS_F90 X SUBROUTINE CGETRS_F90(A,IPIV,B,TRANS,INFO) X USE LA_PRECISION, ONLY: SP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(IN) :: IPIV(:) X COMPLEX(SP), INTENT(IN) :: A(:,:) X COMPLEX(SP), INTENT(INOUT) :: B(:,:) X END SUBROUTINE CGETRS_F90 X SUBROUTINE ZGETRS_F90(A,IPIV,B,TRANS,INFO) X USE LA_PRECISION, ONLY: DP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(IN) :: IPIV(:) X COMPLEX(DP), INTENT(IN) :: A(:,:) X COMPLEX(DP), INTENT(INOUT) :: B(:,:) X END SUBROUTINE ZGETRS_F90 X SUBROUTINE S1GETRS_F90(A,IPIV,B,TRANS,INFO) X USE LA_PRECISION, ONLY: SP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(IN) :: IPIV(:) X REAL(SP), INTENT(IN) :: A(:,:) X REAL(SP), INTENT(INOUT) :: B(:) X END SUBROUTINE S1GETRS_F90 X SUBROUTINE D1GETRS_F90(A,IPIV,B,TRANS,INFO) X USE LA_PRECISION, ONLY: DP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(IN) :: IPIV(:) X REAL(DP), INTENT(IN) :: A(:,:) X REAL(DP), INTENT(INOUT) :: B(:) X END SUBROUTINE D1GETRS_F90 X SUBROUTINE C1GETRS_F90(A,IPIV,B,TRANS,INFO) X USE LA_PRECISION, ONLY: SP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(IN) :: IPIV(:) X COMPLEX(SP), INTENT(IN) :: A(:,:) X COMPLEX(SP), INTENT(INOUT) :: B(:) X END SUBROUTINE C1GETRS_F90 X SUBROUTINE Z1GETRS_F90(A,IPIV,B,TRANS,INFO) X USE LA_PRECISION, ONLY: DP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(IN) :: IPIV(:) X COMPLEX(DP), INTENT(IN) :: A(:,:) X COMPLEX(DP), INTENT(INOUT) :: B(:) X END SUBROUTINE Z1GETRS_F90 X END INTERFACE X! X INTERFACE LA_GETRI X! X! Purpose X! ======= X! X! LA_GETRI computes the inverse of a matrix using the LU factorization X! computed by LA_GETRF. X! X! Arguments X! ========= X! SUBROUTINE LA_GETRI (A, IPIV, INFO) X! (), INTENT(INOUT) :: A(:,:) X! INTEGER, INTENT(IN) :: IPIV(:) X! INTEGER, INTENT(OUT), OPTIONAL :: INFO X! where X! ::= REAL | COMPLEX X! ::= KIND(1.0) | KIND(1.0D0) X! X! ===================== X! X! A (input/output) either REAL or COMPLEX square array, shape (:,:), X! size(A,1) == size(A,2). X! On entry contains the factors L and U from the factorization X! A = PLU as computed by LA_GETRF. X! On exit, if INFO = 0, the inverse of the original matrix A. X! X! IPIV (input) INTEGER array, shape (:), size(IPIV) == size(A,1). X! The pivot indices from LA_GETRF; for 1<=i<=size(A,1), row i of X! the matrix was interchanged with row IPIV(i). X! X! INFO Optional (output) INTEGER. X! If INFO is present X! = 0: successful exit X! < 0: if INFO = -k, the k-th argument had an illegal value X! > 0: if INFO = k, U(k,k) is exactly zero. The matrix is X! singular and its inverse could not be computed. X! If INFO is not present and an error occurs, then the program is X! terminated with an error message. X! X! ===================================================================== X! X SUBROUTINE SGETRI_F90(A,IPIV,INFO) X USE LA_PRECISION, ONLY: WP => SP X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(IN) :: IPIV(:) X REAL(WP), INTENT(INOUT) :: A(:,:) X END SUBROUTINE SGETRI_F90 X SUBROUTINE DGETRI_F90(A,IPIV,INFO) X USE LA_PRECISION, ONLY: WP => DP X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(IN) :: IPIV(:) X REAL(WP), INTENT(INOUT) :: A(:,:) X END SUBROUTINE DGETRI_F90 X SUBROUTINE CGETRI_F90(A,IPIV,INFO) X USE LA_PRECISION, ONLY: WP => SP X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(IN) :: IPIV(:) X COMPLEX(WP), INTENT(INOUT) :: A(:,:) X END SUBROUTINE CGETRI_F90 X SUBROUTINE ZGETRI_F90(A,IPIV,INFO) X USE LA_PRECISION, ONLY: WP => DP X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(IN) :: IPIV(:) X COMPLEX(WP), INTENT(INOUT) :: A(:,:) X END SUBROUTINE ZGETRI_F90 X END INTERFACE X! X INTERFACE LA_GERFS X! X! Purpose X! ======= X! X! LA_GERFS improves the computed solution X of a system of linear X! equations A X = B or A^T X = B X! and provides error bounds and backward error estimates for X! the solution. LA_GERFS uses the LU factors computed by LA_GETRF. X! X! Arguments X! ========= X! SUBROUTINE LA_GERFS (A, AF, IPIV, B, X, TRANS, FERR, BERR, INFO) X! (), INTENT(IN) :: A(:,:), AF(:,:), X! INTEGER, INTENT(IN) :: IPIV(:) X! (), INTENT(INOUT) :: X! REAL(), INTENT(OUT), OPTIONAL :: X! CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS X! INTEGER, INTENT(OUT), OPTIONAL :: INFO X! where X! ::= REAL | COMPLEX X! ::= KIND(1.0) | KIND(1.0D0) X! ::= B(:,:) | B(:) X! ::= X(:,:) | X(:) X! ::= FERR(:), BERR(:) | FERR, BERR X! X! ===================== X! X! A (input) either REAL or COMPLEX square array, X! shape (:,:), size(A,1) == size(A,2). X! The original matrix A. X! X! AF (input) either REAL or COMPLEX square array, X! shape (:,:), size(AF,1) == size(AF,2) == size(A,1). X! The factors L and U from the factorization A = PLU X! as computed by LA_GETRF. X! X! IPIV (input) INTEGER array, shape (:), size(IPIV) == size(A,1). X! The pivot indices from LA_GETRF; for 1<=i<=size(A,1), row i X! of the matrix was interchanged with row IPIV(i). X! X! B (input) either REAL or COMPLEX rectangular array, X! shape either (:,:) or (:), size(B,1) or size(B) == size(A,1). X! The right hand side vector(s) of matrix B for X! the system of equations AX = B. X! X! X (input/output) either REAL or COMPLEX rectangular array, X! shape either (:,:) or (:), size(X,1) or size(X) == size(A,1). X! On entry, the solution matrix X, as computed by LA_GETRS. X! On exit, the improved solution matrix X. X! X! TRANS Optional (input) CHARACTER*1 X! If TRANS is present, it specifies the form of the system X! of equations: X! = 'N': A X = B (No transpose) X! = 'T': A^T X = B (Transpose) X! = 'C': A^H X = B (Conjugate transpose = Transpose) X! otherwise TRANS = 'N' is assumed. X! X! FERR Optional (output) either REAL array of shape (:) or REAL X! scalar. If it is an array, size(FERR) == size(X,2). X! The estimated forward error bound for each solution vector X! X(j) (the j-th column of the solution matrix X). X! If XTRUE is the true solution corresponding to X(j), FERR(j) X! is an estimated upper bound for the magnitude of the largest X! element in (X(j) - XTRUE) divided by the magnitude of the X! largest element in X(j). The estimate is as reliable as X! the estimate for RCOND, and is almost always a slight X! overestimate of the true error. X! X! BERR Optional (output) either REAL array of shape (:) or REAL X! scalar. If it is an array, size(BERR) == size(X,2). X! The componentwise relative backward error of each solution X! vector X(j) (i.e., the smallest relative change in X! any element of A or B that makes X(j) an exact solution). X! X! INFO Optional (output) INTEGER. X! If INFO is present X! = 0: successful exit X! < 0: if INFO = -k, the k-th argument had an illegal value X! If INFO is not present and an error occurs, then the program is X! terminated with an error message. X! X! Internal Parameters X! =================== X! X! ITMAX is the maximum number of steps of iterative refinement. X! It is set to 5 in the LAPACK77 subroutines X! X! ===================================================================== X! X SUBROUTINE SGERFS_F90(A,AF,IPIV,B,X,TRANS,FERR,BERR,INFO) X USE LA_PRECISION, ONLY: WP => SP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(IN) :: IPIV(:) X REAL(WP), INTENT(OUT), OPTIONAL :: FERR(:), BERR(:) X REAL(WP), INTENT(IN) :: A(:,:), AF(:,:), B(:,:) X REAL(WP), INTENT(INOUT) :: X(:,:) X END SUBROUTINE SGERFS_F90 X SUBROUTINE S1GERFS_F90(A,AF,IPIV,B,X,TRANS,FERR,BERR,INFO) X USE LA_PRECISION, ONLY: WP => SP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(IN) :: IPIV(:) X REAL(WP), INTENT(OUT), OPTIONAL :: FERR, BERR X REAL(WP), INTENT(IN) :: A(:,:), AF(:,:), B(:) X REAL(WP), INTENT(INOUT) :: X(:) X END SUBROUTINE S1GERFS_F90 X SUBROUTINE DGERFS_F90(A,AF,IPIV,B,X,TRANS,FERR,BERR,INFO) X USE LA_PRECISION, ONLY: WP => DP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(IN) :: IPIV(:) X REAL(WP), INTENT(OUT), OPTIONAL :: FERR(:), BERR(:) X REAL(WP), INTENT(IN) :: A(:,:), AF(:,:), B(:,:) X REAL(WP), INTENT(INOUT) :: X(:,:) X END SUBROUTINE DGERFS_F90 X SUBROUTINE D1GERFS_F90(A,AF,IPIV,B,X,TRANS,FERR,BERR,INFO) X USE LA_PRECISION, ONLY: WP => DP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(IN) :: IPIV(:) X REAL(WP), INTENT(OUT), OPTIONAL :: FERR, BERR X REAL(WP), INTENT(IN) :: A(:,:), AF(:,:), B(:) X REAL(WP), INTENT(INOUT) :: X(:) X END SUBROUTINE D1GERFS_F90 X SUBROUTINE CGERFS_F90(A,AF,IPIV,B,X,TRANS,FERR,BERR,INFO) X USE LA_PRECISION, ONLY: WP => SP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(IN) :: IPIV(:) X REAL(WP), INTENT(OUT), OPTIONAL :: FERR(:), BERR(:) X COMPLEX(WP), INTENT(IN) :: A(:,:), AF(:,:), B(:,:) X COMPLEX(WP), INTENT(INOUT) :: X(:,:) X END SUBROUTINE CGERFS_F90 X SUBROUTINE C1GERFS_F90(A,AF,IPIV,B,X,TRANS,FERR,BERR,INFO) X USE LA_PRECISION, ONLY: WP => SP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(IN) :: IPIV(:) X REAL(WP), INTENT(OUT), OPTIONAL :: FERR, BERR X COMPLEX(WP), INTENT(IN) :: A(:,:), AF(:,:), B(:) X COMPLEX(WP), INTENT(INOUT) :: X(:) X END SUBROUTINE C1GERFS_F90 X SUBROUTINE ZGERFS_F90(A,AF,IPIV,B,X,TRANS,FERR,BERR,INFO) X USE LA_PRECISION, ONLY: WP => DP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(IN) :: IPIV(:) X REAL(WP), INTENT(OUT), OPTIONAL :: FERR(:), BERR(:) X COMPLEX(WP), INTENT(IN) :: A(:,:), AF(:,:), B(:,:) X COMPLEX(WP), INTENT(INOUT) :: X(:,:) X END SUBROUTINE ZGERFS_F90 X SUBROUTINE Z1GERFS_F90(A,AF,IPIV,B,X,TRANS,FERR,BERR,INFO) X USE LA_PRECISION, ONLY: WP => DP X CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS X INTEGER, INTENT(OUT), OPTIONAL :: INFO X INTEGER, INTENT(IN) :: IPIV(:) X REAL(WP), INTENT(OUT), OPTIONAL :: FERR, BERR X COMPLEX(WP), INTENT(IN) :: A(:,:), AF(:,:), B(:) X COMPLEX(WP), INTENT(INOUT) :: X(:) X END SUBROUTINE Z1GERFS_F90 X END INTERFACE X! X INTERFACE LA_GEEQU X! X! Purpose X! ======= X! X! LA_GEEQU computes row and column scalings intended to equilibrate a X! rectangle matrix A and reduce its condition number. R returns the X! row scale factors and C the column scale factors, chosen to try to X! make the largest entry in each row and column of the matrix B with X! elements B(i,j) = R(i) A(i,j) C(j) have absolute value 1. X! X! R(i) and C(j) are restricted to be between SMLNUM = smallest safe X! number and BIGNUM = largest safe number. Use of these scaling X! factors is not guaranteed to reduce the condition number of A but X! works well in practice. X! X! Arguments X! ========= X! X! SUBROUTINE LA_GEEQU ( A, R, C, ROWCND, COLCND, AMAX, INFO ) X! (), INTENT(IN) :: A(:,:) X! REAL(), INTENT( OUT ) :: R(:), C(:) X! REAL(), INTENT( OUT ), OPTIONAL :: ROWCND, COLCND, AMAX X! INTEGER, INTENT(OUT), OPTIONAL :: INFO X! where X! ::= REAL | COMPLEX X! ::= KIND(1.0) | KIND(1.0D0) X! X! ==================== X! X! A (input) either REAL or COMPLEX array, shape (:,:). X! The matrix A, whose equilibration factors are to be computed. X! X! R (output) REAL array, shape (:), size(R) == size(A,1). X! If INFO = 0 or INFO > size(A,1), R contains the row X! scale factors for A. X! X! C (output) REAL array, shape (:), size(C) == size(A,2). X! If INFO = 0, C contains the column scale factors for A. X! X! ROWCND Optional (output) REAL. X! If INFO = 0 or INFO > size(A,1), ROWCND contains the ratio X! of the smallest R(i) to the largest R(i). If ROWCND >= 0.1 X! and AMAX is neither too large nor too small, it is not worth X! scaling by R. X! X! COLCND Optional (output) REAL. X! If INFO = 0, COLCND contains the ratio of the smallest X! C(i) to the largest C(i). If COLCND >= 0.1, it is not X! worth scaling by C. X! X! AMAX Optional (output) REAL. X! Absolute value of largest matrix element. If AMAX is very X! close to overflow or very close to underflow, the matrix X! should be scaled. X! X! INFO Optional (output) INTEGER X! If INFO is present X! = 0: successful exit X! < 0: if INFO = -k, the k-th argument had an illegal value X! > 0: if INFO = k, and k is X! <= M: the k-th row of A is exactly zero X! > M: the (k-M)-th column of A is exactly zero X! where M = size(A,1) X! If INFO is not present and an error occurs, then the program is X! terminated with an error message. X! X! ===================================================================== X SUBROUTINE SGEEQU_F90( A, R, C, ROWCND, COLCND, AMAX, INFO ) X USE LA_PRECISION, ONLY: WP => SP X INTEGER, INTENT(OUT), OPTIONAL :: INFO X REAL(WP), INTENT( IN ) :: A( :, : ) X REAL(WP), INTENT( OUT ) :: R(:), C(:) X REAL(WP), INTENT( OUT ), OPTIONAL :: ROWCND, COLCND, AMAX X END SUBROUTINE SGEEQU_F90 X SUBROUTINE DGEEQU_F90( A, R, C, ROWCND, COLCND, AMAX, INFO ) X USE LA_PRECISION, ONLY: WP => DP X INTEGER, INTENT(OUT), OPTIONAL :: INFO X REAL(WP), INTENT( IN ) :: A( :, : ) X REAL(WP), INTENT( OUT ) :: R(:), C(:) X REAL(WP), INTENT( OUT ), OPTIONAL :: ROWCND, COLCND, AMAX X END SUBROUTINE DGEEQU_F90 X SUBROUTINE CGEEQU_F90( A, R, C, ROWCND, COLCND, AMAX, INFO ) X USE LA_PRECISION, ONLY: WP => SP X INTEGER, INTENT(OUT), OPTIONAL :: INFO X COMPLEX(WP), INTENT( IN ) :: A( :, : ) X REAL(WP), INTENT( OUT ) :: R(:), C(:) X REAL(WP), INTENT( OUT ), OPTIONAL :: ROWCND, COLCND, AMAX X END SUBROUTINE CGEEQU_F90 X SUBROUTINE ZGEEQU_F90( A, R, C, ROWCND, COLCND, AMAX, INFO ) X USE LA_PRECISION, ONLY: WP => DP X INTEGER, INTENT(OUT), OPTIONAL :: INFO X COMPLEX(WP), INTENT( IN ) :: A( :, : ) X REAL(WP), INTENT( OUT ) :: R(:), C(:) X REAL(WP), INTENT( OUT ), OPTIONAL :: ROWCND, COLCND, AMAX X END SUBROUTINE ZGEEQU_F90 X END INTERFACE X! XEND MODULE LAPACK90_INTERFACES END_OF_FILE if test 45546 -ne `wc -c <'laf90mod.f90'`; then echo shar: \"'laf90mod.f90'\" unpacked with wrong size! fi # end of 'laf90mod.f90' fi if test -f 'pwcr_drv.f90' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'pwcr_drv.f90'\" else echo shar: Extracting \"'pwcr_drv.f90'\" \(4494 characters\) sed "s/^X//" >'pwcr_drv.f90' <<'END_OF_FILE' X!=========================================================================! X! file pwcr_drv.f90 ! X!=========================================================================! X! IMPROVED CYCLIC REDUCTION FOR SOLVING QUEUEING PROBLEMS ! X! by D.A. Bini and B. Meini ! X! (bini@dm.unipi.it meini@dm.unipi.it) ! X! Fortran 90 Program version 1.0, January 30, 1997 ! X! DRIVER PROGRAM ! X!=========================================================================! X! This is the driver program for solving the matrix equation ! X! A_1+X A_2+X^2 A_3+....X^(m-1) A_m-X=O (1) ! X! by means of pointwise cyclic reduction, where X is the (nb x nb) unknown! X! matrix and the (nb x nb) nonnegative matrices A_i, i=1,2,..., are such ! X! that A_1+A_2+...+A_m is column stochastic. ! X!=========================================================================! X! The program reads from the standard input the name of the file ! X! () containing the data. Then reads from the file ! X! the data and calls the subroutine PWCR solving the ! X! matrix equation (1). ! X! The computed solution is stored in the file ! X! it is written row-wise. ! X! The file must contain on each row the following data: ! X! 1-st row: NB ( integer ) = Block dimension ! X! 2-nd row: M ( integer ) = Number of blocks A_i ! X! 3-rd row: EPS ( real(kind(0.d0)) ) = Precision level ! X! The subsequent rows: L, I, J, VAL, where ! X! L : ( integer ) is the index of the block A_L ! X! I,J : ( integer ) are the indices of the (I,J)-th entry of the block ! X! A_L ! X! VAL : ( real(kind(0.d0)) ) is the value of the (I,J)-th entry of the ! X! block A_L ! X! The last row: 0,0,0,0.0d0 which denotes the end of the file. ! X! The values that are not reported in this file are intended to be zero. ! X!=========================================================================! XPROGRAM driver X USE pwcr_interface X IMPLICIT NONE X REAL(KIND(0.d0)), DIMENSION(:,:,:), POINTER :: a X REAL(KIND(0.d0)), DIMENSION(:,:), POINTER :: g X REAL(KIND(0.d0)) :: err, eps, val X INTEGER :: m, nb, i,j,l X CHARACTER(len=10) :: ifn X LOGICAL :: ex X WRITE(*,*)'-------------------------------------------------------' X WRITE(*,*)'IMPROVED CYCLIC REDUCTION FOR SOLVING QUEUEING PROBLEMS' X WRITE(*,*)' by D.A. Bini and B. Meini' X WRITE(*,*)' Fortran 90 Program version 1.0, January 30, 1997' X WRITE(*,*)'-------------------------------------------------------' X WRITE(*,*) X WRITE(*,'(A)', advance='NO')' Input-file name = ' X READ(*,*) ifn X INQUIRE(file=ifn, exist=ex) X IF(.NOT.ex)THEN X WRITE(*,*) X WRITE(*,*)'THE FILE ',ifn,'DOES NOT EXIST' X STOP X ENDIF X OPEN(unit=10,file=ifn,status='old') X J = INDEX(ifn,'.') X IF (J.EQ.0) J = INDEX(ifn,' ') X OPEN(unit=11,file=ifn(1:j-1)//'.out') X READ(10,*) nb X READ(10,*) m X READ(10,*) eps X ALLOCATE(a(nb,nb,m)) X ! reading data X a=0.0d0 X READ(10,*) l,i,j,val X reading : DO WHILE ( i/=0 ) X a(i,j,l)=val X READ(10,*)l,i,j,val X END DO reading X CALL pwcr(a,eps,g,err) X WRITE(11,*)'-------------------------------------------------------' X WRITE(11,*)'IMPROVED CYCLIC REDUCTION FOR SOLVING QUEUEING PROBLEMS' X WRITE(11,*)' by D.A. Bini and B. Meini' X WRITE(11,*)' Fortran 90 Program version 1.0, January 30, 1997' X WRITE(11,*)'-------------------------------------------------------' X WRITE(11,*) X WRITE(*,*)'Residual error=',err X WRITE(11,*)'Residual error=',err X WRITE(*,*) X WRITE(11,*) X loopw1 : DO i=1,nb X loopw2 : DO j=1,nb X WRITE(*,*)g(i,j) X WRITE(11,*)g(i,j) X END DO loopw2 X END DO loopw1 X STOP XEND PROGRAM driver X X X X X X X X X X END_OF_FILE if test 4494 -ne `wc -c <'pwcr_drv.f90'`; then echo shar: \"'pwcr_drv.f90'\" unpacked with wrong size! fi # end of 'pwcr_drv.f90' fi if test -f 'pwcr_fft.f90' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'pwcr_fft.f90'\" else echo shar: Extracting \"'pwcr_fft.f90'\" \(26485 characters\) sed "s/^X//" >'pwcr_fft.f90' <<'END_OF_FILE' X!=========================================================================! X! file pwcr_fft.f90 ! X!=========================================================================! X! IMPROVED CYCLIC REDUCTION FOR SOLVING QUEUEING PROBLEMS ! X! by D.A. Bini and B. Meini ! X! (bini@dm.unipi.it meini@dm.unipi.it) ! X! Fortran 90 Program version 1.0, January 30 1997 ! X! FFT subroutines ! X!=========================================================================! X! This file contains a set of subroutines needed in order ! X! to perform computations involving the Discrete Fourier Transform (DFT). ! X! More precisely the following subroutines are reported: ! X! ! X! fillroots : compute the roots of 1 ! X! ifft1 : compute the inverse DFT ! X! fft1 : compute the DFT ! X! iffts1 : compute the inverse DFT of the DFT of a real vector ! X! (Problem 2) ! X! ffts1 : compute the DFT of a real vector (Problem 1) ! X! iffts2 : solve Problem 4 ! X! ffts2 : solve Problem 3 ! X! twiddle : scale a complex vector ! X! itwiddle : scale a complex vector ! X! ftb1 : compute the block DFT of a real block vector (Problem 1 for ! X! matrix polynomials) ! X! ftb2 : solve Problem 3 for matrix polynomials ! X! iftb1 : compute the block inverse DFT of the DFT of a real block ! X! vector (Problem 2 for matrix polynomials) ! X! iftb2 : solve Problem 4 for matrix polynomials ! X!=========================================================================! X! SUBROUTINE FILLROOTS ! X!=========================================================================! X! Compute the n-th roots of 1 if they have not been yet computed before, ! X! otherwise return. ! X! The real and the imaginary parts of the roots are stored in the vectors ! X! wr, wi, respectively. These vectors are put in a common block. ! X!=========================================================================! Xsubroutine fillroots(n) X implicit none X real(kind(0.d0)), dimension(:), pointer :: wr, wi X real(kind(0.d0)), dimension(:), allocatable, save :: wwr, wwi X real(kind(0.d0)) :: pi, pi2 X integer :: i, j, k, m, mi1, n X common wr, wi X intrinsic size, allocated X pi= 6.28318530717958647692528676656d0/n X k=size(wr,1) X if(.not.allocated(wwr))then X allocate(wwr(n)) X allocate(wwi(n)) X allocate(wr(n)) X allocate(wi(n)) X loop1 : do i=1,n X pi2=(i-1)*pi X wwr(i)=cos(pi2) X wwi(i)=sin(pi2) X end do loop1 X wr=wwr X wi=wwi X return X end if X if(n<=k)then X return X end if X deallocate(wr) X deallocate(wi) X allocate(wr(n)) X allocate(wi(n)) X m=n/k X loop2 : do i=1,k X mi1=m*(i-1) X wr(mi1+1)=wwr(i) X wi(mi1+1)=wwi(i) X loop3 : do j=2,m X wr(mi1+j)=cos(pi*(mi1+j-1)) X wi(mi1+j)=sin(pi*(mi1+j-1)) X end do loop3 X end do loop2 X deallocate(wwr) X deallocate(wwi) X allocate(wwr(n)) X allocate(wwi(n)) X wwr=wr X wwi=wi X return Xend subroutine fillroots X X X X X!========================================================================! X! SUBROUTINE IFFT1 ! X!========================================================================! X! Compute the Inverse Discrete Fourier Transform of the vector having ! X! real parts stored in the vector x and imaginary parts stored in the ! X! vector y. On output x and y contain the real and the imaginary parts ! X! of the transformed vector, respectively. ! X! The algorithm is an adaptation of the split-radix FFT by ! X! Dhuamel-Hollman (Sorensen et al. IEEE trans. ! X! on Acoustics Speech and Signal Processing, ASSP-34, 1986). ! X!========================================================================! Xsubroutine ifft1(x,y) X use fft_interface, only : fillroots X implicit none X real(kind(0.d0)), dimension(:), pointer :: x,y X real(kind(0.d0)), dimension(:), pointer :: wr,wi X real(kind(0.d0)) :: r1, r2, s1, s2, s3, ss1, & X ss3, cc1, cc3, xt, yt, un X integer :: i, j, k, m, n, nmax, n2, & X n4, ne, na, is, id, & X i0, i1, i2, i3, n1 ,na3 X common wr,wi X intrinsic size X n=size(x,1) X m=log(n*1.d0)/log(2.d0) X if(2**m=j)goto 101 X xt=x(j) X yt=y(j) X y(j)=y(i) X y(i)=yt X x(j)=x(i) X x(i)=xt X101 k=n/2 X102 if (k>=j)goto 103 X j=j-k X k=k/2 X goto 102 X103 j=j+k X end do loop14 X un=1.d0/n X x=x*un X y=y*un X return Xend subroutine ifft1 X X X X!========================================================================! X! SUBROUTINE FFT1 ! X!========================================================================! X! Compute the Discrete Fourier Transform of the vector having ! X! real parts stored in the vector x and imaginary parts stored in the ! X! vector y. On output x and y contain the real and the imaginary parts ! X! of the transformed vector, respectively. ! X! The algorithm is an adaptation of the split-radix FFT by ! X! Dhuamel-Hollman (Sorensen et al. IEEE trans. ! X! on Acoustics Speech and Signal Processing, ASSP-34, 1986). ! X!========================================================================! Xsubroutine fft1(x,y) X use fft_interface, only : fillroots X implicit none X real(kind(0.d0)), dimension(:), pointer :: x,y X real(kind(0.d0)), dimension(:), pointer :: wr,wi X real(kind(0.d0)) :: r1, r2, r3, s2, ss1, ss3, & X cc1, cc3, xt, yt, s1 X integer :: i, j, k, m, n, nmax, n1, & X n2, n4, ne, na, is, id, & X i0, i1, i2, i3, na3 X common wr,wi X intrinsic size X n=size(x,1) X m=log(n*1.d0)/log(2.d0) X if(2**m=j)goto 101 X xt=x(j) X yt=y(j) X y(j)=y(i) X y(i)=yt X x(j)=x(i) X x(i)=xt X101 k=n/2 X102 if (k>=j)goto 103 X j=j-k X k=k/2 X goto 102 X103 j=j+k X end do loop104 X ! ---------------LENGTH TWO BUTTERFLIES-------------- X is=1 X id=4 X70 loop60 : do i0=is,n,id X i1=i0+1 X r1=x(i0) X x(i0)=r1+x(i1) X x(i1)=r1-x(i1) X r1=-y(i0) X y(i0)=-r1+y(i1) X y(i1)=-r1-y(i1) X end do loop60 X is=2*id-1 X id=4*id X if (is'pwcr_int.f90' <<'END_OF_FILE' X!=========================================================================! X! file pwcr_int.f90 ! X!=========================================================================! X! IMPROVED CYCLIC REDUCTION FOR SOLVING QUEUEING PROBLEMS ! X! by D.A. Bini and B. Meini ! X! (bini@dm.unipi.it meini@dm.unipi.it) ! X! Fortran 90 Program version 1.0, January 30 1997 ! X! Interface File for PWCR subroutines ! X!=========================================================================! X! Interface file for the subroutines: ! X! pwcr ! X! computeG ! X! residual ! X! schur ! X! test ! X! sc1p ! X! sc2p ! X! scc2p ! X! sc1 ! X! sc2 ! X! prodc ! X! means ! X! pmeans ! X! scc2 ! X! solver ! X! solvec ! X!=========================================================================! XMODULE pwcr_interface X INTERFACE X SUBROUTINE pwcr(a,eps,g,err) X IMPLICIT NONE X REAL(KIND(0.d0)), DIMENSION(:,:,:), POINTER :: a X REAL(KIND(0.d0)), DIMENSION(:,:), POINTER :: g X REAL(KIND(0.d0)) :: err, eps X END SUBROUTINE pwcr X endinterface X !======================================================================= X INTERFACE X SUBROUTINE computeG(a0,a0s,ae,ao,hae,hao,eps,g) X IMPLICIT NONE X REAL(KIND(0.d0)), DIMENSION(:,:,:), POINTER :: ae, ao, hae, hao X REAL(KIND(0.d0)), DIMENSION(:,:), POINTER :: a0, g X REAL(KIND(0.d0)), DIMENSION(:), POINTER :: a0s X REAL(KIND(0.d0)) :: eps X END SUBROUTINE computeG X endinterface X !======================================================================= X INTERFACE X SUBROUTINE residual(a,g,err) X IMPLICIT NONE X REAL(KIND(0.d0)), DIMENSION(:,:,:), POINTER :: a X REAL(KIND(0.d0)), DIMENSION(:,:), POINTER :: g X REAL(KIND(0.d0)) :: err X END SUBROUTINE residual X endinterface XEND MODULE pwcr_interface X!======================================================================= X!======================================================================= XMODULE schur_interface X INTERFACE X SUBROUTINE schur(ae,ao,hae,hao,mean,hmean,a1s,eps) X IMPLICIT NONE X REAL(KIND(0.d0)), DIMENSION(:,:,:), POINTER :: ae, ao, hae, hao X REAL(KIND(0.d0)), DIMENSION(:), POINTER :: mean, hmean, a1s X REAL(KIND(0.d0)) :: eps X END SUBROUTINE schur X END INTERFACE X !======================================================================= X INTERFACE X SUBROUTINE test(u,mean,eps,answer) X IMPLICIT NONE X REAL(KIND(0.d0)), POINTER, DIMENSION(:,:,:) :: u X REAL(KIND(0.d0)), POINTER, DIMENSION(:) :: mean X REAL(KIND(0.d0)) :: eps X LOGICAL :: answer X END SUBROUTINE test X END INTERFACE X !======================================================================= X INTERFACE X SUBROUTINE sc1p(tae,tao,a) X IMPLICIT NONE X REAL(KIND(0.d0)), POINTER, DIMENSION(:,:,:) :: tao, tae, a X END SUBROUTINE sc1p X END INTERFACE X !======================================================================= X INTERFACE X SUBROUTINE sc2p(tae,tao,a1,a2) X IMPLICIT NONE X REAL(KIND(0.d0)), POINTER, DIMENSION(:,:,:) :: tao, tae, a1, a2 X END SUBROUTINE sc2p X END INTERFACE X !======================================================================= X INTERFACE X SUBROUTINE scc2p(thae,thao,a1,a2) X IMPLICIT NONE X REAL(KIND(0.d0)), POINTER, DIMENSION(:,:,:) :: thao, thae, a1, a2 X END SUBROUTINE scc2p X END INTERFACE X !======================================================================= X INTERFACE X SUBROUTINE sc1(tae,tao,a) X IMPLICIT NONE X REAL(KIND(0.d0)), POINTER, DIMENSION(:,:,:) :: tae, tao, a X END SUBROUTINE sc1 X END INTERFACE X !======================================================================= X INTERFACE X SUBROUTINE sc2(tae,tao,a1,a2) X IMPLICIT NONE X REAL(KIND(0.d0)), POINTER, DIMENSION(:,:,:) :: tae, tao, a1, a2 X END SUBROUTINE sc2 X END INTERFACE X !======================================================================= X INTERFACE X SUBROUTINE prodc(a,b,ir,ic,rmat,cmat) X IMPLICIT NONE X REAL(KIND(0.d0)), POINTER, DIMENSION(:,:,:) :: a, b X REAL(KIND(0.d0)), POINTER, DIMENSION(:,:) :: rmat, cmat X INTEGER :: ir,ic X END SUBROUTINE prodc X END INTERFACE X !======================================================================= X INTERFACE X SUBROUTINE means(tae,tao,thae,mean,hmean) X IMPLICIT NONE X REAL(KIND(0.d0)), POINTER, DIMENSION(:,:,:) :: tae,tao, thae X REAL(KIND(0.d0)), POINTER, DIMENSION(:) :: mean,hmean X END SUBROUTINE means X END INTERFACE X !======================================================================= X INTERFACE X SUBROUTINE pmeans(ae,ao,hae,hao,mean,hmean) X IMPLICIT NONE X REAL(KIND(0.d0)), POINTER, DIMENSION(:,:,:) :: ae,ao, hae, hao X REAL(KIND(0.d0)), POINTER, DIMENSION(:) :: mean,hmean X END SUBROUTINE pmeans X END INTERFACE X !======================================================================= X INTERFACE X SUBROUTINE scc2(thae,thao,a1,a2) X IMPLICIT NONE X REAL(KIND(0.d0)), POINTER, DIMENSION(:,:,:) :: thae,thao, a1, a2 X END SUBROUTINE scc2 X END INTERFACE X !======================================================================= X INTERFACE X SUBROUTINE solver(rmat,termr) X IMPLICIT NONE X REAL(KIND(0.d0)), POINTER, DIMENSION(:,:) :: rmat,termr X END SUBROUTINE solver X END INTERFACE X !======================================================================= X INTERFACE X SUBROUTINE solvec(cmat,termc) X IMPLICIT NONE X COMPLEX(KIND(0.d0)), POINTER, DIMENSION(:,:) :: cmat,termc X END SUBROUTINE solvec X END INTERFACE X XEND MODULE schur_interface X X X X X X X X X X X X X X END_OF_FILE if test 7230 -ne `wc -c <'pwcr_int.f90'`; then echo shar: \"'pwcr_int.f90'\" unpacked with wrong size! fi # end of 'pwcr_int.f90' fi if test -f 'pwcr_sub.f90' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'pwcr_sub.f90'\" else echo shar: Extracting \"'pwcr_sub.f90'\" \(45750 characters\) sed "s/^X//" >'pwcr_sub.f90' <<'END_OF_FILE' X!=========================================================================! X! file pwcr_sub.f90 ! X!=========================================================================! X! IMPROVED CYCLIC REDUCTION FOR SOLVING QUEUEING PROBLEMS ! X! by D.A. Bini and B. Meini ! X! (bini@dm.unipi.it meini@dm.unipi.it) ! X! Fortran 90 Program version 1.0, January 30, 1997 ! X! SUBROUTINES ! X!=========================================================================! X! The following subroutines constitute a package for the solution of ! X! the matrix equation ! X! A_1+X A_2+X^2 A_3+....X^(m-1) A_m-X=O (1) ! X! where X is the (nb x nb) unknown matrix and the (nb x nb) ! X! nonnegative matrices A_i, i=1,2,..., are such that A_1+A_2+...+A_m ! X! is column stochastic. ! X! The method used in the subroutines is based on the cyclic reduction ! X! technique expressed in functional form and generates a sequence of ! X! approximations converging quadratically to the solution of (1). ! X! Unlike the method of Bini-Meini, SIMAX 1996, here the cyclic ! X! reduction step is implemented in a point-wise style. That is, all ! X! the intermediate matrix power series are evaluated at the set of ! X! Fourier points. This allows us to keep to the minimum value the ! X! size of the Fourier transforms involved in the subroutines with a ! X! consequent improvement of the performance of our algorithm. ! X!=========================================================================! X! This package is made up by the following subroutines ! X! pwcr (Point-Wise Cyclic Reduction): approximate the solution of ! X! (1) by means of cyclic reduction. ! X! computeG : approximate the solution of (1) if m=2. ! X! residual : compute the 1-norm of the residual ! X! G-A_1+G A_2+G^2 A_3+....G^(m-1) A_m, ! X! where G is an approximation of the solution X of (1). ! X! schur : execute one step of point-wise cyclic reduction by ! X! computing the Schur complement (formulae (7) and (8) in the ! X! paper) ! X! test : auxiliary subroutine used by schur ! X! sc1p : auxiliary subroutine used by schur ! X! sc2p : auxiliary subroutine used by schur ! X! scc2p : auxiliary subroutine used by schur ! X! sc1 : auxiliary subroutine used by schur ! X! sc2 : auxiliary subroutine used by schur ! X! scc2 : auxiliary subroutine used by schur ! X! prodc : compute complex matrix product by performing 3 real ! X! matrix multiplications. ! X! means : auxiliary subroutine used by test ! X! pmeans : auxiliary subroutine used by test ! X! solver : auxiliary subroutine for solving real linear systems ! X! solvec : auxiliary subroutine for solving complex linear systems ! X!=========================================================================! X! This package makes use also of auxiliary routines, for performing ! X! FFT computation, which have been collected in the separate file ! X! pwcr_fft.f90; the requested interfaces have been collected in the file ! X! fft_int.f90. ! X! Moreover, LAPACK and LAPACK90 subroutines and interfaces are used: ! X! the subroutines have been collected in the separate files solve.f and ! X! kgesv1.f90; the interfaces are contained in the files laauxmod.f90, ! X! laf77mod.f90, laf90mod.f90 ! X!=========================================================================! X X!=========================================================================! X! SUBROUTINE PWCR ! X!=========================================================================! X! This subroutine computes the matrix X solving the equation ! X! A_1+XA_2+X^2A_3+....X^(m-1)A_m-X=O ! X! where A_1+A_2+...+A_m is a column stochastic kxk matrix, ! X! by means of the method of pointwise cyclic reduction ! X!=========================================================================! X! Input varables: ! X! a : pointer associated with the blocks A_i, i=1,m ! X! eps : error bound used for checking the stop condition at each ! X! step of the cyclic reduction. ! X!=========================================================================! X! Output variables: ! X! g : pointer associated with the approximation of the solution X ! X! of (1) ! X! err : 1-norm of the left-hand side of (1) where X is replaced by g ! X!=========================================================================! X! Interfaces used: schur_interface, pwcr_interface ! X!=========================================================================! X! Subroutines used: schur, computeG, residual, pmeans ! X!=========================================================================! X X XSUBROUTINE PWCR(a,eps,g,err) X USE schur_interface X USE pwcr_interface, ONLY : computeG, residual X IMPLICIT NONE X REAL(KIND(0.d0)), DIMENSION(:,:,:), POINTER :: a, ae, ao, hae, hao X REAL(KIND(0.d0)), DIMENSION(:,:), POINTER :: a1, g X REAL(KIND(0.d0)), DIMENSION(:), POINTER :: mean, hmean, a1s X REAL(KIND(0.d0)) :: err, eps X INTEGER :: m, n, nb, j, & X l, l1, ln, step X INTRINSIC size X !------------------------------------- X ! Prepare the input X !------------------------------------- X m=SIZE(a,3) X nb=SIZE(a,1) X l1=m/2 X n=l1 X ln=LOG(1.0d0*n)/LOG(2.0d0) X IF(2**ln1) X step=step+1 X CALL pmeans(ae,ao,hae,hao,mean,hmean) X CALL schur(ae,ao,hae,hao,mean,hmean,a1s,eps) X n=SIZE(ae,3) X END DO pwcrstage X CALL computeG(a1,a1s,ae,ao,hae,hao,eps,g) X CALL residual(a,g,err) X RETURN XEND SUBROUTINE PWCR X X X X!=========================================================================! X! SUBROUTINE COMPUTEG ! X!=========================================================================! X! This subroutine computes the matrix X solving the equation ! X! A_1+XA_2+X^2A_3+....X^(m-1)A_m-X=O ! X! in the case where m=2. ! X!=========================================================================! X! Input variables: ! X! a1 : pointer associated with the block A_1 ! X! a1s : pointer associated with the vector (1,1,...,1)A1 ! X! ae : pointer associated with the block coefficients of the series ! X! \phi_{even}, i.e., A_1, A_3, ... ! X! ao : pointer associated with the block coefficients of the series ! X! \phi_{odd}, i.e, A_2, A_4, ... ! X! hae : pointer associated withthe block coefficients of the series ! X! \hat\phi_{even} ! X! hao : pointer associated with the block coefficients of the series ! X! \hat \phi_{odd} ! X! eps : error bound used for checking the stop condition. ! X!=========================================================================! X! Output variables: ! X! g : pointer associated with the approximation of the solution ! X! X of (1) ! X!=========================================================================! X! Interfaces used: lapack90_interfaces ! X!=========================================================================! X! Subroutines used: la_gesv ! X!=========================================================================! XSUBROUTINE computeG(a1,a1s,ae,ao,hae,hao,eps,g) X USE lapack90_interfaces X IMPLICIT NONE X REAL(KIND(0.d0)), DIMENSION(:,:,:), POINTER :: ae, ao, hae, hao X REAL(KIND(0.d0)), DIMENSION(:,:),POINTER :: a1, g, r X REAL(KIND(0.d0)), DIMENSION(:), POINTER :: a1s X REAL(KIND(0.d0)) :: s, eps X INTEGER, DIMENSION(:), POINTER :: ipiv X INTEGER :: n, nb, i, info X LOGICAL :: stoc X INTRINSIC size X nb=SIZE(ae,1) X n=SIZE(ae,3) X ALLOCATE(g(nb,nb)) X ALLOCATE(ipiv(nb)) X stoc=.TRUE. X loop50 : DO i=1,nb X s=a1s(i)+SUM(hao(:,i,1)) X IF(1.0d0-s>eps)stoc=.FALSE. X END DO loop50 X IF(stoc)THEN X g(:,:)=-TRANSPOSE(hao(:,:,1)) X loop10 : DO i=1,nb X g(i,i)=g(i,i)+1.0d0 X END DO loop10 X a1=TRANSPOSE(a1) X CALL la_gesv(g, a1,ipiv, info) X g=TRANSPOSE(a1) X RETURN X ENDIF X ALLOCATE(r(nb,nb)) X g=-TRANSPOSE(ao(:,:,1)) X loop100 : DO i=1,nb X g(i,i)=g(i,i)+1.0d0 X END DO loop100 X r=TRANSPOSE(ae(:,:,1)) X CALL la_gesv(g, r, ipiv, info) X r=TRANSPOSE(r) X g=-hao(:,:,1)-MATMUL(hae(:,:,1),r) X g=TRANSPOSE(g) X loop200 : DO i=1,nb X g(i,i)=g(i,i)+1.0d0 X END DO loop200 X a1=TRANSPOSE(a1) X CALL la_gesv(g, a1, ipiv, info) X g=TRANSPOSE(a1) X RETURN XEND SUBROUTINE computeG X X!=========================================================================! X! SUBROUTINE RESIDUAL ! X!=========================================================================! X! This subroutine computes the residual ERR, i.e., the 1-norm ! X! ERR = || A_1+GA_2+G^2A_3+....G^(m-1)A_m-G || ! X! where G is an approximation of the solution X of (1) ! X!=========================================================================! X! Input variables: ! X! a : pointer associated with the blocks A_1, A_2,..., A_m ! X! g : pointer associated with the approximation of the solution ! X! X of (1) ! X!=========================================================================! X! Output variables: ! X! err : the seeked residual ! X!=========================================================================! XSUBROUTINE residual(a,g,err) X IMPLICIT NONE X REAL(KIND(0.d0)), DIMENSION(:,:,:), POINTER :: a X REAL(KIND(0.d0)), DIMENSION(:,:), POINTER :: g, r X REAL(KIND(0.d0)) :: err, s X INTEGER :: n, nb, i X INTRINSIC size X nb=SIZE(a,1) X n=SIZE(a,3) X ALLOCATE(r(nb,nb)) X r=a(:,:,n) X loop1 : DO i=n-1,1,-1 X r=MATMUL(g,r)+a(:,:,i) X END DO loop1 X r=ABS(r-g) X err=0.0d0 X loop2 : DO i=1,nb X s=SUM(r(:,i)) X IF(s>err) err=s X END DO loop2 X RETURN XEND SUBROUTINE residual X X!=========================================================================! X! SUBROUTINE SCHUR ! X!=========================================================================! X! This subroutine performs one step of cyclic reduction by computing ! X! the even and the odd components of the matrix series \phi^{(n+1)} and ! X! \hat\phi^{(n+1)} (compare formulae (7), (8) in the paper) defining the ! X! Schur complement in the cyclic reduction process. ! X! The subroutine : ! X! - interpolates the series \phi_{even}, \phi_{odd}, \hat\phi_{even}, ! X! \hat\phi_{odd}, numerically truncated to polynomials of degree n-1, ! X! at the n-th roots of 1, ! X! - performes convolutions according to formula (7) of the paper ! X! - computes the matrix polynomials interpolating these values ! X! - checks the accuracy of the result; if the result is not accurate then ! X! doubles the number of interpolation points and repeats; otherwise ! X! outputs the block coefficients of the matrix power series. ! X!=========================================================================! X! Input variables: ! X! ae : pointer associated with the block coefficients of the series ! X! \phi_{even}, i.e., A_1, A_3, ... ! X! ao : pointer associated with the block coefficients of the series ! X! \phi_{odd}, i.e, A_2, A_4, ... ! X! hae : pointer associated withthe block coefficients of the series ! X! \hat\phi_{even} ! X! hao : pointer associated with the block coefficients of the series ! X! \hat \phi_{odd} ! X! mean : pointer associated with the vector (1,...,1)\phi'(1), ! X! for the current function \phi ! X! hmean: pointer associated with the vector (1,...,1)\hat\phi'(1) for ! X! the current function \hat\phi ! X! a1s : pointer associated with the vector (1,...,1)\phi(0), for ! X! the initial function \phi ! X! eps : error bound used for checking the stop condition. ! X!=========================================================================! X! Output variables: new values for AE, AO, HAE, HAO, MEAN, HMEAN ! X!=========================================================================! X! Interfaces used: fft_interface, schur_interface ! X!=========================================================================! X! Subroutines used: ftb1, iftb1, ftb2, iftb2, sc1p, sc2p, scc2p, sc1, sc2 ! X! scc2, means, test ! X!=========================================================================! XSUBROUTINE schur(ae,ao,hae,hao,mean,hmean,a1s,eps) X USE fft_interface X USE schur_interface, ONLY : sc1, sc2p, sc1p, sc2, scc2p, scc2, & X means, test X IMPLICIT NONE X REAL(KIND(0.d0)), DIMENSION(:,:,:), POINTER :: ae, ao, hae, hao X REAL(KIND(0.d0)), DIMENSION(:), POINTER :: mean, hmean, a1s X REAL(KIND(0.d0)) :: eps X REAL(KIND(0.d0)), DIMENSION(:,:,:), POINTER :: tae, tao, thae, thao, & X a1, a2, a3, a4 X REAL(KIND(0.0d0)) :: s1, s2 X INTEGER :: l,nn, nb, n, nradd X LOGICAL :: answer, hanswer X INTRINSIC size X nb=SIZE(ae,1) X n=SIZE(ae,3) X ALLOCATE(tae(nb,nb,n)) X ALLOCATE(tao(nb,nb,n)) X ALLOCATE(a1(nb,nb,n)) X ALLOCATE(a2(nb,nb,n)) X CALL ftb1(ae,tae) X CALL ftb1(ao,tao) X CALL sc1p(tae,tao,a1) X CALL sc2p(tae,tao,a1,a2) X ALLOCATE(a3(nb,nb,n)) X CALL iftb1(a2,a3) X ALLOCATE(thae(nb,nb,n)) X ALLOCATE(thao(nb,nb,n)) X CALL ftb1(hae,thae) X CALL ftb1(hao,thao) X CALL scc2p(thae,thao,a1,a2) X ALLOCATE(a4(nb,nb,n)) X CALL iftb1(a2,a4) X CALL means(tae,tao,thae,mean,hmean) X nn=n X nradd=0 X100 nradd=nradd+1 X ! check the accuracy of the matrix coefficients X CALL test(a3,mean,eps,answer) X CALL test(a4,hmean,eps,hanswer) X IF(answer.OR.hanswer) THEN ! double the number of interpolation points X IF(nradd>1)THEN X n=nn/2 X a1=ae X DEALLOCATE(ae) X ALLOCATE(ae(nb,nb,nn)) X ae(:,:,1:n)=a1 X ae(:,:,n+1:nn)=0.0d0 X a1=ao X DEALLOCATE(ao) X ALLOCATE(ao(nb,nb,nn)) X ao(:,:,1:n)=a1 X ao(:,:,n+1:nn)=0.0d0 X a1=hae X DEALLOCATE(hae) X ALLOCATE(hae(nb,nb,nn)) X hae(:,:,1:n)=a1 X hae(:,:,n+1:nn)=0.0d0 X a1=hao X DEALLOCATE(hao) X ALLOCATE(hao(nb,nb,nn)) X hao(:,:,1:n)=a1 X hao(:,:,n+1:nn)=0.0d0 X DEALLOCATE(a1) X ENDIF X CALL ftb2(ae,tae) X CALL ftb2(ao,tao) X CALL sc1(tae,tao,a1) X CALL sc2(tae,tao,a1,a2) X CALL iftb2(a2,a3) X CALL ftb2(hae,thae) X CALL ftb2(hao,thao) X CALL scc2(thae,thao,a1,a2) X CALL iftb2(a2,a4) X nn=2*nn X GOTO 100 X END IF X DEALLOCATE(ae) X DEALLOCATE(ao) X DEALLOCATE(hae) X DEALLOCATE(hao) X n=nn/2 X ALLOCATE(ae(nb,nb,n)) X ALLOCATE(ao(nb,nb,n)) X ALLOCATE(hae(nb,nb,n)) X ALLOCATE(hao(nb,nb,n)) X loop1 : DO l=1,nn/2 X ae(:,:,l)=a3(:,:,2*l-1) X ao(:,:,l)=a3(:,:,2*l) X hae(:,:,l)=a4(:,:,2*l) X hao(:,:,l)=a4(:,:,2*l-1) X END DO loop1 X loop2 : DO l=1,nb X s1=a1s(l)+SUM(hae(:,l,:))+SUM(hao(:,l,:)) X s2=SUM(ae(:,l,:))+SUM(ao(:,l,:)) X s1=1.d0/s1 X s2=1.d0/s2 X ae(:,l,:)=ae(:,l,:)*s2 X ao(:,l,:)=ao(:,l,:)*s2 X hae(:,l,:)=hae(:,l,:)*s1 X hao(:,l,:)=hao(:,l,:)*s1 X END DO loop2 X RETURN XEND SUBROUTINE schur X X X!=========================================================================! X! SUBROUTINE TEST ! X!=========================================================================! X! This subroutine applies the test (12) in the paper and outputs ! X! answer=.true. if the number of interpolation point must be doubled ! X! (failure of the test), otherwise outputs answer=.false. ! X!=========================================================================! X! Input variables ! X! u : pointer associated with the matrix coefficients of the ! X! polynomial interpolating \phi (or \hat\phi) at the root of 1. ! X! mean: pointer associated with the exact value of (1,...,1)\phi'(1), ! X! or (1,...,1)\hat\phi'(1), ! X! eps : error bound ! X!=========================================================================! X! Output variables ! X! answer ! X!=========================================================================! XSUBROUTINE test(u, mean, eps, answer) X IMPLICIT NONE X REAL(KIND(0.d0)), POINTER, DIMENSION(:,:,:) :: u X REAL(KIND(0.d0)), POINTER, DIMENSION(:) :: mean X REAL(KIND(0.d0)) :: eps, v, err X INTEGER :: j, l, n, nb X LOGICAL :: answer X INTRINSIC size X n=SIZE(u,3) X nb=SIZE(u,1) X answer=.FALSE. X err=0.d0 X loop10 : DO j=1,nb X v=0.d0 X loop20 : DO l=2,n X v=v+SUM(u(:,j,l))*(l-1) X END DO loop20 X IF(ABS(v-mean(j))>eps)answer=.TRUE. X IF(err1) termr=TRANSPOSE(termr) X CALL la_gesv(rmat,termr,ipiv,info) X IF(SIZE(termr,2)>1) termr=TRANSPOSE(termr) X RETURN XEND SUBROUTINE solver X X X X!=========================================================================! X! SUBROUTINE SOLVEC ! X!=========================================================================! X! This subroutine solves the complex linear system x cmat = termc, where ! X! cmat is a square matrix, termc is a matrix ! X!=========================================================================! X! Input variables: ! X! cmat : pointer associated with the matrix cmat ! X! termc : pointer associated with the vector termc ! X!=========================================================================! X! Output variables: ! X! termc: pointer associated with the solution X of the system ! X!=========================================================================! X! Used interfaces: lapack90_interfaces ! X!=========================================================================! X! Used subroutines: la_gesv ! X!=========================================================================! XSUBROUTINE solvec(cmat, termc) X USE lapack90_interfaces X IMPLICIT NONE X COMPLEX(KIND(0.d0)), POINTER, DIMENSION(:,:) :: cmat,termc X INTEGER, POINTER, DIMENSION(:) :: ipiv X INTEGER :: info, nb X INTRINSIC size X nb=SIZE(cmat,1) X ALLOCATE(ipiv(nb)) X cmat=TRANSPOSE(cmat) X termc=TRANSPOSE(termc) X CALL la_gesv(cmat,termc,ipiv,info) X termc=TRANSPOSE(termc) X RETURN XEND SUBROUTINE solvec X X X X X X X X X X X X X X X X X X X X END_OF_FILE if test 45750 -ne `wc -c <'pwcr_sub.f90'`; then echo shar: \"'pwcr_sub.f90'\" unpacked with wrong size! fi # end of 'pwcr_sub.f90' fi if test -f 'solve.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'solve.f'\" else echo shar: Extracting \"'solve.f'\" \(121427 characters\) sed "s/^X//" >'solve.f' <<'END_OF_FILE' Xc===================================================================== Xc file solve.f Xc===================================================================== Xc /netlib/lapack Xc LAPACK, Version 2.0 Date: September 30, 1994 Xc Xc lib: double (tar) Xc o for: double precision real LAPACK routines Xc o prec: double Xc lib: util (tar) Xc o for: LAPACK utility routines Xc===================================================================== X X SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) X* X* -- LAPACK driver routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* March 31, 1993 X* X* .. Scalar Arguments .. X INTEGER INFO, LDA, LDB, N, NRHS X* .. X* .. Array Arguments .. X INTEGER IPIV( * ) X DOUBLE PRECISION A( LDA, * ), B( LDB, * ) X* .. X* X* Purpose X* ======= X* X* DGESV computes the solution to a real system of linear equations X* A * X = B, X* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. X* X* The LU decomposition with partial pivoting and row interchanges is X* used to factor A as X* A = P * L * U, X* where P is a permutation matrix, L is unit lower triangular, and U is X* upper triangular. The factored form of A is then used to solve the X* system of equations A * X = B. X* X* Arguments X* ========= X* X* N (input) INTEGER X* The number of linear equations, i.e., the order of the X* matrix A. N >= 0. X* X* NRHS (input) INTEGER X* The number of right hand sides, i.e., the number of columns X* of the matrix B. NRHS >= 0. X* X* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) X* On entry, the N-by-N coefficient matrix A. X* On exit, the factors L and U from the factorization X* A = P*L*U; the unit diagonal elements of L are not stored. X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(1,N). X* X* IPIV (output) INTEGER array, dimension (N) X* The pivot indices that define the permutation matrix P; X* row i of the matrix was interchanged with row IPIV(i). X* X* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) X* On entry, the N-by-NRHS matrix of right hand side matrix B. X* On exit, if INFO = 0, the N-by-NRHS solution matrix X. X* X* LDB (input) INTEGER X* The leading dimension of the array B. LDB >= max(1,N). X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* > 0: if INFO = i, U(i,i) is exactly zero. The factorization X* has been completed, but the factor U is exactly X* singular, so the solution could not be computed. X* X* ===================================================================== X* X* .. External Subroutines .. X EXTERNAL DGETRF, DGETRS, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF( N.LT.0 ) THEN X INFO = -1 X ELSE IF( NRHS.LT.0 ) THEN X INFO = -2 X ELSE IF( LDA.LT.MAX( 1, N ) ) THEN X INFO = -4 X ELSE IF( LDB.LT.MAX( 1, N ) ) THEN X INFO = -7 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DGESV ', -INFO ) X RETURN X END IF X* X* Compute the LU factorization of A. X* X CALL DGETRF( N, N, A, LDA, IPIV, INFO ) X IF( INFO.EQ.0 ) THEN X* X* Solve the system A*X = B, overwriting B with X. X* X CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, X $ INFO ) X END IF X RETURN X* X* End of DGESV X* X END X X X SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* June 30, 1992 X* X* .. Scalar Arguments .. X INTEGER INFO, LDA, M, N X* .. X* .. Array Arguments .. X INTEGER IPIV( * ) X DOUBLE PRECISION A( LDA, * ) X* .. X* X* Purpose X* ======= X* X* DGETF2 computes an LU factorization of a general m-by-n matrix A X* using partial pivoting with row interchanges. X* X* The factorization has the form X* A = P * L * U X* where P is a permutation matrix, L is lower triangular with unit X* diagonal elements (lower trapezoidal if m > n), and U is upper X* triangular (upper trapezoidal if m < n). X* X* This is the right-looking Level 2 BLAS version of the algorithm. X* X* Arguments X* ========= X* X* M (input) INTEGER X* The number of rows of the matrix A. M >= 0. X* X* N (input) INTEGER X* The number of columns of the matrix A. N >= 0. X* X* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) X* On entry, the m by n matrix to be factored. X* On exit, the factors L and U from the factorization X* A = P*L*U; the unit diagonal elements of L are not stored. X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(1,M). X* X* IPIV (output) INTEGER array, dimension (min(M,N)) X* The pivot indices; for 1 <= i <= min(M,N), row i of the X* matrix was interchanged with row IPIV(i). X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -k, the k-th argument had an illegal value X* > 0: if INFO = k, U(k,k) is exactly zero. The factorization X* has been completed, but the factor U is exactly X* singular, and division by zero will occur if it is used X* to solve a system of equations. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER J, JP X* .. X* .. External Functions .. X INTEGER IDAMAX X EXTERNAL IDAMAX X* .. X* .. External Subroutines .. X EXTERNAL DGER, DSCAL, DSWAP, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX, MIN X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF( M.LT.0 ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X ELSE IF( LDA.LT.MAX( 1, M ) ) THEN X INFO = -4 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DGETF2', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( M.EQ.0 .OR. N.EQ.0 ) X $ RETURN X* X DO 10 J = 1, MIN( M, N ) X* X* Find pivot and test for singularity. X* X JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) X IPIV( J ) = JP X IF( A( JP, J ).NE.ZERO ) THEN X* X* Apply the interchange to columns 1:N. X* X IF( JP.NE.J ) X $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) X* X* Compute elements J+1:M of J-th column. X* X IF( J.LT.M ) X $ CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) X* X ELSE IF( INFO.EQ.0 ) THEN X* X INFO = J X END IF X* X IF( J.LT.MIN( M, N ) ) THEN X* X* Update trailing submatrix. X* X CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, X $ A( J+1, J+1 ), LDA ) X END IF X 10 CONTINUE X RETURN X* X* End of DGETF2 X* X END X X X SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* March 31, 1993 X* X* .. Scalar Arguments .. X INTEGER INFO, LDA, M, N X* .. X* .. Array Arguments .. X INTEGER IPIV( * ) X DOUBLE PRECISION A( LDA, * ) X* .. X* X* Purpose X* ======= X* X* DGETRF computes an LU factorization of a general M-by-N matrix A X* using partial pivoting with row interchanges. X* X* The factorization has the form X* A = P * L * U X* where P is a permutation matrix, L is lower triangular with unit X* diagonal elements (lower trapezoidal if m > n), and U is upper X* triangular (upper trapezoidal if m < n). X* X* This is the right-looking Level 3 BLAS version of the algorithm. X* X* Arguments X* ========= X* X* M (input) INTEGER X* The number of rows of the matrix A. M >= 0. X* X* N (input) INTEGER X* The number of columns of the matrix A. N >= 0. X* X* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) X* On entry, the M-by-N matrix to be factored. X* On exit, the factors L and U from the factorization X* A = P*L*U; the unit diagonal elements of L are not stored. X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(1,M). X* X* IPIV (output) INTEGER array, dimension (min(M,N)) X* The pivot indices; for 1 <= i <= min(M,N), row i of the X* matrix was interchanged with row IPIV(i). X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* > 0: if INFO = i, U(i,i) is exactly zero. The factorization X* has been completed, but the factor U is exactly X* singular, and division by zero will occur if it is used X* to solve a system of equations. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER I, IINFO, J, JB, NB X* .. X* .. External Subroutines .. X EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA X* .. X* .. External Functions .. X INTEGER ILAENV X EXTERNAL ILAENV X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX, MIN X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF( M.LT.0 ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X ELSE IF( LDA.LT.MAX( 1, M ) ) THEN X INFO = -4 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DGETRF', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( M.EQ.0 .OR. N.EQ.0 ) X $ RETURN X* X* Determine the block size for this environment. X* X NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) X IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN X* X* Use unblocked code. X* X CALL DGETF2( M, N, A, LDA, IPIV, INFO ) X ELSE X* X* Use blocked code. X* X DO 20 J = 1, MIN( M, N ), NB X JB = MIN( MIN( M, N )-J+1, NB ) X* X* Factor diagonal and subdiagonal blocks and test for exact X* singularity. X* X CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) X* X* Adjust INFO and the pivot indices. X* X IF( INFO.EQ.0 .AND. IINFO.GT.0 ) X $ INFO = IINFO + J - 1 X DO 10 I = J, MIN( M, J+JB-1 ) X IPIV( I ) = J - 1 + IPIV( I ) X 10 CONTINUE X* X* Apply interchanges to columns 1:J-1. X* X CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) X* X IF( J+JB.LE.N ) THEN X* X* Apply interchanges to columns J+JB:N. X* X CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, X $ IPIV, 1 ) X* X* Compute block row of U. X* X CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, X $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), X $ LDA ) X IF( J+JB.LE.M ) THEN X* X* Update trailing submatrix. X* X CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, X $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, X $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), X $ LDA ) X END IF X END IF X 20 CONTINUE X END IF X RETURN X* X* End of DGETRF X* X END X X X SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* March 31, 1993 X* X* .. Scalar Arguments .. X CHARACTER TRANS X INTEGER INFO, LDA, LDB, N, NRHS X* .. X* .. Array Arguments .. X INTEGER IPIV( * ) X DOUBLE PRECISION A( LDA, * ), B( LDB, * ) X* .. X* X* Purpose X* ======= X* X* DGETRS solves a system of linear equations X* A * X = B or A' * X = B X* with a general N-by-N matrix A using the LU factorization computed X* by DGETRF. X* X* Arguments X* ========= X* X* TRANS (input) CHARACTER*1 X* Specifies the form of the system of equations: X* = 'N': A * X = B (No transpose) X* = 'T': A'* X = B (Transpose) X* = 'C': A'* X = B (Conjugate transpose = Transpose) X* X* N (input) INTEGER X* The order of the matrix A. N >= 0. X* X* NRHS (input) INTEGER X* The number of right hand sides, i.e., the number of columns X* of the matrix B. NRHS >= 0. X* X* A (input) DOUBLE PRECISION array, dimension (LDA,N) X* The factors L and U from the factorization A = P*L*U X* as computed by DGETRF. X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(1,N). X* X* IPIV (input) INTEGER array, dimension (N) X* The pivot indices from DGETRF; for 1<=i<=N, row i of the X* matrix was interchanged with row IPIV(i). X* X* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) X* On entry, the right hand side matrix B. X* On exit, the solution matrix X. X* X* LDB (input) INTEGER X* The leading dimension of the array B. LDB >= max(1,N). X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D+0 ) X* .. X* .. Local Scalars .. X LOGICAL NOTRAN X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. External Subroutines .. X EXTERNAL DLASWP, DTRSM, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X NOTRAN = LSAME( TRANS, 'N' ) X IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. X $ LSAME( TRANS, 'C' ) ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X ELSE IF( NRHS.LT.0 ) THEN X INFO = -3 X ELSE IF( LDA.LT.MAX( 1, N ) ) THEN X INFO = -5 X ELSE IF( LDB.LT.MAX( 1, N ) ) THEN X INFO = -8 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DGETRS', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( N.EQ.0 .OR. NRHS.EQ.0 ) X $ RETURN X* X IF( NOTRAN ) THEN X* X* Solve A * X = B. X* X* Apply row interchanges to the right hand sides. X* X CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) X* X* Solve L*X = B, overwriting B with X. X* X CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, X $ ONE, A, LDA, B, LDB ) X* X* Solve U*X = B, overwriting B with X. X* X CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, X $ NRHS, ONE, A, LDA, B, LDB ) X ELSE X* X* Solve A' * X = B. X* X* Solve U'*X = B, overwriting B with X. X* X CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, X $ ONE, A, LDA, B, LDB ) X* X* Solve L'*X = B, overwriting B with X. X* X CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, X $ A, LDA, B, LDB ) X* X* Apply row interchanges to the solution vectors. X* X CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) X END IF X* X RETURN X* X* End of DGETRS X* X END X X X SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* October 31, 1992 X* X* .. Scalar Arguments .. X INTEGER INCX, K1, K2, LDA, N X* .. X* .. Array Arguments .. X INTEGER IPIV( * ) X DOUBLE PRECISION A( LDA, * ) X* .. X* X* Purpose X* ======= X* X* DLASWP performs a series of row interchanges on the matrix A. X* One row interchange is initiated for each of rows K1 through K2 of A. X* X* Arguments X* ========= X* X* N (input) INTEGER X* The number of columns of the matrix A. X* X* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) X* On entry, the matrix of column dimension N to which the row X* interchanges will be applied. X* On exit, the permuted matrix. X* X* LDA (input) INTEGER X* The leading dimension of the array A. X* X* K1 (input) INTEGER X* The first element of IPIV for which a row interchange will X* be done. X* X* K2 (input) INTEGER X* The last element of IPIV for which a row interchange will X* be done. X* X* IPIV (input) INTEGER array, dimension (M*abs(INCX)) X* The vector of pivot indices. Only the elements in positions X* K1 through K2 of IPIV are accessed. X* IPIV(K) = L implies rows K and L are to be interchanged. X* X* INCX (input) INTEGER X* The increment between successive values of IPIV. If IPIV X* is negative, the pivots are applied in reverse order. X* X* ===================================================================== X* X* .. Local Scalars .. X INTEGER I, IP, IX X* .. X* .. External Subroutines .. X EXTERNAL DSWAP X* .. X* .. Executable Statements .. X* X* Interchange row I with row IPIV(I) for each of rows K1 through K2. X* X IF( INCX.EQ.0 ) X $ RETURN X IF( INCX.GT.0 ) THEN X IX = K1 X ELSE X IX = 1 + ( 1-K2 )*INCX X END IF X IF( INCX.EQ.1 ) THEN X DO 10 I = K1, K2 X IP = IPIV( I ) X IF( IP.NE.I ) X $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) X 10 CONTINUE X ELSE IF( INCX.GT.1 ) THEN X DO 20 I = K1, K2 X IP = IPIV( IX ) X IF( IP.NE.I ) X $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) X IX = IX + INCX X 20 CONTINUE X ELSE IF( INCX.LT.0 ) THEN X DO 30 I = K2, K1, -1 X IP = IPIV( IX ) X IF( IP.NE.I ) X $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) X IX = IX + INCX X 30 CONTINUE X END IF X* X RETURN X* X* End of DLASWP X* X END X X X integer function idamax(n,dx,incx) Xc Xc finds the index of element having max. absolute value. Xc jack dongarra, linpack, 3/11/78. Xc modified 3/93 to return if incx .le. 0. Xc modified 12/3/93, array(1) declarations changed to array(*) Xc X double precision dx(*),dmax X integer i,incx,ix,n Xc X idamax = 0 X if( n.lt.1 .or. incx.le.0 ) return X idamax = 1 X if(n.eq.1)return X if(incx.eq.1)go to 20 Xc Xc code for increment not equal to 1 Xc X ix = 1 X dmax = dabs(dx(1)) X ix = ix + incx X do 10 i = 2,n X if(dabs(dx(ix)).le.dmax) go to 5 X idamax = i X dmax = dabs(dx(ix)) X 5 ix = ix + incx X 10 continue X return Xc Xc code for increment equal to 1 Xc X 20 dmax = dabs(dx(1)) X do 30 i = 2,n X if(dabs(dx(i)).le.dmax) go to 30 X idamax = i X dmax = dabs(dx(i)) X 30 continue X return X end X X X subroutine dscal(n,da,dx,incx) Xc Xc scales a vector by a constant. Xc uses unrolled loops for increment equal to one. Xc jack dongarra, linpack, 3/11/78. Xc modified 3/93 to return if incx .le. 0. Xc modified 12/3/93, array(1) declarations changed to array(*) Xc X double precision da,dx(*) X integer i,incx,m,mp1,n,nincx Xc X if( n.le.0 .or. incx.le.0 )return X if(incx.eq.1)go to 20 Xc Xc code for increment not equal to 1 Xc X nincx = n*incx X do 10 i = 1,nincx,incx X dx(i) = da*dx(i) X 10 continue X return Xc Xc code for increment equal to 1 Xc Xc Xc clean-up loop Xc X 20 m = mod(n,5) X if( m .eq. 0 ) go to 40 X do 30 i = 1,m X dx(i) = da*dx(i) X 30 continue X if( n .lt. 5 ) return X 40 mp1 = m + 1 X do 50 i = mp1,n,5 X dx(i) = da*dx(i) X dx(i + 1) = da*dx(i + 1) X dx(i + 2) = da*dx(i + 2) X dx(i + 3) = da*dx(i + 3) X dx(i + 4) = da*dx(i + 4) X 50 continue X return X end X X X subroutine dswap (n,dx,incx,dy,incy) Xc Xc interchanges two vectors. Xc uses unrolled loops for increments equal one. Xc jack dongarra, linpack, 3/11/78. Xc modified 12/3/93, array(1) declarations changed to array(*) Xc X double precision dx(*),dy(*),dtemp X integer i,incx,incy,ix,iy,m,mp1,n Xc X if(n.le.0)return X if(incx.eq.1.and.incy.eq.1)go to 20 Xc Xc code for unequal increments or equal increments not equal Xc to 1 Xc X ix = 1 X iy = 1 X if(incx.lt.0)ix = (-n+1)*incx + 1 X if(incy.lt.0)iy = (-n+1)*incy + 1 X do 10 i = 1,n X dtemp = dx(ix) X dx(ix) = dy(iy) X dy(iy) = dtemp X ix = ix + incx X iy = iy + incy X 10 continue X return Xc Xc code for both increments equal to 1 Xc Xc Xc clean-up loop Xc X 20 m = mod(n,3) X if( m .eq. 0 ) go to 40 X do 30 i = 1,m X dtemp = dx(i) X dx(i) = dy(i) X dy(i) = dtemp X 30 continue X if( n .lt. 3 ) return X 40 mp1 = m + 1 X do 50 i = mp1,n,3 X dtemp = dx(i) X dx(i) = dy(i) X dy(i) = dtemp X dtemp = dx(i + 1) X dx(i + 1) = dy(i + 1) X dy(i + 1) = dtemp X dtemp = dx(i + 2) X dx(i + 2) = dy(i + 2) X dy(i + 2) = dtemp X 50 continue X return X end X X X INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, X $ N4 ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X CHARACTER*( * ) NAME, OPTS X INTEGER ISPEC, N1, N2, N3, N4 X* .. X* X* Purpose X* ======= X* X* ILAENV is called from the LAPACK routines to choose problem-dependent X* parameters for the local environment. See ISPEC for a description of X* the parameters. X* X* This version provides a set of parameters which should give good, X* but not optimal, performance on many of the currently available X* computers. Users are encouraged to modify this subroutine to set X* the tuning parameters for their particular machine using the option X* and problem size information in the arguments. X* X* This routine will not function correctly if it is converted to all X* lower case. Converting it to all upper case is allowed. X* X* Arguments X* ========= X* X* ISPEC (input) INTEGER X* Specifies the parameter to be returned as the value of X* ILAENV. X* = 1: the optimal blocksize; if this value is 1, an unblocked X* algorithm will give the best performance. X* = 2: the minimum block size for which the block routine X* should be used; if the usable block size is less than X* this value, an unblocked routine should be used. X* = 3: the crossover point (in a block routine, for N less X* than this value, an unblocked routine should be used) X* = 4: the number of shifts, used in the nonsymmetric X* eigenvalue routines X* = 5: the minimum column dimension for blocking to be used; X* rectangular blocks must have dimension at least k by m, X* where k is given by ILAENV(2,...) and m by ILAENV(5,...) X* = 6: the crossover point for the SVD (when reducing an m by n X* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds X* this value, a QR factorization is used first to reduce X* the matrix to a triangular form.) X* = 7: the number of processors X* = 8: the crossover point for the multishift QR and QZ methods X* for nonsymmetric eigenvalue problems. X* X* NAME (input) CHARACTER*(*) X* The name of the calling subroutine, in either upper case or X* lower case. X* X* OPTS (input) CHARACTER*(*) X* The character options to the subroutine NAME, concatenated X* into a single character string. For example, UPLO = 'U', X* TRANS = 'T', and DIAG = 'N' for a triangular routine would X* be specified as OPTS = 'UTN'. X* X* N1 (input) INTEGER X* N2 (input) INTEGER X* N3 (input) INTEGER X* N4 (input) INTEGER X* Problem dimensions for the subroutine NAME; these may not all X* be required. X* X* (ILAENV) (output) INTEGER X* >= 0: the value of the parameter specified by ISPEC X* < 0: if ILAENV = -k, the k-th argument had an illegal value. X* X* Further Details X* =============== X* X* The following conventions have been used when calling ILAENV from the X* LAPACK routines: X* 1) OPTS is a concatenation of all of the character options to X* subroutine NAME, in the same order that they appear in the X* argument list for NAME, even if they are not used in determining X* the value of the parameter specified by ISPEC. X* 2) The problem dimensions N1, N2, N3, N4 are specified in the order X* that they appear in the argument list for NAME. N1 is used X* first, N2 second, and so on, and unused problem dimensions are X* passed a value of -1. X* 3) The parameter value returned by ILAENV is checked for validity in X* the calling subroutine. For example, ILAENV is used to retrieve X* the optimal blocksize for STRTRI as follows: X* X* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) X* IF( NB.LE.1 ) NB = MAX( 1, N ) X* X* ===================================================================== X* X* .. Local Scalars .. X LOGICAL CNAME, SNAME X CHARACTER*1 C1 X CHARACTER*2 C2, C4 X CHARACTER*3 C3 X CHARACTER*6 SUBNAM X INTEGER I, IC, IZ, NB, NBMIN, NX X* .. X* .. Intrinsic Functions .. X INTRINSIC CHAR, ICHAR, INT, MIN, REAL X* .. X* .. Executable Statements .. X* X GO TO ( 100, 100, 100, 400, 500, 600, 700, 800 ) ISPEC X* X* Invalid value for ISPEC X* X ILAENV = -1 X RETURN X* X 100 CONTINUE X* X* Convert NAME to upper case if the first character is lower case. X* X ILAENV = 1 X SUBNAM = NAME X IC = ICHAR( SUBNAM( 1:1 ) ) X IZ = ICHAR( 'Z' ) X IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN X* X* ASCII character set X* X IF( IC.GE.97 .AND. IC.LE.122 ) THEN X SUBNAM( 1:1 ) = CHAR( IC-32 ) X DO 10 I = 2, 6 X IC = ICHAR( SUBNAM( I:I ) ) X IF( IC.GE.97 .AND. IC.LE.122 ) X $ SUBNAM( I:I ) = CHAR( IC-32 ) X 10 CONTINUE X END IF X* X ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN X* X* EBCDIC character set X* X IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. X $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. X $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN X SUBNAM( 1:1 ) = CHAR( IC+64 ) X DO 20 I = 2, 6 X IC = ICHAR( SUBNAM( I:I ) ) X IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. X $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. X $ ( IC.GE.162 .AND. IC.LE.169 ) ) X $ SUBNAM( I:I ) = CHAR( IC+64 ) X 20 CONTINUE X END IF X* X ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN X* X* Prime machines: ASCII+128 X* X IF( IC.GE.225 .AND. IC.LE.250 ) THEN X SUBNAM( 1:1 ) = CHAR( IC-32 ) X DO 30 I = 2, 6 X IC = ICHAR( SUBNAM( I:I ) ) X IF( IC.GE.225 .AND. IC.LE.250 ) X $ SUBNAM( I:I ) = CHAR( IC-32 ) X 30 CONTINUE X END IF X END IF X* X C1 = SUBNAM( 1:1 ) X SNAME = C1.EQ.'S' .OR. C1.EQ.'D' X CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' X IF( .NOT.( CNAME .OR. SNAME ) ) X $ RETURN X C2 = SUBNAM( 2:3 ) X C3 = SUBNAM( 4:6 ) X C4 = C3( 2:3 ) X* X GO TO ( 110, 200, 300 ) ISPEC X* X 110 CONTINUE X* X* ISPEC = 1: block size X* X* In these examples, separate code is provided for setting NB for X* real and complex. We assume that NB will take the same value in X* single or double precision. X* X NB = 1 X* X IF( C2.EQ.'GE' ) THEN X IF( C3.EQ.'TRF' ) THEN X IF( SNAME ) THEN X NB = 64 X ELSE X NB = 64 X END IF X ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. X $ C3.EQ.'QLF' ) THEN X IF( SNAME ) THEN X NB = 32 X ELSE X NB = 32 X END IF X ELSE IF( C3.EQ.'HRD' ) THEN X IF( SNAME ) THEN X NB = 32 X ELSE X NB = 32 X END IF X ELSE IF( C3.EQ.'BRD' ) THEN X IF( SNAME ) THEN X NB = 32 X ELSE X NB = 32 X END IF X ELSE IF( C3.EQ.'TRI' ) THEN X IF( SNAME ) THEN X NB = 64 X ELSE X NB = 64 X END IF X END IF X ELSE IF( C2.EQ.'PO' ) THEN X IF( C3.EQ.'TRF' ) THEN X IF( SNAME ) THEN X NB = 64 X ELSE X NB = 64 X END IF X END IF X ELSE IF( C2.EQ.'SY' ) THEN X IF( C3.EQ.'TRF' ) THEN X IF( SNAME ) THEN X NB = 64 X ELSE X NB = 64 X END IF X ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN X NB = 1 X ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN X NB = 64 X END IF X ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN X IF( C3.EQ.'TRF' ) THEN X NB = 64 X ELSE IF( C3.EQ.'TRD' ) THEN X NB = 1 X ELSE IF( C3.EQ.'GST' ) THEN X NB = 64 X END IF X ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN X IF( C3( 1:1 ).EQ.'G' ) THEN X IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. X $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. X $ C4.EQ.'BR' ) THEN X NB = 32 X END IF X ELSE IF( C3( 1:1 ).EQ.'M' ) THEN X IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. X $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. X $ C4.EQ.'BR' ) THEN X NB = 32 X END IF X END IF X ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN X IF( C3( 1:1 ).EQ.'G' ) THEN X IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. X $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. X $ C4.EQ.'BR' ) THEN X NB = 32 X END IF X ELSE IF( C3( 1:1 ).EQ.'M' ) THEN X IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. X $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. X $ C4.EQ.'BR' ) THEN X NB = 32 X END IF X END IF X ELSE IF( C2.EQ.'GB' ) THEN X IF( C3.EQ.'TRF' ) THEN X IF( SNAME ) THEN X IF( N4.LE.64 ) THEN X NB = 1 X ELSE X NB = 32 X END IF X ELSE X IF( N4.LE.64 ) THEN X NB = 1 X ELSE X NB = 32 X END IF X END IF X END IF X ELSE IF( C2.EQ.'PB' ) THEN X IF( C3.EQ.'TRF' ) THEN X IF( SNAME ) THEN X IF( N2.LE.64 ) THEN X NB = 1 X ELSE X NB = 32 X END IF X ELSE X IF( N2.LE.64 ) THEN X NB = 1 X ELSE X NB = 32 X END IF X END IF X END IF X ELSE IF( C2.EQ.'TR' ) THEN X IF( C3.EQ.'TRI' ) THEN X IF( SNAME ) THEN X NB = 64 X ELSE X NB = 64 X END IF X END IF X ELSE IF( C2.EQ.'LA' ) THEN X IF( C3.EQ.'UUM' ) THEN X IF( SNAME ) THEN X NB = 64 X ELSE X NB = 64 X END IF X END IF X ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN X IF( C3.EQ.'EBZ' ) THEN X NB = 1 X END IF X END IF X ILAENV = NB X RETURN X* X 200 CONTINUE X* X* ISPEC = 2: minimum block size X* X NBMIN = 2 X IF( C2.EQ.'GE' ) THEN X IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. X $ C3.EQ.'QLF' ) THEN X IF( SNAME ) THEN X NBMIN = 2 X ELSE X NBMIN = 2 X END IF X ELSE IF( C3.EQ.'HRD' ) THEN X IF( SNAME ) THEN X NBMIN = 2 X ELSE X NBMIN = 2 X END IF X ELSE IF( C3.EQ.'BRD' ) THEN X IF( SNAME ) THEN X NBMIN = 2 X ELSE X NBMIN = 2 X END IF X ELSE IF( C3.EQ.'TRI' ) THEN X IF( SNAME ) THEN X NBMIN = 2 X ELSE X NBMIN = 2 X END IF X END IF X ELSE IF( C2.EQ.'SY' ) THEN X IF( C3.EQ.'TRF' ) THEN X IF( SNAME ) THEN X NBMIN = 8 X ELSE X NBMIN = 8 X END IF X ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN X NBMIN = 2 X END IF X ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN X IF( C3.EQ.'TRD' ) THEN X NBMIN = 2 X END IF X ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN X IF( C3( 1:1 ).EQ.'G' ) THEN X IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. X $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. X $ C4.EQ.'BR' ) THEN X NBMIN = 2 X END IF X ELSE IF( C3( 1:1 ).EQ.'M' ) THEN X IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. X $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. X $ C4.EQ.'BR' ) THEN X NBMIN = 2 X END IF X END IF X ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN X IF( C3( 1:1 ).EQ.'G' ) THEN X IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. X $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. X $ C4.EQ.'BR' ) THEN X NBMIN = 2 X END IF X ELSE IF( C3( 1:1 ).EQ.'M' ) THEN X IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. X $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. X $ C4.EQ.'BR' ) THEN X NBMIN = 2 X END IF X END IF X END IF X ILAENV = NBMIN X RETURN X* X 300 CONTINUE X* X* ISPEC = 3: crossover point X* X NX = 0 X IF( C2.EQ.'GE' ) THEN X IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. X $ C3.EQ.'QLF' ) THEN X IF( SNAME ) THEN X NX = 128 X ELSE X NX = 128 X END IF X ELSE IF( C3.EQ.'HRD' ) THEN X IF( SNAME ) THEN X NX = 128 X ELSE X NX = 128 X END IF X ELSE IF( C3.EQ.'BRD' ) THEN X IF( SNAME ) THEN X NX = 128 X ELSE X NX = 128 X END IF X END IF X ELSE IF( C2.EQ.'SY' ) THEN X IF( SNAME .AND. C3.EQ.'TRD' ) THEN X NX = 1 X END IF X ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN X IF( C3.EQ.'TRD' ) THEN X NX = 1 X END IF X ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN X IF( C3( 1:1 ).EQ.'G' ) THEN X IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. X $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. X $ C4.EQ.'BR' ) THEN X NX = 128 X END IF X END IF X ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN X IF( C3( 1:1 ).EQ.'G' ) THEN X IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. X $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. X $ C4.EQ.'BR' ) THEN X NX = 128 X END IF X END IF X END IF X ILAENV = NX X RETURN X* X 400 CONTINUE X* X* ISPEC = 4: number of shifts (used by xHSEQR) X* X ILAENV = 6 X RETURN X* X 500 CONTINUE X* X* ISPEC = 5: minimum column dimension (not used) X* X ILAENV = 2 X RETURN X* X 600 CONTINUE X* X* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) X* X ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) X RETURN X* X 700 CONTINUE X* X* ISPEC = 7: number of processors (not used) X* X ILAENV = 1 X RETURN X* X 800 CONTINUE X* X* ISPEC = 8: crossover point for multishift (used by xHSEQR) X* X ILAENV = 50 X RETURN X* X* End of ILAENV X* X END X X X SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, X $ B, LDB ) X* .. Scalar Arguments .. X CHARACTER*1 SIDE, UPLO, TRANSA, DIAG X INTEGER M, N, LDA, LDB X DOUBLE PRECISION ALPHA X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), B( LDB, * ) X* .. X* X* Purpose X* ======= X* X* DTRSM solves one of the matrix equations X* X* op( A )*X = alpha*B, or X*op( A ) = alpha*B, X* X* where alpha is a scalar, X and B are m by n matrices, A is a unit, or X* non-unit, upper or lower triangular matrix and op( A ) is one of X* X* op( A ) = A or op( A ) = A'. X* X* The matrix X is overwritten on B. X* X* Parameters X* ========== X* X* SIDE - CHARACTER*1. X* On entry, SIDE specifies whether op( A ) appears on the left X* or right of X as follows: X* X* SIDE = 'L' or 'l' op( A )*X = alpha*B. X* X* SIDE = 'R' or 'r' X*op( A ) = alpha*B. X* X* Unchanged on exit. X* X* UPLO - CHARACTER*1. X* On entry, UPLO specifies whether the matrix A is an upper or X* lower triangular matrix as follows: X* X* UPLO = 'U' or 'u' A is an upper triangular matrix. X* X* UPLO = 'L' or 'l' A is a lower triangular matrix. X* X* Unchanged on exit. X* X* TRANSA - CHARACTER*1. X* On entry, TRANSA specifies the form of op( A ) to be used in X* the matrix multiplication as follows: X* X* TRANSA = 'N' or 'n' op( A ) = A. X* X* TRANSA = 'T' or 't' op( A ) = A'. X* X* TRANSA = 'C' or 'c' op( A ) = A'. X* X* Unchanged on exit. X* X* DIAG - CHARACTER*1. X* On entry, DIAG specifies whether or not A is unit triangular X* as follows: X* X* DIAG = 'U' or 'u' A is assumed to be unit triangular. X* X* DIAG = 'N' or 'n' A is not assumed to be unit X* triangular. X* X* Unchanged on exit. X* X* M - INTEGER. X* On entry, M specifies the number of rows of B. M must be at X* least zero. X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the number of columns of B. N must be X* at least zero. X* Unchanged on exit. X* X* ALPHA - DOUBLE PRECISION. X* On entry, ALPHA specifies the scalar alpha. When alpha is X* zero then A is not referenced and B need not be set before X* entry. X* Unchanged on exit. X* X* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m X* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. X* Before entry with UPLO = 'U' or 'u', the leading k by k X* upper triangular part of the array A must contain the upper X* triangular matrix and the strictly lower triangular part of X* A is not referenced. X* Before entry with UPLO = 'L' or 'l', the leading k by k X* lower triangular part of the array A must contain the lower X* triangular matrix and the strictly upper triangular part of X* A is not referenced. X* Note that when DIAG = 'U' or 'u', the diagonal elements of X* A are not referenced either, but are assumed to be unity. X* Unchanged on exit. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. When SIDE = 'L' or 'l' then X* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' X* then LDA must be at least max( 1, n ). X* Unchanged on exit. X* X* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). X* Before entry, the leading m by n part of the array B must X* contain the right-hand side matrix B, and on exit is X* overwritten by the solution matrix X. X* X* LDB - INTEGER. X* On entry, LDB specifies the first dimension of B as declared X* in the calling (sub) program. LDB must be at least X* max( 1, m ). X* Unchanged on exit. X* X* X* Level 3 Blas routine. X* X* X* -- Written on 8-February-1989. X* Jack Dongarra, Argonne National Laboratory. X* Iain Duff, AERE Harwell. X* Jeremy Du Croz, Numerical Algorithms Group Ltd. X* Sven Hammarling, Numerical Algorithms Group Ltd. X* X* X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. Local Scalars .. X LOGICAL LSIDE, NOUNIT, UPPER X INTEGER I, INFO, J, K, NROWA X DOUBLE PRECISION TEMP X* .. Parameters .. X DOUBLE PRECISION ONE , ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X LSIDE = LSAME( SIDE , 'L' ) X IF( LSIDE )THEN X NROWA = M X ELSE X NROWA = N X END IF X NOUNIT = LSAME( DIAG , 'N' ) X UPPER = LSAME( UPLO , 'U' ) X* X INFO = 0 X IF( ( .NOT.LSIDE ).AND. X $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN X INFO = 1 X ELSE IF( ( .NOT.UPPER ).AND. X $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN X INFO = 2 X ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. X $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. X $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN X INFO = 3 X ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. X $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN X INFO = 4 X ELSE IF( M .LT.0 )THEN X INFO = 5 X ELSE IF( N .LT.0 )THEN X INFO = 6 X ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN X INFO = 9 X ELSE IF( LDB.LT.MAX( 1, M ) )THEN X INFO = 11 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'DTRSM ', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( N.EQ.0 ) X $ RETURN X* X* And when alpha.eq.zero. X* X IF( ALPHA.EQ.ZERO )THEN X DO 20, J = 1, N X DO 10, I = 1, M X B( I, J ) = ZERO X 10 CONTINUE X 20 CONTINUE X RETURN X END IF X* X* Start the operations. X* X IF( LSIDE )THEN X IF( LSAME( TRANSA, 'N' ) )THEN X* X* Form B := alpha*inv( A )*B. X* X IF( UPPER )THEN X DO 60, J = 1, N X IF( ALPHA.NE.ONE )THEN X DO 30, I = 1, M X B( I, J ) = ALPHA*B( I, J ) X 30 CONTINUE X END IF X DO 50, K = M, 1, -1 X IF( B( K, J ).NE.ZERO )THEN X IF( NOUNIT ) X $ B( K, J ) = B( K, J )/A( K, K ) X DO 40, I = 1, K - 1 X B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) X 40 CONTINUE X END IF X 50 CONTINUE X 60 CONTINUE X ELSE X DO 100, J = 1, N X IF( ALPHA.NE.ONE )THEN X DO 70, I = 1, M X B( I, J ) = ALPHA*B( I, J ) X 70 CONTINUE X END IF X DO 90 K = 1, M X IF( B( K, J ).NE.ZERO )THEN X IF( NOUNIT ) X $ B( K, J ) = B( K, J )/A( K, K ) X DO 80, I = K + 1, M X B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) X 80 CONTINUE X END IF X 90 CONTINUE X 100 CONTINUE X END IF X ELSE X* X* Form B := alpha*inv( A' )*B. X* X IF( UPPER )THEN X DO 130, J = 1, N X DO 120, I = 1, M X TEMP = ALPHA*B( I, J ) X DO 110, K = 1, I - 1 X TEMP = TEMP - A( K, I )*B( K, J ) X 110 CONTINUE X IF( NOUNIT ) X $ TEMP = TEMP/A( I, I ) X B( I, J ) = TEMP X 120 CONTINUE X 130 CONTINUE X ELSE X DO 160, J = 1, N X DO 150, I = M, 1, -1 X TEMP = ALPHA*B( I, J ) X DO 140, K = I + 1, M X TEMP = TEMP - A( K, I )*B( K, J ) X 140 CONTINUE X IF( NOUNIT ) X $ TEMP = TEMP/A( I, I ) X B( I, J ) = TEMP X 150 CONTINUE X 160 CONTINUE X END IF X END IF X ELSE X IF( LSAME( TRANSA, 'N' ) )THEN X* X* Form B := alpha*B*inv( A ). X* X IF( UPPER )THEN X DO 210, J = 1, N X IF( ALPHA.NE.ONE )THEN X DO 170, I = 1, M X B( I, J ) = ALPHA*B( I, J ) X 170 CONTINUE X END IF X DO 190, K = 1, J - 1 X IF( A( K, J ).NE.ZERO )THEN X DO 180, I = 1, M X B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) X 180 CONTINUE X END IF X 190 CONTINUE X IF( NOUNIT )THEN X TEMP = ONE/A( J, J ) X DO 200, I = 1, M X B( I, J ) = TEMP*B( I, J ) X 200 CONTINUE X END IF X 210 CONTINUE X ELSE X DO 260, J = N, 1, -1 X IF( ALPHA.NE.ONE )THEN X DO 220, I = 1, M X B( I, J ) = ALPHA*B( I, J ) X 220 CONTINUE X END IF X DO 240, K = J + 1, N X IF( A( K, J ).NE.ZERO )THEN X DO 230, I = 1, M X B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) X 230 CONTINUE X END IF X 240 CONTINUE X IF( NOUNIT )THEN X TEMP = ONE/A( J, J ) X DO 250, I = 1, M X B( I, J ) = TEMP*B( I, J ) X 250 CONTINUE X END IF X 260 CONTINUE X END IF X ELSE X* X* Form B := alpha*B*inv( A' ). X* X IF( UPPER )THEN X DO 310, K = N, 1, -1 X IF( NOUNIT )THEN X TEMP = ONE/A( K, K ) X DO 270, I = 1, M X B( I, K ) = TEMP*B( I, K ) X 270 CONTINUE X END IF X DO 290, J = 1, K - 1 X IF( A( J, K ).NE.ZERO )THEN X TEMP = A( J, K ) X DO 280, I = 1, M X B( I, J ) = B( I, J ) - TEMP*B( I, K ) X 280 CONTINUE X END IF X 290 CONTINUE X IF( ALPHA.NE.ONE )THEN X DO 300, I = 1, M X B( I, K ) = ALPHA*B( I, K ) X 300 CONTINUE X END IF X 310 CONTINUE X ELSE X DO 360, K = 1, N X IF( NOUNIT )THEN X TEMP = ONE/A( K, K ) X DO 320, I = 1, M X B( I, K ) = TEMP*B( I, K ) X 320 CONTINUE X END IF X DO 340, J = K + 1, N X IF( A( J, K ).NE.ZERO )THEN X TEMP = A( J, K ) X DO 330, I = 1, M X B( I, J ) = B( I, J ) - TEMP*B( I, K ) X 330 CONTINUE X END IF X 340 CONTINUE X IF( ALPHA.NE.ONE )THEN X DO 350, I = 1, M X B( I, K ) = ALPHA*B( I, K ) X 350 CONTINUE X END IF X 360 CONTINUE X END IF X END IF X END IF X* X RETURN X* X* End of DTRSM . X* X END X X X LOGICAL FUNCTION LSAME( CA, CB ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X CHARACTER CA, CB X* .. X* X* Purpose X* ======= X* X* LSAME returns .TRUE. if CA is the same letter as CB regardless of X* case. X* X* Arguments X* ========= X* X* CA (input) CHARACTER*1 X* CB (input) CHARACTER*1 X* CA and CB specify the single characters to be compared. X* X* ===================================================================== X* X* .. Intrinsic Functions .. X INTRINSIC ICHAR X* .. X* .. Local Scalars .. X INTEGER INTA, INTB, ZCODE X* .. X* .. Executable Statements .. X* X* Test if the characters are equal X* X LSAME = CA.EQ.CB X IF( LSAME ) X $ RETURN X* X* Now test for equivalence if both characters are alphabetic. X* X ZCODE = ICHAR( 'Z' ) X* X* Use 'Z' rather than 'A' so that ASCII can be detected on Prime X* machines, on which ICHAR returns a value with bit 8 set. X* ICHAR('A') on Prime machines returns 193 which is the same as X* ICHAR('A') on an EBCDIC machine. X* X INTA = ICHAR( CA ) X INTB = ICHAR( CB ) X* X IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN X* X* ASCII is assumed - ZCODE is the ASCII code of either lower or X* upper case 'Z'. X* X IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 X IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 X* X ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN X* X* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or X* upper case 'Z'. X* X IF( INTA.GE.129 .AND. INTA.LE.137 .OR. X $ INTA.GE.145 .AND. INTA.LE.153 .OR. X $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 X IF( INTB.GE.129 .AND. INTB.LE.137 .OR. X $ INTB.GE.145 .AND. INTB.LE.153 .OR. X $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 X* X ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN X* X* ASCII is assumed, on Prime machines - ZCODE is the ASCII code X* plus 128 of either lower or upper case 'Z'. X* X IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 X IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 X END IF X LSAME = INTA.EQ.INTB X* X* RETURN X* X* End of LSAME X* X END X X X SUBROUTINE XERBLA( SRNAME, INFO ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X CHARACTER*6 SRNAME X INTEGER INFO X* .. X* X* Purpose X* ======= X* X* XERBLA is an error handler for the LAPACK routines. X* It is called by an LAPACK routine if an input parameter has an X* invalid value. A message is printed and execution stops. X* X* Installers may consider modifying the STOP statement in order to X* call system-specific exception-handling facilities. X* X* Arguments X* ========= X* X* SRNAME (input) CHARACTER*6 X* The name of the routine which called XERBLA. X* X* INFO (input) INTEGER X* The position of the invalid parameter in the parameter list X* of the calling routine. X* X* ===================================================================== X* X* .. Executable Statements .. X* X WRITE( *, FMT = 9999 )SRNAME, INFO X* X STOP X* X 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', X $ 'an illegal value' ) X* X* End of XERBLA X* X END X X X SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) X* .. Scalar Arguments .. X DOUBLE PRECISION ALPHA X INTEGER INCX, INCY, LDA, M, N X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) X* .. X* X* Purpose X* ======= X* X* DGER performs the rank 1 operation X* X* A := alpha*x*y' + A, X* X* where alpha is a scalar, x is an m element vector, y is an n element X* vector and A is an m by n matrix. X* X* Parameters X* ========== X* X* M - INTEGER. X* On entry, M specifies the number of rows of the matrix A. X* M must be at least zero. X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the number of columns of the matrix A. X* N must be at least zero. X* Unchanged on exit. X* X* ALPHA - DOUBLE PRECISION. X* On entry, ALPHA specifies the scalar alpha. X* Unchanged on exit. X* X* X - DOUBLE PRECISION array of dimension at least X* ( 1 + ( m - 1 )*abs( INCX ) ). X* Before entry, the incremented array X must contain the m X* element vector x. X* Unchanged on exit. X* X* INCX - INTEGER. X* On entry, INCX specifies the increment for the elements of X* X. INCX must not be zero. X* Unchanged on exit. X* X* Y - DOUBLE PRECISION array of dimension at least X* ( 1 + ( n - 1 )*abs( INCY ) ). X* Before entry, the incremented array Y must contain the n X* element vector y. X* Unchanged on exit. X* X* INCY - INTEGER. X* On entry, INCY specifies the increment for the elements of X* Y. INCY must not be zero. X* Unchanged on exit. X* X* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). X* Before entry, the leading m by n part of the array A must X* contain the matrix of coefficients. On exit, A is X* overwritten by the updated matrix. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. LDA must be at least X* max( 1, m ). X* Unchanged on exit. X* X* X* Level 2 Blas routine. X* X* -- Written on 22-October-1986. X* Jack Dongarra, Argonne National Lab. X* Jeremy Du Croz, Nag Central Office. X* Sven Hammarling, Nag Central Office. X* Richard Hanson, Sandia National Labs. X* X* X* .. Parameters .. X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D+0 ) X* .. Local Scalars .. X DOUBLE PRECISION TEMP X INTEGER I, INFO, IX, J, JY, KX X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF ( M.LT.0 )THEN X INFO = 1 X ELSE IF( N.LT.0 )THEN X INFO = 2 X ELSE IF( INCX.EQ.0 )THEN X INFO = 5 X ELSE IF( INCY.EQ.0 )THEN X INFO = 7 X ELSE IF( LDA.LT.MAX( 1, M ) )THEN X INFO = 9 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'DGER ', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) X $ RETURN X* X* Start the operations. In this version the elements of A are X* accessed sequentially with one pass through A. X* X IF( INCY.GT.0 )THEN X JY = 1 X ELSE X JY = 1 - ( N - 1 )*INCY X END IF X IF( INCX.EQ.1 )THEN X DO 20, J = 1, N X IF( Y( JY ).NE.ZERO )THEN X TEMP = ALPHA*Y( JY ) X DO 10, I = 1, M X A( I, J ) = A( I, J ) + X( I )*TEMP X 10 CONTINUE X END IF X JY = JY + INCY X 20 CONTINUE X ELSE X IF( INCX.GT.0 )THEN X KX = 1 X ELSE X KX = 1 - ( M - 1 )*INCX X END IF X DO 40, J = 1, N X IF( Y( JY ).NE.ZERO )THEN X TEMP = ALPHA*Y( JY ) X IX = KX X DO 30, I = 1, M X A( I, J ) = A( I, J ) + X( IX )*TEMP X IX = IX + INCX X 30 CONTINUE X END IF X JY = JY + INCY X 40 CONTINUE X END IF X* X RETURN X* X* End of DGER . X* X END X X SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, X $ BETA, C, LDC ) X* .. Scalar Arguments .. X CHARACTER*1 TRANSA, TRANSB X INTEGER M, N, K, LDA, LDB, LDC X DOUBLE PRECISION ALPHA, BETA X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) X* .. X* X* Purpose X* ======= X* X* DGEMM performs one of the matrix-matrix operations X* X* C := alpha*op( A )*op( B ) + beta*C, X* X* where op( X ) is one of X* X* op( X ) = X or op( X ) = X', X* X* alpha and beta are scalars, and A, B and C are matrices, with op( A ) X* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. X* X* Parameters X* ========== X* X* TRANSA - CHARACTER*1. X* On entry, TRANSA specifies the form of op( A ) to be used in X* the matrix multiplication as follows: X* X* TRANSA = 'N' or 'n', op( A ) = A. X* X* TRANSA = 'T' or 't', op( A ) = A'. X* X* TRANSA = 'C' or 'c', op( A ) = A'. X* X* Unchanged on exit. X* X* TRANSB - CHARACTER*1. X* On entry, TRANSB specifies the form of op( B ) to be used in X* the matrix multiplication as follows: X* X* TRANSB = 'N' or 'n', op( B ) = B. X* X* TRANSB = 'T' or 't', op( B ) = B'. X* X* TRANSB = 'C' or 'c', op( B ) = B'. X* X* Unchanged on exit. X* X* M - INTEGER. X* On entry, M specifies the number of rows of the matrix X* op( A ) and of the matrix C. M must be at least zero. X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the number of columns of the matrix X* op( B ) and the number of columns of the matrix C. N must be X* at least zero. X* Unchanged on exit. X* X* K - INTEGER. X* On entry, K specifies the number of columns of the matrix X* op( A ) and the number of rows of the matrix op( B ). K must X* be at least zero. X* Unchanged on exit. X* X* ALPHA - DOUBLE PRECISION. X* On entry, ALPHA specifies the scalar alpha. X* Unchanged on exit. X* X* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is X* k when TRANSA = 'N' or 'n', and is m otherwise. X* Before entry with TRANSA = 'N' or 'n', the leading m by k X* part of the array A must contain the matrix A, otherwise X* the leading k by m part of the array A must contain the X* matrix A. X* Unchanged on exit. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. When TRANSA = 'N' or 'n' then X* LDA must be at least max( 1, m ), otherwise LDA must be at X* least max( 1, k ). X* Unchanged on exit. X* X* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is X* n when TRANSB = 'N' or 'n', and is k otherwise. X* Before entry with TRANSB = 'N' or 'n', the leading k by n X* part of the array B must contain the matrix B, otherwise X* the leading n by k part of the array B must contain the X* matrix B. X* Unchanged on exit. X* X* LDB - INTEGER. X* On entry, LDB specifies the first dimension of B as declared X* in the calling (sub) program. When TRANSB = 'N' or 'n' then X* LDB must be at least max( 1, k ), otherwise LDB must be at X* least max( 1, n ). X* Unchanged on exit. X* X* BETA - DOUBLE PRECISION. X* On entry, BETA specifies the scalar beta. When BETA is X* supplied as zero then C need not be set on input. X* Unchanged on exit. X* X* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). X* Before entry, the leading m by n part of the array C must X* contain the matrix C, except when beta is zero, in which X* case C need not be set on entry. X* On exit, the array C is overwritten by the m by n matrix X* ( alpha*op( A )*op( B ) + beta*C ). X* X* LDC - INTEGER. X* On entry, LDC specifies the first dimension of C as declared X* in the calling (sub) program. LDC must be at least X* max( 1, m ). X* Unchanged on exit. X* X* X* Level 3 Blas routine. X* X* -- Written on 8-February-1989. X* Jack Dongarra, Argonne National Laboratory. X* Iain Duff, AERE Harwell. X* Jeremy Du Croz, Numerical Algorithms Group Ltd. X* Sven Hammarling, Numerical Algorithms Group Ltd. X* X* X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. Local Scalars .. X LOGICAL NOTA, NOTB X INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB X DOUBLE PRECISION TEMP X* .. Parameters .. X DOUBLE PRECISION ONE , ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Executable Statements .. X* X* Set NOTA and NOTB as true if A and B respectively are not X* transposed and set NROWA, NCOLA and NROWB as the number of rows X* and columns of A and the number of rows of B respectively. X* X NOTA = LSAME( TRANSA, 'N' ) X NOTB = LSAME( TRANSB, 'N' ) X IF( NOTA )THEN X NROWA = M X NCOLA = K X ELSE X NROWA = K X NCOLA = M X END IF X IF( NOTB )THEN X NROWB = K X ELSE X NROWB = N X END IF X* X* Test the input parameters. X* X INFO = 0 X IF( ( .NOT.NOTA ).AND. X $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. X $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN X INFO = 1 X ELSE IF( ( .NOT.NOTB ).AND. X $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. X $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN X INFO = 2 X ELSE IF( M .LT.0 )THEN X INFO = 3 X ELSE IF( N .LT.0 )THEN X INFO = 4 X ELSE IF( K .LT.0 )THEN X INFO = 5 X ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN X INFO = 8 X ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN X INFO = 10 X ELSE IF( LDC.LT.MAX( 1, M ) )THEN X INFO = 13 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'DGEMM ', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. X $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) X $ RETURN X* X* And if alpha.eq.zero. X* X IF( ALPHA.EQ.ZERO )THEN X IF( BETA.EQ.ZERO )THEN X DO 20, J = 1, N X DO 10, I = 1, M X C( I, J ) = ZERO X 10 CONTINUE X 20 CONTINUE X ELSE X DO 40, J = 1, N X DO 30, I = 1, M X C( I, J ) = BETA*C( I, J ) X 30 CONTINUE X 40 CONTINUE X END IF X RETURN X END IF X* X* Start the operations. X* X IF( NOTB )THEN X IF( NOTA )THEN X* X* Form C := alpha*A*B + beta*C. X* X DO 90, J = 1, N X IF( BETA.EQ.ZERO )THEN X DO 50, I = 1, M X C( I, J ) = ZERO X 50 CONTINUE X ELSE IF( BETA.NE.ONE )THEN X DO 60, I = 1, M X C( I, J ) = BETA*C( I, J ) X 60 CONTINUE X END IF X DO 80, L = 1, K X IF( B( L, J ).NE.ZERO )THEN X TEMP = ALPHA*B( L, J ) X DO 70, I = 1, M X C( I, J ) = C( I, J ) + TEMP*A( I, L ) X 70 CONTINUE X END IF X 80 CONTINUE X 90 CONTINUE X ELSE X* X* Form C := alpha*A'*B + beta*C X* X DO 120, J = 1, N X DO 110, I = 1, M X TEMP = ZERO X DO 100, L = 1, K X TEMP = TEMP + A( L, I )*B( L, J ) X 100 CONTINUE X IF( BETA.EQ.ZERO )THEN X C( I, J ) = ALPHA*TEMP X ELSE X C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) X END IF X 110 CONTINUE X 120 CONTINUE X END IF X ELSE X IF( NOTA )THEN X* X* Form C := alpha*A*B' + beta*C X* X DO 170, J = 1, N X IF( BETA.EQ.ZERO )THEN X DO 130, I = 1, M X C( I, J ) = ZERO X 130 CONTINUE X ELSE IF( BETA.NE.ONE )THEN X DO 140, I = 1, M X C( I, J ) = BETA*C( I, J ) X 140 CONTINUE X END IF X DO 160, L = 1, K X IF( B( J, L ).NE.ZERO )THEN X TEMP = ALPHA*B( J, L ) X DO 150, I = 1, M X C( I, J ) = C( I, J ) + TEMP*A( I, L ) X 150 CONTINUE X END IF X 160 CONTINUE X 170 CONTINUE X ELSE X* X* Form C := alpha*A'*B' + beta*C X* X DO 200, J = 1, N X DO 190, I = 1, M X TEMP = ZERO X DO 180, L = 1, K X TEMP = TEMP + A( L, I )*B( J, L ) X 180 CONTINUE X IF( BETA.EQ.ZERO )THEN X C( I, J ) = ALPHA*TEMP X ELSE X C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) X END IF X 190 CONTINUE X 200 CONTINUE X END IF X END IF X* X RETURN X* X* End of DGEMM . X* X END X X X SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) X* X* -- LAPACK driver routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* March 31, 1993 X* X* .. Scalar Arguments .. X INTEGER INFO, LDA, LDB, N, NRHS X* .. X* .. Array Arguments .. X INTEGER IPIV( * ) X COMPLEX*16 A( LDA, * ), B( LDB, * ) X* .. X* X* Purpose X* ======= X* X* ZGESV computes the solution to a complex system of linear equations X* A * X = B, X* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. X* X* The LU decomposition with partial pivoting and row interchanges is X* used to factor A as X* A = P * L * U, X* where P is a permutation matrix, L is unit lower triangular, and U is X* upper triangular. The factored form of A is then used to solve the X* system of equations A * X = B. X* X* Arguments X* ========= X* X* N (input) INTEGER X* The number of linear equations, i.e., the order of the X* matrix A. N >= 0. X* X* NRHS (input) INTEGER X* The number of right hand sides, i.e., the number of columns X* of the matrix B. NRHS >= 0. X* X* A (input/output) COMPLEX*16 array, dimension (LDA,N) X* On entry, the N-by-N coefficient matrix A. X* On exit, the factors L and U from the factorization X* A = P*L*U; the unit diagonal elements of L are not stored. X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(1,N). X* X* IPIV (output) INTEGER array, dimension (N) X* The pivot indices that define the permutation matrix P; X* row i of the matrix was interchanged with row IPIV(i). X* X* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) X* On entry, the N-by-NRHS matrix of right hand side matrix B. X* On exit, if INFO = 0, the N-by-NRHS solution matrix X. X* X* LDB (input) INTEGER X* The leading dimension of the array B. LDB >= max(1,N). X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* > 0: if INFO = i, U(i,i) is exactly zero. The factorization X* has been completed, but the factor U is exactly X* singular, so the solution could not be computed. X* X* ===================================================================== X* X* .. External Subroutines .. X EXTERNAL XERBLA, ZGETRF, ZGETRS X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF( N.LT.0 ) THEN X INFO = -1 X ELSE IF( NRHS.LT.0 ) THEN X INFO = -2 X ELSE IF( LDA.LT.MAX( 1, N ) ) THEN X INFO = -4 X ELSE IF( LDB.LT.MAX( 1, N ) ) THEN X INFO = -7 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'ZGESV ', -INFO ) X RETURN X END IF X* X* Compute the LU factorization of A. X* X CALL ZGETRF( N, N, A, LDA, IPIV, INFO ) X IF( INFO.EQ.0 ) THEN X* X* Solve the system A*X = B, overwriting B with X. X* X CALL ZGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, X $ INFO ) X END IF X RETURN X* X* End of ZGESV X* X END X X X SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X INTEGER INFO, LDA, M, N X* .. X* .. Array Arguments .. X INTEGER IPIV( * ) X COMPLEX*16 A( LDA, * ) X* .. X* X* Purpose X* ======= X* X* ZGETF2 computes an LU factorization of a general m-by-n matrix A X* using partial pivoting with row interchanges. X* X* The factorization has the form X* A = P * L * U X* where P is a permutation matrix, L is lower triangular with unit X* diagonal elements (lower trapezoidal if m > n), and U is upper X* triangular (upper trapezoidal if m < n). X* X* This is the right-looking Level 2 BLAS version of the algorithm. X* X* Arguments X* ========= X* X* M (input) INTEGER X* The number of rows of the matrix A. M >= 0. X* X* N (input) INTEGER X* The number of columns of the matrix A. N >= 0. X* X* A (input/output) COMPLEX*16 array, dimension (LDA,N) X* On entry, the m by n matrix to be factored. X* On exit, the factors L and U from the factorization X* A = P*L*U; the unit diagonal elements of L are not stored. X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(1,M). X* X* IPIV (output) INTEGER array, dimension (min(M,N)) X* The pivot indices; for 1 <= i <= min(M,N), row i of the X* matrix was interchanged with row IPIV(i). X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -k, the k-th argument had an illegal value X* > 0: if INFO = k, U(k,k) is exactly zero. The factorization X* has been completed, but the factor U is exactly X* singular, and division by zero will occur if it is used X* to solve a system of equations. X* X* ===================================================================== X* X* .. Parameters .. X COMPLEX*16 ONE, ZERO X PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), X $ ZERO = ( 0.0D+0, 0.0D+0 ) ) X* .. X* .. Local Scalars .. X INTEGER J, JP X* .. X* .. External Functions .. X INTEGER IZAMAX X EXTERNAL IZAMAX X* .. X* .. External Subroutines .. X EXTERNAL XERBLA, ZGERU, ZSCAL, ZSWAP X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX, MIN X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF( M.LT.0 ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X ELSE IF( LDA.LT.MAX( 1, M ) ) THEN X INFO = -4 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'ZGETF2', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( M.EQ.0 .OR. N.EQ.0 ) X $ RETURN X* X DO 10 J = 1, MIN( M, N ) X* X* Find pivot and test for singularity. X* X JP = J - 1 + IZAMAX( M-J+1, A( J, J ), 1 ) X IPIV( J ) = JP X IF( A( JP, J ).NE.ZERO ) THEN X* X* Apply the interchange to columns 1:N. X* X IF( JP.NE.J ) X $ CALL ZSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) X* X* Compute elements J+1:M of J-th column. X* X IF( J.LT.M ) X $ CALL ZSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) X* X ELSE IF( INFO.EQ.0 ) THEN X* X INFO = J X END IF X* X IF( J.LT.MIN( M, N ) ) THEN X* X* Update trailing submatrix. X* X CALL ZGERU( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), X $ LDA, A( J+1, J+1 ), LDA ) X END IF X 10 CONTINUE X RETURN X* X* End of ZGETF2 X* X END X X X SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X INTEGER INFO, LDA, M, N X* .. X* .. Array Arguments .. X INTEGER IPIV( * ) X COMPLEX*16 A( LDA, * ) X* .. X* X* Purpose X* ======= X* X* ZGETRF computes an LU factorization of a general M-by-N matrix A X* using partial pivoting with row interchanges. X* X* The factorization has the form X* A = P * L * U X* where P is a permutation matrix, L is lower triangular with unit X* diagonal elements (lower trapezoidal if m > n), and U is upper X* triangular (upper trapezoidal if m < n). X* X* This is the right-looking Level 3 BLAS version of the algorithm. X* X* Arguments X* ========= X* X* M (input) INTEGER X* The number of rows of the matrix A. M >= 0. X* X* N (input) INTEGER X* The number of columns of the matrix A. N >= 0. X* X* A (input/output) COMPLEX*16 array, dimension (LDA,N) X* On entry, the M-by-N matrix to be factored. X* On exit, the factors L and U from the factorization X* A = P*L*U; the unit diagonal elements of L are not stored. X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(1,M). X* X* IPIV (output) INTEGER array, dimension (min(M,N)) X* The pivot indices; for 1 <= i <= min(M,N), row i of the X* matrix was interchanged with row IPIV(i). X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* > 0: if INFO = i, U(i,i) is exactly zero. The factorization X* has been completed, but the factor U is exactly X* singular, and division by zero will occur if it is used X* to solve a system of equations. X* X* ===================================================================== X* X* .. Parameters .. X COMPLEX*16 ONE X PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) X* .. X* .. Local Scalars .. X INTEGER I, IINFO, J, JB, NB X* .. X* .. External Subroutines .. X EXTERNAL XERBLA, ZGEMM, ZGETF2, ZLASWP, ZTRSM X* .. X* .. External Functions .. X INTEGER ILAENV X EXTERNAL ILAENV X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX, MIN X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF( M.LT.0 ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X ELSE IF( LDA.LT.MAX( 1, M ) ) THEN X INFO = -4 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'ZGETRF', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( M.EQ.0 .OR. N.EQ.0 ) X $ RETURN X* X* Determine the block size for this environment. X* X NB = ILAENV( 1, 'ZGETRF', ' ', M, N, -1, -1 ) X IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN X* X* Use unblocked code. X* X CALL ZGETF2( M, N, A, LDA, IPIV, INFO ) X ELSE X* X* Use blocked code. X* X DO 20 J = 1, MIN( M, N ), NB X JB = MIN( MIN( M, N )-J+1, NB ) X* X* Factor diagonal and subdiagonal blocks and test for exact X* singularity. X* X CALL ZGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) X* X* Adjust INFO and the pivot indices. X* X IF( INFO.EQ.0 .AND. IINFO.GT.0 ) X $ INFO = IINFO + J - 1 X DO 10 I = J, MIN( M, J+JB-1 ) X IPIV( I ) = J - 1 + IPIV( I ) X 10 CONTINUE X* X* Apply interchanges to columns 1:J-1. X* X CALL ZLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) X* X IF( J+JB.LE.N ) THEN X* X* Apply interchanges to columns J+JB:N. X* X CALL ZLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, X $ IPIV, 1 ) X* X* Compute block row of U. X* X CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, X $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), X $ LDA ) X IF( J+JB.LE.M ) THEN X* X* Update trailing submatrix. X* X CALL ZGEMM( 'No transpose', 'No transpose', M-J-JB+1, X $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, X $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), X $ LDA ) X END IF X END IF X 20 CONTINUE X END IF X RETURN X* X* End of ZGETRF X* X END X X X SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) X* X* -- LAPACK routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* September 30, 1994 X* X* .. Scalar Arguments .. X CHARACTER TRANS X INTEGER INFO, LDA, LDB, N, NRHS X* .. X* .. Array Arguments .. X INTEGER IPIV( * ) X COMPLEX*16 A( LDA, * ), B( LDB, * ) X* .. X* X* Purpose X* ======= X* X* ZGETRS solves a system of linear equations X* A * X = B, A**T * X = B, or A**H * X = B X* with a general N-by-N matrix A using the LU factorization computed X* by ZGETRF. X* X* Arguments X* ========= X* X* TRANS (input) CHARACTER*1 X* Specifies the form of the system of equations: X* = 'N': A * X = B (No transpose) X* = 'T': A**T * X = B (Transpose) X* = 'C': A**H * X = B (Conjugate transpose) X* X* N (input) INTEGER X* The order of the matrix A. N >= 0. X* X* NRHS (input) INTEGER X* The number of right hand sides, i.e., the number of columns X* of the matrix B. NRHS >= 0. X* X* A (input) COMPLEX*16 array, dimension (LDA,N) X* The factors L and U from the factorization A = P*L*U X* as computed by ZGETRF. X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(1,N). X* X* IPIV (input) INTEGER array, dimension (N) X* The pivot indices from ZGETRF; for 1<=i<=N, row i of the X* matrix was interchanged with row IPIV(i). X* X* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) X* On entry, the right hand side matrix B. X* On exit, the solution matrix X. X* X* LDB (input) INTEGER X* The leading dimension of the array B. LDB >= max(1,N). X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* X* ===================================================================== X* X* .. Parameters .. X COMPLEX*16 ONE X PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) X* .. X* .. Local Scalars .. X LOGICAL NOTRAN X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. External Subroutines .. X EXTERNAL XERBLA, ZLASWP, ZTRSM X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X NOTRAN = LSAME( TRANS, 'N' ) X IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. X $ LSAME( TRANS, 'C' ) ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X ELSE IF( NRHS.LT.0 ) THEN X INFO = -3 X ELSE IF( LDA.LT.MAX( 1, N ) ) THEN X INFO = -5 X ELSE IF( LDB.LT.MAX( 1, N ) ) THEN X INFO = -8 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'ZGETRS', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( N.EQ.0 .OR. NRHS.EQ.0 ) X $ RETURN X* X IF( NOTRAN ) THEN X* X* Solve A * X = B. X* X* Apply row interchanges to the right hand sides. X* X CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) X* X* Solve L*X = B, overwriting B with X. X* X CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, X $ ONE, A, LDA, B, LDB ) X* X* Solve U*X = B, overwriting B with X. X* X CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, X $ NRHS, ONE, A, LDA, B, LDB ) X ELSE X* X* Solve A**T * X = B or A**H * X = B. X* X* Solve U'*X = B, overwriting B with X. X* X CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE, X $ A, LDA, B, LDB ) X* X* Solve L'*X = B, overwriting B with X. X* X CALL ZTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, ONE, A, X $ LDA, B, LDB ) X* X* Apply row interchanges to the solution vectors. X* X CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) X END IF X* X RETURN X* X* End of ZGETRS X* X END X X X SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) X* X* -- LAPACK auxiliary routine (version 2.0) -- X* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., X* Courant Institute, Argonne National Lab, and Rice University X* October 31, 1992 X* X* .. Scalar Arguments .. X INTEGER INCX, K1, K2, LDA, N X* .. X* .. Array Arguments .. X INTEGER IPIV( * ) X COMPLEX*16 A( LDA, * ) X* .. X* X* Purpose X* ======= X* X* ZLASWP performs a series of row interchanges on the matrix A. X* One row interchange is initiated for each of rows K1 through K2 of A. X* X* Arguments X* ========= X* X* N (input) INTEGER X* The number of columns of the matrix A. X* X* A (input/output) COMPLEX*16 array, dimension (LDA,N) X* On entry, the matrix of column dimension N to which the row X* interchanges will be applied. X* On exit, the permuted matrix. X* X* LDA (input) INTEGER X* The leading dimension of the array A. X* X* K1 (input) INTEGER X* The first element of IPIV for which a row interchange will X* be done. X* X* K2 (input) INTEGER X* The last element of IPIV for which a row interchange will X* be done. X* X* IPIV (input) INTEGER array, dimension (M*abs(INCX)) X* The vector of pivot indices. Only the elements in positions X* K1 through K2 of IPIV are accessed. X* IPIV(K) = L implies rows K and L are to be interchanged. X* X* INCX (input) INTEGER X* The increment between successive values of IPIV. If IPIV X* is negative, the pivots are applied in reverse order. X* X* ===================================================================== X* X* .. Local Scalars .. X INTEGER I, IP, IX X* .. X* .. External Subroutines .. X EXTERNAL ZSWAP X* .. X* .. Executable Statements .. X* X* Interchange row I with row IPIV(I) for each of rows K1 through K2. X* X IF( INCX.EQ.0 ) X $ RETURN X IF( INCX.GT.0 ) THEN X IX = K1 X ELSE X IX = 1 + ( 1-K2 )*INCX X END IF X IF( INCX.EQ.1 ) THEN X DO 10 I = K1, K2 X IP = IPIV( I ) X IF( IP.NE.I ) X $ CALL ZSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) X 10 CONTINUE X ELSE IF( INCX.GT.1 ) THEN X DO 20 I = K1, K2 X IP = IPIV( IX ) X IF( IP.NE.I ) X $ CALL ZSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) X IX = IX + INCX X 20 CONTINUE X ELSE IF( INCX.LT.0 ) THEN X DO 30 I = K2, K1, -1 X IP = IPIV( IX ) X IF( IP.NE.I ) X $ CALL ZSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) X IX = IX + INCX X 30 CONTINUE X END IF X* X RETURN X* X* End of ZLASWP X* X END X X X X SUBROUTINE ZTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, X $ B, LDB ) X* .. Scalar Arguments .. X CHARACTER*1 SIDE, UPLO, TRANSA, DIAG X INTEGER M, N, LDA, LDB X COMPLEX*16 ALPHA X* .. Array Arguments .. X COMPLEX*16 A( LDA, * ), B( LDB, * ) X* .. X* X* Purpose X* ======= X* X* ZTRSM solves one of the matrix equations X* X* op( A )*X = alpha*B, or X*op( A ) = alpha*B, X* X* where alpha is a scalar, X and B are m by n matrices, A is a unit, or X* non-unit, upper or lower triangular matrix and op( A ) is one of X* X* op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). X* X* The matrix X is overwritten on B. X* X* Parameters X* ========== X* X* SIDE - CHARACTER*1. X* On entry, SIDE specifies whether op( A ) appears on the left X* or right of X as follows: X* X* SIDE = 'L' or 'l' op( A )*X = alpha*B. X* X* SIDE = 'R' or 'r' X*op( A ) = alpha*B. X* X* Unchanged on exit. X* X* UPLO - CHARACTER*1. X* On entry, UPLO specifies whether the matrix A is an upper or X* lower triangular matrix as follows: X* X* UPLO = 'U' or 'u' A is an upper triangular matrix. X* X* UPLO = 'L' or 'l' A is a lower triangular matrix. X* X* Unchanged on exit. X* X* TRANSA - CHARACTER*1. X* On entry, TRANSA specifies the form of op( A ) to be used in X* the matrix multiplication as follows: X* X* TRANSA = 'N' or 'n' op( A ) = A. X* X* TRANSA = 'T' or 't' op( A ) = A'. X* X* TRANSA = 'C' or 'c' op( A ) = conjg( A' ). X* X* Unchanged on exit. X* X* DIAG - CHARACTER*1. X* On entry, DIAG specifies whether or not A is unit triangular X* as follows: X* X* DIAG = 'U' or 'u' A is assumed to be unit triangular. X* X* DIAG = 'N' or 'n' A is not assumed to be unit X* triangular. X* X* Unchanged on exit. X* X* M - INTEGER. X* On entry, M specifies the number of rows of B. M must be at X* least zero. X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the number of columns of B. N must be X* at least zero. X* Unchanged on exit. X* X* ALPHA - COMPLEX*16 . X* On entry, ALPHA specifies the scalar alpha. When alpha is X* zero then A is not referenced and B need not be set before X* entry. X* Unchanged on exit. X* X* A - COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m X* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. X* Before entry with UPLO = 'U' or 'u', the leading k by k X* upper triangular part of the array A must contain the upper X* triangular matrix and the strictly lower triangular part of X* A is not referenced. X* Before entry with UPLO = 'L' or 'l', the leading k by k X* lower triangular part of the array A must contain the lower X* triangular matrix and the strictly upper triangular part of X* A is not referenced. X* Note that when DIAG = 'U' or 'u', the diagonal elements of X* A are not referenced either, but are assumed to be unity. X* Unchanged on exit. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. When SIDE = 'L' or 'l' then X* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' X* then LDA must be at least max( 1, n ). X* Unchanged on exit. X* X* B - COMPLEX*16 array of DIMENSION ( LDB, n ). X* Before entry, the leading m by n part of the array B must X* contain the right-hand side matrix B, and on exit is X* overwritten by the solution matrix X. X* X* LDB - INTEGER. X* On entry, LDB specifies the first dimension of B as declared X* in the calling (sub) program. LDB must be at least X* max( 1, m ). X* Unchanged on exit. X* X* X* Level 3 Blas routine. X* X* -- Written on 8-February-1989. X* Jack Dongarra, Argonne National Laboratory. X* Iain Duff, AERE Harwell. X* Jeremy Du Croz, Numerical Algorithms Group Ltd. X* Sven Hammarling, Numerical Algorithms Group Ltd. X* X* X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC CONJG, MAX X* .. Local Scalars .. X LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER X INTEGER I, INFO, J, K, NROWA X COMPLEX*16 TEMP X* .. Parameters .. X COMPLEX*16 ONE X PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) X COMPLEX*16 ZERO X PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X LSIDE = LSAME( SIDE , 'L' ) X IF( LSIDE )THEN X NROWA = M X ELSE X NROWA = N X END IF X NOCONJ = LSAME( TRANSA, 'T' ) X NOUNIT = LSAME( DIAG , 'N' ) X UPPER = LSAME( UPLO , 'U' ) X* X INFO = 0 X IF( ( .NOT.LSIDE ).AND. X $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN X INFO = 1 X ELSE IF( ( .NOT.UPPER ).AND. X $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN X INFO = 2 X ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. X $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. X $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN X INFO = 3 X ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. X $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN X INFO = 4 X ELSE IF( M .LT.0 )THEN X INFO = 5 X ELSE IF( N .LT.0 )THEN X INFO = 6 X ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN X INFO = 9 X ELSE IF( LDB.LT.MAX( 1, M ) )THEN X INFO = 11 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'ZTRSM ', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( N.EQ.0 ) X $ RETURN X* X* And when alpha.eq.zero. X* X IF( ALPHA.EQ.ZERO )THEN X DO 20, J = 1, N X DO 10, I = 1, M X B( I, J ) = ZERO X 10 CONTINUE X 20 CONTINUE X RETURN X END IF X* X* Start the operations. X* X IF( LSIDE )THEN X IF( LSAME( TRANSA, 'N' ) )THEN X* X* Form B := alpha*inv( A )*B. X* X IF( UPPER )THEN X DO 60, J = 1, N X IF( ALPHA.NE.ONE )THEN X DO 30, I = 1, M X B( I, J ) = ALPHA*B( I, J ) X 30 CONTINUE X END IF X DO 50, K = M, 1, -1 X IF( B( K, J ).NE.ZERO )THEN X IF( NOUNIT ) X $ B( K, J ) = B( K, J )/A( K, K ) X DO 40, I = 1, K - 1 X B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) X 40 CONTINUE X END IF X 50 CONTINUE X 60 CONTINUE X ELSE X DO 100, J = 1, N X IF( ALPHA.NE.ONE )THEN X DO 70, I = 1, M X B( I, J ) = ALPHA*B( I, J ) X 70 CONTINUE X END IF X DO 90 K = 1, M X IF( B( K, J ).NE.ZERO )THEN X IF( NOUNIT ) X $ B( K, J ) = B( K, J )/A( K, K ) X DO 80, I = K + 1, M X B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) X 80 CONTINUE X END IF X 90 CONTINUE X 100 CONTINUE X END IF X ELSE X* X* Form B := alpha*inv( A' )*B X* or B := alpha*inv( conjg( A' ) )*B. X* X IF( UPPER )THEN X DO 140, J = 1, N X DO 130, I = 1, M X TEMP = ALPHA*B( I, J ) X IF( NOCONJ )THEN X DO 110, K = 1, I - 1 X TEMP = TEMP - A( K, I )*B( K, J ) X 110 CONTINUE X IF( NOUNIT ) X $ TEMP = TEMP/A( I, I ) X ELSE X DO 120, K = 1, I - 1 X TEMP = TEMP - CONJG( A( K, I ) )*B( K, J ) X 120 CONTINUE X IF( NOUNIT ) X $ TEMP = TEMP/CONJG( A( I, I ) ) X END IF X B( I, J ) = TEMP X 130 CONTINUE X 140 CONTINUE X ELSE X DO 180, J = 1, N X DO 170, I = M, 1, -1 X TEMP = ALPHA*B( I, J ) X IF( NOCONJ )THEN X DO 150, K = I + 1, M X TEMP = TEMP - A( K, I )*B( K, J ) X 150 CONTINUE X IF( NOUNIT ) X $ TEMP = TEMP/A( I, I ) X ELSE X DO 160, K = I + 1, M X TEMP = TEMP - CONJG( A( K, I ) )*B( K, J ) X 160 CONTINUE X IF( NOUNIT ) X $ TEMP = TEMP/CONJG( A( I, I ) ) X END IF X B( I, J ) = TEMP X 170 CONTINUE X 180 CONTINUE X END IF X END IF X ELSE X IF( LSAME( TRANSA, 'N' ) )THEN X* X* Form B := alpha*B*inv( A ). X* X IF( UPPER )THEN X DO 230, J = 1, N X IF( ALPHA.NE.ONE )THEN X DO 190, I = 1, M X B( I, J ) = ALPHA*B( I, J ) X 190 CONTINUE X END IF X DO 210, K = 1, J - 1 X IF( A( K, J ).NE.ZERO )THEN X DO 200, I = 1, M X B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) X 200 CONTINUE X END IF X 210 CONTINUE X IF( NOUNIT )THEN X TEMP = ONE/A( J, J ) X DO 220, I = 1, M X B( I, J ) = TEMP*B( I, J ) X 220 CONTINUE X END IF X 230 CONTINUE X ELSE X DO 280, J = N, 1, -1 X IF( ALPHA.NE.ONE )THEN X DO 240, I = 1, M X B( I, J ) = ALPHA*B( I, J ) X 240 CONTINUE X END IF X DO 260, K = J + 1, N X IF( A( K, J ).NE.ZERO )THEN X DO 250, I = 1, M X B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) X 250 CONTINUE X END IF X 260 CONTINUE X IF( NOUNIT )THEN X TEMP = ONE/A( J, J ) X DO 270, I = 1, M X B( I, J ) = TEMP*B( I, J ) X 270 CONTINUE X END IF X 280 CONTINUE X END IF X ELSE X* X* Form B := alpha*B*inv( A' ) X* or B := alpha*B*inv( conjg( A' ) ). X* X IF( UPPER )THEN X DO 330, K = N, 1, -1 X IF( NOUNIT )THEN X IF( NOCONJ )THEN X TEMP = ONE/A( K, K ) X ELSE X TEMP = ONE/CONJG( A( K, K ) ) X END IF X DO 290, I = 1, M X B( I, K ) = TEMP*B( I, K ) X 290 CONTINUE X END IF X DO 310, J = 1, K - 1 X IF( A( J, K ).NE.ZERO )THEN X IF( NOCONJ )THEN X TEMP = A( J, K ) X ELSE X TEMP = CONJG( A( J, K ) ) X END IF X DO 300, I = 1, M X B( I, J ) = B( I, J ) - TEMP*B( I, K ) X 300 CONTINUE X END IF X 310 CONTINUE X IF( ALPHA.NE.ONE )THEN X DO 320, I = 1, M X B( I, K ) = ALPHA*B( I, K ) X 320 CONTINUE X END IF X 330 CONTINUE X ELSE X DO 380, K = 1, N X IF( NOUNIT )THEN X IF( NOCONJ )THEN X TEMP = ONE/A( K, K ) X ELSE X TEMP = ONE/CONJG( A( K, K ) ) X END IF X DO 340, I = 1, M X B( I, K ) = TEMP*B( I, K ) X 340 CONTINUE X END IF X DO 360, J = K + 1, N X IF( A( J, K ).NE.ZERO )THEN X IF( NOCONJ )THEN X TEMP = A( J, K ) X ELSE X TEMP = CONJG( A( J, K ) ) X END IF X DO 350, I = 1, M X B( I, J ) = B( I, J ) - TEMP*B( I, K ) X 350 CONTINUE X END IF X 360 CONTINUE X IF( ALPHA.NE.ONE )THEN X DO 370, I = 1, M X B( I, K ) = ALPHA*B( I, K ) X 370 CONTINUE X END IF X 380 CONTINUE X END IF X END IF X END IF X* X RETURN X* X* End of ZTRSM . X* X END X X X SUBROUTINE ZGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, X $ BETA, C, LDC ) X* .. Scalar Arguments .. X CHARACTER*1 TRANSA, TRANSB X INTEGER M, N, K, LDA, LDB, LDC X COMPLEX*16 ALPHA, BETA X* .. Array Arguments .. X COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) X* .. X* X* Purpose X* ======= X* X* ZGEMM performs one of the matrix-matrix operations X* X* C := alpha*op( A )*op( B ) + beta*C, X* X* where op( X ) is one of X* X* op( X ) = X or op( X ) = X' or op( X ) = conjg( X' ), X* X* alpha and beta are scalars, and A, B and C are matrices, with op( A ) X* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. X* X* Parameters X* ========== X* X* TRANSA - CHARACTER*1. X* On entry, TRANSA specifies the form of op( A ) to be used in X* the matrix multiplication as follows: X* X* TRANSA = 'N' or 'n', op( A ) = A. X* X* TRANSA = 'T' or 't', op( A ) = A'. X* X* TRANSA = 'C' or 'c', op( A ) = conjg( A' ). X* X* Unchanged on exit. X* X* TRANSB - CHARACTER*1. X* On entry, TRANSB specifies the form of op( B ) to be used in X* the matrix multiplication as follows: X* X* TRANSB = 'N' or 'n', op( B ) = B. X* X* TRANSB = 'T' or 't', op( B ) = B'. X* X* TRANSB = 'C' or 'c', op( B ) = conjg( B' ). X* X* Unchanged on exit. X* X* M - INTEGER. X* On entry, M specifies the number of rows of the matrix X* op( A ) and of the matrix C. M must be at least zero. X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the number of columns of the matrix X* op( B ) and the number of columns of the matrix C. N must be X* at least zero. X* Unchanged on exit. X* X* K - INTEGER. X* On entry, K specifies the number of columns of the matrix X* op( A ) and the number of rows of the matrix op( B ). K must X* be at least zero. X* Unchanged on exit. X* X* ALPHA - COMPLEX*16 . X* On entry, ALPHA specifies the scalar alpha. X* Unchanged on exit. X* X* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is X* k when TRANSA = 'N' or 'n', and is m otherwise. X* Before entry with TRANSA = 'N' or 'n', the leading m by k X* part of the array A must contain the matrix A, otherwise X* the leading k by m part of the array A must contain the X* matrix A. X* Unchanged on exit. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. When TRANSA = 'N' or 'n' then X* LDA must be at least max( 1, m ), otherwise LDA must be at X* least max( 1, k ). X* Unchanged on exit. X* X* B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is X* n when TRANSB = 'N' or 'n', and is k otherwise. X* Before entry with TRANSB = 'N' or 'n', the leading k by n X* part of the array B must contain the matrix B, otherwise X* the leading n by k part of the array B must contain the X* matrix B. X* Unchanged on exit. X* X* LDB - INTEGER. X* On entry, LDB specifies the first dimension of B as declared X* in the calling (sub) program. When TRANSB = 'N' or 'n' then X* LDB must be at least max( 1, k ), otherwise LDB must be at X* least max( 1, n ). X* Unchanged on exit. X* X* BETA - COMPLEX*16 . X* On entry, BETA specifies the scalar beta. When BETA is X* supplied as zero then C need not be set on input. X* Unchanged on exit. X* X* C - COMPLEX*16 array of DIMENSION ( LDC, n ). X* Before entry, the leading m by n part of the array C must X* contain the matrix C, except when beta is zero, in which X* case C need not be set on entry. X* On exit, the array C is overwritten by the m by n matrix X* ( alpha*op( A )*op( B ) + beta*C ). X* X* LDC - INTEGER. X* On entry, LDC specifies the first dimension of C as declared X* in the calling (sub) program. LDC must be at least X* max( 1, m ). X* Unchanged on exit. X* X* X* Level 3 Blas routine. X* X* -- Written on 8-February-1989. X* Jack Dongarra, Argonne National Laboratory. X* Iain Duff, AERE Harwell. X* Jeremy Du Croz, Numerical Algorithms Group Ltd. X* Sven Hammarling, Numerical Algorithms Group Ltd. X* X* X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC CONJG, MAX X* .. Local Scalars .. X LOGICAL CONJA, CONJB, NOTA, NOTB X INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB X COMPLEX*16 TEMP X* .. Parameters .. X COMPLEX*16 ONE X PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) X COMPLEX*16 ZERO X PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) X* .. X* .. Executable Statements .. X* X* Set NOTA and NOTB as true if A and B respectively are not X* conjugated or transposed, set CONJA and CONJB as true if A and X* B respectively are to be transposed but not conjugated and set X* NROWA, NCOLA and NROWB as the number of rows and columns of A X* and the number of rows of B respectively. X* X NOTA = LSAME( TRANSA, 'N' ) X NOTB = LSAME( TRANSB, 'N' ) X CONJA = LSAME( TRANSA, 'C' ) X CONJB = LSAME( TRANSB, 'C' ) X IF( NOTA )THEN X NROWA = M X NCOLA = K X ELSE X NROWA = K X NCOLA = M X END IF X IF( NOTB )THEN X NROWB = K X ELSE X NROWB = N X END IF X* X* Test the input parameters. X* X INFO = 0 X IF( ( .NOT.NOTA ).AND. X $ ( .NOT.CONJA ).AND. X $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN X INFO = 1 X ELSE IF( ( .NOT.NOTB ).AND. X $ ( .NOT.CONJB ).AND. X $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN X INFO = 2 X ELSE IF( M .LT.0 )THEN X INFO = 3 X ELSE IF( N .LT.0 )THEN X INFO = 4 X ELSE IF( K .LT.0 )THEN X INFO = 5 X ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN X INFO = 8 X ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN X INFO = 10 X ELSE IF( LDC.LT.MAX( 1, M ) )THEN X INFO = 13 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'ZGEMM ', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. X $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) X $ RETURN X* X* And when alpha.eq.zero. X* X IF( ALPHA.EQ.ZERO )THEN X IF( BETA.EQ.ZERO )THEN X DO 20, J = 1, N X DO 10, I = 1, M X C( I, J ) = ZERO X 10 CONTINUE X 20 CONTINUE X ELSE X DO 40, J = 1, N X DO 30, I = 1, M X C( I, J ) = BETA*C( I, J ) X 30 CONTINUE X 40 CONTINUE X END IF X RETURN X END IF X* X* Start the operations. X* X IF( NOTB )THEN X IF( NOTA )THEN X* X* Form C := alpha*A*B + beta*C. X* X DO 90, J = 1, N X IF( BETA.EQ.ZERO )THEN X DO 50, I = 1, M X C( I, J ) = ZERO X 50 CONTINUE X ELSE IF( BETA.NE.ONE )THEN X DO 60, I = 1, M X C( I, J ) = BETA*C( I, J ) X 60 CONTINUE X END IF X DO 80, L = 1, K X IF( B( L, J ).NE.ZERO )THEN X TEMP = ALPHA*B( L, J ) X DO 70, I = 1, M X C( I, J ) = C( I, J ) + TEMP*A( I, L ) X 70 CONTINUE X END IF X 80 CONTINUE X 90 CONTINUE X ELSE IF( CONJA )THEN X* X* Form C := alpha*conjg( A' )*B + beta*C. X* X DO 120, J = 1, N X DO 110, I = 1, M X TEMP = ZERO X DO 100, L = 1, K X TEMP = TEMP + CONJG( A( L, I ) )*B( L, J ) X 100 CONTINUE X IF( BETA.EQ.ZERO )THEN X C( I, J ) = ALPHA*TEMP X ELSE X C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) X END IF X 110 CONTINUE X 120 CONTINUE X ELSE X* X* Form C := alpha*A'*B + beta*C X* X DO 150, J = 1, N X DO 140, I = 1, M X TEMP = ZERO X DO 130, L = 1, K X TEMP = TEMP + A( L, I )*B( L, J ) X 130 CONTINUE X IF( BETA.EQ.ZERO )THEN X C( I, J ) = ALPHA*TEMP X ELSE X C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) X END IF X 140 CONTINUE X 150 CONTINUE X END IF X ELSE IF( NOTA )THEN X IF( CONJB )THEN X* X* Form C := alpha*A*conjg( B' ) + beta*C. X* X DO 200, J = 1, N X IF( BETA.EQ.ZERO )THEN X DO 160, I = 1, M X C( I, J ) = ZERO X 160 CONTINUE X ELSE IF( BETA.NE.ONE )THEN X DO 170, I = 1, M X C( I, J ) = BETA*C( I, J ) X 170 CONTINUE X END IF X DO 190, L = 1, K X IF( B( J, L ).NE.ZERO )THEN X TEMP = ALPHA*CONJG( B( J, L ) ) X DO 180, I = 1, M X C( I, J ) = C( I, J ) + TEMP*A( I, L ) X 180 CONTINUE X END IF X 190 CONTINUE X 200 CONTINUE X ELSE X* X* Form C := alpha*A*B' + beta*C X* X DO 250, J = 1, N X IF( BETA.EQ.ZERO )THEN X DO 210, I = 1, M X C( I, J ) = ZERO X 210 CONTINUE X ELSE IF( BETA.NE.ONE )THEN X DO 220, I = 1, M X C( I, J ) = BETA*C( I, J ) X 220 CONTINUE X END IF X DO 240, L = 1, K X IF( B( J, L ).NE.ZERO )THEN X TEMP = ALPHA*B( J, L ) X DO 230, I = 1, M X C( I, J ) = C( I, J ) + TEMP*A( I, L ) X 230 CONTINUE X END IF X 240 CONTINUE X 250 CONTINUE X END IF X ELSE IF( CONJA )THEN X IF( CONJB )THEN X* X* Form C := alpha*conjg( A' )*conjg( B' ) + beta*C. X* X DO 280, J = 1, N X DO 270, I = 1, M X TEMP = ZERO X DO 260, L = 1, K X TEMP = TEMP + X $ CONJG( A( L, I ) )*CONJG( B( J, L ) ) X 260 CONTINUE X IF( BETA.EQ.ZERO )THEN X C( I, J ) = ALPHA*TEMP X ELSE X C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) X END IF X 270 CONTINUE X 280 CONTINUE X ELSE X* X* Form C := alpha*conjg( A' )*B' + beta*C X* X DO 310, J = 1, N X DO 300, I = 1, M X TEMP = ZERO X DO 290, L = 1, K X TEMP = TEMP + CONJG( A( L, I ) )*B( J, L ) X 290 CONTINUE X IF( BETA.EQ.ZERO )THEN X C( I, J ) = ALPHA*TEMP X ELSE X C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) X END IF X 300 CONTINUE X 310 CONTINUE X END IF X ELSE X IF( CONJB )THEN X* X* Form C := alpha*A'*conjg( B' ) + beta*C X* X DO 340, J = 1, N X DO 330, I = 1, M X TEMP = ZERO X DO 320, L = 1, K X TEMP = TEMP + A( L, I )*CONJG( B( J, L ) ) X 320 CONTINUE X IF( BETA.EQ.ZERO )THEN X C( I, J ) = ALPHA*TEMP X ELSE X C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) X END IF X 330 CONTINUE X 340 CONTINUE X ELSE X* X* Form C := alpha*A'*B' + beta*C X* X DO 370, J = 1, N X DO 360, I = 1, M X TEMP = ZERO X DO 350, L = 1, K X TEMP = TEMP + A( L, I )*B( J, L ) X 350 CONTINUE X IF( BETA.EQ.ZERO )THEN X C( I, J ) = ALPHA*TEMP X ELSE X C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) X END IF X 360 CONTINUE X 370 CONTINUE X END IF X END IF X* X RETURN X* X* End of ZGEMM . X* X END X X X integer function izamax(n,zx,incx) Xc Xc finds the index of element having max. absolute value. Xc jack dongarra, 1/15/85. Xc modified 3/93 to return if incx .le. 0. Xc modified 12/3/93, array(1) declarations changed to array(*) Xc X complex*16 zx(*) X double precision smax X integer i,incx,ix,n X double precision dcabs1 Xc X izamax = 0 X if( n.lt.1 .or. incx.le.0 )return X izamax = 1 X if(n.eq.1)return X if(incx.eq.1)go to 20 Xc Xc code for increment not equal to 1 Xc X ix = 1 X smax = dcabs1(zx(1)) X ix = ix + incx X do 10 i = 2,n X if(dcabs1(zx(ix)).le.smax) go to 5 X izamax = i X smax = dcabs1(zx(ix)) X 5 ix = ix + incx X 10 continue X return Xc Xc code for increment equal to 1 Xc X 20 smax = dcabs1(zx(1)) X do 30 i = 2,n X if(dcabs1(zx(i)).le.smax) go to 30 X izamax = i X smax = dcabs1(zx(i)) X 30 continue X return X end X X X subroutine zscal(n,za,zx,incx) Xc Xc scales a vector by a constant. Xc jack dongarra, 3/11/78. Xc modified 3/93 to return if incx .le. 0. Xc modified 12/3/93, array(1) declarations changed to array(*) Xc X complex*16 za,zx(*) X integer i,incx,ix,n Xc X if( n.le.0 .or. incx.le.0 )return X if(incx.eq.1)go to 20 Xc Xc code for increment not equal to 1 Xc X ix = 1 X do 10 i = 1,n X zx(ix) = za*zx(ix) X ix = ix + incx X 10 continue X return Xc Xc code for increment equal to 1 Xc X 20 do 30 i = 1,n X zx(i) = za*zx(i) X 30 continue X return X end X X X SUBROUTINE ZGERU ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) X* .. Scalar Arguments .. X COMPLEX*16 ALPHA X INTEGER INCX, INCY, LDA, M, N X* .. Array Arguments .. X COMPLEX*16 A( LDA, * ), X( * ), Y( * ) X* .. X* X* Purpose X* ======= X* X* ZGERU performs the rank 1 operation X* X* A := alpha*x*y' + A, X* X* where alpha is a scalar, x is an m element vector, y is an n element X* vector and A is an m by n matrix. X* X* Parameters X* ========== X* X* M - INTEGER. X* On entry, M specifies the number of rows of the matrix A. X* M must be at least zero. X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the number of columns of the matrix A. X* N must be at least zero. X* Unchanged on exit. X* X* ALPHA - COMPLEX*16 . X* On entry, ALPHA specifies the scalar alpha. X* Unchanged on exit. X* X* X - COMPLEX*16 array of dimension at least X* ( 1 + ( m - 1 )*abs( INCX ) ). X* Before entry, the incremented array X must contain the m X* element vector x. X* Unchanged on exit. X* X* INCX - INTEGER. X* On entry, INCX specifies the increment for the elements of X* X. INCX must not be zero. X* Unchanged on exit. X* X* Y - COMPLEX*16 array of dimension at least X* ( 1 + ( n - 1 )*abs( INCY ) ). X* Before entry, the incremented array Y must contain the n X* element vector y. X* Unchanged on exit. X* X* INCY - INTEGER. X* On entry, INCY specifies the increment for the elements of X* Y. INCY must not be zero. X* Unchanged on exit. X* X* A - COMPLEX*16 array of DIMENSION ( LDA, n ). X* Before entry, the leading m by n part of the array A must X* contain the matrix of coefficients. On exit, A is X* overwritten by the updated matrix. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. LDA must be at least X* max( 1, m ). X* Unchanged on exit. X* X* X* Level 2 Blas routine. X* X* -- Written on 22-October-1986. X* Jack Dongarra, Argonne National Lab. X* Jeremy Du Croz, Nag Central Office. X* Sven Hammarling, Nag Central Office. X* Richard Hanson, Sandia National Labs. X* X* X* .. Parameters .. X COMPLEX*16 ZERO X PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) X* .. Local Scalars .. X COMPLEX*16 TEMP X INTEGER I, INFO, IX, J, JY, KX X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF ( M.LT.0 )THEN X INFO = 1 X ELSE IF( N.LT.0 )THEN X INFO = 2 X ELSE IF( INCX.EQ.0 )THEN X INFO = 5 X ELSE IF( INCY.EQ.0 )THEN X INFO = 7 X ELSE IF( LDA.LT.MAX( 1, M ) )THEN X INFO = 9 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'ZGERU ', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) X $ RETURN X* X* Start the operations. In this version the elements of A are X* accessed sequentially with one pass through A. X* X IF( INCY.GT.0 )THEN X JY = 1 X ELSE X JY = 1 - ( N - 1 )*INCY X END IF X IF( INCX.EQ.1 )THEN X DO 20, J = 1, N X IF( Y( JY ).NE.ZERO )THEN X TEMP = ALPHA*Y( JY ) X DO 10, I = 1, M X A( I, J ) = A( I, J ) + X( I )*TEMP X 10 CONTINUE X END IF X JY = JY + INCY X 20 CONTINUE X ELSE X IF( INCX.GT.0 )THEN X KX = 1 X ELSE X KX = 1 - ( M - 1 )*INCX X END IF X DO 40, J = 1, N X IF( Y( JY ).NE.ZERO )THEN X TEMP = ALPHA*Y( JY ) X IX = KX X DO 30, I = 1, M X A( I, J ) = A( I, J ) + X( IX )*TEMP X IX = IX + INCX X 30 CONTINUE X END IF X JY = JY + INCY X 40 CONTINUE X END IF X* X RETURN X* X* End of ZGERU . X* X END X X X subroutine zswap (n,zx,incx,zy,incy) Xc Xc interchanges two vectors. Xc jack dongarra, 3/11/78. Xc modified 12/3/93, array(1) declarations changed to array(*) Xc X complex*16 zx(*),zy(*),ztemp X integer i,incx,incy,ix,iy,n Xc X if(n.le.0)return X if(incx.eq.1.and.incy.eq.1)go to 20 Xc Xc code for unequal increments or equal increments not equal Xc to 1 Xc X ix = 1 X iy = 1 X if(incx.lt.0)ix = (-n+1)*incx + 1 X if(incy.lt.0)iy = (-n+1)*incy + 1 X do 10 i = 1,n X ztemp = zx(ix) X zx(ix) = zy(iy) X zy(iy) = ztemp X ix = ix + incx X iy = iy + incy X 10 continue X return Xc Xc code for both increments equal to 1 X 20 do 30 i = 1,n X ztemp = zx(i) X zx(i) = zy(i) X zy(i) = ztemp X 30 continue X return X end X X X double precision function dcabs1(z) X complex*16 z Xc complex*16 z,zz Xc double precision t(2) Xc equivalence (zz,t(1)) Xc zz = z Xc dcabs1 = dabs(t(1)) + dabs(t(2)) X dcabs1=abs(real(z))+abs(real(z*(0,1))) X return X end X X X X X X X X X X X X X X END_OF_FILE if test 121427 -ne `wc -c <'solve.f'`; then echo shar: \"'solve.f'\" unpacked with wrong size! fi # end of 'solve.f' fi if test -f 'data' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'data'\" else echo shar: Extracting \"'data'\" \(56589 characters\) sed "s/^X//" >'data' <<'END_OF_FILE' X 16 X241 X 1.000000000000000E-012 X 1 5 1 0.999625272066570 X 1 6 1 3.154477295292300E-004 X 1 7 1 2.023826030560400E-007 X 1 8 1 6.386506465393800E-011 X 1 5 2 6.123397102626200E-004 X 1 6 2 0.999328380085830 X 1 7 2 1.239733607988200E-010 X 1 8 2 2.023224947598900E-007 X 1 5 3 9.522819758999401E-009 X 1 6 3 3.005077958345600E-012 X 1 7 3 0.998036914290950 X 1 8 3 3.149464978497200E-004 X 1 5 4 5.833386625023700E-012 X 1 6 4 9.519991450332800E-009 X 1 7 4 6.113667311200400E-004 X 1 8 4 0.997740494057680 X 1 9 5 0.999625272066570 X 1 10 5 3.154477295292300E-004 X 1 11 5 2.023826030560400E-007 X 1 12 5 6.386506465393800E-011 X 1 9 6 6.123397102626200E-004 X 1 10 6 0.999328380085830 X 1 11 6 1.239733607988200E-010 X 1 12 6 2.023224947598900E-007 X 1 9 7 9.522819758999401E-009 X 1 10 7 3.005077958345600E-012 X 1 11 7 0.998036914290950 X 1 12 7 3.149464978497200E-004 X 1 9 8 5.833386625023700E-012 X 1 10 8 9.519991450332800E-009 X 1 11 8 6.113667311200400E-004 X 1 12 8 0.997740494057680 X 1 13 9 0.932227158348720 X 1 14 9 5.616222488423600E-002 X 1 15 9 3.194606212099700E-005 X 1 16 9 1.924597356918100E-006 X 1 13 10 0.109020789481160 X 1 14 10 0.879368593751780 X 1 15 10 3.735983104605700E-006 X 1 16 10 3.013467637330900E-005 X 1 13 11 1.503175604001000E-006 X 1 14 11 9.055913631816900E-008 X 1 15 11 0.681505132818680 X 1 16 11 4.105742273902600E-002 X 1 13 12 1.757912646176200E-007 X 1 14 12 1.417943475701500E-006 X 1 15 12 7.969970296399100E-002 X 1 16 12 0.642862852593710 X 1 1 13 0.999625272066570 X 1 2 13 3.154477295292300E-004 X 1 3 13 2.023826030560400E-007 X 1 4 13 6.386506465393800E-011 X 1 1 14 6.123397102626200E-004 X 1 2 14 0.999328380085830 X 1 3 14 1.239733607988200E-010 X 1 4 14 2.023224947598900E-007 X 1 1 15 9.522819758999401E-009 X 1 2 15 3.005077958345600E-012 X 1 3 15 0.998036914290950 X 1 4 15 3.149464978497200E-004 X 1 1 16 5.833386625023700E-012 X 1 2 16 9.519991450332800E-009 X 1 3 16 6.113667311200400E-004 X 1 4 16 0.997740494057680 X 4 5 1 5.905736385601500E-005 X 4 6 1 1.863649495560200E-008 X 4 7 1 1.195666352262000E-011 X 4 8 1 3.773116253011600E-015 X 4 5 3 1.570778972913800E-011 X 4 6 3 4.956844073915300E-015 X 4 7 3 1.646251256282000E-003 X 4 8 3 5.195008925246700E-007 X 4 9 5 5.905736385601500E-005 X 4 10 5 1.863649495560200E-008 X 4 11 5 1.195666352262000E-011 X 4 12 5 3.773116253011600E-015 X 4 9 7 1.570778972913800E-011 X 4 10 7 4.956844073915300E-015 X 4 11 7 1.646251256282000E-003 X 4 12 7 5.195008925246700E-007 X 4 13 9 1.083673580128100E-002 X 4 14 9 3.316712956466100E-004 X 4 15 9 5.083931788489500E-006 X 4 16 9 1.054923245477500E-007 X 4 13 10 6.373916210635600E-004 X 4 14 10 1.314101571372500E-005 X 4 15 10 3.962582593912800E-007 X 4 16 10 6.132537288346200E-009 X 4 13 11 2.416076995355800E-007 X 4 14 11 9.754560488070000E-009 X 4 15 11 0.221186466027010 X 4 16 11 6.769677060694300E-003 X 4 13 12 9.625203348854000E-009 X 4 14 12 2.885576446810200E-010 X 4 15 12 1.300967401284300E-002 X 4 16 12 2.682186664737900E-004 X 4 1 13 5.905736385601500E-005 X 4 2 13 1.863649495560200E-008 X 4 3 13 1.195666352262000E-011 X 4 4 13 3.773116253011600E-015 X 4 1 15 1.570778972913800E-011 X 4 2 15 4.956844073915300E-015 X 4 3 15 1.646251256282000E-003 X 4 4 15 5.195008925246700E-007 X 7 5 1 1.744539840620100E-009 X 7 6 1 5.505174260542800E-013 X 7 7 1 3.531968668116600E-016 X 7 5 3 1.295491589776500E-014 X 7 6 3 4.088130742976900E-018 X 7 7 3 1.357736953415000E-006 X 7 8 3 4.284555935318100E-010 X 7 9 5 1.744539840620100E-009 X 7 10 5 5.505174260542800E-013 X 7 11 5 3.531968668116600E-016 X 7 9 7 1.295491589776500E-014 X 7 10 7 4.088130742976900E-018 X 7 11 7 1.357736953415000E-006 X 7 12 7 4.284555935318100E-010 X 7 13 9 6.302409326991700E-005 X 7 14 9 1.296122537635000E-006 X 7 15 9 5.345578539758600E-007 X 7 16 9 8.148046324630401E-009 X 7 13 10 2.478155530717600E-006 X 7 14 10 3.845963434435400E-008 X 7 15 10 3.147739136558200E-008 X 7 16 10 3.866039055804900E-010 X 7 13 11 2.553519844753100E-008 X 7 14 11 7.789695943455900E-010 X 7 15 11 3.591528798559600E-002 X 7 16 11 7.386161664976500E-004 X 7 13 12 7.436674197886100E-010 X 7 14 12 1.819108587089800E-011 X 7 15 12 1.412216580454400E-003 X 7 16 12 2.191683796298700E-005 X 7 1 13 1.744539840620100E-009 X 7 2 13 5.505174260542800E-013 X 7 3 13 3.531968668116600E-016 X 7 1 15 1.295491589776500E-014 X 7 2 15 4.088130742976900E-018 X 7 3 15 1.357736953415000E-006 X 7 4 15 4.284555935318100E-010 X 10 5 1 3.435551534754000E-014 X 10 6 1 1.084143190056000E-017 X 10 5 3 7.122998580626900E-018 X 10 7 3 7.465242127668500E-010 X 10 8 3 2.355776454801500E-013 X 10 9 5 3.435551534754000E-014 X 10 10 5 1.084143190056000E-017 X 10 9 7 7.122998580626900E-018 X 10 11 7 7.465242127668500E-010 X 10 12 7 2.355776454801500E-013 X 10 13 9 2.444155222326100E-007 X 10 14 9 3.791395816166000E-009 X 10 15 9 4.258473727874200E-008 X 10 16 9 5.238557111669800E-010 X 10 13 10 7.212244034134600E-009 X 10 14 10 8.986759369223200E-011 X 10 15 10 2.012882436767600E-009 X 10 16 10 2.074865459886900E-011 X 10 13 11 2.044069905468700E-009 X 10 14 11 5.006338037105800E-011 X 10 15 11 3.888787262579800E-003 X 10 16 11 6.032322047763900E-005 X 10 13 12 4.780463151015900E-011 X 10 14 12 9.762978388614500E-013 X 10 15 12 1.147508219451300E-004 X 10 16 12 1.429843444902800E-006 X 10 1 13 3.435551534754000E-014 X 10 2 13 1.084143190056000E-017 X 10 1 15 7.122998580626900E-018 X 10 3 15 7.465242127668500E-010 X 10 4 15 2.355776454801500E-013 X 13 7 3 3.078459337311900E-013 X 13 8 3 9.714570404923000E-017 X 13 11 7 3.078459337311900E-013 X 13 12 7 9.714570404923000E-017 X 13 13 9 7.109934992240800E-010 X 13 14 9 8.863965248048300E-012 X 13 15 9 2.729448095455500E-009 X 13 16 9 2.818057909730800E-011 X 13 13 10 1.677607816231800E-011 X 13 14 10 1.747965059954600E-013 X 13 15 10 1.076838975781500E-010 X 13 16 10 9.571366784355200E-013 X 13 13 11 1.316489961740500E-010 X 13 14 11 2.691752705282300E-012 X 13 15 11 3.158371250167700E-004 X 13 16 11 3.937543523676700E-006 X 13 13 12 2.571167174750600E-012 X 13 14 12 4.503667773729100E-014 X 13 15 12 7.452255636100300E-006 X 13 16 12 7.764789277188500E-008 X 13 3 15 3.078459337311900E-013 X 13 4 15 9.714570404923000E-017 X 16 7 3 1.015577175331900E-016 X 16 11 7 1.015577175331900E-016 X 16 13 9 1.654752004648700E-012 X 16 14 9 1.726062046093300E-014 X 16 15 9 1.462639409808800E-010 X 16 16 9 1.301670574015300E-012 X 16 13 10 3.250211569507600E-014 X 16 14 10 2.912296952652600E-016 X 16 15 10 4.949947516512400E-012 X 16 16 10 3.868889109458800E-014 X 16 13 11 7.089045311797200E-012 X 16 14 11 1.243577686061400E-013 X 16 15 11 2.052260514168900E-005 X 16 16 11 2.140675258472800E-007 X 16 13 12 1.187416174287800E-013 X 16 14 12 1.820449638486500E-015 X 16 15 12 4.030932597889600E-007 X 16 16 12 3.611776634326800E-009 X 16 3 15 1.015577175331900E-016 X 19 13 9 3.211064141518400E-015 X 19 14 9 2.882126257300500E-017 X 19 15 9 6.731955376875400E-012 X 19 16 9 5.266856225916900E-014 X 19 13 10 5.399742128792900E-017 X 19 15 10 1.994195869116600E-013 X 19 16 10 1.391465022053600E-015 X 19 13 11 3.278717475832200E-013 X 19 14 11 5.035374525150400E-015 X 19 15 11 1.111321108539000E-006 X 19 16 11 9.972045944952000E-009 X 19 13 12 4.803686893582500E-015 X 19 14 12 6.547336779881000E-017 X 19 15 12 1.868237854028200E-008 X 19 16 12 1.469327952697000E-010 X 22 13 9 5.397209351594700E-018 X 22 15 9 2.714839697125300E-013 X 22 16 9 1.895793987004900E-015 X 22 15 10 7.149549467381400E-015 X 22 16 10 4.507231592858100E-017 X 22 13 11 1.328685696080500E-014 X 22 14 11 1.814416026680200E-016 X 22 15 11 5.158370679011400E-008 X 22 16 11 4.063774013218100E-010 X 22 13 12 1.728763798816900E-016 X 22 14 12 2.120812432626500E-018 X 22 15 12 7.574798843936300E-010 X 22 16 12 5.311574495355700E-012 X 25 5 2 3.617672550205200E-008 X 25 6 2 5.903982362546800E-005 X 25 7 2 7.324284491140200E-015 X 25 8 2 1.195311235438200E-011 X 25 5 4 9.622109084659101E-015 X 25 6 4 1.570312446412700E-011 X 25 7 4 1.008442909018500E-006 X 25 8 4 1.645762314265500E-003 X 25 9 6 3.617672550205200E-008 X 25 10 6 5.903982362546800E-005 X 25 11 6 7.324284491140200E-015 X 25 12 6 1.195311235438200E-011 X 25 9 8 9.622109084659101E-015 X 25 10 8 1.570312446412700E-011 X 25 11 8 1.008442909018500E-006 X 25 12 8 1.645762314265500E-003 X 25 13 9 1.314101571372500E-005 X 25 14 9 3.219818577776000E-004 X 25 15 9 6.132547029430300E-009 X 25 16 9 2.011596913656400E-007 X 25 13 10 6.314645002893300E-004 X 25 14 10 1.022153283335300E-002 X 25 15 10 1.990074186698400E-007 X 25 16 10 4.795318126512500E-006 X 25 13 11 2.885581237552100E-010 X 25 14 11 4.818531357877600E-009 X 25 15 11 2.682207615628500E-004 X 25 16 11 6.571907880013400E-003 X 25 13 12 1.866373964039200E-008 X 25 14 12 2.278918483920500E-007 X 25 15 12 1.288869675313800E-002 X 25 16 12 0.208629680214490 X 25 1 14 3.617672550205200E-008 X 25 2 14 5.903982362546800E-005 X 25 3 14 7.324284491140200E-015 X 25 4 14 1.195311235438200E-011 X 25 1 16 9.622109084659101E-015 X 25 2 16 1.570312446412700E-011 X 25 3 16 1.008442909018500E-006 X 25 4 16 1.645762314265500E-003 X 28 13 9 7.691926844265000E-008 X 28 14 9 1.267965049222300E-006 X 28 15 9 5.892890375176000E-010 X 28 16 9 8.273643381084301E-009 X 28 13 10 2.462074615240300E-006 X 28 14 10 7.602457242478500E-008 X 28 15 10 1.588306773444700E-008 X 28 16 10 5.817288468017900E-010 X 28 13 11 2.818706635108100E-011 X 28 14 11 3.923815569254800E-010 X 28 15 11 4.383375156508900E-005 X 28 16 11 7.225701733917800E-004 X 28 13 12 7.704994757476200E-010 X 28 14 12 2.783133180035000E-011 X 28 15 12 1.403052617792100E-003 X 28 16 12 4.332381908976000E-005 X 31 13 9 2.696027607190800E-010 X 31 14 9 3.710945858319400E-009 X 31 15 9 4.184792729058900E-011 X 31 16 9 5.131295295380300E-010 X 31 13 10 7.205684792780900E-009 X 31 14 10 1.780159491305600E-010 X 31 15 10 1.023532367031100E-009 X 31 16 10 3.087646851454600E-011 X 31 13 11 2.013557551195500E-012 X 31 14 11 2.540572102850500E-011 X 31 15 11 4.289532792459000E-006 X 31 16 11 5.904321946210300E-005 X 31 13 12 4.805091919040900E-011 X 31 14 12 1.481778710692100E-012 X 31 15 12 1.146464661078700E-004 X 31 16 12 2.832333033572900E-006 X 34 13 9 6.991848484600201E-013 X 34 14 9 8.670982555741601E-012 X 34 15 9 2.400064234549200E-012 X 34 16 9 2.753417034059800E-011 X 34 13 10 1.683669199414000E-011 X 34 14 10 3.467547954190000E-013 X 34 15 10 5.505615380940200E-011 X 34 16 10 1.424340835264700E-012 X 34 13 11 1.160984673961300E-013 X 34 14 11 1.373038727644900E-012 X 34 15 11 3.105916436881500E-007 X 34 16 11 3.851820266999900E-006 X 34 13 12 2.591035820091500E-012 X 34 14 12 6.857300518369999E-014 X 34 15 12 7.479188313002500E-006 X 34 16 12 1.540351998781100E-007 X 37 13 9 1.456093636014000E-015 X 37 14 9 1.686500151746100E-014 X 37 15 9 1.159507806898900E-013 X 37 16 9 1.269802612941600E-012 X 37 13 10 3.274713316797000E-014 X 37 14 10 5.783468141745600E-016 X 37 15 10 2.541165177040200E-012 X 37 16 10 5.757235165372800E-014 X 37 13 11 5.638012174644500E-015 X 37 14 11 6.367343144127000E-014 X 37 15 11 1.805888513751500E-008 X 37 16 11 2.091647802515200E-007 X 37 13 12 1.200754213557400E-013 X 37 14 12 2.780610253488000E-015 X 37 15 12 4.061397062135000E-007 X 37 16 12 7.172753074535900E-009 X 40 13 9 2.547068650309300E-018 X 40 14 9 2.810757386675600E-017 X 40 15 9 4.849154328230000E-015 X 40 16 9 5.128825354261200E-014 X 40 13 10 5.457695701929300E-017 X 40 15 10 1.027028936280000E-013 X 40 16 10 2.069910859727100E-015 X 40 13 11 2.369911841474500E-016 X 40 14 11 2.585579030178600E-015 X 40 15 11 8.815968207558500E-010 X 40 16 11 9.728838630787600E-009 X 40 13 12 4.873645439178600E-015 X 40 14 12 1.002919133871200E-016 X 40 15 12 1.889064207926600E-008 X 40 16 12 2.920478822986600E-010 X 43 15 9 1.789846261826100E-016 X 43 16 9 1.842545914513000E-015 X 43 15 10 3.691481491969000E-015 X 43 16 10 6.700963501076500E-017 X 43 13 11 8.791721917943199E-018 X 43 14 11 9.337412995560400E-017 X 43 15 11 3.718102260797300E-011 X 43 16 11 3.957685474333200E-010 X 43 13 12 1.759438150771000E-016 X 43 14 12 3.257170642749100E-018 X 43 15 12 7.684685254065800E-010 X 43 16 12 1.056470234452800E-011 X 46 15 9 5.916357980573000E-018 X 46 16 9 5.960147187542800E-017 X 46 15 10 1.194598049384500E-016 X 46 16 10 1.972802519946200E-018 X 46 14 11 3.035981429547300E-018 X 46 15 11 1.382158511427700E-012 X 46 16 11 1.430638127901900E-011 X 46 13 12 5.719176320585100E-018 X 46 15 12 2.777882507476000E-011 X 46 16 12 3.438344639784800E-013 X 49 5 2 1.068651474105400E-012 X 49 6 2 1.744021706572100E-009 X 49 8 2 3.530919661850900E-016 X 49 5 4 7.935783206955100E-018 X 49 6 4 1.295106824530100E-014 X 49 7 4 8.317079168558800E-010 X 49 8 4 1.357333701091700E-006 X 49 9 6 1.068651474105400E-012 X 49 10 6 1.744021706572100E-009 X 49 12 6 3.530919661850900E-016 X 49 9 8 7.935783206955100E-018 X 49 10 8 1.295106824530100E-014 X 49 11 8 8.317079168558800E-010 X 49 12 8 1.357333701091700E-006 X 49 13 9 3.801228633542100E-008 X 49 14 9 1.239736491232300E-006 X 49 15 9 3.828239677736500E-010 X 49 16 9 1.584142787686300E-008 X 49 13 10 2.443663652686500E-006 X 49 14 10 5.944447089737000E-005 X 49 15 10 1.526794562247000E-008 X 49 16 10 5.041963467807100E-007 X 49 13 11 1.801322638199200E-011 X 49 14 11 3.698056959725600E-010 X 49 15 11 2.166190958829300E-005 X 49 16 11 7.064836761713900E-004 X 49 13 12 1.477490513641500E-009 X 49 14 12 2.408487574516800E-008 X 49 15 12 1.392560832884500E-003 X 49 16 12 3.387538289980000E-002 X 49 1 14 1.068651474105400E-012 X 49 2 14 1.744021706572100E-009 X 49 4 14 3.530919661850900E-016 X 49 1 16 7.935783206955100E-018 X 49 2 16 1.295106824530100E-014 X 49 3 16 8.317079168558800E-010 X 49 4 16 1.357333701091700E-006 X 52 13 9 1.780159492143100E-010 X 52 14 9 3.667762806854000E-009 X 52 15 9 3.096154199853400E-011 X 52 16 9 5.270405083182200E-010 X 52 13 10 7.121943014230200E-009 X 52 14 10 2.643962281120600E-010 X 52 15 10 9.767720603191300E-010 X 52 16 10 4.098502125634700E-011 X 52 13 11 1.485498850569800E-012 X 52 14 11 2.426393033604700E-011 X 52 15 11 2.832333034818600E-006 X 52 16 11 5.835615300413100E-005 X 52 13 12 4.931183251784800E-011 X 52 14 12 1.972388996572000E-012 X 52 15 12 1.133140876706800E-004 X 52 16 12 4.206691497388800E-006 X 55 13 9 5.201320622219700E-013 X 55 14 9 8.588767851363199E-012 X 55 15 9 1.896948385620600E-012 X 55 16 9 2.735355529057600E-011 X 55 13 10 1.667726461025600E-011 X 55 14 10 5.158028063391200E-013 X 55 15 10 5.265128803451100E-011 X 55 16 10 1.876248857164700E-012 X 55 13 11 9.159792472296400E-014 X 55 14 11 1.314307372110400E-012 X 55 15 11 2.310527998500500E-007 X 55 16 11 3.815298997156100E-006 X 55 13 12 2.573859275854600E-012 X 55 14 12 9.061779695720400E-014 X 55 15 12 7.408367772982500E-006 X 55 16 12 2.291296615355100E-007 X 58 13 9 1.156684386258800E-015 X 58 14 9 1.673025803910400E-014 X 58 15 9 9.558668436978100E-014 X 58 16 9 1.261196382331000E-012 X 58 13 10 3.248585053290800E-014 X 58 14 10 8.612412964154700E-016 X 58 15 10 2.433807587389900E-012 X 58 16 10 7.589497279895400E-014 X 58 13 11 4.641504355911300E-015 X 58 14 11 6.105122782016200E-014 X 58 15 11 1.434550614987600E-008 X 58 16 11 2.074937837470700E-007 X 58 13 12 1.192580509510600E-013 X 58 14 12 3.678952289272000E-015 X 58 15 12 4.028994686955600E-007 X 58 16 12 1.068131681828500E-008 X 61 13 9 2.109468235737000E-018 X 61 14 9 2.791376340246300E-017 X 61 15 9 4.116415990231300E-015 X 61 16 9 5.098154099519200E-014 X 61 13 10 5.420111193068300E-017 X 61 14 10 1.257699614870300E-018 X 61 15 10 9.847563927567400E-014 X 61 16 10 2.730853843595000E-015 X 61 13 11 2.009590234285200E-016 X 61 14 11 2.482319476651000E-015 X 61 15 11 7.301197057649500E-010 X 61 16 11 9.661888450046601E-009 X 61 13 12 4.844379220344200E-015 X 61 14 12 1.328617174888300E-016 X 61 15 12 1.876082193112700E-008 X 61 16 12 4.352712018382900E-010 X 64 15 9 1.552555616392500E-016 X 64 16 9 1.832776294574500E-015 X 64 15 10 3.542680423261900E-015 X 64 16 10 8.846132892833300E-017 X 64 13 11 7.619123308557300E-018 X 64 14 11 8.973914823749301E-017 X 64 15 11 3.169410703397300E-011 X 64 16 11 3.933845004935900E-010 X 64 13 12 1.750069780100900E-016 X 64 14 12 4.319622408540000E-018 X 64 15 12 7.638458379489300E-010 X 64 16 12 1.575628517627000E-011 X 67 15 9 5.217791346040200E-018 X 67 16 9 5.931893022017900E-017 X 67 15 10 1.147259516026700E-016 X 67 16 10 2.605597497025100E-018 X 67 14 11 2.920337510038400E-018 X 67 15 11 1.203420623932500E-012 X 67 16 11 1.423004173711600E-011 X 67 13 12 5.691946580296900E-018 X 67 15 12 2.763080575165400E-011 X 67 16 12 5.130762254384899E-013 X 70 16 9 1.745792593055800E-018 X 70 15 10 3.378023896951000E-018 X 70 15 11 4.068124697268400E-014 X 70 16 11 4.631097961572800E-013 X 70 15 12 8.992292942983500E-013 X 70 16 12 1.518315458607800E-014 X 73 5 2 2.104513251285100E-017 X 73 6 2 3.434531164692800E-014 X 73 6 4 7.120883026712400E-018 X 73 7 4 4.572977824026500E-013 X 73 8 4 7.463024926299300E-010 X 73 9 6 2.104513251285100E-017 X 73 10 6 3.434531164692800E-014 X 73 10 8 7.120883026712400E-018 X 73 11 8 4.572977824026500E-013 X 73 12 8 7.463024926299300E-010 X 73 13 9 8.813208276739199E-011 X 73 14 9 3.587037442840600E-009 X 73 15 9 2.040430668879400E-011 X 73 16 9 1.007116555597900E-009 X 73 13 10 7.106344835203800E-009 X 73 14 10 2.305299185022000E-007 X 73 15 10 9.778540802370400E-010 X 73 16 10 4.016544226158400E-008 X 73 13 11 9.600950475638801E-013 X 73 14 11 2.368104017721000E-011 X 73 15 11 1.402230500278100E-006 X 73 16 11 5.707176476526700E-005 X 73 13 12 9.440110931343200E-011 X 73 14 12 1.927944170297200E-009 X 73 15 12 1.130659068867000E-004 X 73 16 12 3.667859563608400E-003 X 73 1 14 2.104513251285100E-017 X 73 2 14 3.434531164692800E-014 X 73 2 16 7.120883026712400E-018 X 73 3 16 4.572977824026500E-013 X 73 4 16 7.463024926299300E-010 X 76 13 9 3.438686303557900E-013 X 76 14 9 8.503451466957400E-012 X 76 15 9 1.417467230154500E-012 X 76 16 9 2.811569110786100E-011 X 76 13 10 1.651181099532300E-011 X 76 14 10 6.818719697627000E-013 X 76 15 10 5.212656200393000E-011 X 76 16 10 2.337777909892900E-012 X 76 13 11 6.822380858907800E-014 X 76 14 11 1.301196086165500E-012 X 76 15 11 1.527531077202300E-007 X 76 16 11 3.777399655710100E-006 X 76 13 12 2.642929595668000E-012 X 76 14 12 1.131026497811500E-013 X 76 15 12 7.334869787922500E-006 X 76 16 12 3.029008530676700E-007 X 79 13 9 8.612414469545500E-016 X 79 14 9 1.659094105626800E-014 X 79 15 9 7.614660217143900E-014 X 79 16 9 1.253892594005500E-012 X 79 13 10 3.221568304627800E-014 X 79 14 10 1.139888335288400E-015 X 79 15 10 2.412641423618400E-012 X 79 16 10 9.398260688809600E-014 X 79 13 11 3.690257470313700E-015 X 79 14 11 6.052045769600900E-014 X 79 15 11 1.068131681900600E-008 X 79 16 11 2.057659241672800E-007 X 79 13 12 1.185587810178300E-013 X 79 14 12 4.564472836564600E-015 X 79 15 12 3.995487546984400E-007 X 79 16 12 1.413719860473700E-008 X 82 13 9 1.676843314600400E-018 X 82 14 9 2.771322839273100E-017 X 82 15 9 3.415503160949700E-015 X 82 16 9 5.066430054282500E-014 X 82 13 10 5.381223625838400E-017 X 82 14 10 1.665972597127800E-018 X 82 15 10 9.770942547996100E-014 X 82 16 10 3.383447684810200E-015 X 82 13 11 1.664949285823200E-016 X 82 14 11 2.463040209315900E-015 X 82 15 11 5.803616024672700E-010 X 82 16 11 9.592475646899099E-009 X 82 13 12 4.814102735274500E-015 X 82 14 12 1.649681940230800E-016 X 82 15 12 1.862621776445800E-008 X 82 16 12 5.766008982498400E-010 X 85 15 9 1.325157293245600E-016 X 85 16 9 1.822522899429300E-015 X 85 15 10 3.517661798307100E-015 X 85 16 10 1.096675118568900E-016 X 85 13 11 6.495508966126200E-018 X 85 14 11 8.910756728337899E-017 X 85 15 11 2.626047529412500E-011 X 85 16 11 3.909007873304000E-010 X 85 13 12 1.740239857965500E-016 X 85 14 12 5.368063794871900E-018 X 85 15 12 7.590295530709900E-010 X 85 16 12 2.088656347784600E-011 X 88 15 9 4.547215896497400E-018 X 88 16 9 5.901933861954700E-017 X 88 15 10 1.139820985005300E-016 X 88 16 10 3.231796010214300E-018 X 88 14 11 2.901499775274400E-018 X 88 15 11 1.026152450883700E-012 X 88 16 11 1.414993579321800E-011 X 88 13 12 5.663085733018000E-018 X 88 15 12 2.747547099873900E-011 X 88 16 12 6.805126925241400E-013 X 91 16 9 1.737760399202900E-018 X 91 15 10 3.357726427670700E-018 X 91 15 11 3.542736070097400E-014 X 91 16 11 4.607583219155100E-013 X 91 15 12 8.946695727941800E-013 X 91 16 12 2.014724334245100E-014 X 94 15 11 1.098003033293600E-015 X 94 16 11 1.363459961154800E-014 X 94 15 12 2.647468923808000E-014 X 94 16 12 5.465826294505800E-016 X 97 7 4 1.885769549190900E-016 X 97 8 4 3.077545024803200E-013 X 97 11 8 1.885769549190900E-016 X 97 12 8 3.077545024803200E-013 X 97 13 9 1.704682821771300E-013 X 97 14 9 8.311232914900399E-012 X 97 15 9 9.363705994265800E-013 X 97 16 9 5.365287135816900E-011 X 97 13 10 1.654916607451300E-011 X 97 14 10 6.705953151702300E-010 X 97 15 10 5.245954665970400E-011 X 97 16 10 2.574362860490400E-009 X 97 13 11 4.405956001839600E-014 X 97 14 11 1.270204337864100E-012 X 97 15 11 7.572521329524500E-008 X 97 16 11 3.692009029214500E-006 X 97 13 12 5.054330166410600E-012 X 97 14 12 1.241688229891100E-010 X 97 15 12 7.351457231183000E-006 X 97 16 12 2.978914668343400E-004 X 97 3 16 1.885769549190900E-016 X 97 4 16 3.077545024803200E-013 X 100 13 9 5.699489311473000E-016 X 100 14 9 1.644719375270200E-014 X 100 15 9 5.695652359254701E-014 X 100 16 9 1.289646674698500E-012 X 100 13 10 3.193690694616200E-014 X 100 14 10 1.414115820512400E-015 X 100 15 10 2.394082983610200E-012 X 100 16 10 1.124877978372100E-013 X 100 13 11 2.750079339908600E-015 X 100 14 11 6.005245133177300E-014 X 100 15 11 7.068599303047000E-009 X 100 16 11 2.039829767767700E-007 X 100 13 12 1.217987979271500E-013 X 100 14 12 5.470353790410900E-015 X 100 15 12 3.960910086411800E-007 X 100 16 12 1.753826338984200E-008 X 103 13 9 1.249555044906900E-018 X 103 14 9 2.750827040639600E-017 X 103 15 9 2.723136676081800E-015 X 103 16 9 5.040518183916200E-014 X 103 13 10 5.341476562909200E-017 X 103 14 10 2.068721278648600E-018 X 103 15 10 9.705888362573900E-014 X 103 16 10 4.028919342252800E-015 X 103 13 11 1.324512764650000E-016 X 103 14 11 2.446553952461200E-015 X 103 15 11 4.324506737025200E-010 X 103 16 11 9.521521716176900E-009 X 103 13 12 4.789116047791300E-015 X 103 14 12 1.967207209439200E-016 X 103 15 12 1.848861880454800E-008 X 103 16 12 7.160178809546700E-010 X 106 15 9 1.100289737172800E-016 X 106 16 9 1.812162851248800E-015 X 106 15 10 3.496839516390900E-015 X 106 16 10 1.306401765865000E-016 X 106 13 11 5.384457046216200E-018 X 106 14 11 8.857736093905100E-017 X 106 15 11 2.088656347816200E-011 X 106 16 11 3.883665165830700E-010 X 106 13 12 1.730302820729000E-016 X 106 14 12 6.404843947008500E-018 X 106 15 12 7.541150233352499E-010 X 106 16 12 2.595496564936700E-011 X 109 15 9 3.883503736346800E-018 X 109 16 9 5.871463979681300E-017 X 109 15 10 1.133749524643400E-016 X 109 16 10 3.851696650723700E-018 X 109 14 11 2.885965900166500E-018 X 109 15 11 8.506408656614000E-013 X 109 16 11 1.406832443289900E-011 X 109 13 12 5.633729221043200E-018 X 109 15 12 2.731721090656400E-011 X 109 16 12 8.461282071757100E-013 X 112 16 9 1.729597934350500E-018 X 112 15 10 3.341471753175100E-018 X 112 15 11 3.022086501379200E-014 X 112 16 11 4.583658072168000E-013 X 112 15 12 8.900301016974800E-013 X 112 16 12 2.506218294056400E-014 X 115 15 11 9.565196015405399E-016 X 115 16 11 1.357023585924500E-014 X 115 15 12 2.634987927917800E-014 X 115 16 12 6.801890625068900E-016 X 118 15 11 2.736819898657600E-017 X 118 16 11 3.681464359477300E-016 X 118 15 12 7.148431799908900E-016 X 118 16 12 1.703472552441700E-017 X 121 8 4 1.015275545583700E-016 X 121 12 8 1.015275545583700E-016 X 121 13 9 2.828339278753600E-016 X 121 14 9 1.605754335722400E-014 X 121 15 9 3.769634960365200E-014 X 121 16 9 2.458527594080500E-012 X 121 13 10 3.213592355641700E-014 X 121 14 10 1.560721930254100E-012 X 121 15 10 2.418137797667700E-012 X 121 16 10 1.379526052412300E-010 X 121 13 11 1.773747038671200E-015 X 121 14 11 5.853986764722900E-014 X 121 15 11 3.507652678620000E-009 X 121 16 11 1.991466291466700E-007 X 121 13 12 2.327697871934400E-013 X 121 14 12 6.686216821730300E-012 X 121 15 12 3.985521230145500E-007 X 121 16 12 1.935642309021500E-005 X 121 4 16 1.015275545583700E-016 X 124 14 9 2.729692390635300E-017 X 124 15 9 2.038082579168500E-015 X 124 16 9 5.186978229470500E-014 X 124 13 10 5.300485106389000E-017 X 124 14 10 2.465608817257800E-018 X 124 15 10 9.638934663060100E-014 X 124 16 10 4.689735553803600E-015 X 124 13 11 9.872000354922700E-017 X 124 14 11 2.429584131506100E-015 X 124 15 11 2.864071523963500E-010 X 124 16 11 9.448220537294199E-009 X 124 13 12 4.921826731593100E-015 X 124 14 12 2.292270807743400E-016 X 124 15 12 1.834645967846400E-008 X 124 16 12 8.534024842741700E-010 X 127 15 9 8.776875602822100E-017 X 127 16 9 1.803907858896600E-015 X 127 15 10 3.475825042439700E-015 X 127 16 10 1.514053347897300E-016 X 127 13 11 4.284593479529100E-018 X 127 14 11 8.804202306082000E-017 X 127 15 11 1.557297938992200E-011 X 127 16 11 3.857826457234300E-010 X 127 13 12 1.722282835977900E-016 X 127 14 12 7.431312598048201E-018 X 127 15 12 7.491041072033300E-010 X 127 16 12 3.096093691628200E-011 X 130 15 9 3.225886889485400E-018 X 130 16 9 5.840753993409900E-017 X 130 15 10 1.127633925999600E-016 X 130 16 10 4.465294312468900E-018 X 130 14 11 2.870310966937200E-018 X 130 15 11 6.769025657464700E-013 X 130 16 11 1.398523384094800E-011 X 130 13 12 5.604125200245000E-018 X 130 15 12 2.715607629996300E-011 X 130 16 12 1.009907542468600E-012 X 133 16 9 1.721309989040200E-018 X 133 15 10 3.325128468300300E-018 X 133 15 11 2.506218294067300E-014 X 133 16 11 4.559329123249900E-013 X 133 15 12 8.853121625822300E-013 X 133 16 12 2.992758787969700E-014 X 136 15 11 8.162268750101800E-016 X 136 16 11 1.350485586881700E-014 X 136 15 12 2.622309455086300E-014 X 136 16 12 8.125613919118000E-016 X 139 15 11 2.384861573421600E-017 X 139 16 11 3.665229924848600E-016 X 139 15 12 7.116950457162900E-016 X 139 16 12 2.035678995319700E-017 X 142 16 11 9.179174079465399E-018 X 142 15 12 1.782359224225200E-017 X 145 14 9 2.662170157334600E-017 X 145 15 9 1.351370308438400E-015 X 145 16 9 9.880462721371100E-014 X 145 13 10 5.354735657512000E-017 X 145 14 10 3.028587218234400E-015 X 145 15 10 9.768623660731900E-014 X 145 16 10 6.349394944001400E-012 X 145 13 11 6.358676922141200E-017 X 145 14 11 2.364425042686300E-015 X 145 15 11 1.422337473930500E-010 X 145 16 11 9.210726219341800E-009 X 145 13 12 9.401885293489600E-015 X 145 14 12 3.092396417737900E-013 X 145 15 12 1.852713566073500E-008 X 145 16 12 1.048167447737200E-006 X 148 15 9 6.572345652456999E-017 X 148 16 9 1.857148940996400E-015 X 148 15 10 3.453928997346300E-015 X 148 16 10 1.726721696128200E-016 X 148 13 11 3.193650915192800E-018 X 148 14 11 8.748438623460100E-017 X 148 15 11 1.032031230571800E-011 X 148 16 11 3.831047187913600E-010 X 148 13 12 1.770521667720200E-016 X 148 14 12 8.482560366290800E-018 X 148 15 12 7.439104781244300E-010 X 148 16 12 3.589845870895300E-011 X 151 15 9 2.574374631581700E-018 X 151 16 9 5.816889408854899E-017 X 151 15 10 1.121423950224600E-016 X 151 16 10 5.073339607436600E-018 X 151 14 11 2.854413273744800E-018 X 151 15 11 5.049537712399600E-013 X 151 16 11 1.390068968756000E-011 X 151 13 12 5.580758241613500E-018 X 151 15 12 2.699211700509900E-011 X 151 16 12 1.171835879717600E-012 X 154 16 9 1.712974794028700E-018 X 154 15 10 3.308548953466000E-018 X 154 15 11 1.995172525323600E-014 X 154 16 11 4.534602850541400E-013 X 154 15 12 8.805170128620500E-013 X 154 16 12 3.474308324734800E-014 X 157 15 11 6.771344932616600E-016 X 157 16 11 1.343847456960800E-014 X 157 15 12 2.609436403092500E-014 X 157 16 12 9.436907992825200E-016 X 160 15 11 2.035678995322700E-017 X 160 16 11 3.648761450702700E-016 X 160 15 12 7.085014321161100E-016 X 160 16 12 2.365009964474700E-017 X 163 16 11 9.141201384836701E-018 X 163 15 12 1.774995551888900E-017 X 169 15 9 4.365724772994900E-017 X 169 16 9 3.535377014760900E-015 X 169 14 10 5.090486709601800E-018 X 169 15 10 3.511667388043800E-015 X 169 16 10 2.560555772242500E-013 X 169 13 11 2.054228451601600E-018 X 169 14 11 8.498199778037599E-017 X 169 15 11 5.128351244419300E-012 X 169 16 11 3.728450355773300E-010 X 169 13 12 3.381140578058300E-016 X 169 14 12 1.253176812569200E-014 X 169 15 12 7.537815938922200E-010 X 169 16 12 4.865221226346600E-008 X 172 15 9 1.928678165263900E-018 X 172 16 9 5.990849255814500E-017 X 172 15 10 1.114903845376700E-016 X 172 16 10 5.696157556959600E-018 X 172 14 11 2.837728977489000E-018 X 172 15 11 3.348102513533900E-013 X 172 16 11 1.381260993150800E-011 X 172 13 12 5.738358720126000E-018 X 172 15 12 2.682129003743100E-011 X 172 16 12 1.331644413612300E-012 X 175 16 9 1.706660355982400E-018 X 175 15 10 3.291731203247400E-018 X 175 15 11 1.488989282039300E-014 X 175 16 11 4.509485617799700E-013 X 175 15 12 8.756458877512200E-013 X 175 16 12 3.950830249382600E-014 X 178 15 11 5.392518853060600E-016 X 178 16 11 1.337110710467300E-014 X 178 15 12 2.596371711240400E-014 X 178 16 12 1.073568699060000E-015 X 181 15 11 1.689292831770600E-017 X 181 16 11 3.632062195089900E-016 X 181 15 12 7.052629715811400E-016 X 181 16 12 2.691446596345300E-017 X 184 16 11 9.102725210760700E-018 X 184 15 12 1.767534040990300E-017 X 193 15 9 1.283420413526900E-018 X 193 16 9 1.139861834815400E-016 X 193 15 10 1.137062582128400E-016 X 193 16 10 9.187483375822300E-015 X 193 14 11 2.751181575983000E-018 X 193 15 11 1.664555517069300E-013 X 193 16 11 1.341789513114900E-011 X 193 13 12 1.095650935060000E-017 X 193 14 12 4.518477019398300E-016 X 193 15 12 2.726494842385800E-011 X 193 16 12 1.976021948566900E-009 X 196 16 9 1.758278057803500E-018 X 196 15 10 3.273905717954700E-018 X 196 15 11 9.877075623555499E-015 X 196 16 11 4.483127750115000E-013 X 196 15 12 8.705337945652500E-013 X 196 16 12 4.421255619711100E-014 X 199 15 11 4.025882621492300E-016 X 199 16 11 1.330276796545900E-014 X 199 15 12 2.583118192328700E-014 X 199 16 12 1.202186641650700E-015 X 202 15 11 1.345723298175500E-017 X 202 16 11 3.615135458125200E-016 X 202 15 12 7.019803046757900E-016 X 202 16 12 3.014970523144500E-017 X 205 16 11 9.063752177458601E-018 X 205 15 12 1.759975976526200E-017 X 217 16 9 3.343971906152200E-018 X 217 15 10 3.349063594823000E-018 X 217 16 10 2.968936718501100E-016 X 217 15 11 4.912506244220300E-015 X 217 16 11 4.346471345214500E-013 X 217 14 12 1.467288062526500E-017 X 217 15 12 8.876883182647500E-013 X 217 16 12 7.134032622426699E-011 X 220 15 11 2.671525870351800E-016 X 220 16 11 1.323038130835100E-014 X 220 15 12 2.569078569535900E-014 X 220 16 12 1.329163374464100E-015 X 223 15 11 1.004990174384300E-017 X 223 16 11 3.597984271939000E-016 X 223 15 12 6.986540199318800E-016 X 223 16 12 3.335563482392700E-017 X 226 16 11 9.024289051095601E-018 X 226 15 12 1.752322671843800E-017 X 241 16 10 8.726431352259100E-018 X 241 15 11 1.329163374480600E-016 X 241 16 11 1.280079447060400E-014 X 241 15 12 2.627630016102600E-014 X 241 16 12 2.318066711124800E-012 X 0 0 0 0.000000000000000E+000 END_OF_FILE if test 56589 -ne `wc -c <'data'`; then echo shar: \"'data'\" unpacked with wrong size! fi # end of 'data' fi if test -f 'results' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'results'\" else echo shar: Extracting \"'results'\" \(6711 characters\) sed "s/^X//" >'results' <<'END_OF_FILE' X ------------------------------------------------------- X IMPROVED CYCLIC REDUCTION FOR SOLVING QUEUEING PROBLEMS X by D.A. Bini and B. Meini X Fortran 90 Program version 1.0, January 30, 1997 X ------------------------------------------------------- X X Residual error= 5.384213675968075E-014 X X 5.502897356284980E-005 X 9.581048031318904E-007 X 3.206182693547769E-009 X 4.163641898249051E-008 X 6.061767744504558E-007 X 3.389700218536324E-008 X 1.672628939860436E-009 X 3.916700311081029E-008 X 8.955170067331411E-007 X 2.080308588689834E-007 X 2.539648322358768E-007 X 5.910284628794423E-006 X 0.999625272120924 X 6.382916255661604E-004 X 9.953178869556045E-009 X 5.249033623813577E-008 X 3.374217717619544E-006 X 1.688924999878521E-007 X 5.098454480766029E-010 X 1.936110471738686E-008 X 5.466864259229084E-008 X 5.667895591054034E-009 X 4.464939936760629E-010 X 1.841789179816679E-008 X 9.046076972569157E-008 X 3.088183343199246E-008 X 1.083411909356909E-007 X 2.792584549550251E-006 X 3.154477350275648E-004 X 0.999360322843778 X 1.866584659483768E-010 X 3.949880255849946E-008 X 1.920037610145464E-009 X 2.348423661375434E-009 X 1.129546431045292E-003 X 3.081562244395286E-004 X 2.384309692224167E-010 X 1.726397216816893E-009 X 2.591458519424680E-004 X 2.751443305723508E-004 X 1.517151606858812E-007 X 1.047408548896133E-006 X 9.095137346621061E-003 X 3.907493886195787E-002 X 2.023919555826856E-007 X 4.294429310381154E-009 X 0.998052266748513 X 9.556904777617127E-004 X 1.203859861289877E-010 X 4.236251167297971E-010 X 7.092065315876731E-005 X 6.433578711979324E-005 X 2.043656244692930E-011 X 3.275122116833192E-010 X 2.437640730062386E-005 X 5.702263345408887E-005 X 1.972648819401084E-008 X 2.124743049980597E-007 X 1.085703450833712E-003 X 8.028328564411153E-003 X 6.508172892927032E-011 X 2.062720956742955E-007 X 3.167821241857398E-004 X 0.997939417852592 X 0.999625272160064 X 6.382916277594309E-004 X 1.014695757522177E-008 X 5.298063912979994E-008 X 5.502897420969467E-005 X 9.581048784158912E-007 X 3.290008137826333E-009 X 4.207216085297738E-008 X 6.078935399935849E-005 X 7.999279887413756E-006 X 3.138350871065073E-007 X 6.206475063523973E-006 X 3.678050357435133E-009 X 8.049566346682039E-010 X 5.314562841484935E-010 X 3.578104031798052E-008 X 3.154477381984826E-004 X 0.999360322843959 X 2.664789968250521E-010 X 3.971663993572584E-008 X 3.374217770117404E-006 X 1.688925069649494E-007 X 5.452948508021669E-010 X 1.955464764958731E-008 X 4.917127981496354E-006 X 1.066528182434521E-006 X 1.171664747302771E-007 X 2.913560172640389E-006 X 2.983952750365745E-010 X 1.192967089091502E-010 X 1.986168819533483E-010 X 1.688937171155015E-008 X 2.024010678310167E-007 X 4.374728247737070E-009 X 0.998062891660799 X 9.687672808409023E-004 X 1.922998473914893E-009 X 2.412975790423071E-009 X 1.133376227161384E-003 X 3.197609125446213E-004 X 4.390553830010835E-007 X 1.299079920399856E-006 X 2.716343688747099E-002 X 4.714447153642747E-002 X 2.700170312459971E-011 X 1.348659034708250E-009 X 4.569523151063587E-005 X 2.481547869201292E-004 X 6.593964549870423E-011 X 2.062809651408164E-007 X 3.177973653113798E-004 X 0.997940893033096 X 1.206764521056804E-010 X 4.308163112071743E-010 X 7.129921667360051E-005 X 6.564530142171808E-005 X 4.014747018948232E-008 X 2.514204592516490E-007 X 2.433778568323951E-003 X 9.341713484254053E-003 X 2.474679865796449E-012 X 2.555981951525011E-010 X 4.107340566245731E-006 X 4.960755060598182E-005 X 1.067493080840508E-008 X 1.194819912273343E-009 X 8.110699178841251E-010 X 3.680010993359457E-008 X 0.999625272275584 X 6.382916407539352E-004 X 1.026794155631839E-008 X 5.391874670887475E-008 X 1.083203042514338E-002 X 8.474399470035493E-004 X 5.014494649414113E-007 X 6.786213367669515E-006 X 6.473987406255774E-007 X 3.584061823226653E-008 X 8.473004220118598E-010 X 3.811808834581952E-008 X 5.190705244992331E-010 X 1.316388693862216E-010 X 2.848524639865675E-010 X 1.713552640954725E-008 X 3.154477418445841E-004 X 0.999360322844371 X 3.048269987528375E-010 X 3.993638035501165E-008 X 3.427925251306689E-004 X 4.194931940838162E-005 X 1.275449594052520E-007 X 3.097413618002953E-006 X 2.073379933355694E-008 X 4.130472178228770E-009 X 2.163598159735957E-010 X 1.764256882610731E-008 X 1.010278225053376E-010 X 1.913020334354220E-009 X 1.299214657145208E-004 X 3.381948862825504E-004 X 2.024241004814261E-007 X 4.824688170505549E-009 X 0.998092489776204 X 1.048646916357581E-003 X 5.168028605727761E-006 X 2.462161872590742E-006 X 0.224152802950273 X 8.171180139783044E-002 X 3.134720496234147E-010 X 2.405071033253661E-009 X 3.723926924016054E-004 X 3.812512241086165E-004 X 4.981294529796436E-012 X 2.772470746463206E-010 X 7.022495586060844E-006 X 5.312323497658938E-005 X 6.674964237285129E-011 X 2.062983489863189E-007 X 3.188441095372218E-004 X 0.997944012812475 X 1.247506744451086E-007 X 3.172424715778356E-007 X 7.504655968471595E-003 X 1.138748779055744E-002 X 7.669361553876061E-012 X 3.298798313766744E-010 X 1.262073845302048E-005 X 5.977348101326884E-005 X 6.061767648330473E-007 X 3.389699898723644E-008 X 1.598629339558146E-009 X 3.876929853310351E-008 X 1.001533089901984E-008 X 1.129343524376702E-009 X 1.085313036156109E-009 X 3.734618084157052E-008 X 0.932378776172756 X 0.114000428886699 X 1.815478900846441E-006 X 8.839730416159894E-006 X 5.502897298499894E-005 X 9.581047679864758E-007 X 3.038261317913820E-009 X 4.118875000742889E-008 X 5.466864159706904E-008 X 5.667894504040029E-009 X 4.130291001603110E-010 X 1.823389416405006E-008 X 1.058348068170894E-009 X 1.835873037201547E-010 X 3.748612301215761E-010 X 1.765825998399022E-008 X 5.633972870058777E-002 X 0.885058188356427 X 2.566375604253500E-007 X 6.302336152371540E-006 X 3.374217659034434E-006 X 1.688924954808445E-007 X 4.348010835878198E-010 X 1.915399646362988E-008 X 2.373248050845374E-010 X 1.698374674764293E-009 X 2.577020864388313E-004 X 2.700304992173649E-004 X 7.046275842012295E-011 X 1.351981830992874E-009 X 9.025438124988021E-005 X 2.395480550219042E-004 X 3.205916015858575E-005 X 5.647163556052171E-006 X 0.686264277416479 X 0.132739780879214 X 1.916796599029735E-009 X 2.313910847140333E-009 X 1.125700276382436E-003 X 3.023957359177523E-004 X 2.028782080939953E-011 X 3.232394203079930E-010 X 2.418060490275336E-005 X 5.623442039776515E-005 X 7.643569032378811E-012 X 2.669378036881701E-010 X 1.019604256340302E-005 X 4.995096688310253E-005 X 1.977132676494697E-006 X 3.145181854513598E-005 X 4.229671299305712E-002 X 0.670528628887378 X 1.199707397854034E-010 X 4.184011205844151E-010 X 7.041944135575388E-005 X 6.344812812810396E-005 END_OF_FILE if test 6711 -ne `wc -c <'results'`; then echo shar: \"'results'\" unpacked with wrong size! fi # end of 'results' fi echo shar: End of shell archive. exit 0