Télécharger la plaquette Cast3M


fr en

Télécharger dvout.eso

Retour à la liste

Numérotation des lignes : 

dvout

  1. C DVOUT     SOURCE    PV        22/01/23    21:15:03     11271          
  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.  
  25. -INC PPARAM
  26. -INC CCOPTIO
  27. *     ...
  28. *     ... SPECIFICATIONS FOR ARGUMENTS
  29. *     ...
  30. *     ... SPECIFICATIONS FOR LOCAL VARIABLES
  31. *     .. Scalar Arguments ..
  32.       CHARACTER*(*)    IFMT
  33.       INTEGER            IDIGIT, N
  34. *     ..
  35. *     .. Array Arguments ..
  36.       REAL*8   SX( * )
  37. *     ..
  38. *     .. Local Scalars ..
  39.       CHARACTER*80       LINE
  40.       INTEGER            I, K1, K2, LLL, NDIGIT
  41. *     ..
  42. **     .. Intrinsic Functions ..
  43. *      INTRINSIC          LEN, MIN, MIN0
  44. **     ..
  45. **     .. Executable Statements ..
  46. *     ...
  47. *     ... FIRST EXECUTABLE STATEMENT
  48. *
  49. *
  50.       LLL = MIN( LEN( IFMT ), 80 )
  51.       DO 10 I = 1, LLL
  52.          LINE( I: I ) = '-'
  53.    10 CONTINUE
  54. *
  55.       DO 20 I = LLL + 1, 80
  56.          LINE( I: I ) = ' '
  57.    20 CONTINUE
  58. *
  59.       WRITE(IOIMP, FMT = 9999 )IFMT, LINE( 1: LLL )
  60.  9999 FORMAT( / 1X, A, / 1X, A )
  61. *
  62.       IF( N.LE.0 )
  63.      $   RETURN
  64.       NDIGIT = IDIGIT
  65.       IF( IDIGIT.EQ.0 )
  66.      $   NDIGIT = 4
  67. *
  68. *=======================================================================
  69. *             CODE FOR OUTPUT USING 72 COLUMNS FORMAT
  70. *=======================================================================
  71. *
  72.       IF( IDIGIT.LT.0 ) THEN
  73.          NDIGIT = -IDIGIT
  74.          IF( NDIGIT.LE.4 ) THEN
  75.             DO 30 K1 = 1, N, 5
  76.                K2 = MIN0( N, K1+4 )
  77.                WRITE(IOIMP, FMT = 9998 )K1, K2, ( SX( I ), I = K1, K2 )
  78.    30       CONTINUE
  79.          ELSE IF( NDIGIT.LE.6 ) THEN
  80.             DO 40 K1 = 1, N, 4
  81.                K2 = MIN0( N, K1+3 )
  82.                WRITE(IOIMP, FMT = 9997 )K1, K2, ( SX( I ), I = K1, K2 )
  83.    40       CONTINUE
  84.          ELSE IF( NDIGIT.LE.10 ) THEN
  85.             DO 50 K1 = 1, N, 3
  86.                K2 = MIN0( N, K1+2 )
  87.                WRITE(IOIMP, FMT = 9996 )K1, K2, ( SX( I ), I = K1, K2 )
  88.    50       CONTINUE
  89.          ELSE
  90.             DO 60 K1 = 1, N, 2
  91.                K2 = MIN0( N, K1+1 )
  92.                WRITE(IOIMP, FMT = 9995 )K1, K2, ( SX( I ), I = K1, K2 )
  93.    60       CONTINUE
  94.          END IF
  95. *
  96. *=======================================================================
  97. *             CODE FOR OUTPUT USING 132 COLUMNS FORMAT
  98. *=======================================================================
  99. *
  100.       ELSE
  101.          IF( NDIGIT.LE.4 ) THEN
  102.             DO 70 K1 = 1, N, 10
  103.                K2 = MIN0( N, K1+9 )
  104.                WRITE(IOIMP, FMT = 9998 )K1, K2, ( SX( I ), I = K1, K2 )
  105.    70       CONTINUE
  106.          ELSE IF( NDIGIT.LE.6 ) THEN
  107.             DO 80 K1 = 1, N, 8
  108.                K2 = MIN0( N, K1+7 )
  109.                WRITE(IOIMP, FMT = 9997 )K1, K2, ( SX( I ), I = K1, K2 )
  110.    80       CONTINUE
  111.          ELSE IF( NDIGIT.LE.10 ) THEN
  112.             DO 90 K1 = 1, N, 6
  113.                K2 = MIN0( N, K1+5 )
  114.                WRITE(IOIMP, FMT = 9996 )K1, K2, ( SX( I ), I = K1, K2 )
  115.    90       CONTINUE
  116.          ELSE
  117.             DO 100 K1 = 1, N, 5
  118.                K2 = MIN0( N, K1+4 )
  119.                WRITE(IOIMP, FMT = 9995 )K1, K2, ( SX( I ), I = K1, K2 )
  120.   100       CONTINUE
  121.          END IF
  122.       END IF
  123.       WRITE(IOIMP, FMT = 9994 )
  124.       RETURN
  125.  9998 FORMAT( 1X, I4, ' - ', I4, ':', 1P, 10D12.3 )
  126.  9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 8D14.5 )
  127.  9996 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 6D18.9 )
  128.  9995 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 5D24.13 )
  129.  9994 FORMAT( 1X, ' ' )
  130.       END
  131.  
  132.  
  133.  
  134.  

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