TAP_support/ADFirstAidKit/validityTest.f

b4daa24319 Shre*0001 c$Id$
                0002       BLOCK DATA validityTestBD
                0003 C Keeps the current bounds of the validity interval
                0004 C Initial value is ]-infinity, +infinity[
                0005       REAL gmin, gmax
                0006       LOGICAL infmin, infmax
                0007       COMMON /validity_test_common/
                0008      +     gmin, gmax, infmin, infmax
                0009       DATA infmin/.TRUE./
                0010       DATA infmax/.TRUE./
                0011       DATA gmin/-999.99/
                0012       DATA gmax/999.99/
                0013       END
                0014
                0015       SUBROUTINE validity_domain_real8(t, td)
                0016 C Updates the bounds of the validity interval
                0017 C with the new constraint that t keeps its sign.
                0018       real*8 t, td
                0019       real gmin, gmax, temp
                0020       logical infmin, infmax
                0021       COMMON /validity_test_common/
                0022      +     gmin, gmax, infmin, infmax
                0023
                0024       if(td .ne. 0.0) then
                0025        temp = -(t/td)
                0026        if ( temp .lt. 0.0 ) then
                0027          if ( infmin ) then
                0028             gmin = temp
                0029             infmin = .FALSE.
                0030          else
                0031             gmin = max(gmin,temp)
                0032          endif
                0033        else
                0034          if ( infmax ) then
                0035             gmax = temp
                0036             infmax = .FALSE.
                0037          else
                0038             gmax = min(gmax,temp)
                0039          endif
                0040        endif
                0041       endif
                0042       end
                0043
                0044       SUBROUTINE validity_domain_real4(t, td)
                0045 C Updates the bounds of the validity interval
                0046 C with the new constraint that t keeps its sign.
                0047       real*4 t, td
                0048       real gmin, gmax, temp
                0049       logical infmin, infmax
                0050       COMMON /validity_test_common/
                0051      +     gmin, gmax, infmin, infmax
                0052
                0053       if(td .ne. 0.0) then
                0054        temp = -(t/td)
                0055        if ( temp .lt. 0.0 ) then
                0056          if ( infmin ) then
                0057             gmin = temp
                0058             infmin = .FALSE.
                0059          else
                0060             gmin = max(gmin,temp)
                0061          endif
                0062        else
                0063          if ( infmax ) then
                0064             gmax = temp
                0065             infmax = .FALSE.
                0066          else
                0067             gmax = min(gmax,temp)
                0068          endif
                0069        endif
                0070       endif
                0071       end