1*DECK SNSQQK
2      SUBROUTINE SNSQQK (LUN, KPRINT, IPASS)
3C***BEGIN PROLOGUE  SNSQQK
4C***PURPOSE  Quick check for SNSQE and SNSQ.
5C***LIBRARY   SLATEC
6C***TYPE      SINGLE PRECISION (SNSQQK-S, DNSQQK-D)
7C***KEYWORDS  QUICK CHECK
8C***AUTHOR  (UNKNOWN)
9C***DESCRIPTION
10C
11C   This subroutine performs a quick check on the subroutine SNSQE
12C   (and SNSQ).
13C
14C***ROUTINES CALLED  ENORM, PASS, R1MACH, SNSQE, SQFCN2, SQJAC2
15C***REVISION HISTORY  (YYMMDD)
16C   ??????  DATE WRITTEN
17C   891009  Removed unreferenced variable.  (WRB)
18C   891009  REVISION DATE from Version 3.2
19C   891214  Prologue converted to Version 4.0 format.  (BAB)
20C   920310  Code cleaned up and TYPE section added.  (RWC, WRB)
21C***END PROLOGUE  SNSQQK
22C     .. Scalar Arguments ..
23      INTEGER IPASS, KPRINT, LUN
24C     .. Local Scalars ..
25      REAL FNORM, FNORMS, TOL
26      INTEGER ICNT, INFO, INFOS, IOPT, LWA, N, NPRINT
27C     .. Local Arrays ..
28      REAL FVEC(2), WA(19), X(2)
29      INTEGER ITEST(3)
30C     .. External Functions ..
31      REAL ENORM, R1MACH
32      EXTERNAL ENORM, R1MACH
33C     .. External Subroutines ..
34      EXTERNAL PASS, SNSQE, SQFCN2, SQJAC2
35C     .. Intrinsic Functions ..
36      INTRINSIC SQRT
37C***FIRST EXECUTABLE STATEMENT  SNSQQK
38      INFOS = 1
39      FNORMS = 0.0E0
40      N = 2
41      LWA = 19
42      NPRINT = -1
43      TOL = SQRT(R1MACH(4))
44      IF (KPRINT .GE. 2) WRITE (LUN,9000)
45C
46C     Option 1, the user provides the Jacobian.
47C
48      IOPT = 1
49      X(1) = -1.2E0
50      X(2) = 1.0E0
51      CALL SNSQE (SQFCN2,SQJAC2,IOPT,N,X,FVEC,TOL,NPRINT,INFO,WA,LWA)
52      ICNT = 1
53      FNORM = ENORM(N,FVEC)
54      ITEST(ICNT) = 0
55      IF ((INFO.EQ.INFOS) .AND. (FNORM-FNORMS.LE.TOL)) ITEST(ICNT) = 1
56C
57      IF (KPRINT .NE. 0) THEN
58         IF ((KPRINT.GE.2 .AND. ITEST(ICNT).NE.1) .OR. KPRINT.GE.3)
59     +       WRITE (LUN,9010) INFOS,FNORMS,INFO,FNORM
60         IF ((KPRINT.GE.2) .OR. (KPRINT.EQ.1 .AND. ITEST(ICNT).NE.1))
61     +       CALL PASS (LUN, ICNT, ITEST(ICNT))
62      ENDIF
63C
64C     Option 2, the code approximates the Jacobian.
65C
66      IOPT = 2
67      X(1) = -1.2E0
68      X(2) = 1.0E0
69      CALL SNSQE (SQFCN2,SQJAC2,IOPT,N,X,FVEC,TOL,NPRINT,INFO,WA,LWA)
70      ICNT = 2
71      FNORM = ENORM(N,FVEC)
72      ITEST(ICNT) = 0
73      IF ((INFO.EQ.INFOS) .AND. (FNORM-FNORMS.LE.TOL)) ITEST(ICNT) = 1
74C
75      IF (KPRINT .NE. 0) THEN
76         IF (KPRINT.GE.3 .OR. (KPRINT.GE.2.AND.ITEST(ICNT).NE.1))
77     +       WRITE (LUN,9010) INFOS, FNORMS, INFO, FNORM
78         IF (KPRINT.GE.2 .OR. (KPRINT.EQ.1.AND.ITEST(ICNT).NE.1))
79     +       CALL PASS (LUN, ICNT, ITEST(ICNT))
80      ENDIF
81C
82C     Test improper input parameters.
83C
84      LWA = 15
85      IOPT = 1
86      X(1) = -1.2E0
87      X(2) = 1.0E0
88      CALL SNSQE (SQFCN2,SQJAC2,IOPT,N,X,FVEC,TOL,NPRINT,INFO,WA,LWA)
89      ICNT = 3
90      ITEST(ICNT) = 0
91      IF (INFO .EQ. 0) ITEST(ICNT) = 1
92      IF (KPRINT.GE.2 .OR. (KPRINT.EQ.1.AND.ITEST(ICNT).NE.1))
93     +    CALL PASS (LUN, ICNT, ITEST(ICNT))
94C
95C     Set IPASS.
96C
97      IPASS = ITEST(1)*ITEST(2)*ITEST(3)
98      IF (KPRINT.GE.1 .AND. IPASS.NE.1) WRITE (LUN,9020)
99      IF (KPRINT.GE.2 .AND. IPASS.EQ.1) WRITE (LUN,9030)
100      RETURN
101 9000 FORMAT ('1' / '  SNSQE QUICK CHECK'/)
102 9010 FORMAT (' EXPECTED VALUE OF INFO AND RESIDUAL NORM', I5, E20.5 /
103     +        ' RETURNED VALUE OF INFO AND RESIDUAL NORM', I5, E20.5 /)
104 9020 FORMAT (/' **********WARNING -- SNSQE/SNSQ FAILED SOME TESTS****',
105     +        '******')
106 9030 FORMAT (/' ----------SNSQE/SNSQ PASSED ALL TESTS----------')
107      END
108