eesupp/src/different_multiple.F

C $Header:  $
C $Name:  $

#include "CPP_EEOPTIONS.h"

CBOP
C     !ROUTINE: DIFFERENT_MULTIPLE

C     !INTERFACE:
      LOGICAL FUNCTION DIFFERENT_MULTIPLE( freq, val1, step )
      IMPLICIT NONE

C     !DESCRIPTION:
C     *==========================================================*
C     | LOGICAL FUNCTION DIFFERENT\_MULTIPLE                       
C     | o Checks if a multiple of freq exist
C     |   around val1 +/- step/2
C     *==========================================================*
C     | This routine is used for diagnostic and other periodic    
C     | operations. It is very sensitive to arithmetic precision. 
C     | For IEEE conforming arithmetic it works well but for      
C     | cases where short cut arithmetic  is used it may not work 
C     | as expected. To overcome this issue compile this routine  
C     | separately with no optimisation.                          
C     *==========================================================*

C     !INPUT PARAMETERS:
C     == Routine arguments ==
C     freq       :: Frequency by which time is divided.
C     val1       :: time that is checked 
C     step       :: length of time interval (around val1) that is checked 
      _RL  freq, val1, step

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

C     !LOCAL VARIABLES:
C     == Local variables ==
C     v1, v2, v3, v4 :: Temp. for holding time
C     d1, d2, d3     :: Temp. for hold difference
      _RL  v1, v2, v3, v4, d1, d2, d3
CEOP

C     o Do easy cases first.
      DIFFERENT_MULTIPLE = .FALSE.

      IF ( freq .NE. 0. ) THEN
        IF ( ABS(step) .GT. freq ) THEN
         DIFFERENT_MULTIPLE = .TRUE.
        ELSE

C         o This case is more complex because of round-off error
          v1 = val1
          v2 = val1 - step
          v3 = val1 + step

C         Test v1 to see if its a "closest multiple"
          v4 = NINT(v1/freq)*freq
          d1 = v1-v4
          d2 = v2-v4
          d3 = v3-v4
          IF ( ABS(d1) .LE. ABS(d2) .AND. ABS(d1) .LE. ABS(d3) )
     &        DIFFERENT_MULTIPLE = .TRUE.

        ENDIF
      ENDIF

      RETURN
      END
1	jmc	1.8	C $Header: $
2	cnh	1.5	C $Name: $
3	jmc	1.8
4	cnh	1.1	#include "CPP_EEOPTIONS.h"
5
6	cnh	1.5	CBOP
7			C !ROUTINE: DIFFERENT_MULTIPLE
8
9			C !INTERFACE:
10	jmc	1.8	LOGICAL FUNCTION DIFFERENT_MULTIPLE( freq, val1, step )
11	cnh	1.1	IMPLICIT NONE
12	cnh	1.5
13			C !DESCRIPTION:
14			C ==========================================================
15	edhill	1.6	C \| LOGICAL FUNCTION DIFFERENT\_MULTIPLE
16	jmc	1.8	C \| o Checks if a multiple of freq exist
17			C \| around val1 +/- step/2
18	cnh	1.5	C ==========================================================
19			C \| This routine is used for diagnostic and other periodic
20			C \| operations. It is very sensitive to arithmetic precision.
21			C \| For IEEE conforming arithmetic it works well but for
22			C \| cases where short cut arithmetic is used it may not work
23			C \| as expected. To overcome this issue compile this routine
24			C \| separately with no optimisation.
25			C ==========================================================
26
27			C !INPUT PARAMETERS:
28			C == Routine arguments ==
29	jmc	1.8	C freq :: Frequency by which time is divided.
30			C val1 :: time that is checked
31			C step :: length of time interval (around val1) that is checked
32			_RL freq, val1, step
33
34			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
35	cnh	1.5
36			C !LOCAL VARIABLES:
37			C == Local variables ==
38			C v1, v2, v3, v4 :: Temp. for holding time
39			C d1, d2, d3 :: Temp. for hold difference
40	jmc	1.8	_RL v1, v2, v3, v4, d1, d2, d3
41	cnh	1.5	CEOP
42	cnh	1.2
43			C o Do easy cases first.
44	cnh	1.1	DIFFERENT_MULTIPLE = .FALSE.
45	adcroft	1.3
46			IF ( freq .NE. 0. ) THEN
47	jmc	1.8	IF ( ABS(step) .GT. freq ) THEN
48	adcroft	1.3	DIFFERENT_MULTIPLE = .TRUE.
49			ELSE
50
51			C o This case is more complex because of round-off error
52			v1 = val1
53	jmc	1.8	v2 = val1 - step
54			v3 = val1 + step
55	adcroft	1.3
56			C Test v1 to see if its a "closest multiple"
57	jmc	1.8	v4 = NINT(v1/freq)*freq
58	adcroft	1.3	d1 = v1-v4
59			d2 = v2-v4
60			d3 = v3-v4
61			IF ( ABS(d1) .LE. ABS(d2) .AND. ABS(d1) .LE. ABS(d3) )
62			& DIFFERENT_MULTIPLE = .TRUE.
63
64	jmc	1.8	ENDIF
65			ENDIF
66	cnh	1.1
67	jmc	1.8	RETURN
68	cnh	1.2	END