home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 10 / 10.iso / l / l292 / 1.ddi / SPECDEMO.FOR < prev    next >
Encoding:
Text File  |  1989-10-12  |  5.4 KB  |  187 lines
  1.       PROGRAM specdemo
  2.       INTEGER choice, InptNum, ErrFlag
  3.       REAL xx,yy,zz,ww
  4.  
  5.       choice = -1
  6.       InptNum = -1
  7.       choice = 1
  8.  
  9.       DO WHILE (choice .NE. 25)
  10.         CALL DisplayOptions()
  11.         CALL AskForOne(choice)
  12.         IF (choice .NE. 25) THEN
  13.           CALL NumOfInputs(choice, InptNum)
  14.           CALL ReadReals(InptNum, xx, yy, zz, ww)
  15.           CALL CalculateAnswer(choice, xx, yy, zz, ww, errflag)
  16.           IF (errflag .NE. 0)  CALL DisplayErrorMessage (errflag)
  17.           WRITE (*,*)
  18.      +      ' Press Return to Continue                          '
  19.           READ (*,*)
  20.           DO i = 16, 40
  21.            WRITE (*,*)
  22.           END DO
  23.         END IF
  24.       END DO
  25.       END
  26.  
  27.  
  28.  
  29.  
  30.  
  31.        SUBROUTINE AskForOne (choice)
  32.        INTEGER choice
  33.        choice = 0
  34.        DO WHILE (choice .LT. 1 .OR. CHOICE .GT. 25)
  35.         WRITE (*,5) ' ENTER SELECTION:  '
  36.         READ *, choice
  37.        END DO
  38. 5      FORMAT (1X, A18 \)
  39.        END !SUBROUTINE  AskForOne
  40.  
  41.  
  42.  
  43.        SUBROUTINE CalculateAnswer (choice, x, y, z, w, errflag)
  44.        REAL CalcAns, x, y, z, w
  45.        INTEGER ErrFlag, Int1, choice
  46.        CalcAns = 0.0
  47.        errflag = 0
  48.        SELECT CASE (choice)
  49.         CASE (1)
  50.         CalcAns = LogGamma(x)
  51.         CASE (2)
  52.         CalcAns = Gamma(x, errflag)
  53.         CASE (3)
  54.         CalcAns = IncompleteGamma(x, y)
  55.         CASE (4)
  56.         CalcAns = IncompleteGammaComp(x, y)
  57.         CASE (5)
  58.         CalcAns = Bessel(x, y, errflag)
  59.         CASE (6)
  60.          CalcAns = Tangent(x)
  61.         CASE (7)
  62.          CalcAns = CoshY(x)
  63.         CASE (8)
  64.          CalcAns = SinhY(x)
  65.         CASE (9)
  66.          CalcAns = Sech(x)
  67.         CASE (10)
  68.          CalcAns = ArcTanh(x)
  69.         CASE (11)
  70.          CalcAns = ErrFuncIter(x)
  71.         CASE (12)
  72.          CalcAns = ErrFunc(x, errflag)
  73.         CASE (13)
  74.          CalcAns = ErrFuncComp(x, errflag)
  75.         CASE (14)
  76.          CalcAns = ErrFuncR(x, y)
  77.         CASE (15)
  78.          CalcAns = ErrFuncI(x, y)
  79.         CASE (16)
  80.          Int1 = NINT(x)
  81.            CalcAns = Hermite(Int1, y, errflag)
  82.         CASE (17)
  83.          Int1 = NINT(x)
  84.          CalcAns = Legend(x, y, errflag)
  85.         CASE (18)
  86.          Int1 = NINT(x)
  87.          CalcAns = Laguerre(x, y, z, errflag)
  88.         CASE (19)
  89.          CalcAns = ModBesselI(x, y, ErrFlag)
  90.         CASE (20)
  91.         CalcAns = ModBesselK(x, y)
  92.         CASE (21)
  93.         Int1 = INT(x)
  94.         CalcAns = Jacobi(Int1, y, z, w, errflag)
  95.         CASE (22)
  96.         Int1 = NINT(x)
  97.         CalcAns = Tcheb(Int1, y, errflag)
  98.         CASE (23)
  99.          CalcAns = Beta(x, y, errflag)
  100.         CASE (24)
  101.          CalcAns = IncompleteBeta(x, y, z)
  102.       END SELECT
  103.       !!! LOCATE 22, 5
  104.       WRITE (*,*) ' ANSWER: ', CalcAns
  105.       END !SUBROUTINE
  106.  
  107.  
  108.  
  109.  
  110.       SUBROUTINE DisplayOptions()
  111.  
  112.       WRITE (*,*) '                Special Functions Demo Programs'
  113.       WRITE (*,31) '1.  Log Gamma                  ',
  114.      +             '13. Complement Error Function  '
  115.       WRITE (*,31) '2.  Gamma                      ',
  116.      +             '14. Error Function (Real)      '
  117.       WRITE (*,31) '3.  Incomplete Gamma           ',
  118.      +             '15. Error Function (Imaginary) '
  119.       WRITE (*,31) '4.  Incomplete Gamma Complement',
  120.      +             '16. Hermite Polynomial         '
  121.       WRITE (*,31) '5.  Bessel                     ',
  122.      +             '17. Legendre Polynomial        '
  123.       WRITE (*,31) '6.  Tangent                    ',
  124.      +             '18. LaGuerre Polynomial        '
  125.       WRITE (*,31) '7.  Hyperbolic Cosine          ',
  126.      +             '19. Modified Bessel of I       '
  127.       WRITE (*,31) '8.  Hyperbolic Sine            ',
  128.      +             '20. Modified Bessel of K       '
  129.       WRITE (*,31) '9.  Hyperbolic Secant          ',
  130.      +             '21. Jacobi Polynomial          '
  131.       WRITE (*,31) '10. Hyperbolic ArcTangent      ',
  132.      +             '22. Tchebyshev Polynomial      '
  133.       WRITE (*,31) '11. Error Function (Iterative) ',
  134.      +             '23. Beta                       '
  135.       WRITE (*,31) '12. Error Function             ',
  136.      +             '24. Incomplete Beta            '
  137.       WRITE (*,31) '                               ',
  138.      +             '25. END                        '
  139. 31    FORMAT (1X, A32,A32)
  140.       WRITE (*,*)
  141.      + ' Refer to Special Functions Chapter for function parameters'
  142.       END !SUBROUTINE  DisplayOptions
  143.  
  144.  
  145.  
  146.       SUBROUTINE NumOfInputs (choice, InptNum)
  147.       INTEGER choice, InptNum
  148.       SELECT CASE (choice)
  149.        CASE (1,2, 6,7,8,9,10,11,12,13)
  150.      InptNum = 1
  151.        CASE (3,4,5, 14,15,16,17, 20, 22, 23)
  152.      InptNum = 2
  153.        CASE (18, 19, 24)
  154.      InptNum = 3
  155.        CASE (21)
  156.       InptNum = 4
  157.       END SELECT
  158.       END !SUBROUTINE
  159.  
  160.  
  161.       SUBROUTINE ReadReals (InptNum, x, y, z, w)
  162.       INTEGER InptNum
  163.       REAL x, y, z, w
  164.       WRITE (*,*)
  165.      + ' Enter arguments in the order they appear in manual.       '
  166.       WRITE (*,*) ' ENTER VALUES FOR :'
  167.       WRITE (*,*)
  168.      + '                                                              '
  169.       WRITE (*,6) ' Parameter 1: '
  170.       READ *, x
  171.       IF (InptNum .GT. 1) THEN
  172.         WRITE (*,6) 'Parameter 2:'
  173.         READ *, y
  174.         IF (InptNum .GT. 2) THEN
  175.           WRITE (*,6) 'Parameter 3: '
  176.           READ *, z
  177.           IF (InptNum .EQ. 4) THEN
  178.             WRITE (*,6) 'Parameter 4: '
  179.             READ *, w
  180.           END IF
  181.         END IF
  182.       END IF
  183.       WRITE (*,*)
  184. 6     FORMAT (1X, A14\ )
  185.       END !SUBROUTINE
  186.  
  187.