Loading...
Searching...
No Matches
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
195contains
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)
220 use dc_message, only: messagenotify
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
292999 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', 'dc_scaledsec#operator(*)', &
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', 'dc_scaledsec#operator(*)', &
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', 'dc_scaledsec#operator(*)', &
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', 'dc_scaledsec#operator(*)', &
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
2063end module dc_scaledsec
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
integer, parameter, public dc_etoolargetime
Definition dc_error.f90:574
subroutine, public dcscaledsecputline(sclsec, unit, indent)
種別型パラメタを提供します。
Definition dc_types.f90:49
integer, parameter, public stdout
標準出力の装置番号
Definition dc_types.f90:98
integer, parameter, public dp
倍精度実数型変数
Definition dc_types.f90:83
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition dc_types.f90:118