ModTools.F90

Go to the documentation of this file.

! *********************************************************************
! * Rocstar Simulation Suite                                          *
! * Copyright@2015, Illinois Rocstar LLC. All rights reserved.        *
! *                                                                   *
! * Illinois Rocstar LLC                                              *
! * Champaign, IL                                                     *
! * www.illinoisrocstar.com                                           *
! * sales@illinoisrocstar.com                                         *
! *                                                                   *
! * License: See LICENSE file in top level of distribution package or *
! * http://opensource.org/licenses/NCSA                               *
! *********************************************************************
! *********************************************************************
! * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,   *
! * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES   *
! * OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND          *
! * NONINFRINGEMENT.  IN NO EVENT SHALL THE CONTRIBUTORS OR           *
! * COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER       *
! * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,   *
! * Arising FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE    *
! * USE OR OTHER DEALINGS WITH THE SOFTWARE.                          *
! *********************************************************************
!******************************************************************************
!
! Purpose: Collection of utility functions.
!
! Description: None
!
! Notes: 
!   1. Named ModTools instead of ModUtilities because we already have a 
!      utilities directory.
!
!******************************************************************************
!
! $Id: ModTools.F90,v 1.11 2008/12/06 08:44:19 mtcampbe Exp $
!
! Copyright: (c) 2002-2005 by the University of Illinois
!
!******************************************************************************

MODULE modtools

  USE moddatatypes

  IMPLICIT NONE
  
  CONTAINS
  
! ------------------------------------------------------------------------------
!   Swap two integers
! ------------------------------------------------------------------------------

    SUBROUTINE swapintegers(a,b)
   
      INTEGER, INTENT(INOUT) :: a,b
 
      INTEGER :: c
    
      c = b
      b = a
      a = c
      
    END SUBROUTINE swapintegers
    
! ------------------------------------------------------------------------------
!   Swap two floats 
! ------------------------------------------------------------------------------

    SUBROUTINE swaprfreals(a,b)
   
      REAL(RFREAL), INTENT(INOUT) :: a,b
      
      REAL(RFREAL) :: c
    
      c = b
      b = a
      a = c
    
    END SUBROUTINE swaprfreals
  
! ------------------------------------------------------------------------------
!   Prevent division by zero by blending of variable with machine precision
! ------------------------------------------------------------------------------

    FUNCTION makenonzero(x)
   
      REAL(RFREAL) :: makenonzero
   
      REAL(RFREAL), INTENT(IN) :: x
    
      makenonzero = x + sign(1.0_rfreal,x)*epsilon(1.0_rfreal)
    
    END FUNCTION makenonzero

! ------------------------------------------------------------------------------
!   Comparison of floating-point numbers for equality
! ------------------------------------------------------------------------------

    LOGICAL FUNCTION floatequal(a,b,tolIn)
   
      REAL(RFREAL), INTENT(IN) :: a,b
      REAL(RFREAL), INTENT(IN), OPTIONAL :: tolin
   
      REAL(RFREAL) :: tol 
    
      floatequal = .false.      

      IF ( present(tolin) .EQV. .true. ) THEN 
        tol = tolin
      ELSE  
        tol = 10.0_rfreal*epsilon(1.0_rfreal)
      END IF ! PRESENT

      IF ( abs(a-b) <= (1.0_rfreal + 0.5_rfreal*abs(a+b))*tol ) THEN 
        floatequal = .true.
      END IF ! ABS
        
    END FUNCTION floatequal

! ------------------------------------------------------------------------------
!   Comparison of floating-point numbers: greater than
! ------------------------------------------------------------------------------

    LOGICAL FUNCTION floatgreater(a,b)
   
      REAL(RFREAL), INTENT(IN) :: a,b
    
      floatgreater = .false.
    
      IF ( a - b > b*epsilon(1.0_rfreal) ) THEN 
        floatgreater = .true.
      END IF ! a
        
    END FUNCTION floatgreater

! ------------------------------------------------------------------------------
!   Comparison of floating-point numbers: less than
! ------------------------------------------------------------------------------

    LOGICAL FUNCTION floatless(a,b)
   
      REAL(RFREAL), INTENT(IN) :: a,b
    
      floatless = .false.
    
      IF ( a - b < b*epsilon(1.0_rfreal) ) THEN 
        floatless = .true.
      END IF ! a
        
    END FUNCTION floatless

! ------------------------------------------------------------------------------
!   Compute Factorial
! ------------------------------------------------------------------------------

    INTEGER FUNCTION compfact(n)
    
      INTEGER, INTENT(IN) :: n
      
      INTEGER :: i
    
      compfact = 1

      DO i = 2,n
        compfact = compfact*i
      END DO ! i    
    
    END FUNCTION compfact 

! ------------------------------------------------------------------------------
!   Compute (a^2 + b^2)**(1/2) without under- or overflow
! ------------------------------------------------------------------------------

    FUNCTION comppythag(a,b)
     
      REAL(RFREAL) :: comppythag
    
      REAL(RFREAL), INTENT(IN) :: a,b
      
      REAL(RFREAL) :: absa,absb
      
      absa = abs(a)
      absb = abs(b)

      IF ( absa > absb ) THEN 
        comppythag = absa*sqrt(1.0_rfreal + (absb/absa)**2)
      ELSE
        IF ( absb == 0.0_rfreal ) THEN 
          comppythag = 0.0_rfreal
        ELSE 
          comppythag = absb*sqrt(1.0_rfreal + (absa/absb)**2)
        END IF ! absb  
      END IF ! absa      
    
    END FUNCTION comppythag

! ------------------------------------------------------------------------------
! Detect NaNs
! ------------------------------------------------------------------------------

  FUNCTION isnan(x)
  
    LOGICAL :: isnan
    
    REAL(RFREAL), INTENT(IN) :: x
    
    isnan = .false. 
    
    IF ( .NOT.(x > -huge(1.0) .AND. x < huge(1.0)) ) THEN
      isnan = .true.
    END IF ! NOT
  
  END FUNCTION isnan

! ******************************************************************************
! End
! ******************************************************************************

END MODULE modtools

!******************************************************************************
!
! RCS Revision history:
!
! $Log: ModTools.F90,v $
! Revision 1.11  2008/12/06 08:44:19  mtcampbe
! Updated license.
!
! Revision 1.10  2008/11/19 22:17:30  mtcampbe
! Added Illinois Open Source License/Copyright
!
! Revision 1.9  2006/03/25 21:47:54  haselbac
! Renamed SwapFloats to SwapRFREALS
!
! Revision 1.8  2003/12/04 03:28:29  haselbac
! Added function to detect NaNs
!
! Revision 1.7  2003/02/06 19:30:59  haselbac
! Added optional tolerance argument to FloatEqual
!
! Revision 1.6  2003/01/28 16:49:01  haselbac
! Changed FloatEqual to work better with very small floats
!
! Revision 1.5  2002/11/27 20:24:42  haselbac
! Changed tolerance in FloatEqual
!
! Revision 1.4  2002/11/26 15:25:45  haselbac
! Fixed bug in FloatEqual
!
! Revision 1.3  2002/09/09 15:00:54  haselbac
! Added robust calculation of CompPythag
!
! Revision 1.2  2002/07/25 15:13:39  haselbac
! Added factorial function
!
! Revision 1.1  2002/05/04 16:51:58  haselbac
! Initial revision
!
!******************************************************************************