Commits

ZyX_I  committed a579b5f

Partially working: task is not done, only able to output a sequence of values

  • Participants
  • Parent commits 193d03a

Comments (0)

Files changed (6)

File constants.for

      $           F_ASIN = 'q', F_ACOS = 'b', F_ATG = 'u',
      $           F_SH   = 'h', F_CH   = 'i',
      $           F_EXP  = 'e', F_LN   = 'l',
-     $           C_PI   = 'p')
+     $           C_PI   = '#')
 c vim: ts=2 sts=2 sw=2 tw=72 ft=fortran fenc=utf-8

File data-sequence-analisys.for

+      PROGRAM DSA
+        DOUBLE PRECISION VARS(ICHAR('Z')-ICHAR('A')+1)
+        CHARACTER IN(128), OUT(128), C
+        DOUBLE PRECISION XMIN, XMAX, XSTEP, VV, R
+        INTEGER N, IL, OL, VI, XI, I
+        WRITE(*,*)'Input formula (without spaces):'
+        CALL INSTR(IN, 128, IL)
+        WRITE(*,*)'Input X range (start end):'
+        CALL INDBL(XMIN)
+        CALL INDBL(XMAX)
+        WRITE(*,*)'Input number of iterations (≤10 characters):'
+        CALL ININT(N)
+        WRITE(*,*)'Input variables (v value, use newline to interrupt):'
+  100     READ(UNIT=*,FMT='(A,$)',ERR=200)C
+          IF(C .EQ. ' ')THEN
+            GO TO 200
+          END IF
+          VI=ICHAR(C)-ICHAR('a')+1
+          READ(*,'(A,$)')C
+          CALL INDBL(VV)
+          VARS(VI)=VV
+          GO TO 100
+  200   CALL LEX(IN, OUT, IL, OL)
+        CALL PARSE(OUT, OL)
+        XI=ICHAR('X')-ICHAR('A')+1
+        XSTEP=(XMAX-XMIN)/(N-1)
+        I=0
+  300     VARS(XI)=XMIN+I*XSTEP
+          CALL EXECUTE(OUT, OL, VARS, R)
+          WRITE(*,*) R
+          I=I+1
+        IF(I .LT. N)THEN
+          GO TO 300
+        END IF
+      END
+c vim: ts=2 sts=2 sw=2 tw=72 ft=fortran fenc=utf-8

File executor.for

