pkg/openad/ad_s_different_multiple.F

5dddee4ea2 Jean*0001 #include "CPP_EEOPTIONS.h"
                0002 CBOP
                0003 C     !ROUTINE: DIFFERENT_MULTIPLE
                0004
                0005 C     !INTERFACE:
                0006       subroutine oad_s_DIFFERENT_MULTIPLE( freq, val1, step, isit )
                0007       IMPLICIT NONE
                0008
                0009 C     !DESCRIPTION:
                0010 C     *==========================================================*
681c968868 Jean*0011 C     | LOGICAL FUNCTION DIFFERENT\_MULTIPLE
5dddee4ea2 Jean*0012 C     | o Checks if a multiple of freq exist
                0013 C     |   around val1 +/- step/2
                0014 C     *==========================================================*
681c968868 Jean*0015 C     | This routine is used for diagnostic and other periodic
                0016 C     | operations. It is very sensitive to arithmetic precision.
                0017 C     | For IEEE conforming arithmetic it works well but for
                0018 C     | cases where short cut arithmetic  is used it may not work
                0019 C     | as expected. To overcome this issue compile this routine
                0020 C     | separately with no optimisation.
5dddee4ea2 Jean*0021 C     *==========================================================*
                0022
                0023 C     !INPUT PARAMETERS:
                0024 C     == Routine arguments ==
                0025 C     freq       :: Frequency by which time is divided.
681c968868 Jean*0026 C     val1       :: time that is checked
                0027 C     step       :: length of time interval (around val1) that is checked
5dddee4ea2 Jean*0028       _RL  freq, val1, step
                0029       logical isit
                0030
                0031 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0032
                0033 C     !LOCAL VARIABLES:
                0034 C     == Local variables ==
                0035 C     v1, v2, v3, v4 :: Temp. for holding time
                0036 C     d1, d2, d3     :: Temp. for hold difference
                0037       _RL  v1, v2, v3, v4, d1, d2, d3
                0038 CEOP
                0039
                0040 C     o Do easy cases first.
                0041       isit = .FALSE.
                0042
                0043       IF ( freq .NE. 0. ) THEN
                0044         IF ( ABS(step) .GT. freq ) THEN
                0045          isit = .TRUE.
                0046         ELSE
                0047
                0048 C         o This case is more complex because of round-off error
                0049           v1 = val1
                0050           v2 = val1 - step
                0051           v3 = val1 + step
                0052
                0053 C         Test v1 to see if its a "closest multiple"
                0054           v4 = NINT(v1/freq)*freq
                0055           d1 = v1-v4
                0056           d2 = v2-v4
                0057           d3 = v3-v4
                0058           IF ( ABS(d1) .LT. ABS(d2) .AND. ABS(d1) .LE. ABS(d3) )
                0059      &        isit = .TRUE.
                0060
                0061         ENDIF
                0062       ENDIF
                0063
                0064       RETURN
                0065       END