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