1      PROGRAM COLCALC
2      CHARACTER*8 C_CODE(200,26) , C8
3      REAL*8                       R8
4      INTEGER     NUM_CODE(26)
5      EQUIVALENCE (C8,R8)
6      CHARACTER*666 C_EXPR
7      REAL*8 R8VAL(26) , ROUT(9) , PAREVAL
8      LOGICAL LSTOUT
9C
10      CHARACTER*8 C_CSTOP(200)
11      INTEGER     N_CSTOP
12      REAL*8      R_CSTOP
13C
14      EXTERNAL PAREVAL , INUMC , PARSER
15C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
16C
17      DO 90 I=1,26
18         R8VAL(I) = 0.0D0
1990    CONTINUE
20C
21      NOUT   = 1
22      NCMAX  = 0
23      IALPHA = ICHAR('A') - 1
24C.......................................................................
25100   CONTINUE
26      WRITE(*,101) NOUT
27101   FORMAT(' output',I1,'> '$)
28      READ(*,111,END=1000,ERR=1000) C_EXPR
29111   FORMAT(A)
30      IF( C_EXPR .EQ. ' '    .OR. C_EXPR .EQ. 'end' .OR.
31     X    C_EXPR .EQ. 'exit' .OR. C_EXPR .EQ. 'quit'    )GOTO 1000
32C
33      CALL PARSER( C_EXPR , .TRUE. , NUM_CODE(NOUT) , C_CODE(1,NOUT) )
34C
35      IF( NUM_CODE(NOUT) .LE. 0 )GOTO 100
36C
37C  find maximum symbol (column) reference
38C
39      DO 200 I=1,NUM_CODE(NOUT)-1
40         IF( C_CODE(I,NOUT) .EQ. 'PUSHSYM' )THEN
41            NCMAX = MAX( NCMAX , ICHAR(C_CODE(I+1,NOUT)(1:1))-IALPHA )
42         ENDIF
43200   CONTINUE
44C
45      NOUT = NOUT + 1
46      IF( NOUT .LE. 9 )GOTO 100
47C----------------------------------------------------------------------
481000  CONTINUE
49      NOUT = NOUT - 1
50      IF( NOUT .LE. 0 )THEN
51        WRITE(*,1001)
521001    FORMAT(' Must enter at least one output column!')
53        GOTO 9000
54      ENDIF
55C
561010  CONTINUE
57      NCOL = 0
58      WRITE(*,1002) 'input'
591002  FORMAT(' Enter ',A6,' filename           : '$)
60      READ(*,111,END=9000,ERR=1010) C_EXPR
61      IF( C_EXPR(1:1) .EQ. ' ' )GOTO 1030
62C
63      OPEN( UNIT=77,FILE=C_EXPR,
64     X      FORM='FORMATTED',STATUS='OLD',IOSTAT=IERR)
65      IF( IERR .NE. 0 )GOTO 1010
66C
67C  Find out how many columns of numbers are in this file by
68C  reading the first line
69C
70      READ(77,111) C_EXPR
71      REWIND( UNIT=77 )
72      NCOL = INUMC( C_EXPR )
73ccc      write(*,7707) ncol
74ccc7707  format('inumc returns ',I5)
75      IF( NCOL .LE. 0 )THEN
76         WRITE(*,1019)
771019     FORMAT('*** cannot read numbers from that file ***' )
78         CLOSE( UNIT=77 )
79         GOTO 1010
80      ENDIF
81C
82      IF( NCMAX .GT. NCOL )THEN
83         WRITE(*,1029) NCMAX , NCOL
841029     FORMAT(/
85     X     ' *** max column # in expressions =',I3 /
86     X     ' ***              in input file  =',I3 /
87     X     ' *** trailing columns set to zero ***' /)
88      ENDIF
89      NCOL = MIN( NCOL , NCMAX )
90C
911030  CONTINUE
92      IF( NCOL .EQ. 0 )THEN
93         WRITE(*,1031)
941031     FORMAT(' OK, enter number of rows to run: '$)
95         READ(*,*) NROW
96         IF( NROW.LE.0 )GOTO 1030
97      ELSE
98         NROW = 999999
99      ENDIF
100C
101      WRITE(*,1002) 'output'
102      READ(*,111,END=9000,ERR=1030) C_EXPR
103C
104      LSTOUT = C_EXPR(1:1) .EQ. ' '
105C
106      IF( .NOT. LSTOUT )THEN
107         OPEN( UNIT=78,FILE=C_EXPR,
108     X         FORM='FORMATTED',STATUS='NEW',IOSTAT=IERR )
109         IF( IERR .NE. 0 )GOTO 1030
110      ENDIF
111C.....................................................................
1121050  CONTINUE
113      N_CSTOP = 0
114      WRITE(*,1051)
1151051  FORMAT(' stopping expression (end < 0) : '$)
116      READ(*,111,END=1090,ERR=1090) C_EXPR
117      IF( C_EXPR .EQ. ' ' .OR. C_EXPR .EQ. '1' )GOTO 1090
118      CALL PARSER( C_EXPR , .TRUE. , N_CSTOP , C_CSTOP )
119      IF( N_CSTOP .LE. 0 )GOTO 1050
120C.....................................................................
1211090  CONTINUE
122      IROW      = 0
1231100  CONTINUE
124      IROW      = IROW + 1
125      R8VAL(26) = IROW
126      IF( NCOL .GT. 0 )
127     X  READ(77,*,END=9000,ERR=9000) ( R8VAL(I) , I=1,NCOL )
128C
129      DO 1200 I=1,NOUT
130         ROUT(I) = PAREVAL( NUM_CODE(I) , C_CODE(1,I) , R8VAL )
1311200  CONTINUE
132      IF( N_CSTOP .GT. 0 )THEN
133         R_CSTOP = PAREVAL( N_CSTOP , C_CSTOP , R8VAL )
134         IF( R_CSTOP .LT. 0.D+00 )GOTO 9000
135      ENDIF
136C
137      IF( LSTOUT )THEN
138         WRITE(*,1201) ( ROUT(I) , I=1,NOUT )
139      ELSE
140         WRITE(78,1201) ( ROUT(I) , I=1,NOUT )
141      ENDIF
1421201  FORMAT(9(1X,1PG20.13))
143C
144      IF( NCOL.GT.0 .OR. IROW.LT.NROW )GOTO 1100
145C.......................................................................
1469000  CONTINUE
147      END
148C
149C
150C
151      FUNCTION INUMC( CLINE )
152      IMPLICIT NONE
153C
154C  Find how many columns there are in the string CLINE
155C
156      INTEGER INUMC
157      CHARACTER*(*) CLINE
158C
159      INTEGER ITRY , I , IERR
160      REAL*8  RVAL(26)
161C
162      REAL*8      TRAP                 , TOL
163      PARAMETER ( TRAP = -987654.3D+21 , TOL = 1.D-11 )
164C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
165C
166      DO 100 ITRY=1,26
167         DO 50 I=1,ITRY
168            RVAL(I) = TRAP
16950       CONTINUE
170         READ(CLINE,*,IOSTAT=IERR) ( RVAL(I) , I=1,ITRY )
171         IF( IERR .NE. 0 )GOTO 200
172         IF( ABS(RVAL(ITRY)/TRAP-1.D+00) .LE. TOL )GOTO 200
173100   CONTINUE
174      ITRY = 27
175C
176200   CONTINUE
177      INUMC = ITRY - 1
178      RETURN
179      END
180