REAL FUNCTION RCVTS (STRING, IPOS, IRET) C***************************************************************************** C C Description : Routine to read a real number from a string C C Arguments : STRING = string to be checked, terminated by zero-byte C IPOS = optional C input: C INTEGER position in STRING to start search C for number. C output: C INTEGER position plus 1 of first non-numeric C character in STRING, or C position of first non-numeric character if C this character is a sign-character or the C end-of-string character (=zero byte). C if not given input 1 assumed, no output C IRET = INTEGER return code: C -1 - numeric error C 0 - empty string C 1 - normal return C 2 - leading non-spaces C 4 - trailing non-spaces C RCVTS = REAL value of the number C C Author : F.A.Minkema C AKZO PHARMA, Oss Holland C dep. SDA C C Version : V1.1 Date : 03-jan-83 C C Module name : RCVTS.FTN C C Package : RSX-LIBRARY C C Compilation/Linking : FOR/F4P/TR:NONE RCVTS C C Updates : name version C H.A.M. FIkke V1.1 C description : IPOS optional C C***************************************************************************** BYTE STRING(1),ERB,CHAR DATA ERB/128/ C RCVTS=0. IRET=-1 C IRET1=0 ! switch: number found (yes/no: 1/0) IRET2=0 ! switch: leading non-spaces (yes/no: 2/0) IRET4=0 ! switch: trailing non-spaces (yes/no: 4/0) ISGN=1 ! sign of mantissa (neg/pos: -1/1) IESGN=1 ! sign of exponent (neg/pos: -1/1) RIN=0. ! integer part DEC=0. ! decimal part NDEC=0 ! number of decimal positions IEX=0. ! exponent IPHASE=1 ! indicates where we are LS=LEN(STRING) ! length of string C C turn off INTEGER and FLOATING OVERFLOW (error # 70 and 72) C and FLOATING UNDERFLOW (error # 74) C CALL ERRSET(70,.TRUE.,.FALSE.,.FALSE.,.FALSE.,) CALL ERRSET(72,.TRUE.,.FALSE.,.FALSE.,.FALSE.,) CALL ERRSET(74,.TRUE.,.FALSE.,.FALSE.,.FALSE.,) C C decode string, and compute number C IP=1 IF (LARG(2)) IP=IPOS I=IP 10 IF (I.GT.LS) GOTO 700 ! end of string CHAR=STRING(I) I=I+1 GOTO (100,200,300,400,500,600) IPHASE C C IPHASE=1 : search sign or first character of number C 100 IF ((CHAR.EQ.'+' .OR. CHAR.EQ.'-') .AND. (STRING(I).EQ.'.' .OR. 1 (STRING(I).GE.'0' .AND. STRING(I).LE.'9'))) 110,120,120 C THEN 110 ISGN=44-CHAR IPHASE=2 GOTO 10 C ENDIF 120 IF (CHAR.EQ.'.' .AND. 1 (STRING(I).GE.'0' .AND. STRING(I).LE.'9')) 130,140,140 C THEN 130 IPHASE=3 GOTO 10 C ENDIF 140 IF (CHAR.GE.'0' .AND. CHAR.LE.'9') 150,160,160 C THEN 150 I=I-1 IPHASE=2 GOTO 10 C ENDIF 160 IF (CHAR.NE.' ') IRET2=2 GOTO 10 C C IPHASE=2 : determine integer part C 200 IF (CHAR.EQ.'.') 210,220,220 C THEN 210 IPHASE=3 GOTO 10 C ENDIF 220 IF (CHAR.EQ.'e' .OR. CHAR.EQ.'E') 230,240,240 C THEN 230 IPHASE=4 GOTO 10 C ENDIF 240 IF (CHAR.GE.'0' .AND. CHAR.LE.'9') 250,260,260 C THEN 250 RIN=10.*RIN + (CHAR-'0') IRET1=1 GOTO 10 C ENDIF 260 IPHASE=6 I=I-1 IP=I GOTO 10 C C IPHASE=3 : examine decimal part until E-character C 300 IF (CHAR.EQ.'e' .OR. CHAR.EQ.'E') 310,320,320 C THEN 310 IPHASE=4 GOTO 10 C ENDIF 320 IF (CHAR.GE.'0' .AND. CHAR.LE.'9') 330,340,340 C THEN 330 DEC=10.*DEC + (CHAR-'0') NDEC=NDEC+1 IRET1=1 GOTO 10 C ENDIF 340 IPHASE=6 I=I-1 IP=I GOTO 10 C C IPHASE=4 : determine sign of the exponent C 400 IF (CHAR.EQ.'+' .OR. CHAR.EQ.'-') 410,420,420 C THEN 410 IESGN=44-CHAR GOTO 430 C ELSE 420 I=I-1 C ENDIF 430 IPHASE=5 GOTO 10 C C IPHASE=5 : determine exponent C 500 IF (CHAR.GE.'0' .AND. CHAR.LE.'9') 510,520,520 C THEN 510 IEX=10*IEX + (CHAR-'0') IRET1=1 GOTO 10 C ENDIF 520 IPHASE=6 I=I-1 IP=I GOTO 10 C C IPHASE=6 : check trailing characters C 600 IF (CHAR.NE.' ') IRET4=4 GOTO 10 C C compute valid number C 700 HDEC=1. DO 710 I=1,NDEC IF (I.GT.NDEC) GOTO 710 HDEC=HDEC*10. 710 CONTINUE HEX=1. DO 720 I=1,IEX IF (I.GT.IEX) GOTO 720 HEX=HEX*10. 720 CONTINUE RVAL=ISGN*(RIN+DEC/HDEC) IF (IESGN.GE.0) RVAL=RVAL*HEX IF (IESGN.LT.0) RVAL=RVAL/HEX C C check occurance of error # 70 , 72 and/or 74 C CALL ERRTST(70,IRES1) CALL ERRTST(72,IRES10) CALL ERRTST(74,IRES11) C C compute return parameters C IF (STRING(IP).NE.0) IP=IP+1 IF (((STRING(IP-1).EQ.'+' .OR. STRING(IP-1).EQ.'-') .AND. 1 (STRING(IP).EQ.'.' .OR. 2 (STRING(IP).GE.'0' .AND. STRING(IP).LE.'9'))) .OR. 3 (STRING(IP-1).EQ.'.' .AND. 4 (STRING(IP).GE.'0' .AND. STRING(IP).LE.'9'))) IP=IP-1 IF (IPHASE.NE.6) IP=LS+1 C IF (IRES1.EQ.2 .OR. IRES10.EQ.2 .AND. IRES11.EQ.2) 730,799,799 C THEN 730 RCVTS=RVAL IRET=IRET1+IRET2+IRET4 C ENDIF C C return to calling routine C 799 IF (LARG(2)) IPOS=IP RETURN END