Télécharger dvout.eso

Retour à la liste

Numérotation des lignes :

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

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