1*DECK SSRTQC 2 SUBROUTINE SSRTQC (LUN, KPRINT, IPASS) 3C***BEGIN PROLOGUE SSRTQC 4C***SUBSIDIARY 5C***PURPOSE Quick check for SLATEC routines SSORT, SPSORT, SPPERM 6C***LIBRARY SLATEC 7C***CATEGORY N6A 8C***TYPE SINGLE PRECISION (SSRTQC-S, DSRTQC-D, ISRTQC-I, HSRTQC-H) 9C***KEYWORDS QUICK CHECK, SPPERM, SPSORT, SSORT 10C***AUTHOR Boisvert, Ronald, (NIST) 11C***REFERENCES (NONE) 12C***ROUTINES CALLED SPPERM, SPSORT, SSORT 13C***REVISION HISTORY (YYMMDD) 14C 890620 DATE WRITTEN 15C 901005 Included test of SPPERM. (MAM) 16C 920511 Added error message tests. (MAM) 17C***END PROLOGUE SSRTQC 18C 19 INTEGER N, NTEST 20 PARAMETER (N=9,NTEST=4) 21C 22 LOGICAL FAIL 23 REAL X(N,NTEST), XS(N,NTEST), Y(N), YC(N) 24 INTEGER IX(N,NTEST), IY(N), KFLAG(NTEST), KPRINT, LUN, IPASS, J, 25 + I, KABS, IER, NERR, NUMXER, NN, KKFLAG 26C 27C --------- 28C TEST DATA 29C --------- 30C 31C X = TEST VECTOR 32C XS = TEST VECTOR IN SORTED ORDER 33C IX = PERMUTATION VECTOR, I.E. X(IX(J)) = XS(J) 34C 35 DATA KFLAG(1) / 2 / 36 DATA (X(I,1),I=1,N) /36.,54.,-1.,29., 1.,80.,98.,99.,55./ 37 DATA (IX(I,1),I=1,N)/ 3, 5, 4, 1, 2, 9, 6, 7, 8 / 38 DATA (XS(I,1),I=1,N)/-1., 1.,29.,36.,54.,55.,80.,98.,99./ 39C 40 DATA KFLAG(2) / -1 / 41 DATA (X(I,2),I=1,N) / 1., 2., 3., 4., 5., 6., 7., 8., 9./ 42 DATA (IX(I,2),I=1,N)/ 9, 8, 7, 6, 5, 4, 3, 2, 1 / 43 DATA (XS(I,2),I=1,N)/ 9., 8., 7., 6., 5., 4., 3., 2., 1./ 44C 45 DATA KFLAG(3) / -2 / 46 DATA (X(I,3),I=1,N) / -9.,-8.,-7.,-6.,-5.,-4.,-3.,-2.,-1./ 47 DATA (IX(I,3),I=1,N)/ 9, 8, 7, 6, 5, 4, 3, 2, 1 / 48 DATA (XS(I,3),I=1,N)/ -1.,-2.,-3.,-4.,-5.,-6.,-7.,-8.,-9./ 49C 50 DATA KFLAG(4) / 1 / 51 DATA (X(I,4),I=1,N) / 36.,54.,-1.,29., 1.,80.,98.,99.,55./ 52 DATA (IX(I,4),I=1,N)/ 3, 5, 4, 1, 2, 9, 6, 7, 8 / 53 DATA (XS(I,4),I=1,N)/ -1., 1.,29.,36.,54.,55.,80.,98.,99./ 54C 55C***FIRST EXECUTABLE STATEMENT SSRTQC 56 IF ( KPRINT .GE. 2 ) THEN 57 WRITE (LUN,2001) '=================' 58 WRITE (LUN,2002) 'OUTPUT FROM SSRTQC' 59 WRITE (LUN,2002) '=================' 60 ENDIF 61 IPASS = 1 62C 63C ------------------------------------------------------------- 64C CHECK SSORT 65C ------------------------------------------------------------- 66C 67 DO 200 J=1,NTEST 68C 69C ... SETUP PROBLEM 70C 71 DO 110 I=1,N 72 Y(I) = X(I,J) 73 YC(I) = X(I,J) 74 110 CONTINUE 75C 76C ... CALL ROUTINE TO BE TESTED 77C 78 CALL SSORT(Y,YC,N,KFLAG(J)) 79C 80C ... EVALUATE RESULTS 81C 82 KABS = ABS(KFLAG(J)) 83 FAIL = .FALSE. 84 DO 120 I=1,N 85 FAIL = FAIL .OR. (Y(I).NE.XS(I,J)) 86 + .OR. ((KABS.EQ.1).AND.(YC(I).NE.X(I,J))) 87 + .OR. ((KABS.EQ.2).AND.(YC(I).NE.XS(I,J))) 88 120 CONTINUE 89C 90C ... PRODUCE REQUIRED OUTPUT 91C 92 IF (FAIL) THEN 93 IPASS = 0 94 IF (KPRINT .GT. 0) WRITE(LUN,2001) 'SSORT FAILED TEST ',J 95 ELSE 96 IF (KPRINT .GE. 2) WRITE(LUN,2001) 'SSORT PASSED TEST ',J 97 ENDIF 98 IF ((FAIL .AND. (KPRINT .GE. 2)) .OR. (KPRINT .GE. 3)) THEN 99 WRITE(LUN,2001) '------------------------' 100 WRITE(LUN,2002) 'DETAILS OF SSORT TEST ',J 101 WRITE(LUN,2002) '------------------------' 102 WRITE(LUN,2002) '1ST ARGUMENT (VECTOR TO BE SORTED)' 103 WRITE(LUN,2003) ' INPUT = ',(X(I,J),I=1,N) 104 WRITE(LUN,2003) ' COMPUTED OUTPUT = ',(Y(I),I=1,N) 105 WRITE(LUN,2003) ' CORRECT OUTPUT = ',(XS(I,J),I=1,N) 106 WRITE(LUN,2002) '2ND ARGUMENT (VECTOR CARRIED ALONG)' 107 WRITE(LUN,2003) ' INPUT = ',(X(I,J),I=1,N) 108 WRITE(LUN,2003) ' COMPUTED OUTPUT = ',(YC(I),I=1,N) 109 IF (KABS .EQ. 1) THEN 110 WRITE(LUN,2003) ' CORRECT OUTPUT = ',(X(I,J),I=1,N) 111 ELSE 112 WRITE(LUN,2003) ' CORRECT OUTPUT = ',(XS(I,J),I=1,N) 113 ENDIF 114 WRITE(LUN,2002) '3RD ARGUMENT (VECTOR LENGTH)' 115 WRITE(LUN,2004) ' INPUT = ',N 116 WRITE(LUN,2002) '4TH ARGUMENT (TYPE OF SORT)' 117 WRITE(LUN,2004) ' INPUT = ',KFLAG(J) 118 ENDIF 119 200 CONTINUE 120C 121C ------------------------------------------------------------- 122C CHECK SPSORT 123C ------------------------------------------------------------- 124C 125 DO 300 J=1,NTEST 126C 127C ... SETUP PROBLEM 128C 129 DO 210 I=1,N 130 Y(I) = X(I,J) 131 210 CONTINUE 132C 133C ... CALL ROUTINE TO BE TESTED 134C 135 CALL SPSORT(Y,N,IY,KFLAG(J),IER) 136C 137C ... EVALUATE RESULTS 138C 139 KABS = ABS(KFLAG(J)) 140 FAIL = .FALSE. .OR. (IER.GT.0) 141 DO 220 I=1,N 142 FAIL = FAIL .OR. (IY(I).NE.IX(I,J)) 143 + .OR. ((KABS.EQ.1).AND.(Y(I).NE.X(I,J))) 144 + .OR. ((KABS.EQ.2).AND.(Y(I).NE.XS(I,J))) 145 220 CONTINUE 146C 147C ... PRODUCE REQUIRED OUTPUT 148C 149 IF (FAIL) THEN 150 IPASS = 0 151 IF (KPRINT .GT. 0) WRITE(LUN,2001) 'SPSORT FAILED TEST ',J 152 ELSE 153 IF (KPRINT .GE. 2) WRITE(LUN,2001) 'SPSORT PASSED TEST ',J 154 ENDIF 155 IF ((FAIL .AND. (KPRINT .GE. 2)) .OR. (KPRINT .GE. 3)) THEN 156 WRITE(LUN,2001) '-------------------------' 157 WRITE(LUN,2002) 'DETAILS OF SPSORT TEST ',J 158 WRITE(LUN,2002) '-------------------------' 159 WRITE(LUN,2002) '1ST ARGUMENT (VECTOR TO BE SORTED)' 160 WRITE(LUN,2003) ' INPUT = ',(X(I,J),I=1,N) 161 WRITE(LUN,2003) ' COMPUTED OUTPUT = ',(Y(I),I=1,N) 162 IF (KABS .EQ. 1) THEN 163 WRITE(LUN,2003) ' CORRECT OUTPUT = ',(X(I,J),I=1,N) 164 ELSE 165 WRITE(LUN,2003) ' CORRECT OUTPUT = ',(XS(I,J),I=1,N) 166 ENDIF 167 WRITE(LUN,2002) '2ND ARGUMENT (VECTOR LENGTH)' 168 WRITE(LUN,2004) ' INPUT = ',N 169 WRITE(LUN,2002) '3RD ARGUMENT (PERMUTATION VECTOR)' 170 WRITE(LUN,2004) ' COMPUTED OUTPUT = ',(IY(I),I=1,N) 171 WRITE(LUN,2004) ' CORRECT OUTPUT = ',(IX(I,J),I=1,N) 172 WRITE(LUN,2002) '4TH ARGUMENT (TYPE OF SORT)' 173 WRITE(LUN,2004) ' INPUT = ',KFLAG(J) 174 ENDIF 175C 176 300 CONTINUE 177C 178C ... TEST ERROR MESSAGES 179C 180 IF(KPRINT.LE.2)THEN 181 CALL XSETF(0) 182 ELSE 183 CALL XSETF(-1) 184 ENDIF 185C 186 NN=-1 187 KKFLAG=1 188 IF(KPRINT.GE.3)WRITE(LUN,*) 189 CALL XERCLR 190 CALL SPSORT(Y,NN,IY,KKFLAG,IER) 191 IF(NUMXER(NERR).NE.IER)IPASS=0 192C 193 NN=1 194 KKFLAG=0 195 IF(KPRINT.GE.3)WRITE(LUN,*) 196 CALL XERCLR 197 CALL SPSORT(Y,NN,IY,KKFLAG,IER) 198 IF(NUMXER(NERR).NE.IER)IPASS=0 199C 200 IF((KPRINT.GE.2).AND.(IPASS.EQ.1))THEN 201 WRITE(LUN,*) 202 WRITE(LUN,*)' SPSORT PASSED ERROR MESSAGE TESTS' 203 ELSE IF((KPRINT.GE.1).AND.(IPASS.EQ.0))THEN 204 WRITE(LUN,*) 205 WRITE(LUN,*)' SPSORT FAILED ERROR MESSAGE TESTS' 206 ENDIF 207C 208C ------------------------------------------------------------- 209C CHECK SPPERM 210C ------------------------------------------------------------- 211C 212 DO 400 J=1,NTEST 213C 214C ... SETUP PROBLEM 215C 216 KABS = ABS(KFLAG(J)) 217 DO 310 I=1,N 218 Y(I) = X(I,J) 219 IF(KABS.EQ.1)THEN 220 IY(I) = I 221 ELSE 222 IY(I) = IX(I,J) 223 ENDIF 224 310 CONTINUE 225C 226C ... CALL ROUTINE TO BE TESTED 227C 228 CALL SPPERM(Y,N,IY,IER) 229C 230C ... EVALUATE RESULTS 231C 232 FAIL = .FALSE. .OR. (IER.GT.0) 233 DO 320 I=1,N 234 FAIL = FAIL .OR. ((KABS.EQ.1).AND.(IY(I).NE.I)) 235 + .OR. ((KABS.EQ.2).AND.(IY(I).NE.IX(I,J))) 236 + .OR. ((KABS.EQ.1).AND.(Y(I).NE.X(I,J))) 237 + .OR. ((KABS.EQ.2).AND.(Y(I).NE.XS(I,J))) 238 320 CONTINUE 239C 240C ... PRODUCE REQUIRED OUTPUT 241C 242 IF (FAIL) THEN 243 IPASS = 0 244 IF (KPRINT.GT.0) WRITE(LUN,2001)'SPPERM FAILED TEST ',J 245 ELSE 246 IF (KPRINT.GE.2) WRITE(LUN,2001)'SPPERM PASSED TEST ',J 247 ENDIF 248 IF ((FAIL .AND. (KPRINT.GE.2)) .OR. (KPRINT.GE.3)) THEN 249 WRITE(LUN,2001)'------------------------' 250 WRITE(LUN,2002)'DETAILS OF SPPERM TEST',J 251 WRITE(LUN,2002)'------------------------' 252 WRITE(LUN,2002)'1ST ARGUMENT (VECTOR TO BE PERMUTED)' 253 WRITE(LUN,2003)' INPUT =',(X(I,J),I=1,N) 254 WRITE(LUN,2003)' COMPUTED OUTPUT =',(Y(I),I=1,N) 255 IF(KABS.EQ.1)THEN 256 WRITE(LUN,2003)' CORRECT OUTPUT =',(X(I,J),I=1,N) 257 ELSE 258 WRITE(LUN,2003)' CORRECT OUTPUT =',(XS(I,J),I=1,N) 259 ENDIF 260 WRITE(LUN,2002)'2ND ARGUMENT (VECTOR LENGTH)' 261 WRITE(LUN,2004)' INPUT =',N 262 WRITE(LUN,2002)'3RD ARGUMENT (PERMUTATION VECTOR)' 263 WRITE(LUN,2004)' INPUT =',(IY(I),I=1,N) 264 WRITE(LUN,2002)'4TH ARGUMENT (ERROR FLAG)' 265 WRITE(LUN,2004)' OUTPUT =',IER 266 ENDIF 267C 268 400 CONTINUE 269C 270C ... TEST ERROR MESSAGES 271C 272 IF(KPRINT.LE.2)THEN 273 CALL XSETF(0) 274 ELSE 275 CALL XSETF(-1) 276 ENDIF 277C 278 NN=-1 279 IF(KPRINT.GE.3)WRITE(LUN,*) 280 CALL XERCLR 281 CALL SPPERM(Y,NN,IY,IER) 282 IF(NUMXER(NERR).NE.IER)IPASS=0 283C 284 NN=1 285 IY(1)=5 286 IF(KPRINT.GE.3)WRITE(LUN,*) 287 CALL XERCLR 288 CALL SPPERM(Y,NN,IY,IER) 289 IF(NUMXER(NERR).NE.IER)IPASS=0 290C 291 IF((KPRINT.GE.2).AND.(IPASS.EQ.1))THEN 292 WRITE(LUN,*) 293 WRITE(LUN,*)' SPPERM PASSED ERROR MESSAGE TESTS' 294 ELSE IF((KPRINT.GE.1).AND.(IPASS.EQ.0))THEN 295 WRITE(LUN,*) 296 WRITE(LUN,*)' SPPERM FAILED ERROR MESSAGE TESTS' 297 ENDIF 298C 299 RETURN 300C 301 2001 FORMAT(/ 1X,A,I2) 302 2002 FORMAT(1X,A,I2) 303 2003 FORMAT(1X,A,9F4.0) 304 2004 FORMAT(1X,A,9I4) 305 END 306