SUBROUTINE CMREAL(TOKEN,NCHARS, REAVAL,ISTAT) NOLINEUP C C CONVERT CHARACTER STRING TO REAL VALUE C SIGN, DECIMAL POINT, EXPONENT OPTIONAL C C INPUTS-- C . TOKEN() - TOKEN TO BE CONVERTED - CHAR*1(NCHARS) C . NCHARS - NUMBER OF CHARACTERS IN TOKEN C C OUTPUTS-- C . REAVAL - REAL VALUE CONVERTED FROM TOKEN C . ISTAT - RESULT CODE - = 0 IF OK C . = 1 IF ILLEGAL CHARACTER C CHARACTER*1 TOKEN(1) INTEGER NCHARS, ISTAT REAL REAVAL CHARACTER*1 DIGIT(10),MINUS,PLUS,PERIOD,ECHAR INTEGER NLEFT,NRIGHT,LEFT,RIGHT,EXPVAL,LSTART,RSTART DOUBLE PRECISION DPTEMP,SIGN C DATA DIGIT / '0','1','2','3','4','5','6','7','8','9' / DATA MINUS / '-' / , PLUS / '+' / DATA PERIOD / '.' / , ECHAR / 'E' / C SIGN = 1.D0 REAVAL = 0.0 ISTAT = 0 NLEFT = 0 NRIGHT = 0 EXPVAL = 0 ICHAR = 1 C C SIGN PART C IF (TOKEN(1).EQ.PLUS) ICHAR = 2 IF (TOKEN(1).EQ.MINUS) THEN ICHAR = 2 SIGN = -1.D0 ENDIF C C INTEGER PART C LSTART = ICHAR DO WHILE (ICHAR.LE.NCHARS .AND. ISTAT.EQ.0) INDEX = 0 DO FOR I = 1,10 IF (TOKEN(ICHAR).EQ.DIGIT(I)) INDEX = I END FOR IF (INDEX.NE.0) THEN NLEFT = NLEFT + 1 ICHAR = ICHAR + 1 ELSE ISTAT = 1 ENDIF END WHILE CALL CMINTG(TOKEN(LSTART),NLEFT, LEFT,ISTAT) C CALL WILL RESET ISTAT TO ZERO C C FRACTIONAL PART C IF (ICHAR.LE.NCHARS .AND. TOKEN(ICHAR).EQ.PERIOD) THEN ICHAR = MIN0(ICHAR+1,NCHARS) RSTART = ICHAR DO WHILE (ICHAR.LE.NCHARS .AND. ISTAT.EQ.0) INDEX = 0 DO FOR I = 1,10 IF (TOKEN(ICHAR).EQ.DIGIT(I)) INDEX = I END FOR IF (INDEX.NE.0) THEN NRIGHT = NRIGHT + 1 ICHAR = ICHAR + 1 ELSE ISTAT = 1 ENDIF END WHILE CALL CMINTG(TOKEN(RSTART),NRIGHT, RIGHT,ISTAT) C CALL WILL RESET ISTAT TO ZERO ENDIF C C EXPONENT PART C IF (ICHAR.LT.NCHARS .AND. TOKEN(ICHAR).EQ.ECHAR) THEN ICHAR = ICHAR + 1 CALL CMINTG(TOKEN(ICHAR),NCHARS-ICHAR+1, EXPVAL,ISTAT) C CALL MAY SET ISTAT TO 0 OR 1 ELSEIF ( ICHAR.LT.NCHARS *.OR. (ICHAR.EQ.NCHARS .AND. TOKEN(ICHAR).NE.PERIOD) ) THEN C ILLEGAL CHARACTER, OR 'E' AT END OF TOKEN ISTAT = 1 ENDIF C C PUT IT ALL TOGETHER C DPTEMP = LEFT IF (NRIGHT.GT.0) DPTEMP = DPTEMP + FLOAT(RIGHT)/10.0**NRIGHT IF (ISTAT.EQ.0) DPTEMP = DPTEMP*10.0**EXPVAL IF (DPTEMP.NE.0.D0) REAVAL = DPTEMP*SIGN RETURN END