relibc_openlibm/slatec/dmout.f

*DECK DMOUT
      SUBROUTINE DMOUT (M, N, LDA, A, IFMT, IDIGIT)
C***BEGIN PROLOGUE  DMOUT
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DBOCLS and DFC
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (SMOUT-S, DMOUT-D)
C***AUTHOR  Hanson, R. J., (SNLA)
C           Wisniewski, J. A., (SNLA)
C***DESCRIPTION
C
C     DOUBLE PRECISION MATRIX OUTPUT ROUTINE.
C
C  INPUT..
C
C  M,N,LDA,A(*,*) PRINT THE DOUBLE PRECISION ARRAY A(I,J),I = 1,...,M,
C                 J=1,...,N, ON OUTPUT UNIT LOUT=6. LDA IS THE DECLARED
C                 FIRST DIMENSION OF A(*,*) AS SPECIFIED IN THE CALLING
C                 PROGRAM. THE HEADING IN THE FORTRAN FORMAT STATEMENT
C                 IFMT(*), DESCRIBED BELOW, IS PRINTED AS A FIRST STEP.
C                 THE COMPONENTS A(I,J) ARE INDEXED, ON OUTPUT, IN A
C                 PLEASANT FORMAT.
C  IFMT(*)        A FORTRAN FORMAT STATEMENT. THIS IS PRINTED ON
C                 OUTPUT UNIT LOUT=6 WITH THE VARIABLE FORMAT FORTRAN
C                 STATEMENT
C                       WRITE(LOUT,IFMT).
C  IDIGIT         PRINT AT LEAST ABS(IDIGIT) DECIMAL DIGITS PER NUMBER.
C                 THE SUBPROGRAM WILL CHOOSE THAT INTEGER 4,6,14,20 OR
C                 28 WHICH WILL PRINT AT LEAST ABS(IDIGIT) NUMBER OF
C                 PLACES.  IF IDIGIT.LT.0, 72 PRINTING COLUMNS ARE
C                 UTILIZED TO WRITE EACH LINE OF OUTPUT OF THE ARRAY
C                 A(*,*). (THIS CAN BE USED ON MOST TIME-SHARING
C                 TERMINALS).  IF IDIGIT.GE.0, 133 PRINTING COLUMNS ARE
C                 UTILIZED. (THIS CAN BE USED ON MOST LINE PRINTERS).
C
C  EXAMPLE..
C
C  PRINT AN ARRAY CALLED (SIMPLEX TABLEAU   ) OF SIZE 10 BY 20 SHOWING
C  6 DECIMAL DIGITS PER NUMBER. THE USER IS RUNNING ON A TIME-SHARING
C  SYSTEM WITH A 72 COLUMN OUTPUT DEVICE.
C
C     DOUBLE PRECISION TABLEU(20,20)
C     M = 10
C     N = 20
C     LDTABL = 20
C     IDIGIT = -6
C     CALL DMOUT(M,N,LDTABL,TABLEU,21H(16H1SIMPLEX TABLEAU),IDIGIT)
C
C***SEE ALSO  DBOCLS, DFC
C***ROUTINES CALLED  I1MACH
C***REVISION HISTORY  (YYMMDD)
C   821220  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891107  Added comma after 1P edit descriptor in FORMAT
C           statements.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910403  Updated AUTHOR section.  (WRB)
C***END PROLOGUE  DMOUT
      DOUBLE PRECISION A(LDA,*)
      CHARACTER IFMT*(*),ICOL*3
      SAVE ICOL
      DATA ICOL /'COL'/
C***FIRST EXECUTABLE STATEMENT  DMOUT
      LOUT=I1MACH(2)
      WRITE(LOUT,IFMT)
      IF(M.LE.0.OR.N.LE.0.OR.LDA.LE.0) RETURN
      NDIGIT = IDIGIT
      IF(IDIGIT.EQ.0) NDIGIT = 4
      IF(IDIGIT.GE.0) GO TO 80
C
      NDIGIT = -IDIGIT
      IF(NDIGIT.GT.4) GO TO 9
C
      DO 5 K1=1,N,5
      K2 = MIN(N,K1+4)
      WRITE(LOUT,1010) (ICOL,I,I = K1, K2)
      DO 5 I = 1, M
      WRITE(LOUT,1009) I,(A(I,J),J = K1, K2)
   5  CONTINUE
      RETURN
