Mercurial > hg > octave-thorsten
diff libcruft/arpack/util/ivout.f @ 12194:470857149e61
import ARPACK sources to libcruft from Debian package libarpack2 2.1+parpack96.dfsg-3+b1
author | John W. Eaton <jwe@octave.org> |
---|---|
date | Fri, 28 Jan 2011 14:04:33 -0500 |
parents | |
children |
line wrap: on
line diff
new file mode 100644 --- /dev/null +++ b/libcruft/arpack/util/ivout.f @@ -0,0 +1,120 @@ +C----------------------------------------------------------------------- +C Routine: IVOUT +C +C Purpose: Integer vector output routine. +C +C Usage: CALL IVOUT (LOUT, N, IX, IDIGIT, IFMT) +C +C Arguments +C N - Length of array IX. (Input) +C IX - Integer array to be printed. (Input) +C IFMT - Format to be used in printing array IX. (Input) +C IDIGIT - Print up to ABS(IDIGIT) decimal digits / number. (Input) +C If IDIGIT .LT. 0, printing is done with 72 columns. +C If IDIGIT .GT. 0, printing is done with 132 columns. +C +C----------------------------------------------------------------------- +C + SUBROUTINE IVOUT (LOUT, N, IX, IDIGIT, IFMT) +C ... +C ... SPECIFICATIONS FOR ARGUMENTS + INTEGER IX(*), N, IDIGIT, LOUT + CHARACTER IFMT*(*) +C ... +C ... SPECIFICATIONS FOR LOCAL VARIABLES + INTEGER I, NDIGIT, K1, K2, LLL + CHARACTER*80 LINE +* ... +* ... SPECIFICATIONS INTRINSICS + INTRINSIC MIN +* +C + LLL = MIN ( LEN ( IFMT ), 80 ) + DO 1 I = 1, LLL + LINE(I:I) = '-' + 1 CONTINUE +C + DO 2 I = LLL+1, 80 + LINE(I:I) = ' ' + 2 CONTINUE +C + WRITE ( LOUT, 2000 ) IFMT, LINE(1:LLL) + 2000 FORMAT ( /1X, A /1X, A ) +C + IF (N .LE. 0) RETURN + NDIGIT = IDIGIT + IF (IDIGIT .EQ. 0) NDIGIT = 4 +C +C======================================================================= +C CODE FOR OUTPUT USING 72 COLUMNS FORMAT +C======================================================================= +C + IF (IDIGIT .LT. 0) THEN +C + NDIGIT = -IDIGIT + IF (NDIGIT .LE. 4) THEN + DO 10 K1 = 1, N, 10 + K2 = MIN0(N,K1+9) + WRITE(LOUT,1000) K1,K2,(IX(I),I=K1,K2) + 10 CONTINUE +C + ELSE IF (NDIGIT .LE. 6) THEN + DO 30 K1 = 1, N, 7 + K2 = MIN0(N,K1+6) + WRITE(LOUT,1001) K1,K2,(IX(I),I=K1,K2) + 30 CONTINUE +C + ELSE IF (NDIGIT .LE. 10) THEN + DO 50 K1 = 1, N, 5 + K2 = MIN0(N,K1+4) + WRITE(LOUT,1002) K1,K2,(IX(I),I=K1,K2) + 50 CONTINUE +C + ELSE + DO 70 K1 = 1, N, 3 + K2 = MIN0(N,K1+2) + WRITE(LOUT,1003) K1,K2,(IX(I),I=K1,K2) + 70 CONTINUE + END IF +C +C======================================================================= +C CODE FOR OUTPUT USING 132 COLUMNS FORMAT +C======================================================================= +C + ELSE +C + IF (NDIGIT .LE. 4) THEN + DO 90 K1 = 1, N, 20 + K2 = MIN0(N,K1+19) + WRITE(LOUT,1000) K1,K2,(IX(I),I=K1,K2) + 90 CONTINUE +C + ELSE IF (NDIGIT .LE. 6) THEN + DO 110 K1 = 1, N, 15 + K2 = MIN0(N,K1+14) + WRITE(LOUT,1001) K1,K2,(IX(I),I=K1,K2) + 110 CONTINUE +C + ELSE IF (NDIGIT .LE. 10) THEN + DO 130 K1 = 1, N, 10 + K2 = MIN0(N,K1+9) + WRITE(LOUT,1002) K1,K2,(IX(I),I=K1,K2) + 130 CONTINUE +C + ELSE + DO 150 K1 = 1, N, 7 + K2 = MIN0(N,K1+6) + WRITE(LOUT,1003) K1,K2,(IX(I),I=K1,K2) + 150 CONTINUE + END IF + END IF + WRITE (LOUT,1004) +C + 1000 FORMAT(1X,I4,' - ',I4,':',20(1X,I5)) + 1001 FORMAT(1X,I4,' - ',I4,':',15(1X,I7)) + 1002 FORMAT(1X,I4,' - ',I4,':',10(1X,I11)) + 1003 FORMAT(1X,I4,' - ',I4,':',7(1X,I15)) + 1004 FORMAT(1X,' ') +C + RETURN + END