Télécharger dvout.eso

Retour à la liste

Numérotation des lignes :

  1. C DVOUT SOURCE BP208322 20/02/06 21:15:35 10512
  2. *-----------------------------------------------------------------------
  3. * Routine: DVOUT
  4. *
  5. * Purpose: Real vector output routine.
  6. *
  7. * Usage: CALL DVOUT (LOUT, N, SX, IDIGIT, IFMT)
  8. * BP,2020 CALL DVOUT ( N, SX, IDIGIT, IFMT)
  9. * LOUT --> IOIMP
  10. *
  11. * Arguments
  12. * N - Length of array SX. (Input)
  13. * SX - Real array to be printed. (Input)
  14. * IFMT - Format to be used in printing array SX. (Input)
  15. * IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In)
  16. * If IDIGIT .LT. 0, printing is done with 72 columns.
  17. * If IDIGIT .GT. 0, printing is done with 132 columns.
  18. *
  19. *-----------------------------------------------------------------------
  20. *
  21. c SUBROUTINE DVOUT( LOUT, N, SX, IDIGIT, IFMT )
  22. SUBROUTINE DVOUT( N, SX, IDIGIT, IFMT )
  23.  
  24. -INC CCOPTIO
  25. * ...
  26. * ... SPECIFICATIONS FOR ARGUMENTS
  27. * ...
  28. * ... SPECIFICATIONS FOR LOCAL VARIABLES
  29. * .. Scalar Arguments ..
  30. CHARACTER*(*) IFMT
  31. INTEGER IDIGIT, N
  32. * ..
  33. * .. Array Arguments ..
  34. REAL*8 SX( * )
  35. * ..
  36. * .. Local Scalars ..
  37. CHARACTER*80 LINE
  38. INTEGER I, K1, K2, LLL, NDIGIT
  39. * ..
  40. ** .. Intrinsic Functions ..
  41. * INTRINSIC LEN, MIN, MIN0
  42. ** ..
  43. ** .. Executable Statements ..
  44. * ...
  45. * ... FIRST EXECUTABLE STATEMENT
  46. *
  47. *
  48. LLL = MIN( LEN( IFMT ), 80 )
  49. DO 10 I = 1, LLL
  50. LINE( I: I ) = '-'
  51. 10 CONTINUE
  52. *
  53. DO 20 I = LLL + 1, 80
  54. LINE( I: I ) = ' '
  55. 20 CONTINUE
  56. *
  57. WRITE(IOIMP, FMT = 9999 )IFMT, LINE( 1: LLL )
  58. 9999 FORMAT( / 1X, A, / 1X, A )
  59. *
  60. IF( N.LE.0 )
  61. $ RETURN
  62. NDIGIT = IDIGIT
  63. IF( IDIGIT.EQ.0 )
  64. $ NDIGIT = 4
  65. *
  66. *=======================================================================
  67. * CODE FOR OUTPUT USING 72 COLUMNS FORMAT
  68. *=======================================================================
  69. *
  70. IF( IDIGIT.LT.0 ) THEN
  71. NDIGIT = -IDIGIT
  72. IF( NDIGIT.LE.4 ) THEN
  73. DO 30 K1 = 1, N, 5
  74. K2 = MIN0( N, K1+4 )
  75. WRITE(IOIMP, FMT = 9998 )K1, K2, ( SX( I ), I = K1, K2 )
  76. 30 CONTINUE
  77. ELSE IF( NDIGIT.LE.6 ) THEN
  78. DO 40 K1 = 1, N, 4
  79. K2 = MIN0( N, K1+3 )
  80. WRITE(IOIMP, FMT = 9997 )K1, K2, ( SX( I ), I = K1, K2 )
  81. 40 CONTINUE
  82. ELSE IF( NDIGIT.LE.10 ) THEN
  83. DO 50 K1 = 1, N, 3
  84. K2 = MIN0( N, K1+2 )
  85. WRITE(IOIMP, FMT = 9996 )K1, K2, ( SX( I ), I = K1, K2 )
  86. 50 CONTINUE
  87. ELSE
  88. DO 60 K1 = 1, N, 2
  89. K2 = MIN0( N, K1+1 )
  90. WRITE(IOIMP, FMT = 9995 )K1, K2, ( SX( I ), I = K1, K2 )
  91. 60 CONTINUE
  92. END IF
  93. *
  94. *=======================================================================
  95. * CODE FOR OUTPUT USING 132 COLUMNS FORMAT
  96. *=======================================================================
  97. *
  98. ELSE
  99. IF( NDIGIT.LE.4 ) THEN
  100. DO 70 K1 = 1, N, 10
  101. K2 = MIN0( N, K1+9 )
  102. WRITE(IOIMP, FMT = 9998 )K1, K2, ( SX( I ), I = K1, K2 )
  103. 70 CONTINUE
  104. ELSE IF( NDIGIT.LE.6 ) THEN
  105. DO 80 K1 = 1, N, 8
  106. K2 = MIN0( N, K1+7 )
  107. WRITE(IOIMP, FMT = 9997 )K1, K2, ( SX( I ), I = K1, K2 )
  108. 80 CONTINUE
  109. ELSE IF( NDIGIT.LE.10 ) THEN
  110. DO 90 K1 = 1, N, 6
  111. K2 = MIN0( N, K1+5 )
  112. WRITE(IOIMP, FMT = 9996 )K1, K2, ( SX( I ), I = K1, K2 )
  113. 90 CONTINUE
  114. ELSE
  115. DO 100 K1 = 1, N, 5
  116. K2 = MIN0( N, K1+4 )
  117. WRITE(IOIMP, FMT = 9995 )K1, K2, ( SX( I ), I = K1, K2 )
  118. 100 CONTINUE
  119. END IF
  120. END IF
  121. WRITE(IOIMP, FMT = 9994 )
  122. RETURN
  123. 9998 FORMAT( 1X, I4, ' - ', I4, ':', 1P, 10D12.3 )
  124. 9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 8D14.5 )
  125. 9996 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 6D18.9 )
  126. 9995 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 5D24.13 )
  127. 9994 FORMAT( 1X, ' ' )
  128. END
  129.  
  130.  
  131.  

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