kencode/real_def.for at master · ajj/kencode · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
		FUNCTION real_def(r,ch,OK)
		PARAMETER(length=50)

		REAL	x(length)
		CHARACTER*(length) ch, string
		LOGICAL OK, found

		OK=.TRUE.
		found=.FALSE.
		factor=1.

		IF (ch.EQ.' ') THEN
			real_def=r
			GOTO 1000
		END IF

		j=0
		DO i=1,length-1
			iascii=ICHAR(ch(i:i))
			iascii1=ICHAR(ch(i+1:i+1))
			IF (j.EQ.0 .AND. iascii.EQ.45) THEN
				factor=-1.
			ELSE IF (j.NE.0 .AND. iascii.EQ.32 .AND. iascii1.NE.32) THEN
				OK=.FALSE.
c				PRINT*,'Error -have found non-blank after a blank'
 				GOTO 1000
			ELSE IF (iascii.NE.32) THEN
				j=j+1
				string(j:j)=ch(i:i)
			END IF
		END DO
		n=j

		ndigits=0
		DO i=1,n
			iascii=ICHAR(string(i:i))
			IF (iascii.EQ.46) THEN
				IF (found) THEN
					OK=.FALSE.
c					PRINT*,'Error -have found more than two decimal points'
					GOTO 1000
				END IF
				found=.TRUE.
				rmag=REAL(i-1)
			ELSE IF (iascii.LT.48 .OR. iascii.GT.57) THEN
				OK=.FALSE.
c				PRINT*,'Error -have found non-decimal character'
 				GOTO 1000
			ELSE
				ndigits=ndigits+1
				x(ndigits)=iascii-48
			END IF
		END DO
		IF (.NOT.found) rmag=REAL(n)

		rnum=0.
		DO i=1,ndigits
			rnum=rnum+x(i)*10.**(rmag-REAL(i))
		END DO
		real_def=rnum*factor

 1000	IF (.NOT.OK) WRITE(*,1100)
 1100	FORMAT(' Input must be real number')

		RETURN
		END