|
111
|
1 ! { dg-do run }
|
|
|
2 ! { dg-require-visibility "" }
|
|
|
3 ! { dg-additional-options "-fbounds-check" }
|
|
|
4 MODULE cp_units
|
|
|
5
|
|
|
6 INTEGER, PARAMETER :: default_string_length=80, dp=KIND(0.0D0)
|
|
|
7
|
|
|
8 LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE.
|
|
|
9 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'cp_units'
|
|
|
10 INTEGER, SAVE, PRIVATE :: last_unit_id=0, last_unit_set_id=0
|
|
|
11
|
|
|
12 INTEGER, PARAMETER, PUBLIC :: cp_unit_max_kinds=8, cp_unit_basic_desc_length=15,&
|
|
|
13 cp_unit_desc_length=cp_unit_max_kinds*cp_unit_basic_desc_length, cp_ukind_max=9
|
|
|
14
|
|
|
15 CONTAINS
|
|
|
16
|
|
|
17 FUNCTION cp_to_string(i) RESULT(res)
|
|
|
18 INTEGER, INTENT(in) :: i
|
|
|
19 CHARACTER(len=6) :: res
|
|
|
20
|
|
|
21 INTEGER :: iostat
|
|
|
22 REAL(KIND=dp) :: tmp_r
|
|
|
23
|
|
|
24 IF (i>999999 .OR. i<-99999) THEN
|
|
|
25 tmp_r=i
|
|
|
26 WRITE (res,fmt='(es6.1)',iostat=iostat) tmp_r
|
|
|
27 ELSE
|
|
|
28 WRITE (res,fmt='(i6)',iostat=iostat) i
|
|
|
29 END IF
|
|
|
30 IF (iostat/=0) THEN
|
|
|
31 STOP 7
|
|
|
32 END IF
|
|
|
33 END FUNCTION cp_to_string
|
|
|
34
|
|
|
35 SUBROUTINE cp_unit_create(string)
|
|
|
36 CHARACTER(len=*), INTENT(in) :: string
|
|
|
37
|
|
|
38 CHARACTER(len=*), PARAMETER :: routineN = 'cp_unit_create', &
|
|
|
39 routineP = moduleN//':'//routineN
|
|
|
40
|
|
|
41 CHARACTER(default_string_length) :: desc
|
|
|
42 CHARACTER(LEN=40) :: formatstr
|
|
|
43 INTEGER :: i_high, i_low, i_unit, &
|
|
|
44 len_string, next_power
|
|
|
45 INTEGER, DIMENSION(cp_unit_max_kinds) :: kind_id, power, unit_id
|
|
|
46 LOGICAL :: failure
|
|
|
47
|
|
|
48 failure=.FALSE.
|
|
|
49 unit_id=0
|
|
|
50 kind_id=0
|
|
|
51 power=0
|
|
|
52 i_low=1
|
|
|
53 i_high=1
|
|
|
54 len_string=LEN(string)
|
|
|
55 i_unit=0
|
|
|
56 next_power=1
|
|
|
57 DO WHILE(i_low<len_string)
|
|
|
58 IF (string(i_low:i_low)/=' ') EXIT
|
|
|
59 i_low=i_low+1
|
|
|
60 END DO
|
|
|
61 i_high=i_low
|
|
|
62 DO WHILE(i_high<=len_string)
|
|
|
63 IF ( string(i_high:i_high)==' '.OR.string(i_high:i_high)=='^'.OR.&
|
|
|
64 string(i_high:i_high)=='*'.OR.string(i_high:i_high)=='/') EXIT
|
|
|
65 i_high=i_high+1
|
|
|
66 END DO
|
|
|
67 DO WHILE(.NOT.failure)
|
|
|
68 IF (i_high<=i_low.OR.i_low>len_string) EXIT
|
|
|
69 i_unit=i_unit+1
|
|
|
70 IF (i_unit>cp_unit_max_kinds) THEN
|
|
|
71 EXIT
|
|
|
72 END IF
|
|
|
73 power(i_unit)=next_power
|
|
|
74 ! parse op
|
|
|
75 i_low=i_high
|
|
|
76 DO WHILE(i_low<=len_string)
|
|
|
77 IF (string(i_low:i_low)/=' ') EXIT
|
|
|
78 i_low=i_low+1
|
|
|
79 END DO
|
|
|
80 i_high=i_low
|
|
|
81 DO WHILE(i_high<=len_string)
|
|
|
82 IF ( string(i_high:i_high)==' '.OR.string(i_high:i_high)=='^'.OR.&
|
|
|
83 string(i_high:i_high)=='*'.OR.string(i_high:i_high)=='/') EXIT
|
|
|
84 i_high=i_high+1
|
|
|
85 END DO
|
|
|
86 IF (i_high<i_low.OR.i_low>len_string) EXIT
|
|
|
87
|
|
|
88 IF (i_high<=len_string) THEN
|
|
|
89 IF (string(i_low:i_high)=='^') THEN
|
|
|
90 i_low=i_high+1
|
|
|
91 DO WHILE(i_low<=len_string)
|
|
|
92 IF (string(i_low:i_low)/=' ') EXIT
|
|
|
93 i_low=i_low+1
|
|
|
94 END DO
|
|
|
95 i_high=i_low
|
|
|
96 DO WHILE(i_high<=len_string)
|
|
|
97 SELECT CASE(string(i_high:i_high))
|
|
|
98 CASE('+','-','0','1','2','3','4','5','6','7','8','9')
|
|
|
99 i_high=i_high+1
|
|
|
100 CASE default
|
|
|
101 EXIT
|
|
|
102 END SELECT
|
|
|
103 END DO
|
|
|
104 IF (i_high<=i_low.OR.i_low>len_string) THEN
|
|
|
105 write(6,*) "BUG : XXX"//string//"XXX integer expected"
|
|
|
106 STOP 1
|
|
|
107 EXIT
|
|
|
108 END IF
|
|
|
109 END IF
|
|
|
110 ENDIF
|
|
|
111 END DO
|
|
|
112 END SUBROUTINE cp_unit_create
|
|
|
113
|
|
|
114 END MODULE cp_units
|
|
|
115
|
|
|
116 USE cp_units
|
|
|
117 CALL cp_unit_create("fs^-1")
|
|
|
118 END
|