+      SUBROUTINE EXECUTE(OUT, L, VARS, R)
+        CHARACTER OUT*(*)
+        INTEGER L
+        DOUBLE PRECISION VARS(ICHAR('Z')-ICHAR('A')+1)
+        DOUBLE PRECISION R
+        DOUBLE PRECISION STACK(128), V
+        INTEGER SP, OP, CI
+        CHARACTER C
+        INCLUDE "constants.for"
+        SP=1
+        OP=0
+  100     OP=OP+1
+          IF(OP .GT. L)THEN
+            GO TO 200
+          END IF
+          C=OUT(OP:OP)
+          IF(C .EQ. '+')THEN
+            STACK(SP-1)=STACK(SP-1)+STACK(SP)
+            SP=SP-1
+            GO TO 100
+          END IF
+          IF(C .EQ. '-')THEN
+            STACK(SP-1)=STACK(SP-1)-STACK(SP)
+            SP=SP-1
+            GO TO 100
+          END IF
+          IF(C .EQ. '*')THEN
+            STACK(SP-1)=STACK(SP-1)*STACK(SP)
+            SP=SP-1
+            GO TO 100
+          END IF
+          IF(C .EQ. '/')THEN
+            STACK(SP-1)=STACK(SP-1)/STACK(SP)
+            SP=SP-1
+            GO TO 100
+          END IF
+          IF(C .EQ. '^')THEN
+            STACK(SP-1)=STACK(SP-1)**STACK(SP)
+            SP=SP-1
+            GO TO 100
+          END IF
+          IF(C .EQ. '!')THEN
+            STACK(SP)=-STACK(SP)
+            GO TO 100
+          END IF
+          IF(C .EQ. F_SIN)THEN
+            STACK(SP)=SIN(STACK(SP))
+            GO TO 100
+          END IF
+          IF(C .EQ. F_COS)THEN
+            STACK(SP)=COS(STACK(SP))
+            GO TO 100
+          END IF
+          IF(C .EQ. F_TG)THEN
+            STACK(SP)=TAN(STACK(SP))
+            GO TO 100
+          END IF
+          IF(C .EQ. F_ASIN)THEN
+            STACK(SP)=ASIN(STACK(SP))
+            GO TO 100
+          END IF
+          IF(C .EQ. F_ACOS)THEN
+            STACK(SP)=ACOS(STACK(SP))
+            GO TO 100
+          END IF
+          IF(C .EQ. F_ATG)THEN
+            STACK(SP)=ATAN(STACK(SP))
+            GO TO 100
+          END IF
+          IF(C .EQ. F_SH)THEN
+            V=STACK(SP)
+            STACK(SP)=(EXP(V)-EXP(-V))/2
+            GO TO 100
+          END IF
+          IF(C .EQ. F_CH)THEN
+            V=STACK(SP)
+            STACK(SP)=(EXP(V)+EXP(-V))/2
+            GO TO 100
+          END IF
+          IF(C .EQ. F_EXP)THEN
+            STACK(SP)=EXP(STACK(SP))
+            GO TO 100
+          END IF
+          IF(C .EQ. F_LN)THEN
+            STACK(SP)=LOG(STACK(SP))
+            GO TO 100
+          END IF
+          IF(C .EQ. C_PI)THEN
+            STACK(SP+1)=3.1415926535897932384626433832795028841971D0
+            SP=SP+1
+            GO TO 100
+          END IF
+          CI=ICHAR(C)
+          IF(      ICHAR('A') .LE. CI
+     $       .AND. CI         .LE. ICHAR('Z'))THEN
+            STACK(SP+1)=VARS(CI-ICHAR('A')+1)
+            SP=SP+1
+            GO TO 100
+          END IF
+          IF(      ICHAR('0') .LE. CI
+     $       .AND. CI         .LE. ICHAR('9'))THEN
+            STACK(SP+1)=DBLE(CI-ICHAR('0'))
+            SP=SP+1
+            GO TO 100
+          END IF
+  200   R=STACK(SP)
+      END SUBROUTINE
+c vim: ts=2 sts=2 sw=2 tw=72 ft=fortran fenc=utf-8
+      SUBROUTINE INSTR(IN, MAXL, L)
+        CHARACTER IN*(*)
+        INTEGER L, MAXL
+        INTEGER CI
+        CHARACTER C
+        L=0
+  100     READ(*,'(A,$)') C
+          CI=ICHAR(C)
+          IF(33 .LE. CI .AND. CI .LE. 128)THEN
+            L=L+1
+            IN(L:L)=C
+            IF(L .NE. MAXL)THEN
+              GO TO 100
+            END IF
+          END IF
+      END SUBROUTINE
+      SUBROUTINE INDBL(X)
+        DOUBLE PRECISION X
+        CHARACTER XS*128, C, F*14
+        INTEGER W, D, E, I, LI
+        LOGICAL HSGN, HDIG, HDEC, HEXP, HESG, HEDG
+        W=0
+        D=0
+        E=0
+        HSGN=.FALSE.
+        HDIG=.FALSE.
+        HDEC=.FALSE.
+        HEXP=.FALSE.
+        HESG=.FALSE.
+        HEDG=.FALSE.
+  200     READ(*,'(A,$)')C
+          IF(C .EQ. '+' .OR. C .EQ. '-')THEN
+            IF(HSGN .AND. .NOT. HDIG)THEN
+              STOP 'Duplicate sign'
+            END IF
+            IF(HDIG .AND. .NOT. HEXP)THEN
+              STOP 'Sign inside number'
+            END IF
+            IF(HESG)THEN
+              STOP 'Duplicate exponent sign'
+            END IF
+            IF(HEDG)THEN
+              STOP 'No place for sign anymore'
+            END IF
+            IF(HSGN .OR. HDIG)THEN
+              HESG=.TRUE.
+            ELSE
+              HSGN=.TRUE.
+            END IF
+            W=W+1
+            XS(W:W)=C
+            GO TO 200
+          END IF
+          IF(C .EQ. '.')THEN
+            IF(HDEC)THEN
+              STOP 'Duplicate decimal dot'
+            END IF
+            IF(.NOT. HDIG)THEN
+              W=W+1
+              XS(W:W)='0'
+              HDIG=.TRUE.
+            END IF
+            W=W+1
+            XS(W:W)=C
+            HDEC=.TRUE.
+            GO TO 200
+          END IF
+          IF(C .EQ. 'e')THEN
+            IF(HEXP)THEN
+              STOP 'Duplicate exponent'
+            END IF
+            IF(.NOT. HDIG)THEN
+              STOP 'No mantiss'
+            END IF
+            IF(.NOT. HDEC)THEN
+              W=W+1
+              XS(W:W)='.'
+              W=W+1
+              XS(W:W)='0'
+              HDEC=.TRUE.
+            END IF
+            W=W+1
+            XS(W:W)='E'
+            HEXP=.TRUE.
+            GO TO 200
+          END IF
+          CI=ICHAR(C)
+          IF(ICHAR('0') .LE. CI .AND. CI .LE. ICHAR('9'))THEN
+            IF(HDIG)THEN
+              IF(HEXP)THEN
+                HEDG=.TRUE.
+                E=E+1
+              ELSE
+                IF(HDEC)THEN
+                  D=D+1
+                END IF
+              END IF
+            ELSE
+              HDIG=.TRUE.
+            END IF
+            W=W+1
+            XS(W:W)=C
+            GO TO 200
+          END IF
+        IF(.NOT. HDEC)THEN
+          W=W+1
+          XS(W:W)='.'
+          W=W+1
+          XS(W:W)='0'
+          W=W+1
+          XS(W:W)='E'
+          W=W+1
+          XS(W:W)='0'
+          D=1
+          E=1
+        ELSE
+          IF(.NOT. HEXP)THEN
+            W=W+1
+            XS(W:W)='E'
+            W=W+1
+            XS(W:W)='0'
+            E=1
+          END IF
+        END IF
+        WRITE(F,'(A,I3,A,I3,A,I3,A)')'(E',W,'.',D,'E',E,')'
+        LI=INDEX(F, ')')
+  210     I=INDEX(F, ' ')
+          IF(I .NE. 0 .AND. I .LT. LI)THEN
+            F(I:13)=F(I+1:14)
+            F(14:14)=' '
+            LI=LI-1
+            GO TO 210
+          END IF
+        READ(XS,F)X
+      END SUBROUTINE
+      SUBROUTINE ININT(N)
+        INTEGER N
+        CHARACTER C
+        INTEGER CI, SGN
+        SGN=1
+        N=0
+  300     READ(*,'(A,$)')C
+          IF(C .EQ. '-')THEN
+            SGN=-1
+            GO TO 300
+          END IF
+          CI=ICHAR(C)
+          IF(ICHAR('0') .LE. CI .AND. CI .LE. ICHAR('9'))THEN
+            N=N*10+CI-ICHAR('0')
+            GO TO 300
+          END IF
+        N=SGN*N
+      END SUBROUTINE
+c vim: ts=2 sts=2 sw=2 tw=72 ft=fortran fenc=utf-8
-      PROGRAM LEXER
-        CHARACTER INPUT*128, OUTPUT*128
-        INTEGER I
-        READ(*,'(A128)') INPUT
-        DO 25, I=1,128
-          OUTPUT(I:I)=' '
-  25    END DO
-        CALL LEX(INPUT, OUTPUT)
-        WRITE(*,'(A128)') OUTPUT
-      END PROGRAM
-      SUBROUTINE LEX(S, OUT, L)
-        CHARACTER*(*) S, OUT
+c     PROGRAM LEXER
+c       CHARACTER INPUT*128, OUTPUT*128
+c       INTEGER I
+c       READ(*,'(A128)') INPUT
+c       DO 25, I=1,128
+c         OUTPUT(I:I)=' '
+c 25    END DO
+c       CALL LEX(INPUT, OUTPUT)
+c       WRITE(*,'(A128)') OUTPUT
+c     END PROGRAM
+      SUBROUTINE LEX(IN, OUT, IL, OL)
+        CHARACTER IN*(*), OUT*(*)
         CHARACTER C
