Télécharger dmout.eso

Retour à la liste

Numérotation des lignes :

  1. C DMOUT SOURCE BP208322 15/10/13 21:15:42 8670
  2. *-----------------------------------------------------------------------
  3. * Routine: DMOUT
  4. *
  5. * Purpose: Real matrix output routine.
  6. *
  7. * Usage: CALL DMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT)
  8. *
  9. * Arguments
  10. * M - Number of rows of A. (Input)
  11. * N - Number of columns of A. (Input)
  12. * A - Real M by N matrix to be printed. (Input)
  13. * LDA - Leading dimension of A exactly as specified in the
  14. * dimension statement of the calling program. (Input)
  15. * IFMT - Format to be used in printing matrix A. (Input)
  16. * IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In)
  17. * If IDIGIT .LT. 0, printing is done with 72 columns.
  18. * If IDIGIT .GT. 0, printing is done with 132 columns.
  19. *
  20. *-----------------------------------------------------------------------
  21. *
  22. SUBROUTINE DMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT )
  23. * ...
  24. * ... SPECIFICATIONS FOR ARGUMENTS
  25. * ...
  26. * ... SPECIFICATIONS FOR LOCAL VARIABLES
  27. * .. Scalar Arguments ..
  28. CHARACTER*( * ) IFMT
  29. INTEGER IDIGIT, LDA, LOUT, M, N
  30. * ..
  31. * .. Array Arguments ..
  32. REAL*8 A( LDA, * )
  33. * ..
  34. * .. Local Scalars ..
  35. CHARACTER*80 LINE
  36. INTEGER I, J, K1, K2, LLL, NDIGIT
  37. * ..
  38. * .. Local Arrays ..
  39. CHARACTER ICOL( 3 )
  40. * ..
  41. ** .. Intrinsic Functions ..
  42. * INTRINSIC LEN, MIN, MIN0
  43. ** ..
  44. ** .. Data statements ..
  45. DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o',
  46. $ 'l' /
  47. ** ..
  48. ** .. Executable Statements ..
  49. * ...
  50. * ... FIRST EXECUTABLE STATEMENT
  51. *
  52. LLL = MIN( LEN( IFMT ), 80 )
  53. DO 10 I = 1, LLL
  54. LINE( I: I ) = '-'
  55. 10 CONTINUE
  56. *
  57. DO 20 I = LLL + 1, 80
  58. LINE( I: I ) = ' '
  59. 20 CONTINUE
  60. *
  61. WRITE( LOUT, FMT = 9999 )IFMT, LINE( 1: LLL )
  62. 9999 FORMAT( / 1X, A, / 1X, A )
  63. *
  64. IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 )
  65. $ RETURN
  66. NDIGIT = IDIGIT
  67. IF( IDIGIT.EQ.0 )
  68. $ NDIGIT = 4
  69. *
  70. *=======================================================================
  71. * CODE FOR OUTPUT USING 72 COLUMNS FORMAT
  72. *=======================================================================
  73. *
  74. IF( IDIGIT.LT.0 ) THEN
  75. NDIGIT = -IDIGIT
  76. IF( NDIGIT.LE.4 ) THEN
  77. DO 40 K1 = 1, N, 5
  78. K2 = MIN0( N, K1+4 )
  79. WRITE( LOUT, FMT = 9998 )( ICOL, I, I = K1, K2 )
  80. DO 30 I = 1, M
  81. WRITE( LOUT, FMT = 9994 )I, ( A( I, J ), J = K1, K2 )
  82. 30 CONTINUE
  83. 40 CONTINUE
  84. *
  85. ELSE IF( NDIGIT.LE.6 ) THEN
  86. DO 60 K1 = 1, N, 4
  87. K2 = MIN0( N, K1+3 )
  88. WRITE( LOUT, FMT = 9997 )( ICOL, I, I = K1, K2 )
  89. DO 50 I = 1, M
  90. WRITE( LOUT, FMT = 9993 )I, ( A( I, J ), J = K1, K2 )
  91. 50 CONTINUE
  92. 60 CONTINUE
  93. *
  94. ELSE IF( NDIGIT.LE.10 ) THEN
  95. DO 80 K1 = 1, N, 3
  96. K2 = MIN0( N, K1+2 )
  97. WRITE( LOUT, FMT = 9996 )( ICOL, I, I = K1, K2 )
  98. DO 70 I = 1, M
  99. WRITE( LOUT, FMT = 9992 )I, ( A( I, J ), J = K1, K2 )
  100. 70 CONTINUE
  101. 80 CONTINUE
  102. *
  103. ELSE
  104. DO 100 K1 = 1, N, 2
  105. K2 = MIN0( N, K1+1 )
  106. WRITE( LOUT, FMT = 9995 )( ICOL, I, I = K1, K2 )
  107. DO 90 I = 1, M
  108. WRITE( LOUT, FMT = 9991 )I, ( A( I, J ), J = K1, K2 )
  109. 90 CONTINUE
  110. 100 CONTINUE
  111. END IF
  112. *
  113. *=======================================================================
  114. * CODE FOR OUTPUT USING 132 COLUMNS FORMAT
  115. *=======================================================================
  116. *
  117. ELSE
  118. IF( NDIGIT.LE.4 ) THEN
  119. DO 120 K1 = 1, N, 10
  120. K2 = MIN0( N, K1+9 )
  121. WRITE( LOUT, FMT = 9998 )( ICOL, I, I = K1, K2 )
  122. DO 110 I = 1, M
  123. WRITE( LOUT, FMT = 9994 )I, ( A( I, J ), J = K1, K2 )
  124. 110 CONTINUE
  125. 120 CONTINUE
  126. *
  127. ELSE IF( NDIGIT.LE.6 ) THEN
  128. DO 140 K1 = 1, N, 8
  129. K2 = MIN0( N, K1+7 )
  130. WRITE( LOUT, FMT = 9997 )( ICOL, I, I = K1, K2 )
  131. DO 130 I = 1, M
  132. WRITE( LOUT, FMT = 9993 )I, ( A( I, J ), J = K1, K2 )
  133. 130 CONTINUE
  134. 140 CONTINUE
  135. *
  136. ELSE IF( NDIGIT.LE.10 ) THEN
  137. DO 160 K1 = 1, N, 6
  138. K2 = MIN0( N, K1+5 )
  139. WRITE( LOUT, FMT = 9996 )( ICOL, I, I = K1, K2 )
  140. DO 150 I = 1, M
  141. WRITE( LOUT, FMT = 9992 )I, ( A( I, J ), J = K1, K2 )
  142. 150 CONTINUE
  143. 160 CONTINUE
  144. *
  145. ELSE
  146. DO 180 K1 = 1, N, 5
  147. K2 = MIN0( N, K1+4 )
  148. WRITE( LOUT, FMT = 9995 )( ICOL, I, I = K1, K2 )
  149. DO 170 I = 1, M
  150. WRITE( LOUT, FMT = 9991 )I, ( A( I, J ), J = K1, K2 )
  151. 170 CONTINUE
  152. 180 CONTINUE
  153. END IF
  154. END IF
  155. WRITE( LOUT, FMT = 9990 )
  156. *
  157. 9998 FORMAT( 10X, 10( 4X, 3A1, I4, 1X ) )
  158. 9997 FORMAT( 10X, 8( 5X, 3A1, I4, 2X ) )
  159. 9996 FORMAT( 10X, 6( 7X, 3A1, I4, 4X ) )
  160. 9995 FORMAT( 10X, 5( 9X, 3A1, I4, 6X ) )
  161. 9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 10D12.3 )
  162. 9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 8D14.5 )
  163. 9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 6D18.9 )
  164. 9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 5D22.13 )
  165. 9990 FORMAT( 1X, ' ' )
  166. *
  167. RETURN
  168. END
  169.  
  170.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales