34 public::
operator(==),
operator(>),
operator(<),
operator(>=),
operator(<=)
35 public::
operator(+),
operator(-),
operator(*),
operator(/),
mod,
modulo
42 integer,
parameter:: imin = -2
43 integer,
parameter:: imax = 8
44 real(DP),
parameter:: scale_factor = 1.0e+3_dp
45 real(DP),
parameter:: scale_factor_xx (-(imax+1):imax+1) = &
47 & 1.0e-24_DP, 1.0e-21_DP, 1.0e-18_DP, 1.0e-15_DP, &
48 & 1.0e-12_DP, 1.0e-9_DP, 1.0e-6_DP, 1.0e-3_DP, &
50 & 1.0e+3_DP, 1.0e+6_DP, 1.0e+9_DP, 1.0e+12_DP, &
51 & 1.0e+15_DP, 1.0e+18_DP, 1.0e+21_DP, 1.0e+24_DP, &
54 integer,
parameter:: scale_factor_int = 1000
55 integer,
parameter:: scale_factor_int_xx (0:3) = &
56 & (/ 1, 1000, 1000000, 1000000000 /)
67 integer:: sec_ary(imin:imax) = 0
68 logical:: flag_negative = .false.
69 logical:: dummy = .false.
72 interface assignment(=)
73 module procedure dcscaledseccreater
74 module procedure dcscaledseccreated
75 module procedure dcscaledseccreatei
77 module procedure dcscaledsectonumr
78 module procedure dcscaledsectonumd
79 module procedure dcscaledsectonumi
86 interface operator(==)
87 module procedure dcscaledsec_eq_ss
88 module procedure dcscaledsec_eq_si
89 module procedure dcscaledsec_eq_is
90 module procedure dcscaledsec_eq_sr
91 module procedure dcscaledsec_eq_rs
92 module procedure dcscaledsec_eq_sd
93 module procedure dcscaledsec_eq_ds
97 module procedure dcscaledsec_gt_ss
98 module procedure dcscaledsec_gt_si
99 module procedure dcscaledsec_gt_is
102 interface operator(<)
103 module procedure dcscaledsec_lt_ss
104 module procedure dcscaledsec_lt_si
105 module procedure dcscaledsec_lt_is
108 interface operator(>=)
109 module procedure dcscaledsec_ge_ss
110 module procedure dcscaledsec_ge_si
111 module procedure dcscaledsec_ge_is
114 interface operator(<=)
115 module procedure dcscaledsec_le_ss
116 module procedure dcscaledsec_le_si
117 module procedure dcscaledsec_le_is
120 interface operator(+)
121 module procedure dcscaledsec_add_ss
122 module procedure dcscaledsec_add_si
123 module procedure dcscaledsec_add_is
124 module procedure dcscaledsec_add_sr
125 module procedure dcscaledsec_add_rs
126 module procedure dcscaledsec_add_sd
127 module procedure dcscaledsec_add_ds
130 interface operator(-)
131 module procedure dcscaledsec_sub_s
132 module procedure dcscaledsec_sub_ss
133 module procedure dcscaledsec_sub_si
134 module procedure dcscaledsec_sub_is
135 module procedure dcscaledsec_sub_sr
136 module procedure dcscaledsec_sub_rs
137 module procedure dcscaledsec_sub_sd
138 module procedure dcscaledsec_sub_ds
141 interface operator(*)
142 module procedure dcscaledsec_mul_ss
143 module procedure dcscaledsec_mul_si
144 module procedure dcscaledsec_mul_is
145 module procedure dcscaledsec_mul_sd
146 module procedure dcscaledsec_mul_ds
147 module procedure dcscaledsec_mul_sr
148 module procedure dcscaledsec_mul_rs
151 interface operator(/)
152 module procedure dcscaledsec_div_si
153 module procedure dcscaledsec_div_sr
154 module procedure dcscaledsec_div_sd
155 module procedure dcscaledsec_div_ss
159 module procedure dcscaledsec_mod_si
160 module procedure dcscaledsec_mod_sr
161 module procedure dcscaledsec_mod_sd
162 module procedure dcscaledsec_mod_ss
166 module procedure dcscaledsec_modulo_si
167 module procedure dcscaledsec_modulo_sr
168 module procedure dcscaledsec_modulo_sd
169 module procedure dcscaledsec_modulo_ss
173 module procedure dcscaledsec_abs_s
177 module procedure dcscaledsec_int_s
181 module procedure dcscaledsec_sign_si
182 module procedure dcscaledsec_sign_sr
183 module procedure dcscaledsec_sign_sd
184 module procedure dcscaledsec_sign_ss
188 module procedure dcscaledsec_floor_s
192 module procedure dcscaledsec_ceiling_s
199 subroutine dcscaledseccreatei(sclsec, sec)
202 integer,
intent(in):: sec
204 call dcscaledseccreated(sclsec, real( sec, dp ))
205 end subroutine dcscaledseccreatei
209 subroutine dcscaledseccreater(sclsec, sec)
212 real,
intent(in):: sec
214 call dcscaledseccreated(sclsec, real( sec, dp ))
215 end subroutine dcscaledseccreater
219 subroutine dcscaledseccreated(sclsec, sec)
220 use dc_message,
only: messagenotify
222 use dc_trace,
only: beginsub, endsub
226 real(DP),
intent(in):: sec
228 real(DP):: work_sec, print_sec
229 integer:: i, cd, move_up, work_sec_scl_nint
232 character(STRING) :: cause_c
233 character(*),
parameter:: subname =
'dc_scaledsec'
240 if ( sec < 0.0_dp )
then
241 sclsec % flag_negative = .true.
244 sclsec % flag_negative = .false.
248 if ( work_sec > scale_factor_xx(imax + 1) )
then
249 call messagenotify(
'W', subname, &
250 &
'input number (%f) is too large.', &
257 do i = imax, imin, -1
259 work_sec_scl_nint = nint( work_sec * scale_factor_xx(-i) )
260 if ( .not. work_sec < scale_factor_xx(i) &
261 & .or. ( i == imin .and. work_sec_scl_nint >= 1 ) )
then
264 sclsec % sec_ary(i) = work_sec_scl_nint
266 sclsec % sec_ary(i) =
int( work_sec / scale_factor_xx(i) )
268 work_sec = work_sec - sclsec % sec_ary(i) * scale_factor_xx(i)
269 cd = cd + count_digit( sclsec % sec_ary(i) )
272 if ( .not.
abs( work_sec ) < scale_factor_xx(i-1) )
then
284 sclsec % sec_ary(i) = sclsec % sec_ary(i) + move_up
286 do while ( sclsec % sec_ary(i) >= scale_factor_int )
287 move_up = move_up + 1
288 sclsec % sec_ary(i) = sclsec % sec_ary(i) - scale_factor_int
293 call storeerror(stat, subname, cause_c=cause_c)
295 end subroutine dcscaledseccreated
299 subroutine dcscaledsectonumi(sec, sclsec)
302 integer,
intent(out):: sec
306 call dcscaledsectonumd(secd, sclsec)
308 end subroutine dcscaledsectonumi
312 subroutine dcscaledsectonumr(sec, sclsec)
315 real,
intent(out):: sec
319 call dcscaledsectonumd(secd, sclsec)
321 end subroutine dcscaledsectonumr
325 subroutine dcscaledsectonumd(sec, sclsec)
328 real(DP),
intent(out):: sec
334 do i = imax, imin, -1
335 sec = sec + ( sclsec % sec_ary(i) * scale_factor_xx(i) )
337 if ( sclsec % flag_negative ) sec = - sec
338 end subroutine dcscaledsectonumd
352 use dc_string,
only: printf, tochar
353 use dc_trace,
only: beginsub, endsub
357 integer,
intent(in),
optional :: unit
363 character(*),
intent(in),
optional:: indent
368 integer :: out_unit, sec_ary_rev(imin:imax)
370 character(STRING):: indent_str
372 character(*),
parameter:: subname =
'DCScaledSecPutLine'
376 if (
present(unit))
then
384 if (
present(indent) )
then
385 if ( len(indent) /= 0 )
then
386 indent_len = len(indent)
387 indent_str(1:indent_len) = indent
391 sec_ary_rev(imin:imax) = sclsec % sec_ary(imax:imin:-1)
392 if ( sclsec % flag_negative )
then
397 if ( imax - imin + 1 == 6 )
then
398 call printf(out_unit, &
399 & indent_str(1:indent_len) // &
400 &
'#<DC_SCALED_SEC:: @sign=%c @yotta=%d @exa=%d @tera=%d @mega=%d @base=%d @micro=%d>', &
401 & i = sec_ary_rev, c1 =
sign )
402 elseif ( imax - imin + 1 == 11 )
then
403 call printf(out_unit, &
404 & indent_str(1:indent_len) // &
405 &
'#<DC_SCALED_SEC:: @sign=%c @yotta=%d @zetta=%d @exa=%d @peta=%d @tera=%d', &
406 & i = sec_ary_rev(imin:imin+4), c1 =
sign )
407 call printf(out_unit, &
408 & indent_str(1:indent_len) // &
409 &
' @giga=%d @mega=%d @kilo=%d @base=%d @milli=%d @micro=%d>', &
410 & i = sec_ary_rev(imax-5:imax) )
412 call printf(out_unit, &
413 & indent_str(1:indent_len) // &
414 &
'#<DC_SCALED_SEC:: @sign=%c @sec_ary=%*d>', &
415 & i = sec_ary_rev, n = (/ imax - imin + 1 /), c1 =
sign )
423 logical function dcscaledsec_eq_ss(sclsec1, sclsec2)
result(result)
434 if ( sclsec1 % flag_negative .and. .not. sclsec2 % flag_negative )
then
438 elseif ( .not. sclsec1 % flag_negative .and. sclsec2 % flag_negative )
then
443 do i = imax, imin, -1
444 if ( .not. sclsec1 % sec_ary(i) == sclsec2 % sec_ary(i) )
then
451 end function dcscaledsec_eq_ss
455 logical function dcscaledsec_eq_si(sclsec, sec)
result(result)
458 integer,
intent(in):: sec
462 if ( sclsec % flag_negative .and. .not. sec < 0 )
then
465 elseif ( .not. sclsec % flag_negative .and. sec < 0 )
then
470 if (
abs(sec) > scale_factor_int_xx(3) )
then
472 result = sclsec == sclsec2
474 if ( .not. all( sclsec % sec_ary(imin:-1) == (/0, 0/) ) &
475 & .or. .not. all( sclsec % sec_ary(3:imax) == (/0, 0, 0, 0, 0, 0/) ) )
then
479 sec1 = sclsec % sec_ary(0)
481 sec1 = sec1 + sclsec % sec_ary(i) * scale_factor_int_xx(i)
485 end function dcscaledsec_eq_si
489 logical function dcscaledsec_eq_is(sec, sclsec)
result(result)
491 integer,
intent(in):: sec
494 result = sclsec == sec
495 end function dcscaledsec_eq_is
499 logical function dcscaledsec_eq_sr(sclsec, sec)
result(result)
502 real,
intent(in):: sec
506 result = sclsec == sclsec2
507 end function dcscaledsec_eq_sr
511 logical function dcscaledsec_eq_rs(sec, sclsec)
result(result)
513 real,
intent(in):: sec
518 result = sclsec == sclsec2
519 end function dcscaledsec_eq_rs
523 logical function dcscaledsec_eq_sd(sclsec, sec)
result(result)
526 real(dp),
intent(in):: sec
530 result = sclsec == sclsec2
531 end function dcscaledsec_eq_sd
535 logical function dcscaledsec_eq_ds(sec, sclsec)
result(result)
537 real(dp),
intent(in):: sec
542 result = sclsec == sclsec2
543 end function dcscaledsec_eq_ds
547 logical function dcscaledsec_gt_ss(sclsec1, sclsec2)
result(result)
557 logical:: both_negative, flag_equal
562 if ( sclsec1 % flag_negative .and. .not. sclsec2 % flag_negative )
then
565 elseif ( .not. sclsec1 % flag_negative .and. sclsec2 % flag_negative )
then
568 elseif ( sclsec1 % flag_negative .and. sclsec2 % flag_negative )
then
569 both_negative = .true.
571 both_negative = .false.
574 do i = imax, imin, -1
575 if ( sclsec1 % sec_ary(i) > sclsec2 % sec_ary(i) )
then
579 elseif ( sclsec1 % sec_ary(i) < sclsec2 % sec_ary(i) )
then
586 if ( .not. flag_equal .and. both_negative ) result = .not. result
588 end function dcscaledsec_gt_ss
592 logical function dcscaledsec_gt_si(sclsec, factor)
result(result)
600 integer,
intent(in):: factor
602 integer:: i, sec1, factor_abs
603 logical:: both_negative
605 if ( sclsec % flag_negative .and. .not. factor < 0 )
then
608 elseif ( .not. sclsec % flag_negative .and. factor < 0 )
then
611 elseif ( sclsec % flag_negative .and. factor < 0 )
then
612 both_negative = .true.
614 both_negative = .false.
617 factor_abs =
abs(factor)
619 if ( factor_abs > scale_factor_int_xx(3) )
then
621 result = sclsec > factor_scl
624 if ( .not. all( sclsec % sec_ary(3:imax) == (/0, 0, 0, 0, 0, 0/) ) )
then
627 sec1 = sclsec % sec_ary(0)
629 sec1 = sec1 + sclsec % sec_ary(i) * scale_factor_int_xx(i)
631 if ( sec1 == factor_abs )
then
632 result = .not. all( sclsec % sec_ary(imin:-1) == (/0, 0/) )
634 result = sec1 > factor_abs
638 if ( both_negative ) result = .not. result
641 end function dcscaledsec_gt_si
645 logical function dcscaledsec_gt_is(factor, sclsec)
result(result)
652 integer,
intent(in):: factor
655 integer:: i, sec1, factor_abs
656 logical:: both_negative
658 if ( sclsec % flag_negative .and. .not. factor < 0 )
then
661 elseif ( .not. sclsec % flag_negative .and. factor < 0 )
then
664 elseif ( sclsec % flag_negative .and. factor < 0 )
then
665 both_negative = .true.
667 both_negative = .false.
670 factor_abs =
abs(factor)
672 if ( factor_abs > scale_factor_int_xx(3) )
then
674 result = factor_scl > sclsec
677 if ( .not. all( sclsec % sec_ary(3:imax) == (/0, 0, 0, 0, 0, 0/) ) )
then
680 sec1 = sclsec % sec_ary(0)
682 sec1 = sec1 + sclsec % sec_ary(i) * scale_factor_int_xx(i)
684 if ( sec1 == factor_abs )
then
687 result = factor_abs > sec1
691 if ( both_negative ) result = .not. result
693 end function dcscaledsec_gt_is
697 logical function dcscaledsec_lt_ss(sclsec1, sclsec2)
result(result)
706 logical:: both_negative, flag_equal
711 if ( sclsec1 % flag_negative .and. .not. sclsec2 % flag_negative )
then
714 elseif ( .not. sclsec1 % flag_negative .and. sclsec2 % flag_negative )
then
717 elseif ( sclsec1 % flag_negative .and. sclsec2 % flag_negative )
then
718 both_negative = .true.
720 both_negative = .false.
723 do i = imax, imin, -1
724 if ( sclsec1 % sec_ary(i) > sclsec2 % sec_ary(i) )
then
728 elseif ( sclsec1 % sec_ary(i) < sclsec2 % sec_ary(i) )
then
735 if ( .not. flag_equal .and. both_negative ) result = .not. result
737 end function dcscaledsec_lt_ss
741 logical function dcscaledsec_lt_si(sclsec, factor)
result(result)
749 integer,
intent(in):: factor
751 integer:: i, sec1, factor_abs
752 logical:: both_negative
754 if ( sclsec % flag_negative .and. .not. factor < 0 )
then
757 elseif ( .not. sclsec % flag_negative .and. factor < 0 )
then
760 elseif ( sclsec % flag_negative .and. factor < 0 )
then
761 both_negative = .true.
763 both_negative = .false.
766 factor_abs =
abs(factor)
768 if ( factor_abs > scale_factor_int_xx(3) )
then
770 result = sclsec < factor_scl
773 if ( .not. all( sclsec % sec_ary(3:imax) == (/0, 0, 0, 0, 0, 0/) ) )
then
776 sec1 = sclsec % sec_ary(0)
778 sec1 = sec1 + sclsec % sec_ary(i) * scale_factor_int_xx(i)
780 if ( sec1 == factor_abs )
then
783 result = sec1 < factor_abs
787 if ( both_negative ) result = .not. result
789 end function dcscaledsec_lt_si
793 logical function dcscaledsec_lt_is(factor, sclsec)
result(result)
800 integer,
intent(in):: factor
803 integer:: i, sec1, factor_abs
804 logical:: both_negative
806 if ( sclsec % flag_negative .and. .not. factor < 0 )
then
809 elseif ( .not. sclsec % flag_negative .and. factor < 0 )
then
812 elseif ( sclsec % flag_negative .and. factor < 0 )
then
813 both_negative = .true.
815 both_negative = .false.
818 factor_abs =
abs(factor)
820 if ( factor_abs > scale_factor_int_xx(3) )
then
822 result = factor_scl < sclsec
825 if ( .not. all( sclsec % sec_ary(3:imax) == (/0, 0, 0, 0, 0, 0/) ) )
then
828 sec1 = sclsec % sec_ary(0)
830 sec1 = sec1 + sclsec % sec_ary(i) * scale_factor_int_xx(i)
832 if ( sec1 == factor_abs )
then
833 result = .not. all( sclsec % sec_ary(imin:-1) == (/0, 0/) )
835 result = factor_abs < sec1
839 if ( both_negative ) result = .not. result
842 end function dcscaledsec_lt_is
846 logical function dcscaledsec_ge_ss(sclsec1, sclsec2)
result(result)
855 result = .not. sclsec1 < sclsec2
856 end function dcscaledsec_ge_ss
860 logical function dcscaledsec_ge_si(sclsec, factor)
result(result)
868 integer,
intent(in):: factor
870 result = .not. sclsec < factor
871 end function dcscaledsec_ge_si
875 logical function dcscaledsec_ge_is(factor, sclsec)
result(result)
882 integer,
intent(in):: factor
885 result = .not. factor < sclsec
886 end function dcscaledsec_ge_is
890 logical function dcscaledsec_le_ss(sclsec1, sclsec2)
result(result)
899 result = .not. sclsec1 > sclsec2
900 end function dcscaledsec_le_ss
904 logical function dcscaledsec_le_si(sclsec, factor)
result(result)
912 integer,
intent(in):: factor
914 result = .not. sclsec > factor
915 end function dcscaledsec_le_si
919 logical function dcscaledsec_le_is(factor, sclsec)
result(result)
926 integer,
intent(in):: factor
929 result = .not. factor > sclsec
930 end function dcscaledsec_le_is
934 type(
dc_scaled_sec) function dcscaledsec_add_ss(sclsec1, sclsec2) result(result)
940 use dc_message,
only: messagenotify
945 logical:: both_negative, sclsec2_flag_negative
949 both_negative = .false.
954 sclsec2_flag_negative = sclsec2 % flag_negative
955 if ( sclsec1 % flag_negative )
then
956 both_negative = .true.
957 sclsec2_flag_negative = .not. sclsec2_flag_negative
959 if ( sclsec2_flag_negative )
then
960 sclsec1_opsign = sclsec1
961 sclsec1_opsign % flag_negative = .false.
962 sclsec2_opsign = sclsec2
963 sclsec2_opsign % flag_negative = .false.
964 result = sclsec1_opsign - sclsec2_opsign
965 if ( both_negative )
then
966 result % flag_negative = .not. result % flag_negative
975 result % sec_ary(i) = sclsec1 % sec_ary(i) + sclsec2 % sec_ary(i) + move_up
976 if ( .not. result % sec_ary(i) < scale_factor_int )
then
977 if ( i == imax )
then
978 call messagenotify(
'E',
'dc_scaledsec#operator(*)', &
979 &
'DC_SCALED_SEC must be smaller than 10^24' )
981 move_up = result % sec_ary(i) / scale_factor_int
982 result % sec_ary(i) =
mod( result % sec_ary(i), scale_factor_int )
988 if ( both_negative )
then
989 result % flag_negative = .true.
991 result % flag_negative = .false.
994 end function dcscaledsec_add_ss
998 type(
dc_scaled_sec) function dcscaledsec_add_si(sclsec, factor) result(result)
1006 integer,
intent(in):: factor
1010 result = sclsec + factor_scl
1011 end function dcscaledsec_add_si
1022 integer,
intent(in):: factor
1027 result = factor_scl + sclsec
1028 end function dcscaledsec_add_is
1040 real,
intent(in):: factor
1044 result = sclsec + factor_scl
1045 end function dcscaledsec_add_sr
1056 real,
intent(in):: factor
1061 result = sclsec + factor_scl
1062 end function dcscaledsec_add_rs
1074 real(dp),
intent(in):: factor
1078 result = sclsec + factor_scl
1079 end function dcscaledsec_add_sd
1090 real(dp),
intent(in):: factor
1095 result = sclsec + factor_scl
1096 end function dcscaledsec_add_ds
1109 result % flag_negative = .not. sclsec % flag_negative
1110 result % sec_ary = sclsec % sec_ary
1111 end function dcscaledsec_sub_s
1115 type(
dc_scaled_sec) function dcscaledsec_sub_ss(sclsec1, sclsec2) result(result)
1124 integer:: i, move_down
1125 logical:: both_negative, sclsec2_flag_negative
1130 both_negative = .false.
1135 sclsec2_flag_negative = sclsec2 % flag_negative
1136 if ( sclsec1 % flag_negative )
then
1137 both_negative = .true.
1138 sclsec2_flag_negative = .not. sclsec2_flag_negative
1140 if ( sclsec2_flag_negative )
then
1141 sclsec1_opsign = sclsec1
1142 sclsec1_opsign % flag_negative = .false.
1143 sclsec2_opsign = sclsec2
1144 sclsec2_opsign % flag_negative = .false.
1146 result = sclsec1_opsign + sclsec2_opsign
1147 if ( both_negative )
then
1148 result % flag_negative = .not. result % flag_negative
1156 sclsec1_nosign = sclsec1
1157 sclsec1_nosign % flag_negative = .false.
1158 sclsec2_nosign = sclsec2
1159 sclsec2_nosign % flag_negative = .false.
1161 if ( sclsec1_nosign > sclsec2_nosign )
then
1162 result % flag_negative = .false.
1163 large = sclsec1_nosign
1164 small = sclsec2_nosign
1165 elseif ( sclsec1_nosign < sclsec2_nosign )
then
1166 result % flag_negative = .true.
1167 large = sclsec2_nosign
1168 small = sclsec1_nosign
1176 result % sec_ary(i) = large % sec_ary(i) - small % sec_ary(i) + move_down
1177 if ( result % sec_ary(i) < 0 )
then
1178 move_down = ( result % sec_ary(i) / scale_factor_int ) - 1
1179 result % sec_ary(i) = &
1180 &
mod( result % sec_ary(i), scale_factor_int ) + scale_factor_int
1186 if ( both_negative )
then
1187 result % flag_negative = .not. result % flag_negative
1190 end function dcscaledsec_sub_ss
1202 integer,
intent(in):: factor
1206 result = sclsec - factor_scl
1207 end function dcscaledsec_sub_si
1218 integer,
intent(in):: factor
1223 result = factor_scl - sclsec
1224 end function dcscaledsec_sub_is
1236 real,
intent(in):: factor
1240 result = sclsec - factor_scl
1241 end function dcscaledsec_sub_sr
1252 real,
intent(in):: factor
1257 result = factor_scl - sclsec
1258 end function dcscaledsec_sub_rs
1270 real(dp),
intent(in):: factor
1274 result = sclsec - factor_scl
1275 end function dcscaledsec_sub_sd
1286 real(dp),
intent(in):: factor
1291 result = factor_scl - sclsec
1292 end function dcscaledsec_sub_ds
1296 type(
dc_scaled_sec) function dcscaledsec_mul_ss(sclsec1, sclsec2) result(result)
1302 use dc_message,
only: messagenotify
1305 integer:: sec_ary_int(imin:imax,imin:imax)
1307 integer:: i, j, move_up
1310 if ( sclsec1 == zero_sec .or. sclsec2 == zero_sec )
then
1315 if ( sclsec1 % flag_negative )
then
1316 result % flag_negative = .not. sclsec2 % flag_negative
1318 result % flag_negative = sclsec2 % flag_negative
1322 sec_ary_int(:,:) = 0
1325 sec_ary_int(i,j) = &
1326 & sclsec1 % sec_ary(j) * sclsec2 % sec_ary(i) + move_up
1327 if ( i + j > imax .and. sec_ary_int(i,j) /= 0 )
then
1328 call messagenotify(
'E',
'dc_scaledsec#operator(*)', &
1329 &
'DC_SCALED_SEC must be smaller than 10^24' )
1331 if ( .not. sec_ary_int(i,j) < scale_factor )
then
1332 move_up =
int( sec_ary_int(i,j) / scale_factor_int )
1333 sec_ary_int(i,j) = sec_ary_int(i,j) - move_up * scale_factor_int
1340 result % sec_ary = 0
1343 if ( i + j < imin ) cycle
1344 if ( i + j > imax ) cycle
1345 result % sec_ary(i+j) = result % sec_ary(i+j) + sec_ary_int(i,j)
1351 result % sec_ary(i) = result % sec_ary(i) + move_up
1353 do while ( .not. result % sec_ary(i) < scale_factor_int )
1354 if ( i == imax )
then
1355 call messagenotify(
'E',
'dc_scaledsec#operator(*)', &
1356 &
'DC_SCALED_SEC must be smaller than 10^24' )
1358 result % sec_ary(i) = result % sec_ary(i) - scale_factor_int
1359 move_up = move_up + 1
1363 end function dcscaledsec_mul_ss
1376 use dc_message,
only: messagenotify
1379 integer,
intent(in):: factor
1380 integer:: factor_abs
1382 real(dp):: sec_ary_dp(imin:imax)
1383 integer:: i, move_up
1385 if ( sclsec == zero_sec .or. factor == 0 )
then
1390 if ( sclsec % flag_negative )
then
1391 result % flag_negative = .not. factor < 0
1393 result % flag_negative = factor < 0
1395 factor_abs =
abs(factor)
1398 sec_ary_dp(:) = 0.0_dp
1400 sec_ary_dp(i) = sclsec % sec_ary(i) * factor_abs + move_up
1402 if ( .not. sec_ary_dp(i) < scale_factor )
then
1403 move_up =
int( sec_ary_dp(i) / scale_factor )
1404 sec_ary_dp(i) = sec_ary_dp(i) - move_up * scale_factor
1410 if ( move_up /= 0 )
then
1411 call messagenotify(
'E',
'dc_scaledsec#operator(*)', &
1412 &
'DC_SCALED_SEC must be smaller than 10^24' )
1415 result % sec_ary(imin:imax) = sec_ary_dp(imin:imax)
1417 end function dcscaledsec_mul_si
1428 integer,
intent(in):: factor
1431 result = sclsec * factor
1432 end function dcscaledsec_mul_is
1442 use dc_message,
only: messagenotify
1445 real(dp),
intent(in):: factor
1449 result = sclsec * factor_scl
1450 end function dcscaledsec_mul_sd
1460 use dc_message,
only: messagenotify
1462 real(dp),
intent(in):: factor
1465 result = sclsec * factor
1466 end function dcscaledsec_mul_ds
1476 use dc_message,
only: messagenotify
1479 real,
intent(in):: factor
1483 result = sclsec * factor_scl
1484 end function dcscaledsec_mul_sr
1494 use dc_message,
only: messagenotify
1496 real,
intent(in):: factor
1499 result = sclsec * factor
1500 end function dcscaledsec_mul_rs
1510 use dc_message,
only: messagenotify
1513 real(dp):: factor_abs
1521 if ( .not. all( factor % sec_ary (imax-4:imax) == (/ 0, 0, 0, 0, 0 /) ) )
then
1522 call messagenotify(
'E',
'dc_scaledsec#mod', &
1523 &
'factor must be smaller than 10^12' )
1527 result = sclsec / factor_abs
1529 end function dcscaledsec_div_ss
1539 use dc_message,
only: messagenotify
1542 integer,
intent(in):: factor
1544 result = sclsec / real( factor, dp )
1545 end function dcscaledsec_div_si
1555 use dc_message,
only: messagenotify
1558 real(dp),
intent(in):: factor
1560 real(dp):: factor_abs, move_down, sec_ary_mod(imin+imin:imax)
1563 if ( sclsec % flag_negative )
then
1564 result % flag_negative = .not. factor < 0.0_dp
1566 result % flag_negative = factor < 0.0_dp
1568 factor_abs =
abs(factor) * scale_factor_xx(2)
1572 do i = imax, imin + imin, -1
1573 if ( i > imax + imin )
then
1574 sec_ary_mod(i) = sclsec % sec_ary(i)
1575 elseif ( i > imin - 1 )
then
1576 result % sec_ary(i-imin) =
int( ( sclsec % sec_ary(i) + move_down ) / factor_abs )
1578 &
mod( ( sclsec % sec_ary(i) + move_down ), factor_abs )
1580 result % sec_ary(i-imin) =
int( move_down / factor_abs )
1581 sec_ary_mod(i) =
mod( move_down, factor_abs )
1584 if ( sec_ary_mod(i) /= 0.0_dp )
then
1586 move_down = sec_ary_mod(i) * scale_factor
1597 end function dcscaledsec_div_sd
1607 use dc_message,
only: messagenotify
1610 real,
intent(in):: factor
1612 result = sclsec / real( factor, dp )
1613 end function dcscaledsec_div_sr
1623 use dc_message,
only: messagenotify
1628 real(dp):: sec_ary_mod(imin+imin:imax)
1629 integer:: i, move_down_index
1630 real(dp):: move_down
1631 real(dp):: factor_dp
1640 if ( .not. all( factor % sec_ary (imax-4:imax) == (/ 0, 0, 0, 0, 0 /) ) )
then
1641 call messagenotify(
'E',
'dc_scaledsec#mod', &
1642 &
'factor must be smaller than 10^12' )
1645 if ( sclsec == factor )
then
1650 factor_scl % sec_ary(imin:-1) = 0
1651 factor_scl % sec_ary(imin-imin:imax) = factor % sec_ary(imin:imax+imin)
1652 factor_scl % flag_negative = factor % flag_negative
1654 factor_dp = factor_scl
1657 do i = imax, imin + imin, -1
1659 if ( move_down /= 0.0_dp )
then
1660 if (
abs(factor_dp) > ( move_down + scale_factor ) * scale_factor_xx( i - imin ) )
exit
1663 if ( i > imin - 1 )
then
1665 &
mod( ( sclsec % sec_ary(i) + move_down ), factor_dp )
1667 sec_ary_mod(i) =
mod( move_down, factor_dp )
1670 if ( sec_ary_mod(i) /= 0.0_dp )
then
1671 move_down = sec_ary_mod(i) * scale_factor
1678 result = move_down * scale_factor_xx(move_down_index)
1679 if ( move_down_index > imin - 1 )
then
1680 result % sec_ary(imin:move_down_index) = sclsec % sec_ary(imin:move_down_index)
1683 result % flag_negative = sclsec % flag_negative
1685 end function dcscaledsec_mod_ss
1695 use dc_message,
only: messagenotify
1698 integer,
intent(in):: factor
1703 result =
mod( sclsec, factor_scl )
1704 end function dcscaledsec_mod_si
1714 use dc_message,
only: messagenotify
1717 real,
intent(in):: factor
1722 result =
mod( sclsec, factor_scl )
1723 end function dcscaledsec_mod_sr
1733 use dc_message,
only: messagenotify
1736 real(dp),
intent(in):: factor
1741 result =
mod( sclsec, factor_scl )
1742 end function dcscaledsec_mod_sd
1746 type(
dc_scaled_sec) function dcscaledsec_modulo_ss(sclsec, factor) result(result)
1752 use dc_message,
only: messagenotify
1757 real(dp):: sec_ary_mod(imin+imin:imax)
1758 integer:: i, move_down_index
1759 real(dp):: move_down
1760 real(dp):: factor_dp
1769 if ( .not. all( factor % sec_ary (imax-4:imax) == (/ 0, 0, 0, 0, 0 /) ) )
then
1770 call messagenotify(
'E',
'dc_scaledsec#modulo', &
1771 &
'factor must be smaller than 10^12' )
1774 if ( sclsec == factor )
then
1779 factor_scl % sec_ary(imin:-1) = 0
1780 factor_scl % sec_ary(imin-imin:imax) = factor % sec_ary(imin:imax+imin)
1781 factor_scl % flag_negative = factor % flag_negative
1783 factor_dp = factor_scl
1786 do i = imax, imin + imin, -1
1788 if ( move_down /= 0.0_dp )
then
1789 if (
abs(factor_dp) > ( move_down + scale_factor ) * scale_factor_xx( i - imin ) )
exit
1792 if ( i > imin - 1 )
then
1794 &
mod( ( sclsec % sec_ary(i) + move_down ), factor_dp )
1796 sec_ary_mod(i) =
mod( move_down, factor_dp )
1799 if ( sec_ary_mod(i) /= 0.0_dp )
then
1800 move_down = sec_ary_mod(i) * scale_factor
1807 result = move_down * scale_factor_xx(move_down_index)
1808 if ( move_down_index > imin - 1 )
then
1809 result % sec_ary(imin:move_down_index) = sclsec % sec_ary(imin:move_down_index)
1812 result % flag_negative = .false.
1814 if ( .not. result == zero_sec )
then
1815 if ( .not. sclsec % flag_negative .and. factor % flag_negative )
then
1816 result = - factor - result
1817 result % flag_negative = .not. sclsec % flag_negative
1819 elseif ( sclsec % flag_negative .and. .not. factor % flag_negative )
then
1820 result = factor - result
1821 result % flag_negative = .not. sclsec % flag_negative
1824 result % flag_negative = sclsec % flag_negative
1829 end function dcscaledsec_modulo_ss
1833 type(
dc_scaled_sec) function dcscaledsec_modulo_si(sclsec, factor) result(result)
1839 use dc_message,
only: messagenotify
1842 integer,
intent(in):: factor
1847 result =
modulo( sclsec, factor_scl )
1848 end function dcscaledsec_modulo_si
1852 type(
dc_scaled_sec) function dcscaledsec_modulo_sr(sclsec, factor) result(result)
1858 use dc_message,
only: messagenotify
1861 real,
intent(in):: factor
1866 result =
modulo( sclsec, factor_scl )
1867 end function dcscaledsec_modulo_sr
1871 type(
dc_scaled_sec) function dcscaledsec_modulo_sd(sclsec, factor) result(result)
1877 use dc_message,
only: messagenotify
1880 real(dp),
intent(in):: factor
1885 result =
modulo( sclsec, factor_scl )
1886 end function dcscaledsec_modulo_sd
1901 if ( result % flag_negative ) result % flag_negative = .false.
1902 end function dcscaledsec_abs_s
1918 result % sec_ary(i) = 0
1920 end function dcscaledsec_int_s
1924 type(
dc_scaled_sec) function dcscaledsec_sign_ss(sclsec1, sclsec2) result(result)
1934 result % flag_negative = sclsec2 % flag_negative
1935 end function dcscaledsec_sign_ss
1947 integer,
intent(in):: factor
1950 sclsec_work = factor
1951 result =
sign( sclsec, sclsec_work )
1952 end function dcscaledsec_sign_si
1964 real,
intent(in):: factor
1967 sclsec_work = factor
1968 result =
sign( sclsec, sclsec_work )
1969 end function dcscaledsec_sign_sr
1981 real(dp),
intent(in):: factor
1984 sclsec_work = factor
1985 result =
sign( sclsec, sclsec_work )
1986 end function dcscaledsec_sign_sd
2000 logical:: flag_after_decimal
2003 flag_after_decimal = .false.
2005 if ( result % sec_ary(i) /= 0 ) flag_after_decimal = .true.
2006 result % sec_ary(i) = 0
2008 if ( flag_after_decimal .and. result % flag_negative )
then
2012 end function dcscaledsec_floor_s
2026 logical:: flag_after_decimal
2029 flag_after_decimal = .false.
2031 if ( result % sec_ary(i) /= 0 ) flag_after_decimal = .true.
2032 result % sec_ary(i) = 0
2034 if ( flag_after_decimal .and. .not. result % flag_negative )
then
2038 end function dcscaledsec_ceiling_s
2044 function count_digit(sec)
result(result)
2046 integer,
intent(in):: sec
2053 if ( .not. sec < 10**i )
then
2060 end function count_digit
subroutine, public storeerror(number, where, err, cause_c, cause_i)
integer, parameter, public dc_noerr
integer, parameter, public dc_etoolargetime
subroutine, public dcscaledsecputline(sclsec, unit, indent)
integer, parameter, public stdout
標準出力の装置番号
integer, parameter, public dp
倍精度実数型変数
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