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