2 ! { dg-require-visibility "" }
3 ! { dg-additional-options "-fbounds-check" }
6 INTEGER, PARAMETER :: default_string_length
=80, dp
=KIND(0.0D0
)
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
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
17 FUNCTION cp_to_string(i
) RESULT(res
)
18 INTEGER, INTENT(in
) :: i
19 CHARACTER(len
=6) :: res
22 REAL(KIND
=dp
) :: tmp_r
24 IF (i
>999999 .OR
. i
<-99999) THEN
26 WRITE (res
,fmt
='(es6.1)',iostat
=iostat
) tmp_r
28 WRITE (res
,fmt
='(i6)',iostat
=iostat
) i
33 END FUNCTION cp_to_string
35 SUBROUTINE cp_unit_create(string
)
36 CHARACTER(len
=*), INTENT(in
) :: string
38 CHARACTER(len
=*), PARAMETER :: routineN
= 'cp_unit_create', &
39 routineP
= moduleN
//':'//routineN
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
54 len_string
=LEN(string
)
57 DO WHILE(i_low
<len_string
)
58 IF (string(i_low
:i_low
)/=' ') EXIT
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
67 DO WHILE(.NOT
.failure
)
68 IF (i_high
<=i_low
.OR
.i_low
>len_string
) EXIT
70 IF (i_unit
>cp_unit_max_kinds
) THEN
73 power(i_unit
)=next_power
76 DO WHILE(i_low
<=len_string
)
77 IF (string(i_low
:i_low
)/=' ') EXIT
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
86 IF (i_high
<i_low
.OR
.i_low
>len_string
) EXIT
88 IF (i_high
<=len_string
) THEN
89 IF (string(i_low
:i_high
)=='^') THEN
91 DO WHILE(i_low
<=len_string
)
92 IF (string(i_low
:i_low
)/=' ') EXIT
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')
104 IF (i_high
<=i_low
.OR
.i_low
>len_string
) THEN
105 write(6,*) "BUG : XXX"//string
//"XXX integer expected"
112 END SUBROUTINE cp_unit_create
117 CALL cp_unit_create("fs^-1")