trunk/misc/tanh_cautious.f

module tanh_cautious_m

  implicit none

contains

  elemental double precision function tanh_cautious(fa, fb)

    ! Compute tanh(fa / fb) with caution.

    double precision, intent(in):: fa, fb

    !-------------------------------------------------------------

    IF (200d0 * fb < - fa) THEN
       tanh_cautious = - 1d0
    ELSE IF (200d0 * fb < fa) THEN
       tanh_cautious = 1d0
    ELSE
       IF (ABS(fa) < 1d-13 .AND. ABS(fb) < 1d-13) THEN
          IF (200d0 * fb + fa < 1d-10) THEN
             tanh_cautious = - 1d0
          ELSE IF (200d0 * fb - fa < 1d-10) THEN
             tanh_cautious = 1d0
          END IF
       ELSE
          tanh_cautious = TANH(fa / fb)
       END IF
    END IF

  end function tanh_cautious

end module tanh_cautious_m
1	guez	144	module tanh_cautious_m
2
3			implicit none
4
5			contains
6
7			elemental double precision function tanh_cautious(fa, fb)
8
9			! Compute tanh(fa / fb) with caution.
10
11			double precision, intent(in):: fa, fb
12
13			!-------------------------------------------------------------
14
15			IF (200d0 * fb < - fa) THEN
16			tanh_cautious = - 1d0
17			ELSE IF (200d0 * fb < fa) THEN
18			tanh_cautious = 1d0
19			ELSE
20			IF (ABS(fa) < 1d-13 .AND. ABS(fb) < 1d-13) THEN
21			IF (200d0 * fb + fa < 1d-10) THEN
22			tanh_cautious = - 1d0
23			ELSE IF (200d0 * fb - fa < 1d-10) THEN
24			tanh_cautious = 1d0
25			END IF
26			ELSE
27			tanh_cautious = TANH(fa / fb)
28			END IF
29			END IF
30
31			end function tanh_cautious
32
33			end module tanh_cautious_m