dc_scaledsec.f90
Go to the documentation of this file.
1 != 小数点以下の「秒」や整数型では表現できない大きい数を正確に演算するためのモジュール
2 != A module for correct operations of "seconds" after the decimal point, and large number more than integer type
3 !
4 ! Authors:: Yasuhiro MORIKAWA
5 ! Version:: $Id: dc_scaledsec.f90,v 1.1 2009-03-20 09:09:53 morikawa Exp $
6 ! Tag Name:: $Name: $
7 ! Copyright:: Copyright (C) GFD Dennou Club, 2008. All rights reserved.
8 ! License:: See COPYRIGHT[link:../../COPYRIGHT]
9 
11  !
12  ! #assignment(=) :: 代入
13  ! #operator(+) :: 加算
14  ! #operator(-) :: 減算
15  ! #operator(*) :: 乗算
16  ! #operator(/) :: 除算
17  ! mod :: 余り
18  ! modulo :: 剰余
19  ! #operator(==) :: 比較
20  ! #operator(>) :: 比較
21  ! #operator(<) :: 比較
22  ! abs :: 絶対値の算出
23  ! int :: 整数の算出 (小数点以下切捨て)
24  ! sign :: 符号の設定
25  ! floor :: 整数の算出 (対象の数値以下で最大の整数)
26  ! ceiling :: 整数の算出 (対象の数値以上で最小の整数)
27  !
28  use dc_types, only: dp
29  implicit none
30  private
31 
32  public:: dc_scaled_sec
33  public:: assignment(=), dcscaledsecputline
34  public:: operator(==), operator(>), operator(<), operator(>=), operator(<=)
35  public:: operator(+), operator(-), operator(*), operator(/), mod, modulo
36  public:: abs, int, sign, floor, ceiling
37 
38 !!$ integer, parameter:: imin = -1 ! 最小値の指数 = imin*6
39 !!$ integer, parameter:: imax = 4 ! 最大値の指数 = imax*6
40 !!$ real(DP), parameter:: scale_factor = 1.0e+6_DP
41 !!$ integer, parameter:: scale_factor_int = 1000000
42  integer, parameter:: imin = -2 ! 最小値の指数 = imin*3
43  integer, parameter:: imax = 8 ! 最大値の指数 = imax*3
44  real(DP), parameter:: scale_factor = 1.0e+3_dp
45  real(DP), parameter:: scale_factor_xx (-(imax+1):imax+1) = &
46  & (/ 1.0e-27_DP, &
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, &
49  & 1.0_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, &
52  & 1.0e+27_DP /)
53 
54  integer, parameter:: scale_factor_int = 1000
55  integer, parameter:: scale_factor_int_xx (0:3) = &
56  & (/ 1, 1000, 1000000, 1000000000 /)
57 
59  !
60  ! 小数点以下の「秒」や, 整数型では表現できないほど大きい数を
61  ! 正確に演算するための型.
62  !
63  ! Derived type for precise operations of "seconds" after
64  ! the decimal point, and large number more than integer type.
65  !
66  sequence
67  integer:: sec_ary(imin:imax) = 0
68  logical:: flag_negative = .false.
69  logical:: dummy = .false.
70  end type dc_scaled_sec
71 
72  interface assignment(=)
73  module procedure dcscaledseccreater !:doc-priority 20:
74  module procedure dcscaledseccreated !:doc-priority 30:
75  module procedure dcscaledseccreatei !:doc-priority 40:
76 
77  module procedure dcscaledsectonumr !:doc-priority 60:
78  module procedure dcscaledsectonumd !:doc-priority 70:
79  module procedure dcscaledsectonumi !:doc-priority 80:
80  end interface
81 
82  interface putline
83  module procedure dcscaledsecputline
84  end interface
85 
86  interface operator(==)
87  module procedure dcscaledsec_eq_ss !:doc-priority 20:
88  module procedure dcscaledsec_eq_si !:doc-priority 61:
89  module procedure dcscaledsec_eq_is !:doc-priority 62:
90  module procedure dcscaledsec_eq_sr !:doc-priority 63:
91  module procedure dcscaledsec_eq_rs !:doc-priority 64:
92  module procedure dcscaledsec_eq_sd !:doc-priority 65:
93  module procedure dcscaledsec_eq_ds !:doc-priority 66:
94  end interface
95 
96  interface operator(>)
97  module procedure dcscaledsec_gt_ss
98  module procedure dcscaledsec_gt_si
99  module procedure dcscaledsec_gt_is
100  end interface
101 
102  interface operator(<)
103  module procedure dcscaledsec_lt_ss
104  module procedure dcscaledsec_lt_si
105  module procedure dcscaledsec_lt_is
106  end interface
107 
108  interface operator(>=)
109  module procedure dcscaledsec_ge_ss
110  module procedure dcscaledsec_ge_si
111  module procedure dcscaledsec_ge_is
112  end interface
113 
114  interface operator(<=)
115  module procedure dcscaledsec_le_ss
116  module procedure dcscaledsec_le_si
117  module procedure dcscaledsec_le_is
118  end interface
119 
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
128  end interface
129 
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
139  end interface
140 
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
149  end interface
150 
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
156  end interface
157 
158  interface mod
159  module procedure dcscaledsec_mod_si
160  module procedure dcscaledsec_mod_sr
161  module procedure dcscaledsec_mod_sd
162  module procedure dcscaledsec_mod_ss
163  end interface
164 
165  interface modulo
166  module procedure dcscaledsec_modulo_si
167  module procedure dcscaledsec_modulo_sr
168  module procedure dcscaledsec_modulo_sd
169  module procedure dcscaledsec_modulo_ss
170  end interface
171 
172  interface abs
173  module procedure dcscaledsec_abs_s
174  end interface
175 
176  interface int
177  module procedure dcscaledsec_int_s
178  end interface
179 
180  interface sign
181  module procedure dcscaledsec_sign_si
182  module procedure dcscaledsec_sign_sr
183  module procedure dcscaledsec_sign_sd
184  module procedure dcscaledsec_sign_ss
185  end interface
186 
187  interface floor
188  module procedure dcscaledsec_floor_s
189  end interface
190 
191  interface ceiling
192  module procedure dcscaledsec_ceiling_s
193  end interface
194 
195 contains
196 
197  !-------------------------------------------------------------------
198 
199  subroutine dcscaledseccreatei(sclsec, sec)
200  implicit none
201  type(dc_scaled_sec), intent(out):: sclsec
202  integer, intent(in):: sec
203  continue
204  call dcscaledseccreated(sclsec, real( sec, dp ))
205  end subroutine dcscaledseccreatei
206 
207  !-------------------------------------------------------------------
208 
209  subroutine dcscaledseccreater(sclsec, sec)
210  implicit none
211  type(dc_scaled_sec), intent(out):: sclsec
212  real, intent(in):: sec
213  continue
214  call dcscaledseccreated(sclsec, real( sec, dp ))
215  end subroutine dcscaledseccreater
216 
217  !-------------------------------------------------------------------
218 
219  subroutine dcscaledseccreated(sclsec, sec)
222  use dc_trace, only: beginsub, endsub
223  use dc_types, only: dp, string
224  implicit none
225  type(dc_scaled_sec), intent(out):: sclsec
226  real(DP), intent(in):: sec
227 
228  real(DP):: work_sec, print_sec
229  integer:: i, cd, move_up, work_sec_scl_nint
230 
231  integer :: stat
232  character(STRING) :: cause_c
233  character(*), parameter:: subname = 'dc_scaledsec'
234  continue
235  !call BeginSub(subname, 'sec=<%f>', d = (/ sec /) )
236  stat = dc_noerr
237  cause_c = ''
238 
239  cd = 0
240  if ( sec < 0.0_dp ) then
241  sclsec % flag_negative = .true.
242  work_sec = - sec
243  else
244  sclsec % flag_negative = .false.
245  work_sec = sec
246  end if
247 
248  if ( work_sec > scale_factor_xx(imax + 1) ) then
249  call messagenotify( 'W', subname, &
250  & 'input number (%f) is too large.', &
251  & d = (/ sec /) )
252  stat = dc_etoolargetime
253  goto 999
254  end if
255 
256  sclsec % sec_ary = 0
257  do i = imax, imin, -1
258 
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
262 
263  if ( i < 0 ) then
264  sclsec % sec_ary(i) = work_sec_scl_nint
265  else
266  sclsec % sec_ary(i) = int( work_sec / scale_factor_xx(i) )
267  end if
268  work_sec = work_sec - sclsec % sec_ary(i) * scale_factor_xx(i)
269  cd = cd + count_digit( sclsec % sec_ary(i) )
270  end if
271  if ( cd > 5 ) then
272  if ( .not. abs( work_sec ) < scale_factor_xx(i-1) ) then
273  print_sec = sclsec
274 !!$ call MessageNotify( 'W', subname, &
275 !!$ & 'input number (%f) is truncated to (%f).', &
276 !!$ & d = (/ sec, print_sec /) )
277  end if
278  exit
279  end if
280  end do
281 
282  move_up = 0
283  do i = imin, imax
284  sclsec % sec_ary(i) = sclsec % sec_ary(i) + move_up
285  move_up = 0
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
289  end do
290  end do
291 
292 999 continue
293  call storeerror(stat, subname, cause_c=cause_c)
294  !call EndSub(subname)
295  end subroutine dcscaledseccreated
296 
297  !-------------------------------------------------------------------
298 
299  subroutine dcscaledsectonumi(sec, sclsec)
300  use dc_types, only: dp
301  implicit none
302  integer, intent(out):: sec
303  type(dc_scaled_sec), intent(in):: sclsec
304  real(DP):: secd
305  continue
306  call dcscaledsectonumd(secd, sclsec)
307  sec = nint( secd )
308  end subroutine dcscaledsectonumi
309 
310  !-------------------------------------------------------------------
311 
312  subroutine dcscaledsectonumr(sec, sclsec)
313  use dc_types, only: dp
314  implicit none
315  real, intent(out):: sec
316  type(dc_scaled_sec), intent(in):: sclsec
317  real(DP):: secd
318  continue
319  call dcscaledsectonumd(secd, sclsec)
320  sec = real( secd )
321  end subroutine dcscaledsectonumr
322 
323  !-------------------------------------------------------------------
324 
325  subroutine dcscaledsectonumd(sec, sclsec)
326  use dc_types, only: dp
327  implicit none
328  real(DP), intent(out):: sec
329  type(dc_scaled_sec), intent(in):: sclsec
330 
331  integer:: i
332  continue
333  sec = 0.0_dp
334  do i = imax, imin, -1
335  sec = sec + ( sclsec % sec_ary(i) * scale_factor_xx(i) )
336  end do
337  if ( sclsec % flag_negative ) sec = - sec
338  end subroutine dcscaledsectonumd
339 
340  !-------------------------------------------------------------------
341 
342  subroutine dcscaledsecputline( sclsec, unit, indent )
343  !
344  ! 引数 *sclsec* に設定されている情報を印字します.
345  ! デフォルトではメッセージは標準出力に出力されます.
346  ! *unit* に装置番号を指定することで, 出力先を変更することが可能です.
347  !
348  ! Print information of *sclsec*.
349  ! By default messages are output to standard output.
350  ! Unit number for output can be changed by *unit* argument.
351  !
352  use dc_string, only: printf, tochar
353  use dc_trace, only: beginsub, endsub
354  use dc_types, only: stdout, string
355  implicit none
356  type(dc_scaled_sec), intent(in) :: sclsec
357  integer, intent(in), optional :: unit
358  ! 出力先の装置番号.
359  ! デフォルトの出力先は標準出力.
360  !
361  ! Unit number for output.
362  ! Default value is standard output.
363  character(*), intent(in), optional:: indent
364  ! 表示されるメッセージの字下げ.
365  !
366  ! Indent of displayed messages.
367 
368  integer :: out_unit, sec_ary_rev(imin:imax)
369  integer:: indent_len
370  character(STRING):: indent_str
371  character(1):: sign
372  character(*), parameter:: subname = 'DCScaledSecPutLine'
373  continue
374  !call BeginSub(subname)
375 
376  if (present(unit)) then
377  out_unit = unit
378  else
379  out_unit = stdout
380  end if
381 
382  indent_len = 0
383  indent_str = ''
384  if ( present(indent) ) then
385  if ( len(indent) /= 0 ) then
386  indent_len = len(indent)
387  indent_str(1:indent_len) = indent
388  end if
389  end if
390 
391  sec_ary_rev(imin:imax) = sclsec % sec_ary(imax:imin:-1)
392  if ( sclsec % flag_negative ) then
393  sign = '-'
394  else
395  sign = '+'
396  end if
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) )
411  else
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 )
416  end if
417  999 continue
418  !call EndSub(subname)
419  end subroutine dcscaledsecputline
420 
421  !-------------------------------------------------------------------
422 
423  logical function dcscaledsec_eq_ss(sclsec1, sclsec2) result(result)
424  !
425  ! 2 つの DC_SCALED_SEC 型変数の比較
426  !
427  ! Comparison of two "DC_SCALED_SEC" variables
428  !
429  implicit none
430  type(dc_scaled_sec), intent(in):: sclsec1, sclsec2
431 
432  integer:: i
433  continue
434  if ( sclsec1 % flag_negative .and. .not. sclsec2 % flag_negative ) then
435  result = .false.
436 
437  return
438  elseif ( .not. sclsec1 % flag_negative .and. sclsec2 % flag_negative ) then
439  result = .false.
440  return
441  end if
442 
443  do i = imax, imin, -1
444  if ( .not. sclsec1 % sec_ary(i) == sclsec2 % sec_ary(i) ) then
445  result = .false.
446  return
447  end if
448  end do
449 
450  result = .true.
451  end function dcscaledsec_eq_ss
452 
453  !-------------------------------------------------------------------
454 
455  logical function dcscaledsec_eq_si(sclsec, sec) result(result)
456  implicit none
457  type(dc_scaled_sec), intent(in):: sclsec
458  integer, intent(in):: sec
459  type(dc_scaled_sec):: sclsec2
460  integer:: i, sec1
461  continue
462  if ( sclsec % flag_negative .and. .not. sec < 0 ) then
463  result = .false.
464  return
465  elseif ( .not. sclsec % flag_negative .and. sec < 0 ) then
466  result = .false.
467  return
468  end if
469 
470  if ( abs(sec) > scale_factor_int_xx(3) ) then
471  sclsec2 = sec
472  result = sclsec == sclsec2
473  else
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
476  result = .false.
477  return
478  end if
479  sec1 = sclsec % sec_ary(0)
480  do i = 1, 2
481  sec1 = sec1 + sclsec % sec_ary(i) * scale_factor_int_xx(i)
482  end do
483  result = sec1 == sec
484  end if
485  end function dcscaledsec_eq_si
486 
487  !-------------------------------------------------------------------
488 
489  logical function dcscaledsec_eq_is(sec, sclsec) result(result)
490  implicit none
491  integer, intent(in):: sec
492  type(dc_scaled_sec), intent(in):: sclsec
493  continue
494  result = sclsec == sec
495  end function dcscaledsec_eq_is
496 
497  !-------------------------------------------------------------------
498 
499  logical function dcscaledsec_eq_sr(sclsec, sec) result(result)
500  implicit none
501  type(dc_scaled_sec), intent(in):: sclsec
502  real, intent(in):: sec
503  type(dc_scaled_sec):: sclsec2
504  continue
505  sclsec2 = sec
506  result = sclsec == sclsec2
507  end function dcscaledsec_eq_sr
508 
509  !-------------------------------------------------------------------
510 
511  logical function dcscaledsec_eq_rs(sec, sclsec) result(result)
512  implicit none
513  real, intent(in):: sec
514  type(dc_scaled_sec), intent(in):: sclsec
515  type(dc_scaled_sec):: sclsec2
516  continue
517  sclsec2 = sec
518  result = sclsec == sclsec2
519  end function dcscaledsec_eq_rs
520 
521  !-------------------------------------------------------------------
522 
523  logical function dcscaledsec_eq_sd(sclsec, sec) result(result)
524  implicit none
525  type(dc_scaled_sec), intent(in):: sclsec
526  real(DP), intent(in):: sec
527  type(dc_scaled_sec):: sclsec2
528  continue
529  sclsec2 = sec
530  result = sclsec == sclsec2
531  end function dcscaledsec_eq_sd
532 
533  !-------------------------------------------------------------------
534 
535  logical function dcscaledsec_eq_ds(sec, sclsec) result(result)
536  implicit none
537  real(DP), intent(in):: sec
538  type(dc_scaled_sec), intent(in):: sclsec
539  type(dc_scaled_sec):: sclsec2
540  continue
541  sclsec2 = sec
542  result = sclsec == sclsec2
543  end function dcscaledsec_eq_ds
544 
545  !-------------------------------------------------------------------
546 
547  logical function dcscaledsec_gt_ss(sclsec1, sclsec2) result(result)
548  !
549  ! 2 つの DC_SCALED_SEC 型変数の比較
550  !
551  ! Comparison of two "DC_SCALED_SEC" variables
552  !
553  implicit none
554  type(dc_scaled_sec), intent(in):: sclsec1, sclsec2
555 
556  integer:: i
557  logical:: both_negative, flag_equal
558  continue
559  result = .false.
560  flag_equal = .true.
561 
562  if ( sclsec1 % flag_negative .and. .not. sclsec2 % flag_negative ) then
563  result = .false.
564  return
565  elseif ( .not. sclsec1 % flag_negative .and. sclsec2 % flag_negative ) then
566  result = .true.
567  return
568  elseif ( sclsec1 % flag_negative .and. sclsec2 % flag_negative ) then
569  both_negative = .true.
570  else
571  both_negative = .false.
572  end if
573 
574  do i = imax, imin, -1
575  if ( sclsec1 % sec_ary(i) > sclsec2 % sec_ary(i) ) then
576  result = .true.
577  flag_equal = .false.
578  exit
579  elseif ( sclsec1 % sec_ary(i) < sclsec2 % sec_ary(i) ) then
580  result = .false.
581  flag_equal = .false.
582  exit
583  end if
584  end do
585 
586  if ( .not. flag_equal .and. both_negative ) result = .not. result
587 
588  end function dcscaledsec_gt_ss
589 
590  !-------------------------------------------------------------------
591 
592  logical function dcscaledsec_gt_si(sclsec, factor) result(result)
593  !
594  ! 2 つの DC_SCALED_SEC 型変数の比較
595  !
596  ! Comparison of two "DC_SCALED_SEC" variables
597  !
598  implicit none
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
604  continue
605  if ( sclsec % flag_negative .and. .not. factor < 0 ) then
606  result = .false.
607  return
608  elseif ( .not. sclsec % flag_negative .and. factor < 0 ) then
609  result = .true.
610  return
611  elseif ( sclsec % flag_negative .and. factor < 0 ) then
612  both_negative = .true.
613  else
614  both_negative = .false.
615  end if
616 
617  factor_abs = abs(factor)
618 
619  if ( factor_abs > scale_factor_int_xx(3) ) then
620  factor_scl = factor
621  result = sclsec > factor_scl
622  return
623  else
624  if ( .not. all( sclsec % sec_ary(3:imax) == (/0, 0, 0, 0, 0, 0/) ) ) then
625  result = .true.
626  else
627  sec1 = sclsec % sec_ary(0)
628  do i = 1, 2
629  sec1 = sec1 + sclsec % sec_ary(i) * scale_factor_int_xx(i)
630  end do
631  if ( sec1 == factor_abs ) then
632  result = .not. all( sclsec % sec_ary(imin:-1) == (/0, 0/) )
633  else
634  result = sec1 > factor_abs
635  end if
636  end if
637 
638  if ( both_negative ) result = .not. result
639  end if
640 
641  end function dcscaledsec_gt_si
642 
643  !-------------------------------------------------------------------
644 
645  logical function dcscaledsec_gt_is(factor, sclsec) result(result)
646  !
647  ! 2 つの DC_SCALED_SEC 型変数の比較
648  !
649  ! Comparison of two "DC_SCALED_SEC" variables
650  !
651  implicit none
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
657  continue
658  if ( sclsec % flag_negative .and. .not. factor < 0 ) then
659  result = .true.
660  return
661  elseif ( .not. sclsec % flag_negative .and. factor < 0 ) then
662  result = .false.
663  return
664  elseif ( sclsec % flag_negative .and. factor < 0 ) then
665  both_negative = .true.
666  else
667  both_negative = .false.
668  end if
669 
670  factor_abs = abs(factor)
671 
672  if ( factor_abs > scale_factor_int_xx(3) ) then
673  factor_scl = factor
674  result = factor_scl > sclsec
675  return
676  else
677  if ( .not. all( sclsec % sec_ary(3:imax) == (/0, 0, 0, 0, 0, 0/) ) ) then
678  result = .false.
679  else
680  sec1 = sclsec % sec_ary(0)
681  do i = 1, 2
682  sec1 = sec1 + sclsec % sec_ary(i) * scale_factor_int_xx(i)
683  end do
684  if ( sec1 == factor_abs ) then
685  result = .false.
686  else
687  result = factor_abs > sec1
688  end if
689  end if
690 
691  if ( both_negative ) result = .not. result
692  end if
693  end function dcscaledsec_gt_is
694 
695  !-------------------------------------------------------------------
696 
697  logical function dcscaledsec_lt_ss(sclsec1, sclsec2) result(result)
698  !
699  ! 2 つの DC_SCALED_SEC 型変数の比較
700  !
701  ! Comparison of two "DC_SCALED_SEC" variables
702  !
703  implicit none
704  type(dc_scaled_sec), intent(in):: sclsec1, sclsec2
705  integer:: i
706  logical:: both_negative, flag_equal
707  continue
708  result = .false.
709  flag_equal = .true.
710 
711  if ( sclsec1 % flag_negative .and. .not. sclsec2 % flag_negative ) then
712  result = .true.
713  return
714  elseif ( .not. sclsec1 % flag_negative .and. sclsec2 % flag_negative ) then
715  result = .false.
716  return
717  elseif ( sclsec1 % flag_negative .and. sclsec2 % flag_negative ) then
718  both_negative = .true.
719  else
720  both_negative = .false.
721  end if
722 
723  do i = imax, imin, -1
724  if ( sclsec1 % sec_ary(i) > sclsec2 % sec_ary(i) ) then
725  result = .false.
726  flag_equal = .false.
727  exit
728  elseif ( sclsec1 % sec_ary(i) < sclsec2 % sec_ary(i) ) then
729  result = .true.
730  flag_equal = .false.
731  exit
732  end if
733  end do
734 
735  if ( .not. flag_equal .and. both_negative ) result = .not. result
736 
737  end function dcscaledsec_lt_ss
738 
739  !-------------------------------------------------------------------
740 
741  logical function dcscaledsec_lt_si(sclsec, factor) result(result)
742  !
743  ! 2 つの DC_SCALED_SEC 型変数の比較
744  !
745  ! Comparison of two "DC_SCALED_SEC" variables
746  !
747  implicit none
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
753  continue
754  if ( sclsec % flag_negative .and. .not. factor < 0 ) then
755  result = .true.
756  return
757  elseif ( .not. sclsec % flag_negative .and. factor < 0 ) then
758  result = .false.
759  return
760  elseif ( sclsec % flag_negative .and. factor < 0 ) then
761  both_negative = .true.
762  else
763  both_negative = .false.
764  end if
765 
766  factor_abs = abs(factor)
767 
768  if ( factor_abs > scale_factor_int_xx(3) ) then
769  factor_scl = factor
770  result = sclsec < factor_scl
771  return
772  else
773  if ( .not. all( sclsec % sec_ary(3:imax) == (/0, 0, 0, 0, 0, 0/) ) ) then
774  result = .false.
775  else
776  sec1 = sclsec % sec_ary(0)
777  do i = 1, 2
778  sec1 = sec1 + sclsec % sec_ary(i) * scale_factor_int_xx(i)
779  end do
780  if ( sec1 == factor_abs ) then
781  result = .false.
782  else
783  result = sec1 < factor_abs
784  end if
785  end if
786 
787  if ( both_negative ) result = .not. result
788  end if
789  end function dcscaledsec_lt_si
790 
791  !-------------------------------------------------------------------
792 
793  logical function dcscaledsec_lt_is(factor, sclsec) result(result)
794  !
795  ! 2 つの DC_SCALED_SEC 型変数の比較
796  !
797  ! Comparison of two "DC_SCALED_SEC" variables
798  !
799  implicit none
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
805  continue
806  if ( sclsec % flag_negative .and. .not. factor < 0 ) then
807  result = .false.
808  return
809  elseif ( .not. sclsec % flag_negative .and. factor < 0 ) then
810  result = .true.
811  return
812  elseif ( sclsec % flag_negative .and. factor < 0 ) then
813  both_negative = .true.
814  else
815  both_negative = .false.
816  end if
817 
818  factor_abs = abs(factor)
819 
820  if ( factor_abs > scale_factor_int_xx(3) ) then
821  factor_scl = factor
822  result = factor_scl < sclsec
823  return
824  else
825  if ( .not. all( sclsec % sec_ary(3:imax) == (/0, 0, 0, 0, 0, 0/) ) ) then
826  result = .true.
827  else
828  sec1 = sclsec % sec_ary(0)
829  do i = 1, 2
830  sec1 = sec1 + sclsec % sec_ary(i) * scale_factor_int_xx(i)
831  end do
832  if ( sec1 == factor_abs ) then
833  result = .not. all( sclsec % sec_ary(imin:-1) == (/0, 0/) )
834  else
835  result = factor_abs < sec1
836  end if
837  end if
838 
839  if ( both_negative ) result = .not. result
840  end if
841 
842  end function dcscaledsec_lt_is
843 
844  !-------------------------------------------------------------------
845 
846  logical function dcscaledsec_ge_ss(sclsec1, sclsec2) result(result)
847  !
848  ! 2 つの DC_SCALED_SEC 型変数の比較
849  !
850  ! Comparison of two "DC_SCALED_SEC" variables
851  !
852  implicit none
853  type(dc_scaled_sec), intent(in):: sclsec1, sclsec2
854  continue
855  result = .not. sclsec1 < sclsec2
856  end function dcscaledsec_ge_ss
857 
858  !-------------------------------------------------------------------
859 
860  logical function dcscaledsec_ge_si(sclsec, factor) result(result)
861  !
862  ! 2 つの DC_SCALED_SEC 型変数の比較
863  !
864  ! Comparison of two "DC_SCALED_SEC" variables
865  !
866  implicit none
867  type(dc_scaled_sec), intent(in):: sclsec
868  integer, intent(in):: factor
869  continue
870  result = .not. sclsec < factor
871  end function dcscaledsec_ge_si
872 
873  !-------------------------------------------------------------------
874 
875  logical function dcscaledsec_ge_is(factor, sclsec) result(result)
876  !
877  ! 2 つの DC_SCALED_SEC 型変数の比較
878  !
879  ! Comparison of two "DC_SCALED_SEC" variables
880  !
881  implicit none
882  integer, intent(in):: factor
883  type(dc_scaled_sec), intent(in):: sclsec
884  continue
885  result = .not. factor < sclsec
886  end function dcscaledsec_ge_is
887 
888  !-------------------------------------------------------------------
889 
890  logical function dcscaledsec_le_ss(sclsec1, sclsec2) result(result)
891  !
892  ! 2 つの DC_SCALED_SEC 型変数の比較
893  !
894  ! Comparison of two "DC_SCALED_SEC" variables
895  !
896  implicit none
897  type(dc_scaled_sec), intent(in):: sclsec1, sclsec2
898  continue
899  result = .not. sclsec1 > sclsec2
900  end function dcscaledsec_le_ss
901 
902  !-------------------------------------------------------------------
903 
904  logical function dcscaledsec_le_si(sclsec, factor) result(result)
905  !
906  ! 2 つの DC_SCALED_SEC 型変数の比較
907  !
908  ! Comparison of two "DC_SCALED_SEC" variables
909  !
910  implicit none
911  type(dc_scaled_sec), intent(in):: sclsec
912  integer, intent(in):: factor
913  continue
914  result = .not. sclsec > factor
915  end function dcscaledsec_le_si
916 
917  !-------------------------------------------------------------------
918 
919  logical function dcscaledsec_le_is(factor, sclsec) result(result)
920  !
921  ! 2 つの DC_SCALED_SEC 型変数の比較
922  !
923  ! Comparison of two "DC_SCALED_SEC" variables
924  !
925  implicit none
926  integer, intent(in):: factor
927  type(dc_scaled_sec), intent(in):: sclsec
928  continue
929  result = .not. factor > sclsec
930  end function dcscaledsec_le_is
931 
932  !-------------------------------------------------------------------
933 
934  type(dc_scaled_sec) function dcscaledsec_add_ss(sclsec1, sclsec2) result(result)
935  !
936  ! 2 つの DC_SCALED_SEC 型変数の加算.
937  !
938  ! Addition of two "DC_SCALED_SEC" variables
939  !
940  use dc_message, only: messagenotify
941  implicit none
942  type(dc_scaled_sec), intent(in):: sclsec1, sclsec2
943 
944  integer:: i, move_up
945  logical:: both_negative, sclsec2_flag_negative
946  type(dc_scaled_sec):: sclsec1_opsign, sclsec2_opsign
947  continue
948  move_up = 0
949  both_negative = .false.
950 
951  ! 負の値の処理
952  ! Handle negative value
953  !
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
958  end if
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
967  end if
968  return
969  end if
970 
971  ! 加算
972  ! Addition
973  !
974  do i = imin, imax
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' )
980  end if
981  move_up = result % sec_ary(i) / scale_factor_int
982  result % sec_ary(i) = mod( result % sec_ary(i), scale_factor_int )
983  else
984  move_up = 0
985  end if
986  end do
987 
988  if ( both_negative ) then
989  result % flag_negative = .true.
990  else
991  result % flag_negative = .false.
992  end if
993 
994  end function dcscaledsec_add_ss
995 
996  !-------------------------------------------------------------------
997 
998  type(dc_scaled_sec) function dcscaledsec_add_si(sclsec, factor) result(result)
999  !
1000  ! 2 つの DC_SCALED_SEC 型変数の加算.
1001  !
1002  ! Addition of two "DC_SCALED_SEC" variables
1003  !
1004  implicit none
1005  type(dc_scaled_sec), intent(in):: sclsec
1006  integer, intent(in):: factor
1007  type(dc_scaled_sec):: factor_scl
1008  continue
1009  factor_scl = factor
1010  result = sclsec + factor_scl
1011  end function dcscaledsec_add_si
1012 
1013  !-------------------------------------------------------------------
1014 
1015  type(dc_scaled_sec) function dcscaledsec_add_is(factor, sclsec) result(result)
1016  !
1017  ! 2 つの DC_SCALED_SEC 型変数の加算.
1018  !
1019  ! Addition of two "DC_SCALED_SEC" variables
1020  !
1021  implicit none
1022  integer, intent(in):: factor
1023  type(dc_scaled_sec), intent(in):: sclsec
1024  type(dc_scaled_sec):: factor_scl
1025  continue
1026  factor_scl = factor
1027  result = factor_scl + sclsec
1028  end function dcscaledsec_add_is
1029 
1030  !-------------------------------------------------------------------
1031 
1032  type(dc_scaled_sec) function dcscaledsec_add_sr(sclsec, factor) result(result)
1033  !
1034  ! 2 つの DC_SCALED_SEC 型変数の加算.
1035  !
1036  ! Addition of two "DC_SCALED_SEC" variables
1037  !
1038  implicit none
1039  type(dc_scaled_sec), intent(in):: sclsec
1040  real, intent(in):: factor
1041  type(dc_scaled_sec):: factor_scl
1042  continue
1043  factor_scl = factor
1044  result = sclsec + factor_scl
1045  end function dcscaledsec_add_sr
1046 
1047  !-------------------------------------------------------------------
1048 
1049  type(dc_scaled_sec) function dcscaledsec_add_rs(factor, sclsec) result(result)
1050  !
1051  ! 2 つの DC_SCALED_SEC 型変数の加算.
1052  !
1053  ! Addition of two "DC_SCALED_SEC" variables
1054  !
1055  implicit none
1056  real, intent(in):: factor
1057  type(dc_scaled_sec), intent(in):: sclsec
1058  type(dc_scaled_sec):: factor_scl
1059  continue
1060  factor_scl = factor
1061  result = sclsec + factor_scl
1062  end function dcscaledsec_add_rs
1063 
1064  !-------------------------------------------------------------------
1065 
1066  type(dc_scaled_sec) function dcscaledsec_add_sd(sclsec, factor) result(result)
1067  !
1068  ! 2 つの DC_SCALED_SEC 型変数の加算.
1069  !
1070  ! Addition of two "DC_SCALED_SEC" variables
1071  !
1072  implicit none
1073  type(dc_scaled_sec), intent(in):: sclsec
1074  real(DP), intent(in):: factor
1075  type(dc_scaled_sec):: factor_scl
1076  continue
1077  factor_scl = factor
1078  result = sclsec + factor_scl
1079  end function dcscaledsec_add_sd
1080 
1081  !-------------------------------------------------------------------
1082 
1083  type(dc_scaled_sec) function dcscaledsec_add_ds(factor, sclsec) result(result)
1084  !
1085  ! 2 つの DC_SCALED_SEC 型変数の加算.
1086  !
1087  ! Addition of two "DC_SCALED_SEC" variables
1088  !
1089  implicit none
1090  real(DP), intent(in):: factor
1091  type(dc_scaled_sec), intent(in):: sclsec
1092  type(dc_scaled_sec):: factor_scl
1093  continue
1094  factor_scl = factor
1095  result = sclsec + factor_scl
1096  end function dcscaledsec_add_ds
1097 
1098  !-------------------------------------------------------------------
1099 
1100  type(dc_scaled_sec) function dcscaledsec_sub_s(sclsec) result(result)
1101  !
1102  ! DC_SCALED_SEC 型変数の符号を逆にする.
1103  !
1104  ! Inverse sign of a "DC_SCALED_SEC" variable
1105  !
1106  implicit none
1107  type(dc_scaled_sec), intent(in):: sclsec
1108  continue
1109  result % flag_negative = .not. sclsec % flag_negative
1110  result % sec_ary = sclsec % sec_ary
1111  end function dcscaledsec_sub_s
1112 
1113  !-------------------------------------------------------------------
1114 
1115  type(dc_scaled_sec) function dcscaledsec_sub_ss(sclsec1, sclsec2) result(result)
1116  !
1117  ! 2 つの DC_SCALED_SEC 型変数の減算.
1118  !
1119  ! Subtraction of two "DC_SCALED_SEC" variables
1120  !
1121  implicit none
1122  type(dc_scaled_sec), intent(in):: sclsec1, sclsec2
1123 
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
1129  continue
1130  both_negative = .false.
1131 
1132  ! 負の値の処理
1133  ! Handle negative value
1134  !
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
1139  end if
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.
1145 
1146  result = sclsec1_opsign + sclsec2_opsign
1147  if ( both_negative ) then
1148  result % flag_negative = .not. result % flag_negative
1149  end if
1150  return
1151  end if
1152 
1153  ! 絶対値の比較
1154  ! Compare absolute values
1155  !
1156  sclsec1_nosign = sclsec1
1157  sclsec1_nosign % flag_negative = .false.
1158  sclsec2_nosign = sclsec2
1159  sclsec2_nosign % flag_negative = .false.
1160 
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
1169  else
1170  result = 0
1171  return
1172  end if
1173 
1174  move_down = 0
1175  do i = imin, imax
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
1181  else
1182  move_down = 0
1183  end if
1184  end do
1185 
1186  if ( both_negative ) then
1187  result % flag_negative = .not. result % flag_negative
1188  end if
1189 
1190  end function dcscaledsec_sub_ss
1191 
1192  !-------------------------------------------------------------------
1193 
1194  type(dc_scaled_sec) function dcscaledsec_sub_si(sclsec, factor) result(result)
1195  !
1196  ! 2 つの DC_SCALED_SEC 型変数の減算.
1197  !
1198  ! Subtraction of two "DC_SCALED_SEC" variables
1199  !
1200  implicit none
1201  type(dc_scaled_sec), intent(in):: sclsec
1202  integer, intent(in):: factor
1203  type(dc_scaled_sec):: factor_scl
1204  continue
1205  factor_scl = factor
1206  result = sclsec - factor_scl
1207  end function dcscaledsec_sub_si
1208 
1209  !-------------------------------------------------------------------
1210 
1211  type(dc_scaled_sec) function dcscaledsec_sub_is(factor, sclsec) result(result)
1212  !
1213  ! 2 つの DC_SCALED_SEC 型変数の減算.
1214  !
1215  ! Subtraction of two "DC_SCALED_SEC" variables
1216  !
1217  implicit none
1218  integer, intent(in):: factor
1219  type(dc_scaled_sec), intent(in):: sclsec
1220  type(dc_scaled_sec):: factor_scl
1221  continue
1222  factor_scl = factor
1223  result = factor_scl - sclsec
1224  end function dcscaledsec_sub_is
1225 
1226  !-------------------------------------------------------------------
1227 
1228  type(dc_scaled_sec) function dcscaledsec_sub_sr(sclsec, factor) result(result)
1229  !
1230  ! 2 つの DC_SCALED_SEC 型変数の減算.
1231  !
1232  ! Subtraction of two "DC_SCALED_SEC" variables
1233  !
1234  implicit none
1235  type(dc_scaled_sec), intent(in):: sclsec
1236  real, intent(in):: factor
1237  type(dc_scaled_sec):: factor_scl
1238  continue
1239  factor_scl = factor
1240  result = sclsec - factor_scl
1241  end function dcscaledsec_sub_sr
1242 
1243  !-------------------------------------------------------------------
1244 
1245  type(dc_scaled_sec) function dcscaledsec_sub_rs(factor, sclsec) result(result)
1246  !
1247  ! 2 つの DC_SCALED_SEC 型変数の減算.
1248  !
1249  ! Subtraction of two "DC_SCALED_SEC" variables
1250  !
1251  implicit none
1252  real, intent(in):: factor
1253  type(dc_scaled_sec), intent(in):: sclsec
1254  type(dc_scaled_sec):: factor_scl
1255  continue
1256  factor_scl = factor
1257  result = factor_scl - sclsec
1258  end function dcscaledsec_sub_rs
1259 
1260  !-------------------------------------------------------------------
1261 
1262  type(dc_scaled_sec) function dcscaledsec_sub_sd(sclsec, factor) result(result)
1263  !
1264  ! 2 つの DC_SCALED_SEC 型変数の減算.
1265  !
1266  ! Subtraction of two "DC_SCALED_SEC" variables
1267  !
1268  implicit none
1269  type(dc_scaled_sec), intent(in):: sclsec
1270  real(DP), intent(in):: factor
1271  type(dc_scaled_sec):: factor_scl
1272  continue
1273  factor_scl = factor
1274  result = sclsec - factor_scl
1275  end function dcscaledsec_sub_sd
1276 
1277  !-------------------------------------------------------------------
1278 
1279  type(dc_scaled_sec) function dcscaledsec_sub_ds(factor, sclsec) result(result)
1280  !
1281  ! 2 つの DC_SCALED_SEC 型変数の減算.
1282  !
1283  ! Subtraction of two "DC_SCALED_SEC" variables
1284  !
1285  implicit none
1286  real(DP), intent(in):: factor
1287  type(dc_scaled_sec), intent(in):: sclsec
1288  type(dc_scaled_sec):: factor_scl
1289  continue
1290  factor_scl = factor
1291  result = factor_scl - sclsec
1292  end function dcscaledsec_sub_ds
1293 
1294  !-------------------------------------------------------------------
1295 
1296  type(dc_scaled_sec) function dcscaledsec_mul_ss(sclsec1, sclsec2) result(result)
1297  !
1298  ! DC_SCALED_SEC 型変数の乗算.
1299  !
1300  ! Multiplication of a "DC_SCALED_SEC" variable
1301  !
1302  use dc_message, only: messagenotify
1303  implicit none
1304  type(dc_scaled_sec), intent(in), target:: sclsec1, sclsec2
1305  integer:: sec_ary_int(imin:imax,imin:imax)
1306 ! real(DP):: sec_ary_int(imin:imax,imin:imax)
1307  integer:: i, j, move_up
1308  type(dc_scaled_sec):: zero_sec
1309  continue
1310  if ( sclsec1 == zero_sec .or. sclsec2 == zero_sec ) then
1311  result = zero_sec
1312  return
1313  end if
1314 
1315  if ( sclsec1 % flag_negative ) then
1316  result % flag_negative = .not. sclsec2 % flag_negative
1317  else
1318  result % flag_negative = sclsec2 % flag_negative
1319  end if
1320 
1321  move_up = 0
1322  sec_ary_int(:,:) = 0
1323  do i = imin, imax
1324  do j = imin, imax
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' )
1330  end if
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
1334  else
1335  move_up = 0
1336  end if
1337  end do
1338  end do
1339 
1340  result % sec_ary = 0
1341  do i = imin, imax
1342  do j = imin, imax
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)
1346  end do
1347  end do
1348 
1349  move_up = 0
1350  do i = imin, imax
1351  result % sec_ary(i) = result % sec_ary(i) + move_up
1352  move_up = 0
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' )
1357  end if
1358  result % sec_ary(i) = result % sec_ary(i) - scale_factor_int
1359  move_up = move_up + 1
1360  end do
1361  end do
1362 
1363  end function dcscaledsec_mul_ss
1364 
1365  !-------------------------------------------------------------------
1366 
1367  type(dc_scaled_sec) function dcscaledsec_mul_si(sclsec, factor) result(result)
1368  !
1369  ! DC_SCALED_SEC 型変数の乗算.
1370  !
1371  ! Multiplication of a "DC_SCALED_SEC" variable
1372  !
1373  !--
1374  ! 高速化のため, mul_ss を使用しない.
1375  !++
1376  use dc_message, only: messagenotify
1377  implicit none
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
1384  continue
1385  if ( sclsec == zero_sec .or. factor == 0 ) then
1386  result = zero_sec
1387  return
1388  end if
1389 
1390  if ( sclsec % flag_negative ) then
1391  result % flag_negative = .not. factor < 0
1392  else
1393  result % flag_negative = factor < 0
1394  end if
1395  factor_abs = abs(factor)
1396 
1397  move_up = 0
1398  sec_ary_dp(:) = 0.0_dp
1399  do i = imin, imax
1400  sec_ary_dp(i) = sclsec % sec_ary(i) * factor_abs + move_up
1401 
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
1405  else
1406  move_up = 0
1407  end if
1408  end do
1409 
1410  if ( move_up /= 0 ) then
1411  call messagenotify( 'E', operator'dc_scaledsec#(*)', &
1412  & 'DC_SCALED_SEC must be smaller than 10^24' )
1413  end if
1414 
1415  result % sec_ary(imin:imax) = sec_ary_dp(imin:imax)
1416 
1417  end function dcscaledsec_mul_si
1418 
1419  !-------------------------------------------------------------------
1420 
1421  type(dc_scaled_sec) function dcscaledsec_mul_is(factor, sclsec) result(result)
1422  !
1423  ! DC_SCALED_SEC 型変数の乗算.
1424  !
1425  ! Multiplication of a "DC_SCALED_SEC" variable
1426  !
1427  implicit none
1428  integer, intent(in):: factor
1429  type(dc_scaled_sec), intent(in):: sclsec
1430  continue
1431  result = sclsec * factor
1432  end function dcscaledsec_mul_is
1433 
1434  !-------------------------------------------------------------------
1435 
1436  type(dc_scaled_sec) function dcscaledsec_mul_sd(sclsec, factor) result(result)
1437  !
1438  ! DC_SCALED_SEC 型変数の乗算.
1439  !
1440  ! Multiplication of a "DC_SCALED_SEC" variable
1441  !
1442  use dc_message, only: messagenotify
1443  implicit none
1444  type(dc_scaled_sec), intent(in):: sclsec
1445  real(DP), intent(in):: factor
1446  type(dc_scaled_sec):: factor_scl
1447  continue
1448  factor_scl = factor
1449  result = sclsec * factor_scl
1450  end function dcscaledsec_mul_sd
1451 
1452  !-------------------------------------------------------------------
1453 
1454  type(dc_scaled_sec) function dcscaledsec_mul_ds(factor, sclsec) result(result)
1455  !
1456  ! DC_SCALED_SEC 型変数の乗算.
1457  !
1458  ! Multiplication of a "DC_SCALED_SEC" variable
1459  !
1460  use dc_message, only: messagenotify
1461  implicit none
1462  real(DP), intent(in):: factor
1463  type(dc_scaled_sec), intent(in):: sclsec
1464  continue
1465  result = sclsec * factor
1466  end function dcscaledsec_mul_ds
1467 
1468  !-------------------------------------------------------------------
1469 
1470  type(dc_scaled_sec) function dcscaledsec_mul_sr(sclsec, factor) result(result)
1471  !
1472  ! DC_SCALED_SEC 型変数の乗算.
1473  !
1474  ! Multiplication of a "DC_SCALED_SEC" variable
1475  !
1476  use dc_message, only: messagenotify
1477  implicit none
1478  type(dc_scaled_sec), intent(in):: sclsec
1479  real, intent(in):: factor
1480  type(dc_scaled_sec):: factor_scl
1481  continue
1482  factor_scl = factor
1483  result = sclsec * factor_scl
1484  end function dcscaledsec_mul_sr
1485 
1486  !-------------------------------------------------------------------
1487 
1488  type(dc_scaled_sec) function dcscaledsec_mul_rs(factor, sclsec) result(result)
1489  !
1490  ! DC_SCALED_SEC 型変数の乗算.
1491  !
1492  ! Multiplication of a "DC_SCALED_SEC" variable
1493  !
1494  use dc_message, only: messagenotify
1495  implicit none
1496  real, intent(in):: factor
1497  type(dc_scaled_sec), intent(in):: sclsec
1498  continue
1499  result = sclsec * factor
1500  end function dcscaledsec_mul_rs
1501 
1502  !-------------------------------------------------------------------
1503 
1504  type(dc_scaled_sec) function dcscaledsec_div_ss(sclsec, factor) result(result)
1505  !
1506  ! DC_SCALED_SEC 型変数の除算.
1507  !
1508  ! Division of a "DC_SCALED_SEC" variable
1509  !
1510  use dc_message, only: messagenotify
1511  implicit none
1512  type(dc_scaled_sec), intent(in):: sclsec, factor
1513  real(DP):: factor_abs
1514  continue
1515 
1516  ! frt, ifort などでは, 1.0e+23 などの実数とすると,
1517  ! 9.9999e+22 などとなってしまうため,
1518  ! factor として指定するものは 10e+12 までとする. (うーむ, 汚い対応だな....)
1519  ! (morikawa 2008/09/01)
1520  !
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' )
1524  end if
1525 
1526  factor_abs = factor
1527  result = sclsec / factor_abs
1528 
1529  end function dcscaledsec_div_ss
1530 
1531  !-------------------------------------------------------------------
1532 
1533  type(dc_scaled_sec) function dcscaledsec_div_si(sclsec, factor) result(result)
1534  !
1535  ! DC_SCALED_SEC 型変数の除算.
1536  !
1537  ! Division of a "DC_SCALED_SEC" variable
1538  !
1539  use dc_message, only: messagenotify
1540  implicit none
1541  type(dc_scaled_sec), intent(in):: sclsec
1542  integer, intent(in):: factor
1543  continue
1544  result = sclsec / real( factor, dp )
1545  end function dcscaledsec_div_si
1546 
1547  !-------------------------------------------------------------------
1548 
1549  type(dc_scaled_sec) function dcscaledsec_div_sd(sclsec, factor) result(result)
1550  !
1551  ! DC_SCALED_SEC 型変数の除算.
1552  !
1553  ! Division of a "DC_SCALED_SEC" variable
1554  !
1555  use dc_message, only: messagenotify
1556  implicit none
1557  type(dc_scaled_sec), intent(in):: sclsec
1558  real(DP), intent(in):: factor
1559  integer:: i
1560  real(DP):: factor_abs, move_down, sec_ary_mod(imin+imin:imax)
1561  !logical:: flag_approximate
1562  continue
1563  if ( sclsec % flag_negative ) then
1564  result % flag_negative = .not. factor < 0.0_dp
1565  else
1566  result % flag_negative = factor < 0.0_dp
1567  end if
1568  factor_abs = abs(factor) * scale_factor_xx(2)
1569 
1570 ! flag_approximate = .false.
1571  move_down = 0.0_dp
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 )
1577  sec_ary_mod(i) = &
1578  & mod( ( sclsec % sec_ary(i) + move_down ), factor_abs )
1579  else
1580  result % sec_ary(i-imin) = int( move_down / factor_abs )
1581  sec_ary_mod(i) = mod( move_down, factor_abs )
1582  end if
1583 
1584  if ( sec_ary_mod(i) /= 0.0_dp ) then
1585  !if ( i < imin ) flag_approximate = .true.
1586  move_down = sec_ary_mod(i) * scale_factor
1587  else
1588  move_down = 0.0_dp
1589  end if
1590  end do
1591 
1592 !!$ if ( flag_approximate ) then
1593 !!$ call MessageNotify( 'W', 'dc_scaledsec#operator(/)', &
1594 !!$ & 'result may be calculated approximately' )
1595 !!$ end if
1596 
1597  end function dcscaledsec_div_sd
1598 
1599  !-------------------------------------------------------------------
1600 
1601  type(dc_scaled_sec) function dcscaledsec_div_sr(sclsec, factor) result(result)
1602  !
1603  ! DC_SCALED_SEC 型変数の除算.
1604  !
1605  ! Division of a "DC_SCALED_SEC" variable
1606  !
1607  use dc_message, only: messagenotify
1608  implicit none
1609  type(dc_scaled_sec), intent(in):: sclsec
1610  real, intent(in):: factor
1611  continue
1612  result = sclsec / real( factor, dp )
1613  end function dcscaledsec_div_sr
1614 
1615  !-------------------------------------------------------------------
1616 
1617  type(dc_scaled_sec) function dcscaledsec_mod_ss(sclsec, factor) result(result)
1618  !
1619  ! DC_SCALED_SEC 型変数を割った際の余りを計算.
1620  !
1621  ! Calculate of remainder by division of a "DC_SCALED_SEC" variable
1622  !
1623  use dc_message, only: messagenotify
1624  implicit none
1625  type(dc_scaled_sec), intent(in):: sclsec, factor
1626 
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
1633  continue
1634 
1635  ! frt, ifort などでは, 1.0e+23 などの実数とすると,
1636  ! 9.9999e+22 などとなってしまうため,
1637  ! factor として指定するものは 10e+12 までとする. (うーむ, 汚い対応だな....)
1638  ! (morikawa 2008/09/01)
1639  !
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' )
1643  end if
1644 
1645  if ( sclsec == factor ) then
1646  result = zero_sec
1647  return
1648  end if
1649 
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
1653 
1654  factor_dp = factor_scl
1655 
1656  move_down = 0.0_dp
1657  do i = imax, imin + imin, -1
1658  move_down_index = i
1659  if ( move_down /= 0.0_dp ) then
1660  if ( abs(factor_dp) > ( move_down + scale_factor ) * scale_factor_xx( i - imin ) ) exit
1661  end if
1662 
1663  if ( i > imin - 1 ) then
1664  sec_ary_mod(i) = &
1665  & mod( ( sclsec % sec_ary(i) + move_down ), factor_dp )
1666  else
1667  sec_ary_mod(i) = mod( move_down, factor_dp )
1668  end if
1669 
1670  if ( sec_ary_mod(i) /= 0.0_dp ) then
1671  move_down = sec_ary_mod(i) * scale_factor
1672  else
1673  move_down = 0.0_dp
1674  end if
1675 
1676  end do
1677 
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)
1681  end if
1682 
1683  result % flag_negative = sclsec % flag_negative
1684 
1685  end function dcscaledsec_mod_ss
1686 
1687  !-------------------------------------------------------------------
1688 
1689  type(dc_scaled_sec) function dcscaledsec_mod_si(sclsec, factor) result(result)
1690  !
1691  ! DC_SCALED_SEC 型変数を割った際の余りを計算.
1692  !
1693  ! Calculate of remainder by division of a "DC_SCALED_SEC" variable
1694  !
1695  use dc_message, only: messagenotify
1696  implicit none
1697  type(dc_scaled_sec), intent(in):: sclsec
1698  integer, intent(in):: factor
1699  type(dc_scaled_sec):: factor_scl
1700 
1701  continue
1702  factor_scl = factor
1703  result = mod( sclsec, factor_scl )
1704  end function dcscaledsec_mod_si
1705 
1706  !-------------------------------------------------------------------
1707 
1708  type(dc_scaled_sec) function dcscaledsec_mod_sr(sclsec, factor) result(result)
1709  !
1710  ! DC_SCALED_SEC 型変数を割った際の余りを計算.
1711  !
1712  ! Calculate of remainder by division of a "DC_SCALED_SEC" variable
1713  !
1714  use dc_message, only: messagenotify
1715  implicit none
1716  type(dc_scaled_sec), intent(in):: sclsec
1717  real, intent(in):: factor
1718  type(dc_scaled_sec):: factor_scl
1719 
1720  continue
1721  factor_scl = factor
1722  result = mod( sclsec, factor_scl )
1723  end function dcscaledsec_mod_sr
1724 
1725  !-------------------------------------------------------------------
1726 
1727  type(dc_scaled_sec) function dcscaledsec_mod_sd(sclsec, factor) result(result)
1728  !
1729  ! DC_SCALED_SEC 型変数を割った際の余りを計算.
1730  !
1731  ! Calculate of remainder by division of a "DC_SCALED_SEC" variable
1732  !
1733  use dc_message, only: messagenotify
1734  implicit none
1735  type(dc_scaled_sec), intent(in):: sclsec
1736  real(DP), intent(in):: factor
1737  type(dc_scaled_sec):: factor_scl
1738 
1739  continue
1740  factor_scl = factor
1741  result = mod( sclsec, factor_scl )
1742  end function dcscaledsec_mod_sd
1743 
1744  !-------------------------------------------------------------------
1745 
1746  type(dc_scaled_sec) function dcscaledsec_modulo_ss(sclsec, factor) result(result)
1747  !
1748  ! DC_SCALED_SEC 型変数を割った際の剰余を計算.
1749  !
1750  ! Calculate of remainder by division of a "DC_SCALED_SEC" variable
1751  !
1752  use dc_message, only: messagenotify
1753  implicit none
1754  type(dc_scaled_sec), intent(in):: sclsec, factor
1755 
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
1762  continue
1763 
1764  ! frt, ifort などでは, 1.0e+23 などの実数とすると,
1765  ! 9.9999e+22 などとなってしまうため,
1766  ! factor として指定するものは 10e+12 までとする. (うーむ, 汚い対応だな....)
1767  ! (morikawa 2008/09/01)
1768  !
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' )
1772  end if
1773 
1774  if ( sclsec == factor ) then
1775  result = zero_sec
1776  return
1777  end if
1778 
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
1782 
1783  factor_dp = factor_scl
1784 
1785  move_down = 0.0_dp
1786  do i = imax, imin + imin, -1
1787  move_down_index = i
1788  if ( move_down /= 0.0_dp ) then
1789  if ( abs(factor_dp) > ( move_down + scale_factor ) * scale_factor_xx( i - imin ) ) exit
1790  end if
1791 
1792  if ( i > imin - 1 ) then
1793  sec_ary_mod(i) = &
1794  & mod( ( sclsec % sec_ary(i) + move_down ), factor_dp )
1795  else
1796  sec_ary_mod(i) = mod( move_down, factor_dp )
1797  end if
1798 
1799  if ( sec_ary_mod(i) /= 0.0_dp ) then
1800  move_down = sec_ary_mod(i) * scale_factor
1801  else
1802  move_down = 0.0_dp
1803  end if
1804 
1805  end do
1806 
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)
1810  end if
1811 
1812  result % flag_negative = .false.
1813 
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
1818 
1819  elseif ( sclsec % flag_negative .and. .not. factor % flag_negative ) then
1820  result = factor - result
1821  result % flag_negative = .not. sclsec % flag_negative
1822 
1823  else
1824  result % flag_negative = sclsec % flag_negative
1825 
1826  end if
1827  end if
1828 
1829  end function dcscaledsec_modulo_ss
1830 
1831  !-------------------------------------------------------------------
1832 
1833  type(dc_scaled_sec) function dcscaledsec_modulo_si(sclsec, factor) result(result)
1834  !
1835  ! DC_SCALED_SEC 型変数を割った際の剰余を計算.
1836  !
1837  ! Calculate of remainder by division of a "DC_SCALED_SEC" variable
1838  !
1839  use dc_message, only: messagenotify
1840  implicit none
1841  type(dc_scaled_sec), intent(in):: sclsec
1842  integer, intent(in):: factor
1843  type(dc_scaled_sec):: factor_scl
1844 
1845  continue
1846  factor_scl = factor
1847  result = modulo( sclsec, factor_scl )
1848  end function dcscaledsec_modulo_si
1849 
1850  !-------------------------------------------------------------------
1851 
1852  type(dc_scaled_sec) function dcscaledsec_modulo_sr(sclsec, factor) result(result)
1853  !
1854  ! DC_SCALED_SEC 型変数を割った際の剰余を計算.
1855  !
1856  ! Calculate of remainder by division of a "DC_SCALED_SEC" variable
1857  !
1858  use dc_message, only: messagenotify
1859  implicit none
1860  type(dc_scaled_sec), intent(in):: sclsec
1861  real, intent(in):: factor
1862  type(dc_scaled_sec):: factor_scl
1863 
1864  continue
1865  factor_scl = factor
1866  result = modulo( sclsec, factor_scl )
1867  end function dcscaledsec_modulo_sr
1868 
1869  !-------------------------------------------------------------------
1870 
1871  type(dc_scaled_sec) function dcscaledsec_modulo_sd(sclsec, factor) result(result)
1872  !
1873  ! DC_SCALED_SEC 型変数を割った際の剰余を計算.
1874  !
1875  ! Calculate of remainder by division of a "DC_SCALED_SEC" variable
1876  !
1877  use dc_message, only: messagenotify
1878  implicit none
1879  type(dc_scaled_sec), intent(in):: sclsec
1880  real(DP), intent(in):: factor
1881  type(dc_scaled_sec):: factor_scl
1882 
1883  continue
1884  factor_scl = factor
1885  result = modulo( sclsec, factor_scl )
1886  end function dcscaledsec_modulo_sd
1887 
1888  !-------------------------------------------------------------------
1889 
1890  type(dc_scaled_sec) function dcscaledsec_abs_s(sclsec) result(result)
1891  !
1892  ! DC_SCALED_SEC 型変数の絶対値を返す.
1893  !
1894  ! Return an absolute value of a "DC_SCALED_SEC" variable
1895  !
1896  implicit none
1897  type(dc_scaled_sec), intent(in):: sclsec
1898 
1899  continue
1900  result = sclsec
1901  if ( result % flag_negative ) result % flag_negative = .false.
1902  end function dcscaledsec_abs_s
1903 
1904  !-------------------------------------------------------------------
1905 
1906  type(dc_scaled_sec) function dcscaledsec_int_s(sclsec) result(result)
1907  !
1908  ! DC_SCALED_SEC 型変数の整数値 (小数点以下切捨て) を返す.
1909  !
1910  ! Return an integer value (fractional parts are truncated) of a "DC_SCALED_SEC" variable
1911  !
1912  implicit none
1913  type(dc_scaled_sec), intent(in):: sclsec
1914  integer:: i
1915  continue
1916  result = sclsec
1917  do i = -1, imin, -1
1918  result % sec_ary(i) = 0
1919  end do
1920  end function dcscaledsec_int_s
1921 
1922  !-------------------------------------------------------------------
1923 
1924  type(dc_scaled_sec) function dcscaledsec_sign_ss(sclsec1, sclsec2) result(result)
1925  !
1926  ! sclsec1 の絶対値に sclsec2 の符号をつけたものを返す.
1927  !
1928  ! Return an absolute value of "sclsec1" with sign of "sclsec2".
1929  !
1930  implicit none
1931  type(dc_scaled_sec), intent(in):: sclsec1, sclsec2
1932  continue
1933  result = sclsec1
1934  result % flag_negative = sclsec2 % flag_negative
1935  end function dcscaledsec_sign_ss
1936 
1937  !-------------------------------------------------------------------
1938 
1939  type(dc_scaled_sec) function dcscaledsec_sign_si(sclsec, factor) result(result)
1940  !
1941  ! sclsec の絶対値に factor の符号をつけたものを返す.
1942  !
1943  ! Return an absolute value of "sclsec" with sign of "factor".
1944  !
1945  implicit none
1946  type(dc_scaled_sec), intent(in):: sclsec
1947  integer, intent(in):: factor
1948  type(dc_scaled_sec):: sclsec_work
1949  continue
1950  sclsec_work = factor
1951  result = sign( sclsec, sclsec_work )
1952  end function dcscaledsec_sign_si
1953 
1954  !-------------------------------------------------------------------
1955 
1956  type(dc_scaled_sec) function dcscaledsec_sign_sr(sclsec, factor) result(result)
1957  !
1958  ! sclsec の絶対値に factor の符号をつけたものを返す.
1959  !
1960  ! Return an absolute value of "sclsec" with sign of "factor".
1961  !
1962  implicit none
1963  type(dc_scaled_sec), intent(in):: sclsec
1964  real, intent(in):: factor
1965  type(dc_scaled_sec):: sclsec_work
1966  continue
1967  sclsec_work = factor
1968  result = sign( sclsec, sclsec_work )
1969  end function dcscaledsec_sign_sr
1970 
1971  !-------------------------------------------------------------------
1972 
1973  type(dc_scaled_sec) function dcscaledsec_sign_sd(sclsec, factor) result(result)
1974  !
1975  ! sclsec の絶対値に factor の符号をつけたものを返す.
1976  !
1977  ! Return an absolute value of "sclsec" with sign of "factor".
1978  !
1979  implicit none
1980  type(dc_scaled_sec), intent(in):: sclsec
1981  real(DP), intent(in):: factor
1982  type(dc_scaled_sec):: sclsec_work
1983  continue
1984  sclsec_work = factor
1985  result = sign( sclsec, sclsec_work )
1986  end function dcscaledsec_sign_sd
1987 
1988  !-------------------------------------------------------------------
1989 
1990  type(dc_scaled_sec) function dcscaledsec_floor_s(sclsec) result(result)
1991  !
1992  ! DC_SCALED_SEC 型変数の整数値 (対象の数値以下で最大の整数) を返す.
1993  !
1994  ! Return an integer value (maximum integer under the given value)
1995  ! of a "DC_SCALED_SEC" variable
1996  !
1997  implicit none
1998  type(dc_scaled_sec), intent(in):: sclsec
1999  integer:: i
2000  logical:: flag_after_decimal
2001  continue
2002  result = sclsec
2003  flag_after_decimal = .false.
2004  do i = -1, imin, -1
2005  if ( result % sec_ary(i) /= 0 ) flag_after_decimal = .true.
2006  result % sec_ary(i) = 0
2007  end do
2008  if ( flag_after_decimal .and. result % flag_negative ) then
2009  result = result - 1
2010  end if
2011 
2012  end function dcscaledsec_floor_s
2013 
2014  !-------------------------------------------------------------------
2015 
2016  type(dc_scaled_sec) function dcscaledsec_ceiling_s(sclsec) result(result)
2017  !
2018  ! DC_SCALED_SEC 型変数の整数値 (対象の数値以上で最小の整数) を返す.
2019  !
2020  ! Return an integer value (minimum integer over the given value)
2021  ! of a "DC_SCALED_SEC" variable
2022  !
2023  implicit none
2024  type(dc_scaled_sec), intent(in):: sclsec
2025  integer:: i
2026  logical:: flag_after_decimal
2027  continue
2028  result = sclsec
2029  flag_after_decimal = .false.
2030  do i = -1, imin, -1
2031  if ( result % sec_ary(i) /= 0 ) flag_after_decimal = .true.
2032  result % sec_ary(i) = 0
2033  end do
2034  if ( flag_after_decimal .and. .not. result % flag_negative ) then
2035  result = result + 1
2036  end if
2037 
2038  end function dcscaledsec_ceiling_s
2039 
2040  !-------------------------------------------------------------------
2041  !----------------- 内部サブルーチン ------------------------------
2042  !-------------------------------------------------------------------
2043 
2044  function count_digit(sec) result(result)
2045  implicit none
2046  integer, intent(in):: sec
2047  integer:: result
2048 
2049  integer:: i
2050  continue
2051 
2052  do i = 5, 0, -1
2053  if ( .not. sec < 10**i ) then
2054  result = i+1
2055  return
2056  end if
2057  end do
2058  result = 0
2059 
2060  end function count_digit
2061 
2062 
2063 end module dc_scaledsec
logical function dcscaledsec_eq_sr(sclsec, sec)
logical function dcscaledsec_ge_ss(sclsec1, sclsec2)
type(dc_scaled_sec) function dcscaledsec_modulo_sr(sclsec, factor)
subroutine dcscaledsectonumr(sec, sclsec)
type(dc_scaled_sec) function dcscaledsec_sign_si(sclsec, factor)
logical function dcscaledsec_gt_si(sclsec, factor)
type(dc_scaled_sec) function dcscaledsec_abs_s(sclsec)
integer function count_digit(sec)
type(dc_scaled_sec) function dcscaledsec_add_rs(factor, sclsec)
type(dc_scaled_sec) function dcscaledsec_mul_sd(sclsec, factor)
type(dc_scaled_sec) function dcscaledsec_ceiling_s(sclsec)
logical function dcscaledsec_gt_ss(sclsec1, sclsec2)
type(dc_scaled_sec) function dcscaledsec_sign_sd(sclsec, factor)
logical function dcscaledsec_lt_ss(sclsec1, sclsec2)
logical function dcscaledsec_le_ss(sclsec1, sclsec2)
type(dc_scaled_sec) function dcscaledsec_sub_rs(factor, sclsec)
real(dp), parameter scale_factor
type(dc_scaled_sec) function dcscaledsec_modulo_si(sclsec, factor)
type(dc_scaled_sec) function dcscaledsec_add_is(factor, sclsec)
subroutine dcscaledsectonumi(sec, sclsec)
type(dc_scaled_sec) function dcscaledsec_sub_sd(sclsec, factor)
type(dc_scaled_sec) function dcscaledsec_add_si(sclsec, factor)
subroutine dcscaledsectonumd(sec, sclsec)
integer, parameter, public dc_etoolargetime
Definition: dc_error.f90:574
type(dc_scaled_sec) function dcscaledsec_add_ss(sclsec1, sclsec2)
type(dc_scaled_sec) function dcscaledsec_sign_sr(sclsec, factor)
logical function dcscaledsec_gt_is(factor, sclsec)
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)
Definition: dc_error.f90:830
integer, parameter, public dc_noerr
Definition: dc_error.f90:509
type(dc_scaled_sec) function dcscaledsec_add_sd(sclsec, factor)
logical function dcscaledsec_eq_sd(sclsec, sec)
integer, dimension(0:3), parameter scale_factor_int_xx
type(dc_scaled_sec) function dcscaledsec_sub_ds(factor, sclsec)
type(dc_scaled_sec) function dcscaledsec_int_s(sclsec)
logical function dcscaledsec_le_si(sclsec, factor)
type(dc_scaled_sec) function dcscaledsec_mod_si(sclsec, factor)
logical function dcscaledsec_le_is(factor, sclsec)
type(dc_scaled_sec) function dcscaledsec_sub_s(sclsec)
subroutine dcscaledseccreater(sclsec, sec)
subroutine dcscaledseccreatei(sclsec, sec)
real(dp), dimension(-(imax+1):imax+1), parameter scale_factor_xx
logical function dcscaledsec_ge_si(sclsec, factor)
integer, parameter, public dp
倍精度実数型変数
Definition: dc_types.f90:83
type(dc_scaled_sec) function dcscaledsec_div_sr(sclsec, factor)
integer, parameter imax
subroutine, public beginsub(name, fmt, i, r, d, L, n, c1, c2, c3, ca, version)
Definition: dc_trace.f90:351
logical function dcscaledsec_eq_ds(sec, sclsec)
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_add_sr(sclsec, factor)
logical function dcscaledsec_lt_is(factor, sclsec)
type(dc_scaled_sec) function dcscaledsec_mul_ds(factor, sclsec)
logical function dcscaledsec_eq_si(sclsec, sec)
integer, parameter, public stdout
標準出力の装置番号
Definition: dc_types.f90:98
type(dc_scaled_sec) function dcscaledsec_mod_ss(sclsec, factor)
文字型変数の操作.
Definition: dc_string.f90:24
種別型パラメタを提供します。
Definition: dc_types.f90:49
type(dc_scaled_sec) function dcscaledsec_sign_ss(sclsec1, sclsec2)
logical function dcscaledsec_ge_is(factor, sclsec)
type(dc_scaled_sec) function dcscaledsec_sub_si(sclsec, factor)
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_add_ds(factor, sclsec)
type(dc_scaled_sec) function dcscaledsec_floor_s(sclsec)
type(dc_scaled_sec) function dcscaledsec_mul_si(sclsec, factor)
type(dc_scaled_sec) function dcscaledsec_sub_is(factor, sclsec)
logical function dcscaledsec_lt_si(sclsec, factor)
type(dc_scaled_sec) function dcscaledsec_modulo_ss(sclsec, factor)
logical function dcscaledsec_eq_ss(sclsec1, sclsec2)
integer, parameter scale_factor_int
subroutine, public dcscaledsecputline(sclsec, unit, indent)
type(dc_scaled_sec) function dcscaledsec_sub_ss(sclsec1, sclsec2)
logical function dcscaledsec_eq_is(sec, sclsec)
type(dc_scaled_sec) function dcscaledsec_mul_ss(sclsec1, sclsec2)
type(dc_scaled_sec) function dcscaledsec_sub_sr(sclsec, factor)
subroutine dcscaledseccreated(sclsec, sec)
subroutine, public endsub(name, fmt, i, r, d, L, n, c1, c2, c3, ca)
Definition: dc_trace.f90:446
type(dc_scaled_sec) function dcscaledsec_div_sd(sclsec, factor)
logical function dcscaledsec_eq_rs(sec, sclsec)
type(dc_scaled_sec) function dcscaledsec_mod_sd(sclsec, factor)
integer, parameter imin
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118