home *** CD-ROM | disk | FTP | other *** search
/ Frostbyte's 1980s DOS Shareware Collection / floppyshareware.zip / floppyshareware / DOOG / PCSSP1.ZIP / ITRPAPSM.ZIP / DATSM.FOR < prev    next >
Text File  |  1985-11-29  |  4KB  |  124 lines
  1. C
  2. C     ..................................................................
  3. C
  4. C        SUBROUTINE DATSM
  5. C
  6. C        PURPOSE
  7. C           NDIM POINTS OF A GIVEN TABLE WITH MONOTONIC ARGUMENTS ARE
  8. C           SELECTED AND ORDERED SUCH THAT
  9. C           ABS(ARG(I)-X).GE.ABS(ARG(J)-X) IF I.GT.J.
  10. C
  11. C        USAGE
  12. C           CALL DATSM (X,Z,F,IROW,ICOL,ARG,VAL,NDIM)
  13. C
  14. C        DESCRIPTION OF PARAMETERS
  15. C           X      - DOUBLE PRECISION SEARCH ARGUMENT.
  16. C           Z      - DOUBLE PRECISION VECTOR OF ARGUMENT VALUES (DIMEN-
  17. C                    SION IROW). THE ARGUMENT VALUES MUST BE STORED IN
  18. C                    INCREASING OR DECREASING SEQUENCE.
  19. C           F      - IN CASE ICOL=1, F IS THE DOUBLE PRECISION VECTOR
  20. C                    OF FUNCTION VALUES (DIMENSION IROW).
  21. C                    IN CASE ICOL=2, F IS A DOUBLE PRECISION IROW BY 2
  22. C                    MATRIX. THE FIRST COLUMN SPECIFIES VECTOR OF FUNC-
  23. C                   TION VALUES AND THE SECOND VECTOR OF DERIVATIVES.
  24. C           IROW   - THE DIMENSION OF VECTOR Z AND OF EACH COLUMN
  25. C                    IN MATRIX F.
  26. C           ICOL   - THE NUMBER OF COLUMNS IN F (I.E. 1 OR 2).
  27. C           ARG    - RESULTING DOUBLE PRECISION VECTOR OF SELECTED AND
  28. C                    ORDERED ARGUMENT VALUES (DIMENSION NDIM).
  29. C           VAL    - RESULTING DOUBLE PRECISION VECTOR OF SELECTED
  30. C                    FUNCTION VALUES (DIMENSION NDIM) IN CASE ICOL=1.
  31. C                    IN CASE ICOL=2, VAL IS THE DOUBLE PRECISION VECTOR
  32. C                    OF FUNCTION AND DERIVATIVE VALUES (DIMENSION
  33. C                    2*NDIM) WHICH ARE STORED IN PAIRS (I.E. EACH FUNC-
  34. C                    TION VALUE IS FOLLOWED BY ITS DERIVATIVE VALUE).
  35. C           NDIM   - THE NUMBER OF POINTS WHICH MUST BE SELECTED OUT OF
  36. C                    THE GIVEN TABLE (Z,F).
  37. C
  38. C        REMARKS
  39. C           NO ACTION IN CASE IROW LESS THAN 1.
  40. C           IF INPUT VALUE NDIM IS GREATER THAN IROW, THE PROGRAM
  41. C           SELECTS ONLY A MAXIMUM TABLE OF IROW POINTS.  THEREFORE THE
  42. C           USER OUGHT TO CHECK CORRESPONDENCE BETWEEN TABLE (ARG,VAL)
  43. C           AND ITS DIMENSION BY COMPARISON OF NDIM AND IROW, IN ORDER
  44. C           TO GET CORRECT RESULTS IN FURTHER WORK WITH TABLE (ARG,VAL).
  45. C           THIS TEST MAY BE DONE BEFORE OR AFTER CALLING
  46. C           SUBROUTINE DATSM.
  47. C           SUBROUTINE DATSM ESPECIALLY CAN BE USED FOR GENERATING THE
  48. C           TABLE (ARG,VAL) NEEDED IN SUBROUTINES DALI, DAHI, AND DACFI.
  49. C
  50. C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  51. C           NONE
  52. C
  53. C        METHOD
  54. C           SELECTION IS DONE BY SEARCHING THE SUBSCRIPT J OF THAT
  55. C           ARGUMENT, WHICH IS NEXT TO X (BINARY SEARCH).
  56. C           AFTERWARDS NEIGHBOURING ARGUMENT VALUES ARE TESTED AND
  57. C           SELECTED IN THE ABOVE SENSE.
  58. C
  59. C     ..................................................................
  60. C
  61.       SUBROUTINE DATSM(X,Z,F,IROW,ICOL,ARG,VAL,NDIM)
  62. C
  63. C
  64.       DIMENSION Z(1),F(1),ARG(1),VAL(1)
  65.       DOUBLE PRECISION X,Z,F,ARG,VAL
  66. C
  67. C     CASE IROW=1 IS CHECKED OUT
  68.       IF(IROW-1)23,21,1
  69.     1 N=NDIM
  70. C
  71. C     IF N IS GREATER THAN IROW, N IS SET EQUAL TO IROW.
  72.       IF(N-IROW)3,3,2
  73.     2 N=IROW
  74. C
  75. C     CASE IROW.GE.2
  76. C     SEARCHING FOR SUBSCRIPT J SUCH THAT Z(J) IS NEXT TO X.
  77.     3 IF(Z(IROW)-Z(1))5,4,4
  78.     4 J=IROW
  79.       I=1
  80.       GOTO 6
  81.     5 I=IROW
  82.       J=1
  83.     6 K=(J+I)/2
  84.       IF(X-Z(K))7,7,8
  85.     7 J=K
  86.       GOTO 9
  87.     8 I=K
  88.     9 IF(IABS(J-I)-1)10,10,6
  89.    10 IF(DABS(Z(J)-X)-DABS(Z(I)-X))12,12,11
  90.    11 J=I
  91. C
  92. C     TABLE SELECTION
  93.    12 K=J
  94.       JL=0
  95.       JR=0
  96.       DO 20 I=1,N
  97.       ARG(I)=Z(K)
  98.       IF(ICOL-1)14,14,13
  99.    13 VAL(2*I-1)=F(K)
  100.       KK=K+IROW
  101.       VAL(2*I)=F(KK)
  102.       GOTO 15
  103.    14 VAL(I)=F(K)
  104.    15 JJR=J+JR
  105.       IF(JJR-IROW)16,18,18
  106.    16 JJL=J-JL
  107.       IF(JJL-1)19,19,17
  108.    17 IF(DABS(Z(JJR+1)-X)-DABS(Z(JJL-1)-X))19,19,18
  109.    18 JL=JL+1
  110.       K=J-JL
  111.       GOTO 20
  112.    19 JR=JR+1
  113.       K=J+JR
  114.    20 CONTINUE
  115.       RETURN
  116. C
  117. C     CASE IROW=1
  118.    21 ARG(1)=Z(1)
  119.       VAL(1)=F(1)
  120.       IF(ICOL-2)23,22,23
  121.    22 VAL(2)=F(2)
  122.    23 RETURN
  123.       END
  124.