-        INTEGER I, OL, CI, CAP, L
+        INTEGER IL, OL
+        INTEGER I, CI, CAP
         PARAMETER (CAP = ICHAR('A')-ICHAR('a'))
         LOGICAL STRMATCH
         INCLUDE "constants.for"
         OL=1
         I=1
   50    CONTINUE
-          IF(STRMATCH('sin', S, I))THEN
+          IF(STRMATCH('sin', IN, I, IL))THEN
             CALL PUSH(OUT, OL, F_SIN)
             I=I+3
-          ELSE
-            IF(STRMATCH('cos', S, I))THEN
-              CALL PUSH(OUT, OL, F_COS)
-              I=I+3
+            GO TO 75
+          END IF
+          IF(STRMATCH('cos', IN, I, IL))THEN
+            CALL PUSH(OUT, OL, F_COS)
+            I=I+3
+            GO TO 75
+          END IF
+          IF(STRMATCH('tg', IN, I, IL))THEN
+            CALL PUSH(OUT, OL, F_TG)
+            I=I+2
+            GO TO 75
+          END IF
+          IF(STRMATCH('asin', IN, I, IL))THEN
+            CALL PUSH(OUT, OL, F_ASIN)
+            I=I+4
+            GO TO 75
+          END IF
+          IF(STRMATCH('acos', IN, I, IL))THEN
+            CALL PUSH(OUT, OL, F_ACOS)
+            I=I+4
+            GO TO 75
+          END IF
+          IF(STRMATCH('atg', IN, I, IL))THEN
+            CALL PUSH(OUT, OL, F_ATG)
+            I=I+3
+            GO TO 75
+          END IF
+          IF(STRMATCH('exp', IN, I, IL))THEN
+            CALL PUSH(OUT, OL, F_EXP)
+            I=I+3
+            GO TO 75
+          END IF
+          IF(STRMATCH('ln', IN, I, IL))THEN
+            CALL PUSH(OUT, OL, F_LN)
+            I=I+2
+            GO TO 75
+          END IF
+          IF(STRMATCH('sh', IN, I, IL))THEN
+            CALL PUSH(OUT, OL, F_SH)
+            I=I+2
+            GO TO 75
+          END IF
+          IF(STRMATCH('ch', IN, I, IL))THEN
+            CALL PUSH(OUT, OL, F_CH)
+            I=I+2
+            GO TO 75
+          END IF
+          IF(STRMATCH('pi', IN, I, IL))THEN
+            CALL PUSH(OUT, OL, C_PI)
+            I=I+2
+            GO TO 75
+          END IF
+          C=IN(I:I)
+          IF(INDEX('+-*/^()', C) .NE. 0)THEN
+            IF(C .EQ. '-' .AND.
+     $         (     I .EQ. 1
+     $          .OR. INDEX('(+-*/^',IN(I-1:I-1)) .NE. 0)
+     $        )THEN
+c             Unary minus
+              CALL PUSH(OUT, OL, '!')
             ELSE