C
   9  CONTINUE
      IF(NDIGIT.GT.6) GO TO 20
C
      DO 10 K1=1,N,4
      K2 = MIN(N,K1+3)
      WRITE(LOUT,1000) (ICOL,I,I = K1, K2)
      DO 10 I = 1, M
      WRITE(LOUT,1004) I,(A(I,J),J = K1, K2)
   10 CONTINUE
      RETURN
C
   20 CONTINUE
      IF(NDIGIT.GT.14) GO TO 40
C
      DO 30 K1=1,N,2
      K2 = MIN(N,K1+1)
      WRITE(LOUT,1001) (ICOL,I,I = K1, K2)
      DO 30 I = 1, M
      WRITE(LOUT,1005) I,(A(I,J),J = K1, K2)
   30 CONTINUE
      RETURN
C
   40 CONTINUE
      IF(NDIGIT.GT.20) GO TO 60
C
      DO 50 K1=1,N,2
      K2=MIN(N,K1+1)
      WRITE(LOUT,1002) (ICOL,I,I = K1, K2)
      DO 50 I = 1, M
      WRITE(LOUT,1006) I,(A(I,J),J = K1, K2)
   50 CONTINUE
      RETURN
C
   60 CONTINUE
      DO 70 K1=1,N
      K2 = K1
      WRITE(LOUT,1003) (ICOL,I,I = K1, K2)
      DO 70 I = 1, M
      WRITE(LOUT,1007) I,(A(I,J),J = K1, K2)
   70 CONTINUE
      RETURN
C
   80 CONTINUE
      IF(NDIGIT.GT.4) GO TO 86
C
      DO 85 K1=1,N,10
      K2 = MIN(N,K1+9)
      WRITE(LOUT,1000) (ICOL,I,I = K1, K2)
      DO 85 I = 1, M
      WRITE(LOUT,1009) I,(A(I,J),J = K1, K2)
   85 CONTINUE
C
86    IF (NDIGIT.GT.6) GO TO 100
C
      DO 90 K1=1,N,8
      K2 = MIN(N,K1+7)
      WRITE(LOUT,1000) (ICOL,I,I = K1, K2)
      DO 90 I = 1, M
      WRITE(LOUT,1004) I,(A(I,J),J = K1, K2)
   90 CONTINUE
      RETURN
C
  100 CONTINUE
      IF(NDIGIT.GT.14) GO TO 120
C
      DO 110 K1=1,N,5
      K2 = MIN(N,K1+4)
      WRITE(LOUT,1001) (ICOL,I,I = K1, K2)
      DO 110 I = 1, M
      WRITE(LOUT,1005) I,(A(I,J),J = K1, K2)
  110 CONTINUE
      RETURN
C
  120 CONTINUE
      IF(NDIGIT.GT.20) GO TO 140
C
      DO 130 K1=1,N,4
      K2 = MIN(N,K1+3)
      WRITE(LOUT,1002) (ICOL,I,I = K1, K2)
      DO 130 I = 1, M
      WRITE(LOUT,1006) I,(A(I,J),J = K1, K2)
  130 CONTINUE
      RETURN
C
  140 CONTINUE
      DO 150 K1=1,N,3
      K2 = MIN(N,K1+2)
      WRITE(LOUT,1003) (ICOL,I,I = K1, K2)
      DO 150 I = 1, M
      WRITE(LOUT,1007) I,(A(I,J),J = K1, K2)
  150 CONTINUE
      RETURN
 1000 FORMAT(10X,8(5X,A,I4,2X))
 1001 FORMAT(10X,5(9X,A,I4,6X))
 1002 FORMAT(10X,4(12X,A,I4,9X))
 1003 FORMAT(10X,3(16X,A,I4,13X))
 1004 FORMAT(1X,3HROW,I4,2X,1P,8D14.5)
 1005 FORMAT(1X,3HROW,I4,2X,1P,5D22.13)
 1006 FORMAT(1X,3HROW,I4,2X,1P,4D28.19)
 1007 FORMAT(1X,3HROW,I4,2X,1P,3D36.27)
 1009 FORMAT(1X,3HROW,I4,2X,1P,10D12.3)
 1010 FORMAT(10X,10(4X,A,I4,1X))
      END