32 public:: dc_scaled_sec
34 public::
operator(==),
operator(>),
operator(<),
operator(>=),
operator(<=)
35 public::
operator(+),
operator(-),
operator(*),
operator(/), mod, modulo
36 public:: abs, int, sign, floor, ceiling
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.
70 end type dc_scaled_sec
72 interface assignment(=)
73 module procedure dcscaledseccreater
74 module procedure dcscaledseccreated
75 module procedure dcscaledseccreatei
86 interface operator(==)
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
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
145 module procedure dcscaledsec_mul_sd
151 interface operator(/)
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)
201 type(dc_scaled_sec),
intent(out):: sclsec
202 integer,
intent(in):: sec
204 call dcscaledseccreated(sclsec,
real( sec,
dp ))
205 end subroutine dcscaledseccreatei
209 subroutine dcscaledseccreater(sclsec, sec)
211 type(dc_scaled_sec),
intent(out):: sclsec
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
225 type(dc_scaled_sec),
intent(out):: sclsec
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
302 integer,
intent(out):: sec
303 type(dc_scaled_sec),
intent(in):: sclsec
315 real,
intent(out):: sec
316 type(dc_scaled_sec),
intent(in):: sclsec
328 real(DP),
intent(out):: sec
329 type(dc_scaled_sec),
intent(in):: sclsec
334 do i = imax, imin, -1
335 sec = sec + ( sclsec % sec_ary(i) * scale_factor_xx(i) )
337 if ( sclsec % flag_negative ) sec = - sec
352 use dc_string
, only: printf, tochar
353 use dc_trace
, only: beginsub, endsub
356 type(dc_scaled_sec),
intent(in) :: sclsec
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 )
430 type(dc_scaled_sec),
intent(in):: sclsec1, sclsec2
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 455 logical function dcscaledsec_eq_si(sclsec, sec)
result(result)
457 type(dc_scaled_sec),
intent(in):: sclsec
458 integer,
intent(in):: sec
459 type(dc_scaled_sec):: sclsec2
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
492 type(dc_scaled_sec),
intent(in):: sclsec
494 result = sclsec == sec
495 end function dcscaledsec_eq_is
499 logical function dcscaledsec_eq_sr(sclsec, sec)
result(result)
501 type(dc_scaled_sec),
intent(in):: sclsec
502 real,
intent(in):: sec
503 type(dc_scaled_sec):: sclsec2
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
514 type(dc_scaled_sec),
intent(in):: sclsec
515 type(dc_scaled_sec):: sclsec2
518 result = sclsec == sclsec2
519 end function dcscaledsec_eq_rs
523 logical function dcscaledsec_eq_sd(sclsec, sec)
result(result)
525 type(dc_scaled_sec),
intent(in):: sclsec
526 real(DP),
intent(in):: sec
527 type(dc_scaled_sec):: sclsec2
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
538 type(dc_scaled_sec),
intent(in):: sclsec
539 type(dc_scaled_sec):: sclsec2
542 result = sclsec == sclsec2
543 end function dcscaledsec_eq_ds
547 logical function dcscaledsec_gt_ss(sclsec1, sclsec2)
result(result)
554 type(dc_scaled_sec),
intent(in):: sclsec1, sclsec2
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)
599 type(dc_scaled_sec),
intent(in):: sclsec
600 integer,
intent(in):: factor
601 type(dc_scaled_sec):: factor_scl
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
653 type(dc_scaled_sec),
intent(in):: sclsec
654 type(dc_scaled_sec):: factor_scl
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)
704 type(dc_scaled_sec),
intent(in):: sclsec1, sclsec2
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)
748 type(dc_scaled_sec),
intent(in):: sclsec
749 integer,
intent(in):: factor
750 type(dc_scaled_sec):: factor_scl
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
801 type(dc_scaled_sec),
intent(in):: sclsec
802 type(dc_scaled_sec):: factor_scl
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)
853 type(dc_scaled_sec),
intent(in):: sclsec1, sclsec2
855 result = .not. sclsec1 < sclsec2
856 end function dcscaledsec_ge_ss
860 logical function dcscaledsec_ge_si(sclsec, factor)
result(result)
867 type(dc_scaled_sec),
intent(in):: sclsec
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
883 type(dc_scaled_sec),
intent(in):: sclsec
885 result = .not. factor < sclsec
886 end function dcscaledsec_ge_is
890 logical function dcscaledsec_le_ss(sclsec1, sclsec2)
result(result)
897 type(dc_scaled_sec),
intent(in):: sclsec1, sclsec2
899 result = .not. sclsec1 > sclsec2
900 end function dcscaledsec_le_ss
904 logical function dcscaledsec_le_si(sclsec, factor)
result(result)
911 type(dc_scaled_sec),
intent(in):: sclsec
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
927 type(dc_scaled_sec),
intent(in):: sclsec
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
942 type(dc_scaled_sec),
intent(in):: sclsec1, sclsec2
945 logical:: both_negative, sclsec2_flag_negative
946 type(dc_scaled_sec):: sclsec1_opsign, sclsec2_opsign
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',
operator'dc_scaledsec#(*)', &
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)
1005 type(dc_scaled_sec),
intent(in):: sclsec
1006 integer,
intent(in):: factor
1007 type(dc_scaled_sec):: factor_scl
1010 result = sclsec + factor_scl
1015 type(dc_scaled_sec) function dcscaledsec_add_is(factor, sclsec) result(result)
1022 integer,
intent(in):: factor
1023 type(dc_scaled_sec),
intent(in):: sclsec
1024 type(dc_scaled_sec):: factor_scl
1027 result = factor_scl + sclsec
1028 end function dcscaledsec_add_is
1032 type(dc_scaled_sec) function dcscaledsec_add_sr(sclsec, factor) result(result)
1039 type(dc_scaled_sec),
intent(in):: sclsec
1040 real,
intent(in):: factor
1041 type(dc_scaled_sec):: factor_scl
1044 result = sclsec + factor_scl
1045 end function dcscaledsec_add_sr
1049 type(dc_scaled_sec) function dcscaledsec_add_rs(factor, sclsec) result(result)
1056 real,
intent(in):: factor
1057 type(dc_scaled_sec),
intent(in):: sclsec
1058 type(dc_scaled_sec):: factor_scl
1061 result = sclsec + factor_scl
1062 end function dcscaledsec_add_rs
1066 type(dc_scaled_sec) function dcscaledsec_add_sd(sclsec, factor) result(result)
1073 type(dc_scaled_sec),
intent(in):: sclsec
1074 real(DP),
intent(in):: factor
1075 type(dc_scaled_sec):: factor_scl
1078 result = sclsec + factor_scl
1079 end function dcscaledsec_add_sd
1083 type(dc_scaled_sec) function dcscaledsec_add_ds(factor, sclsec) result(result)
1090 real(DP),
intent(in):: factor
1091 type(dc_scaled_sec),
intent(in):: sclsec
1092 type(dc_scaled_sec):: factor_scl
1095 result = sclsec + factor_scl
1096 end function dcscaledsec_add_ds
1100 type(dc_scaled_sec) function dcscaledsec_sub_s(sclsec) result(result)
1107 type(dc_scaled_sec),
intent(in):: sclsec
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)
1122 type(dc_scaled_sec),
intent(in):: sclsec1, sclsec2
1124 integer:: i, move_down
1125 logical:: both_negative, sclsec2_flag_negative
1126 type(dc_scaled_sec):: sclsec1_opsign, sclsec2_opsign
1127 type(dc_scaled_sec):: sclsec1_nosign, sclsec2_nosign
1128 type(dc_scaled_sec):: large, small
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
1194 type(dc_scaled_sec) function dcscaledsec_sub_si(sclsec, factor) result(result)
1201 type(dc_scaled_sec),
intent(in):: sclsec
1202 integer,
intent(in):: factor
1203 type(dc_scaled_sec):: factor_scl
1206 result = sclsec - factor_scl
1207 end function dcscaledsec_sub_si
1211 type(dc_scaled_sec) function dcscaledsec_sub_is(factor, sclsec) result(result)
1218 integer,
intent(in):: factor
1219 type(dc_scaled_sec),
intent(in):: sclsec
1220 type(dc_scaled_sec):: factor_scl
1223 result = factor_scl - sclsec
1224 end function dcscaledsec_sub_is
1228 type(dc_scaled_sec) function dcscaledsec_sub_sr(sclsec, factor) result(result)
1235 type(dc_scaled_sec),
intent(in):: sclsec
1236 real,
intent(in):: factor
1237 type(dc_scaled_sec):: factor_scl
1240 result = sclsec - factor_scl
1241 end function dcscaledsec_sub_sr
1245 type(dc_scaled_sec) function dcscaledsec_sub_rs(factor, sclsec) result(result)
1252 real,
intent(in):: factor
1253 type(dc_scaled_sec),
intent(in):: sclsec
1254 type(dc_scaled_sec):: factor_scl
1257 result = factor_scl - sclsec
1258 end function dcscaledsec_sub_rs
1262 type(dc_scaled_sec) function dcscaledsec_sub_sd(sclsec, factor) result(result)
1269 type(dc_scaled_sec),
intent(in):: sclsec
1270 real(DP),
intent(in):: factor
1271 type(dc_scaled_sec):: factor_scl
1274 result = sclsec - factor_scl
1275 end function dcscaledsec_sub_sd
1279 type(dc_scaled_sec) function dcscaledsec_sub_ds(factor, sclsec) result(result)
1286 real(DP),
intent(in):: factor
1287 type(dc_scaled_sec),
intent(in):: sclsec
1288 type(dc_scaled_sec):: factor_scl
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
1304 type(dc_scaled_sec),
intent(in),
target:: sclsec1, sclsec2
1305 integer:: sec_ary_int(imin:imax,imin:imax)
1307 integer:: i, j, move_up
1308 type(dc_scaled_sec):: zero_sec
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',
operator'dc_scaledsec#(*)', &
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',
operator'dc_scaledsec#(*)', &
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
1367 type(dc_scaled_sec) function dcscaledsec_mul_si(sclsec, factor) result(result)
1376 use dc_message
, only: messagenotify
1378 type(dc_scaled_sec),
intent(in):: sclsec
1379 integer,
intent(in):: factor
1380 integer:: factor_abs
1381 type(dc_scaled_sec):: zero_sec
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',
operator'dc_scaledsec#(*)', &
1412 &
'DC_SCALED_SEC must be smaller than 10^24' )
1415 result % sec_ary(imin:imax) = sec_ary_dp(imin:imax)
1421 type(dc_scaled_sec) function dcscaledsec_mul_is(factor, sclsec) result(result)
1428 integer,
intent(in):: factor
1429 type(dc_scaled_sec),
intent(in):: sclsec
1431 result = sclsec * factor
1436 type(dc_scaled_sec) function dcscaledsec_mul_sd(sclsec, factor) result(result)
1442 use dc_message
, only: messagenotify
1444 type(dc_scaled_sec),
intent(in):: sclsec
1445 real(DP),
intent(in):: factor
1446 type(dc_scaled_sec):: factor_scl
1449 result = sclsec * factor_scl
1450 end function dcscaledsec_mul_sd
1454 type(dc_scaled_sec) function dcscaledsec_mul_ds(factor, sclsec) result(result)
1460 use dc_message
, only: messagenotify
1462 real(DP),
intent(in):: factor
1463 type(dc_scaled_sec),
intent(in):: sclsec
1465 result = sclsec * factor
1470 type(dc_scaled_sec) function dcscaledsec_mul_sr(sclsec, factor) result(result)
1476 use dc_message
, only: messagenotify
1478 type(dc_scaled_sec),
intent(in):: sclsec
1479 real,
intent(in):: factor
1480 type(dc_scaled_sec):: factor_scl
1483 result = sclsec * factor_scl
1488 type(dc_scaled_sec) function dcscaledsec_mul_rs(factor, sclsec) result(result)
1494 use dc_message
, only: messagenotify
1496 real,
intent(in):: factor
1497 type(dc_scaled_sec),
intent(in):: sclsec
1499 result = sclsec * factor
1504 type(dc_scaled_sec) function dcscaledsec_div_ss(sclsec, factor) result(result)
1510 use dc_message
, only: messagenotify
1512 type(dc_scaled_sec),
intent(in):: sclsec, factor
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
1533 type(dc_scaled_sec) function dcscaledsec_div_si(sclsec, factor) result(result)
1539 use dc_message
, only: messagenotify
1541 type(dc_scaled_sec),
intent(in):: sclsec
1542 integer,
intent(in):: factor
1544 result = sclsec /
real( factor,
dp )
1549 type(dc_scaled_sec) function dcscaledsec_div_sd(sclsec, factor) result(result)
1555 use dc_message
, only: messagenotify
1557 type(dc_scaled_sec),
intent(in):: sclsec
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
1601 type(dc_scaled_sec) function dcscaledsec_div_sr(sclsec, factor) result(result)
1607 use dc_message
, only: messagenotify
1609 type(dc_scaled_sec),
intent(in):: sclsec
1610 real,
intent(in):: factor
1612 result = sclsec /
real( factor,
dp )
1617 type(dc_scaled_sec) function dcscaledsec_mod_ss(sclsec, factor) result(result)
1623 use dc_message
, only: messagenotify
1625 type(dc_scaled_sec),
intent(in):: sclsec, factor
1627 type(dc_scaled_sec):: factor_scl
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
1632 type(dc_scaled_sec):: zero_sec
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
1689 type(dc_scaled_sec) function dcscaledsec_mod_si(sclsec, factor) result(result)
1695 use dc_message
, only: messagenotify
1697 type(dc_scaled_sec),
intent(in):: sclsec
1698 integer,
intent(in):: factor
1699 type(dc_scaled_sec):: factor_scl
1703 result = mod( sclsec, factor_scl )
1708 type(dc_scaled_sec) function dcscaledsec_mod_sr(sclsec, factor) result(result)
1714 use dc_message
, only: messagenotify
1716 type(dc_scaled_sec),
intent(in):: sclsec
1717 real,
intent(in):: factor
1718 type(dc_scaled_sec):: factor_scl
1722 result = mod( sclsec, factor_scl )
1727 type(dc_scaled_sec) function dcscaledsec_mod_sd(sclsec, factor) result(result)
1733 use dc_message
, only: messagenotify
1735 type(dc_scaled_sec),
intent(in):: sclsec
1736 real(DP),
intent(in):: factor
1737 type(dc_scaled_sec):: factor_scl
1741 result = mod( sclsec, factor_scl )
1746 type(dc_scaled_sec) function dcscaledsec_modulo_ss(sclsec, factor) result(result)
1752 use dc_message
, only: messagenotify
1754 type(dc_scaled_sec),
intent(in):: sclsec, factor
1756 type(dc_scaled_sec):: factor_scl
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
1761 type(dc_scaled_sec):: zero_sec
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
1833 type(dc_scaled_sec) function dcscaledsec_modulo_si(sclsec, factor) result(result)
1839 use dc_message
, only: messagenotify
1841 type(dc_scaled_sec),
intent(in):: sclsec
1842 integer,
intent(in):: factor
1843 type(dc_scaled_sec):: factor_scl
1847 result = modulo( sclsec, factor_scl )
1852 type(dc_scaled_sec) function dcscaledsec_modulo_sr(sclsec, factor) result(result)
1858 use dc_message
, only: messagenotify
1860 type(dc_scaled_sec),
intent(in):: sclsec
1861 real,
intent(in):: factor
1862 type(dc_scaled_sec):: factor_scl
1866 result = modulo( sclsec, factor_scl )
1871 type(dc_scaled_sec) function dcscaledsec_modulo_sd(sclsec, factor) result(result)
1877 use dc_message
, only: messagenotify
1879 type(dc_scaled_sec),
intent(in):: sclsec
1880 real(DP),
intent(in):: factor
1881 type(dc_scaled_sec):: factor_scl
1885 result = modulo( sclsec, factor_scl )
1890 type(dc_scaled_sec) function dcscaledsec_abs_s(sclsec) result(result)
1897 type(dc_scaled_sec),
intent(in):: sclsec
1901 if ( result % flag_negative ) result % flag_negative = .false.
1906 type(dc_scaled_sec) function dcscaledsec_int_s(sclsec) result(result)
1913 type(dc_scaled_sec),
intent(in):: sclsec
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)
1931 type(dc_scaled_sec),
intent(in):: sclsec1, sclsec2
1934 result % flag_negative = sclsec2 % flag_negative
1935 end function dcscaledsec_sign_ss
1939 type(dc_scaled_sec) function dcscaledsec_sign_si(sclsec, factor) result(result)
1946 type(dc_scaled_sec),
intent(in):: sclsec
1947 integer,
intent(in):: factor
1948 type(dc_scaled_sec):: sclsec_work
1950 sclsec_work = factor
1951 result = sign( sclsec, sclsec_work )
1952 end function dcscaledsec_sign_si
1956 type(dc_scaled_sec) function dcscaledsec_sign_sr(sclsec, factor) result(result)
1963 type(dc_scaled_sec),
intent(in):: sclsec
1964 real,
intent(in):: factor
1965 type(dc_scaled_sec):: sclsec_work
1967 sclsec_work = factor
1968 result = sign( sclsec, sclsec_work )
1969 end function dcscaledsec_sign_sr
1973 type(dc_scaled_sec) function dcscaledsec_sign_sd(sclsec, factor) result(result)
1980 type(dc_scaled_sec),
intent(in):: sclsec
1981 real(DP),
intent(in):: factor
1982 type(dc_scaled_sec):: sclsec_work
1984 sclsec_work = factor
1985 result = sign( sclsec, sclsec_work )
1986 end function dcscaledsec_sign_sd
1990 type(dc_scaled_sec) function dcscaledsec_floor_s(sclsec) result(result)
1998 type(dc_scaled_sec),
intent(in):: sclsec
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
2016 type(dc_scaled_sec) function dcscaledsec_ceiling_s(sclsec) result(result)
2024 type(dc_scaled_sec),
intent(in):: sclsec
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
type(dc_scaled_sec) function dcscaledsec_modulo_sr(sclsec, factor)
subroutine dcscaledsectonumr(sec, sclsec)
type(dc_scaled_sec) function dcscaledsec_abs_s(sclsec)
type(dc_scaled_sec) function dcscaledsec_modulo_si(sclsec, factor)
subroutine dcscaledsectonumi(sec, sclsec)
type(dc_scaled_sec) function dcscaledsec_add_si(sclsec, factor)
subroutine dcscaledsectonumd(sec, sclsec)
integer, parameter, public dc_etoolargetime
type(dc_scaled_sec) function dcscaledsec_mod_sr(sclsec, factor)
type(dc_scaled_sec) function dcscaledsec_div_ss(sclsec, factor)
subroutine, public storeerror(number, where, err, cause_c, cause_i)
integer, parameter, public dc_noerr
type(dc_scaled_sec) function dcscaledsec_mod_si(sclsec, factor)
integer, parameter, public dp
Double Precision Real number.
type(dc_scaled_sec) function dcscaledsec_div_sr(sclsec, factor)
type(dc_scaled_sec) function dcscaledsec_mul_rs(factor, sclsec)
type(dc_scaled_sec) function dcscaledsec_div_si(sclsec, factor)
type(dc_scaled_sec) function dcscaledsec_mul_is(factor, sclsec)
type(dc_scaled_sec) function dcscaledsec_mul_ds(factor, sclsec)
integer, parameter, public stdout
Unit number for Standard OUTPUT.
type(dc_scaled_sec) function dcscaledsec_mod_ss(sclsec, factor)
Provides kind type parameter values.
type(dc_scaled_sec) function dcscaledsec_modulo_sd(sclsec, factor)
type(dc_scaled_sec) function dcscaledsec_mul_sr(sclsec, factor)
type(dc_scaled_sec) function dcscaledsec_mul_si(sclsec, factor)
type(dc_scaled_sec) function dcscaledsec_modulo_ss(sclsec, factor)
logical function dcscaledsec_eq_ss(sclsec1, sclsec2)
subroutine, public dcscaledsecputline(sclsec, unit, indent)
type(dc_scaled_sec) function dcscaledsec_div_sd(sclsec, factor)
type(dc_scaled_sec) function dcscaledsec_mod_sd(sclsec, factor)
integer, parameter, public string
Character length for string.