-              IF(STRMATCH('tg', S, I))THEN
-                CALL PUSH(OUT, OL, F_TG)
-                I=I+2
-              ELSE
-                IF(STRMATCH('asin', S, I))THEN
-                  CALL PUSH(OUT, OL, F_ASIN)
-                  I=I+4
-                ELSE
-                  IF(STRMATCH('exp', S, I))THEN
-                    CALL PUSH(OUT, OL, F_EXP)
-                    I=I+3
-                  ELSE
-                    IF(STRMATCH('ln', S, I))THEN
-                      CALL PUSH(OUT, OL, F_LN)
-                      I=I+2
-                    ELSE
-                      IF(STRMATCH('sh', S, I))THEN
-                        CALL PUSH(OUT, OL, F_SH)
-                        I=I+2
-                      ELSE
-                        IF(STRMATCH('ch', S, I))THEN
-                          CALL PUSH(OUT, OL, F_CH)
-                          I=I+2
-                        ELSE
-                          C=S(I:I)
-                          IF(INDEX('+-*/^()', C) .NE. 0)THEN
-                            IF(C .EQ. '-' .AND.
-     $                         (     I .EQ. 1
-     $                          .OR. INDEX('(+-*/^', S(I-1:I-1)) .NE. 0)
-     $                        )THEN
-c                             Unary minus
-                              CALL PUSH(OUT, OL, '!')
-                            ELSE
-                              CALL PUSH(OUT, OL, C)
-                            END IF
-                            I=I+1
-                          ELSE
-                            CI=ICHAR(C)
-                            IF(      ICHAR('a') .LE. CI
-     $                         .AND. CI         .LE. ICHAR('z'))THEN
-                              CALL PUSH(OUT, OL, CHAR(CI+CAP))
-                              I=I+1
-                            ELSE
-                              IF(      ICHAR('0') .LE. CI
-     $                           .AND. CI         .LE. ICHAR('9'))THEN
-                                CALL PUSH(OUT, OL, C)
-                                I=I+1
-                              ELSE
-                                I=I+1
-                              END IF
-                            END IF
-                          END IF
-                        END IF
-                      END IF
-                    END IF
-                  END IF
-                END IF
-              END IF
+              CALL PUSH(OUT, OL, C)
             END IF
