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