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