+            I=I+1
+            GO TO 75
           END IF
-        IF(I .LE. LEN(S))THEN
+          CI=ICHAR(C)
+          IF(      ICHAR('a') .LE. CI
+     $       .AND. CI         .LE. ICHAR('z'))THEN
+            CALL PUSH(OUT, OL, CHAR(CI+CAP))
+            I=I+1
+            GO TO 75
+          END IF
+          IF(      ICHAR('0') .LE. CI
+     $       .AND. CI         .LE. ICHAR('9'))THEN
+            CALL PUSH(OUT, OL, C)
+            I=I+1
+            GO TO 75
+          END IF
+          I=I+1
+   75   IF(I .LE. IL)THEN
           GO TO 50
         END IF
-        L=OL
+        OL=OL-1
       END SUBROUTINE
       SUBROUTINE PUSH(OUT, OL, ATOM)
         CHARACTER OUT*(*), ATOM
         OUT(OL:OL)=ATOM
         OL=OL+1
       END SUBROUTINE
-      LOGICAL FUNCTION STRMATCH(S, OS, START)
-        INTEGER I, START
-        CHARACTER S*(*), OS*(*)
-        IF(LEN(S) .GT. LEN(OS)-START)THEN
+      LOGICAL FUNCTION STRMATCH(S, IN, START, L)
+        INTEGER I, START, L
+        CHARACTER S*(*), IN*(*)
+        IF(LEN(S) .GT. L-START)THEN
           STRMATCH=.FALSE.
           GO TO 200
         END IF
         STRMATCH=.TRUE.
         DO 100, I = 1,LEN(S)
-          IF(S(I:I) .NE. OS(I-START+1:I-START+1))THEN
+          IF(S(I:I) .NE. IN(I+START-1:I+START-1))THEN
             STRMATCH=.FALSE.
             GO TO 200
           END IF
-      PROGRAM PARSER
-        CHARACTER INPUT*128, OUTPUT*128
-        INTEGER LEVEL
-        INTEGER L, I
-        DO 25, I=1,128
-          INPUT(I:I)=' '
-   25   END DO
-        READ(*,'(A128)') INPUT
-        DO 30, I=1,128
-          IF(LEVEL(INPUT(I:I)) .EQ. 0)THEN
-            L=I-1
-            GO TO 35
-          END IF
-   30   END DO
-   35   CALL PARSE(INPUT, L)
-        WRITE(*,'(A(L))') INPUT
-      END PROGRAM
+c     PROGRAM PARSER
+c       CHARACTER INPUT*128, OUTPUT*128
+c       INTEGER LEVEL
+c       INTEGER L, I
+c       DO 25, I=1,128
+c         INPUT(I:I)=' '
+c  25   END DO
+c       READ(*,'(A128)') INPUT
+c       DO 30, I=1,128
+c         IF(LEVEL(INPUT(I:I)) .EQ. 0)THEN
+c           L=I-1
+c           GO TO 35
+c         END IF
+c  30   END DO
+c  35   CALL PARSE(INPUT, L)
+c       WRITE(*,'(A(L))') INPUT
+c     END PROGRAM
       SUBROUTINE PARSE(OUT, L)
         CHARACTER OUT*(*)
         INTEGER L
       INTEGER FUNCTION LEVEL(ATOM)
         CHARACTER ATOM
         INTEGER AI
+        INCLUDE "constants.for"
         AI=ICHAR(ATOM)
         IF(     (ICHAR('0') .LE. AI .AND. AI .LE. ICHAR('9'))
-     $     .OR. (ICHAR('A') .LE. AI .AND. AI .LE. ICHAR('Z')))THEN
+     $     .OR. (ICHAR('A') .LE. AI .AND. AI .LE. ICHAR('Z'))
+     $     .OR. (ATOM .EQ. C_PI))THEN
           LEVEL=5
         ELSE
           IF(     ATOM .EQ. '('