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