00001 *DECK PCHST 00002 REAL FUNCTION PCHST (ARG1, ARG2) 00003 C***BEGIN PROLOGUE PCHST 00004 C***SUBSIDIARY 00005 C***PURPOSE PCHIP Sign-Testing Routine 00006 C***LIBRARY SLATEC (PCHIP) 00007 C***TYPE SINGLE PRECISION (PCHST-S, DPCHST-D) 00008 C***AUTHOR Fritsch, F. N., (LLNL) 00009 C***DESCRIPTION 00010 C 00011 C PCHST: PCHIP Sign-Testing Routine. 00012 C 00013 C Returns: 00014 C -1. if ARG1 and ARG2 are of opposite sign. 00015 C 0. if either argument is zero. 00016 C +1. if ARG1 and ARG2 are of the same sign. 00017 C 00018 C The object is to do this without multiplying ARG1*ARG2, to avoid 00019 C possible over/underflow problems. 00020 C 00021 C Fortran intrinsics used: SIGN. 00022 C 00023 C***SEE ALSO PCHCE, PCHCI, PCHCS, PCHIM 00024 C***ROUTINES CALLED (NONE) 00025 C***REVISION HISTORY (YYMMDD) 00026 C 811103 DATE WRITTEN 00027 C 820805 Converted to SLATEC library version. 00028 C 870813 Minor cosmetic changes. 00029 C 890411 Added SAVE statements (Vers. 3.2). 00030 C 890411 REVISION DATE from Version 3.2 00031 C 891214 Prologue converted to Version 4.0 format. (BAB) 00032 C 900328 Added TYPE section. (WRB) 00033 C 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) 00034 C 930503 Improved purpose. (FNF) 00035 C***END PROLOGUE PCHST 00036 C 00037 C**End 00038 C 00039 C DECLARE ARGUMENTS. 00040 C 00041 REAL ARG1, ARG2 00042 C 00043 C DECLARE LOCAL VARIABLES. 00044 C 00045 REAL ONE, ZERO 00046 SAVE ZERO, ONE 00047 DATA ZERO /0./, ONE /1./ 00048 C 00049 C PERFORM THE TEST. 00050 C 00051 C***FIRST EXECUTABLE STATEMENT PCHST 00052 PCHST = SIGN(ONE,ARG1) * SIGN(ONE,ARG2) 00053 IF ((ARG1.EQ.ZERO) .OR. (ARG2.EQ.ZERO)) PCHST = ZERO 00054 C 00055 RETURN 00056 C------------- LAST LINE OF PCHST FOLLOWS ------------------------------ 00057 END
1.7.1
