Los Alamos National Laboratory

home *** CD-ROM | disk | FTP | other *** search

/ Los Alamos National Laboratory / LANL_CD.ISO / software / slatec / quik_chk.txt < prev next >

Wrap

Text File | 1992-10-16 | 956.7 KB | 30,523 lines

*DECK AVNTST SUBROUTINE AVNTST (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE AVNTST C***PURPOSE Quick check for AVINT. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (AVNTST-S, DAVNTS-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED AVINT, R1MACH, XERCLR, XGETF, XSETF C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Changed usage of R1MACH(3) to R1MACH(4). (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C 910708 Minor modifications in use of KPRINT. (WRB) C 920210 Code restructured and revised to test error returns for all C values of KPRINT. (WRB) C***END PROLOGUE AVNTST DIMENSION X(501), Y(501) LOGICAL FATAL C***FIRST EXECUTABLE STATEMENT AVNTST IF (KPRINT .GE. 2) WRITE (LUN,9000) IPASS = 1 TOL = MAX(.0001E0,SQRT(R1MACH(4))) TOL1 = 1.0E-2*TOL C C Perform first accuracy test. C A = 0.0E0 B = 5.0E0 XINT = EXP(5.0D0) - 1.0D0 N = 500 RN1 = N - 1 SQB = SQRT(B) DEL = 0.4E0*(B-A)/(N-1) DO 100 I = 1,N X(I) = SQB*SQRT(A+(I-1)*(B-A)/RN1) + DEL Y(I) = EXP(X(I)) 100 CONTINUE CALL AVINT (X, Y, N, A, B, ANS, IERR) C C See if test was passed. C IF (ABS(ANS-XINT) .GT. TOL) THEN IPASS = 0 IF (KPRINT .GE. 3) WRITE (LUN,9010) IERR, ANS, XINT ENDIF C C Perform second accuracy test. C X(1) = 0.0E0 X(2) = 5.0E0 Y(1) = 1.0E0 Y(2) = 0.5E0 A = -0.5E0 B = 0.5E0 XINT = 1.0E0 CALL AVINT (X, Y, 2, A, B, ANS, IERR) C C See if test was passed. C IF (ABS(ANS-XINT) .GT. TOL1) THEN IPASS = 0 IF (KPRINT .GE. 3) WRITE (LUN,9010) IERR, ANS, XINT ENDIF C C Send message indicating passage or failure of tests. C IF (KPRINT .GE. 2) THEN IF (IPASS .EQ. 1) THEN IF (KPRINT .GE. 3) WRITE (LUN,9020) ELSE WRITE (LUN,9030) ENDIF ENDIF C C Test error returns. C CALL XGETF (KONTRL) IF (KPRINT .LE. 2) THEN CALL XSETF (0) ELSE CALL XSETF (1) ENDIF FATAL = .FALSE. CALL XERCLR C IF (KPRINT .GE. 3) THEN WRITE (LUN,9040) ENDIF DO 110 I = 1,20 X(I) = (I-1)/19.0E0 - 0.01E0 IF (I .NE. 1) Y(I) = X(I)/(EXP(X(I))-1.0) 110 CONTINUE C C Test IERR = 1 error return. C Y(1) = 1.0E0 CALL AVINT (X, Y, 20, 0.0E0, 1.0E0, ANS, IERR) IF (IERR .NE. 1) THEN IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 3) WRITE (LUN,9060) IERR, 1 ENDIF CALL XERCLR C C Test IERR = 2 error return. C CALL AVINT (X, Y, 20, 1.0E0, 0.0E0, ANS, IERR) IF (IERR .NE. 2) THEN IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 3) WRITE (LUN,9060) IERR, 2 ENDIF IF (ANS .NE. 0.0E0) THEN IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 3) WRITE (LUN,9070) ENDIF CALL XERCLR C C Test IERR = 5 error return. C CALL AVINT (X, Y, 1, 0.0E0, 1.0E0, ANS, IERR) IF (IERR .NE. 5) THEN IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 3) WRITE (LUN,9060) IERR, 5 ENDIF IF (ANS .NE. 0.0E0) THEN IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 3) WRITE (LUN,9070) ENDIF CALL XERCLR C C Test IERR = 4 error return. C X(1) = 1.0E0/19.0E0 X(2) = 0.0E0 CALL AVINT (X, Y, 20, 0.0E0, 1.0E0, ANS, IERR) IF (IERR .NE. 4) THEN IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 3) WRITE (LUN,9060) IERR, 4 ENDIF IF (ANS .NE. 0.0E0) THEN IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 3) WRITE (LUN,9070) ENDIF CALL XERCLR C C Test IERR = 3 error return. C X(1) = 0.0E0 X(2) = 1.0E0/19.0E0 CALL AVINT (X, Y, 20, 0.0E0, .01E0, ANS, IERR) IF (IERR .NE. 3) THEN IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 3) WRITE (LUN,9060) IERR, 3 ENDIF IF (ANS .NE. 0.0E0) THEN IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 3) WRITE (LUN,9070) ENDIF CALL XERCLR C C Reset XERMSG control variables and write summary. C CALL XSETF (KONTRL) IF (FATAL) THEN IF (KPRINT .GE. 2) THEN WRITE (LUN, 9080) ENDIF ELSE IF (KPRINT .GE. 3) THEN WRITE (LUN, 9090) ENDIF ENDIF C C Write PASS/FAIL message. C IF (IPASS.EQ.1 .AND. KPRINT.GE.3) WRITE (LUN,9100) IF (IPASS.EQ.0 .AND. KPRINT.GE.2) WRITE (LUN,9110) RETURN 9000 FORMAT ('1' / ' AVINT Quick Check') 9010 FORMAT (/' FAILED ACCURACY TEST' / + ' IERR=', I2, 5X, 'COMPUTED ANS=', E20.11 / 14X, + 'CORRECT ANS=', E20.11, 5X, 'REQUESTED ERR=', E10.2) 9020 FORMAT (/ ' AVINT passed both accuracy tests.') 9030 FORMAT (/ ' AVINT failed at least one accuracy test.') 9040 FORMAT (/ ' Test error returns from AVINT' / + ' 4 error messages expected' /) 9060 FORMAT (/' IERR =', I2, ' and it should =', I2 /) 9070 FORMAT (1X, 'ANS .NE. 0') 9080 FORMAT (/ ' At least one incorrect argument test FAILED') 9090 FORMAT (/ ' All incorrect argument tests PASSED') 9100 FORMAT (/' ***************AVINT PASSED ALL TESTS***************') 9110 FORMAT (/' ***************AVINT FAILED SOME TESTS**************') END *DECK BIKCK SUBROUTINE BIKCK (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE BIKCK C***PURPOSE Quick check for BESI and BESK. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (BIKCK-S, DBIKCK-D) C***KEYWORDS QUICK CHECK C***AUTHOR Amos, D. E., (SNLA) C***DESCRIPTION C C BIKCK is a quick check routine for BESI and BESK. The main loops C evaluate the Wronskian and test the error. Underflow and overflow C diagnostics are checked in addition to illegal arguments. C C***ROUTINES CALLED BESI, BESK, NUMXER, R1MACH, XERCLR, XGETF, XSETF C***REVISION HISTORY (YYMMDD) C 750101 DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 891004 Removed unreachable code. (WRB) C 891004 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901013 Editorial changes, some restructing and modifications to C obtain more information when there is failure of the C Wronskian. (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C 910708 Code revised to test error returns for all values of C KPRINT. (WRB) C***END PROLOGUE BIKCK INTEGER I, IX, K, KONTRL, KODE, LUN, M, N, NERR, NU, NW, NY REAL ALP, DEL, ER, FNU, FNUP, RX, TOL, X REAL FN(3), W(5), XX(5), Y(5) REAL R1MACH LOGICAL FATAL C***FIRST EXECUTABLE STATEMENT BIKCK IF (KPRINT .GE. 2) WRITE (LUN,90000) C IPASS = 1 XX(1) = 0.49E0 XX(2) = 1.3E0 XX(3) = 5.3E0 XX(4) = 13.3E0 XX(5) = 21.3E0 FN(1) = 0.095E0 FN(2) = 0.70E0 FN(3) = 0.0E0 TOL = 500.0E0*MAX(R1MACH(4), 7.1E-15) DO 60 KODE=1,2 DO 50 M=1,3 DO 40 N=1,4 DO 30 NU=1,4 FNU = FN(M) + 12*(NU-1) DO 20 IX=1,5 IF (IX.LT.2 .AND. NU.GT.3) GO TO 20 X = XX(IX) RX = 1.0E0/X CALL BESI(X, FNU, KODE, N, Y, NY) IF (NY.NE.0) GO TO 20 CALL BESK(X, FNU, KODE, N, W, NW) IF (NW.NE.0) GO TO 20 FNUP = FNU + N CALL BESI(X,FNUP,KODE,1,Y(N+1),NY) IF (NY.NE.0) GO TO 20 CALL BESK(X,FNUP,KODE,1,W(N+1),NW) IF (NW.NE.0) GO TO 20 DO 10 I=1,N ER = Y(I+1)*W(I) + W(I+1)*Y(I) - RX ER = ABS(ER)*X IF (ER.GT.TOL) THEN IPASS = 0 IF (KPRINT.GE.2) WRITE (LUN,90010) KODE,M,N, * NU,IX,I,X,ER,TOL, * Y(I),Y(I+1),W(I),W(I+1) ENDIF 10 CONTINUE 20 CONTINUE 30 CONTINUE 40 CONTINUE 50 CONTINUE 60 CONTINUE C C Check small values of X and order C N = 2 FNU = 1.0E0 X = R1MACH(4)/100.0E0 DO 80 I=1,3 DO 70 KODE=1,2 CALL BESI(X, FNU, KODE, N, Y, NY) CALL BESK(X, FNU, KODE, N, W, NW) ER = Y(2)*W(1) + W(2)*Y(1) - 1.0E0/X ER = ABS(ER)*X IF (ER.GT.TOL) THEN IPASS = 0 IF (KPRINT.GE.2) WRITE (LUN,90020) I,KODE,FNU,X,ER,TOL, + Y(1),Y(2),W(1),W(2) GO TO 700 ENDIF 70 CONTINUE C 700 FNU = R1MACH(4)/100.0E0 X = XX(2*I-1) 80 CONTINUE C C Check large values of X and order C KODE = 2 DO 76 K=1,2 DEL = 30*(K-1) FNU = 45.0E0+DEL DO 75 N=1,2 X = 20.0E0 + DEL DO 71 I=1,5 RX = 1.0E0/X CALL BESI(X, FNU, KODE, N, Y, NY) IF (NY.NE.0) GO TO 71 CALL BESK(X, FNU, KODE, N, W, NW) IF (NW.NE.0) GO TO 71 IF (N.EQ.1) THEN FNUP = FNU + 1.0E0 CALL BESI(X,FNUP,KODE,1,Y(2),NY) IF (NY.NE.0) GO TO 71 CALL BESK(X,FNUP,KODE,1,W(2),NW) IF (NW.NE.0) GO TO 71 ENDIF ER = Y(2)*W(1) + Y(1)*W(2) - RX ER = ABS(ER)*X IF (ER.GT.TOL) THEN IPASS = 0 IF (KPRINT.GE.2) WRITE (LUN,90030) K,N,I,FNUP,X, + ER,TOL,Y(1),Y(2),W(1),W(2) GO TO 760 ENDIF X = X + 10.0E0 71 CONTINUE 75 CONTINUE 76 CONTINUE C C Check underflow flags C 760 X = R1MACH(1)*10.0E0 ALP = 12.3E0 N = 3 CALL BESI(X, ALP, 1, N, Y, NY) IF (NY.NE.3) THEN IPASS = 0 IF (KPRINT.GE.2) WRITE (LUN,90040) ENDIF C X = LOG(R1MACH(2)/10.0E0) + 20.0E0 ALP = 1.3E0 N = 3 CALL BESK(X, ALP, 1, N, W, NW) IF (NW.NE.3) THEN IPASS = 0 IF (KPRINT.GE.2) WRITE (LUN,90050) ENDIF C C Trigger 10 error conditions C CALL XGETF (KONTRL) IF (KPRINT .LE. 2) THEN CALL XSETF (0) ELSE CALL XSETF (1) ENDIF FATAL = .FALSE. CALL XERCLR C IF (KPRINT .GE. 3) WRITE (LUN,90060) XX(1) = 1.0E0 XX(2) = 1.0E0 XX(3) = 1.0E0 XX(4) = 1.0E0 C C Illegal arguments C DO 90 I=1,4 XX(I) = -XX(I) K = INT(XX(3)) N = INT(XX(4)) CALL BESI(XX(1), XX(2), K, N, Y, NY) IF (NUMXER(NERR) .NE. 2) THEN IPASS = 0 FATAL = .TRUE. ENDIF CALL XERCLR CALL BESK(XX(1), XX(2), K, N, W, NW) IF (NUMXER(NERR) .NE. 2) THEN IPASS = 0 FATAL = .TRUE. ENDIF CALL XERCLR XX(I) = -XX(I) 90 CONTINUE C C Trigger overflow C X = LOG(R1MACH(2)/10.0E0) + 20.0E0 N = 3 ALP = 2.3E0 CALL BESI(X, ALP, 1, N, Y, NY) IF (NUMXER(NERR) .NE. 6) THEN IPASS = 0 FATAL = .TRUE. ENDIF CALL XERCLR C X = R1MACH(1)*10.0E0 CALL BESK(X, ALP, 1, N, W, NW) IF (NUMXER(NERR) .NE. 6) THEN IPASS = 0 FATAL = .TRUE. ENDIF CALL XERCLR C CALL XSETF (KONTRL) IF (FATAL) THEN IF (KPRINT .GE. 2) THEN WRITE (LUN, 90070) ENDIF ELSE IF (KPRINT .GE. 3) THEN WRITE (LUN, 90080) ENDIF ENDIF C IF (IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN,90100) IF (IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN,90110) RETURN C 90000 FORMAT (/ ' QUICK CHECKS FOR BESI AND BESK' //) 90010 FORMAT (/ ' ERROR IN QUICK CHECK OF WRONSKIAN', 1P / + ' KODE = ', I1,', M = ', I1, ', N = ', I1, ', NU = ', I1, + ', IX = ', I1, ', I = ', I1 / + ' X = ', E14.7, ', ER = ', E14.7, ', TOL = ', E14.7 / + ' Y(I) = ', E14.7, ', Y(I+1) = ', E14.7 / + ' W(I) = ', E14.7, ', W(I+1) = ', E14.7) 90020 FORMAT (/ ' ERROR IN QUICK CHECK OF SMALL X AND ORDER', 1P / + ' I = ', I1,', KODE = ', I1, ', FNU = ', E14.7 / + ' X = ', E14.7, ', ER = ', E14.7, ', TOL = ', E14.7 / + ' Y(1) = ', E14.7, ', Y(2) = ', E14.7 / + ' W(1) = ', E14.7, ', W(2) = ', E14.7) 90030 FORMAT (/ ' ERROR IN QUICK CHECK OF LARGE X AND ORDER', 1P / + ' K = ', I1,', N = ', I1, ', I = ', I1, + ', FNUP = ', E14.7 / + ' X = ', E14.7, ', ER = ', E14.7, ', TOL = ', E14.7 / + ' Y(1) = ', E14.7, ', Y(2) = ', E14.7 / + ' W(1) = ', E14.7, ', W(2) = ', E14.7) 90040 FORMAT (/ ' ERROR IN BESI UNDERFLOW TEST' /) 90050 FORMAT (/ ' ERROR IN BESK UNDERFLOW TEST' /) 90060 FORMAT (// ' TRIGGER 10 ERROR CONDITIONS' //) 90070 FORMAT (/ ' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED') 90080 FORMAT (/ ' ALL INCORRECT ARGUMENT TESTS PASSED') 90100 FORMAT (/' **********BESI AND BESK PASSED ALL TESTS************') 90110 FORMAT (/' **********BESI OR BESK FAILED SOME TESTS************') END *DECK BJYCK SUBROUTINE BJYCK (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE BJYCK C***PURPOSE Quick check for BESJ and BESY. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (BJYCK-S, DBJYCK-D) C***KEYWORDS QUICK CHECK C***AUTHOR Amos, D. E., (SNLA) C***DESCRIPTION C C BJYCK is a quick check routine for BESJ and BESY. The main loops C evaluate the Wronskian and test the error. Underflow and overflow C diagnostics are checked in addition to illegal arguments. C C***ROUTINES CALLED BESJ, BESY, NUMXER, R1MACH, XERCLR, XGETF, XSETF C***REVISION HISTORY (YYMMDD) C 750101 DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 891004 Removed unreachable code. (WRB) C 891004 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901013 Editorial changes, some restructing and modifications to C obtain more information when there is failure of the C Wronskian. (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C 910708 Code revised to test error returns for all values of C KPRINT. (WRB) C***END PROLOGUE BJYCK INTEGER I, IX, K, KONTRL, LUN, M, N, NERR, NU, NY REAL ALP, DEL, ER, FNU, FNUP, RHPI, RX, TOL, X REAL FN(3), W(5), XX(5), Y(5) REAL R1MACH LOGICAL FATAL C***FIRST EXECUTABLE STATEMENT BJYCK IF (KPRINT.GE.2) WRITE (LUN,90000) C IPASS=1 RHPI = 0.5E0/ATAN(1.0E0) XX(1) = 0.49E0 XX(2) = 1.3E0 XX(3) = 5.3E0 XX(4) = 13.3E0 XX(5) = 21.3E0 FN(1) = 0.095E0 FN(2) = 0.70E0 FN(3) = 0.0E0 TOL = 500.0E0*MAX(R1MACH(4), 7.1E-15) DO 50 M=1,3 DO 40 N=1,4 DO 30 NU=1,4 FNU = FN(M) + 12*(NU-1) DO 20 IX=1,5 IF (IX.LT.2 .AND. NU.GT.3) GO TO 20 X = XX(IX) RX = RHPI/X CALL BESJ(X, FNU, N, Y, NY) IF (NY.NE.0) GO TO 20 CALL BESY(X, FNU, N, W) FNUP = FNU + N CALL BESJ(X,FNUP,1,Y(N+1),NY) IF (NY.NE.0) GO TO 20 CALL BESY(X,FNUP,1,W(N+1)) DO 10 I=1,N ER = Y(I+1)*W(I) - W(I+1)*Y(I) - RX ER = ABS(ER)/RX IF (ER.GT.TOL) THEN IPASS = 0 IF (KPRINT.GE.2) WRITE (LUN,90010) M,N,NU,IX,I, * X,ER,TOL,Y(I),Y(I+1),W(I),W(I+1) ENDIF 10 CONTINUE 20 CONTINUE 30 CONTINUE 40 CONTINUE 50 CONTINUE C C Check small values of X and order C N = 2 FNU = 1.0E0 X = R1MACH(4)/100.0E0 RX = RHPI/X DO 60 I=1,3 CALL BESJ(X, FNU, N, Y, NY) CALL BESY(X, FNU, N, W) ER = Y(2)*W(1) - W(2)*Y(1) - RX ER = ABS(ER)/RX IF (ER.GT.TOL) THEN IPASS = 0 IF (KPRINT.GE.2) WRITE (LUN,90020) I,FNU,X,ER,TOL, + Y(I),Y(I+1),W(I),W(I+1) GO TO 600 ENDIF C FNU = R1MACH(4)/100.0E0 X = XX(2*I-1) RX = RHPI/X 60 CONTINUE C C Check large values of X and order C 600 DO 76 K=1,2 DEL = 30*(K-1) FNU = 70.0E0+DEL DO 75 N=1,2 X = 50.0E0 + DEL DO 70 I=1,5 RX = RHPI/X CALL BESJ(X, FNU, N, Y, NY) IF (NY.NE.0) GO TO 70 CALL BESY(X, FNU, N, W) IF (N.EQ.1) THEN FNUP = FNU + 1.0E0 CALL BESJ(X,FNUP,1,Y(2),NY) IF (NY.NE.0) GO TO 70 CALL BESY(X,FNUP,1,W(2)) ENDIF ER = Y(2)*W(1) - Y(1)*W(2) - RX ER = ABS(ER)/RX IF (ER.GT.TOL) THEN IPASS = 0 IF (KPRINT.GE.2) WRITE (LUN,90030) K,N,I,X,ER,TOL, * Y(1),Y(2),W(1),W(2) GO TO 800 ENDIF X = X + 10.0E0 70 CONTINUE 75 CONTINUE 76 CONTINUE C C Check underflow flags C 800 X = R1MACH(1)*10.0E0 ALP = 12.3E0 N = 3 CALL BESJ(X, ALP, N, Y, NY) IF (NY.NE.3) THEN IPASS = 0 IF (KPRINT.GE.2) WRITE (LUN,90040) ENDIF C C Trigger 7 error conditions C CALL XGETF (KONTRL) IF (KPRINT .LE. 2) THEN CALL XSETF (0) ELSE CALL XSETF (1) ENDIF FATAL = .FALSE. CALL XERCLR C IF (KPRINT .GE. 3) WRITE (LUN,90050) XX(1) = 1.0E0 XX(2) = 1.0E0 XX(3) = 1.0E0 C C Illegal arguments C DO 80 I=1,3 XX(I) = -XX(I) N = INT(XX(3)) CALL BESJ(XX(1), XX(2), N, Y, NY) IF (NUMXER(NERR) .NE. 2) THEN IPASS = 0 FATAL = .TRUE. ENDIF CALL XERCLR CALL BESY(XX(1), XX(2), N, W) IF (NUMXER(NERR) .NE. 2) THEN IPASS = 0 FATAL = .TRUE. ENDIF CALL XERCLR XX(I) = -XX(I) 80 CONTINUE C C Trigger overflow C X = R1MACH(1)*10.0E0 N = 3 ALP = 2.3E0 CALL BESY(X, ALP, N, W) IF (NUMXER(NERR) .NE. 6) THEN IPASS = 0 FATAL = .TRUE. ENDIF CALL XERCLR CALL XSETF (KONTRL) IF (FATAL) THEN IF (KPRINT .GE. 2) THEN WRITE (LUN, 90070) ENDIF ELSE IF (KPRINT .GE. 3) THEN WRITE (LUN, 90080) ENDIF ENDIF C IF (IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN,90100) IF (IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN,90110) RETURN C 90000 FORMAT (/ ' QUICK CHECKS FOR BESJ AND BESY' //) 90010 FORMAT (/ ' ERROR IN QUICK CHECK OF WRONSKIAN', 1P / + ' M = ', I1,', N = ', I1, ', NU = ', I1, ', IX = ', I1, + ', I = ', I1, / + ' X = ', E14.7, ', ER = ', E14.7, ', TOL = ', E14.7 / + ' Y(I) = ', E14.7, ', Y(I+1) = ', E14.7 / + ' W(I) = ', E14.7, ', W(I+1) = ', E14.7) 90020 FORMAT (/ ' ERROR IN QUICK CHECK OF SMALL X AND ORDER', 1P / + ' I = ', I1,', FNU = ', E14.7 / + ' X = ', E14.7, ', ER = ', E14.7, ', TOL = ', E14.7 / + ' Y(1) = ', E14.7, ', Y(2) = ', E14.7 / + ' W(1) = ', E14.7, ', W(2) = ', E14.7) 90030 FORMAT (/ ' ERROR IN QUICK CHECK OF LARGE X AND ORDER', 1P / + ' K = ', I1,', N = ', I1, ', I = ', I1 / + ' X = ', E14.7, ', ER = ', E14.7, ', TOL = ', E14.7 / + ' Y(1) = ', E14.7, ', Y(2) = ', E14.7 / + ' W(1) = ', E14.7, ', W(2) = ', E14.7) 90040 FORMAT (/ ' ERROR IN BESJ UNDERFLOW TEST' /) 90050 FORMAT (// ' TRIGGER 7 ERROR CONDITIONS' //) 90070 FORMAT (/ ' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED') 90080 FORMAT (/ ' ALL INCORRECT ARGUMENT TESTS PASSED') 90100 FORMAT (/' **********BESJ AND BESY PASSED ALL TESTS**********') 90110 FORMAT (/' **********BESJ OR BESY FAILED SOME TESTS**********') END *DECK BLACHK SUBROUTINE BLACHK (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE BLACHK C***PURPOSE Quick check for Basic Linear Algebra Subprograms. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Lawson, C. L., (JPL) C***DESCRIPTION C C ********************************* TBLA *************************** C TEST DRIVER FOR BASIC LINEAR ALGEBRA SUBPROGRAMS. C C. L. LAWSON, JPL, 1974 DEC 10, 1975 MAY 28 C C UPDATED BY K. HASKELL - JUNE 23,1980 C C***ROUTINES CALLED CHECK0, CHECK1, CHECK2, HEADER C***COMMON BLOCKS COMBLA C***REVISION HISTORY (YYMMDD) C 751210 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE BLACHK INTEGER IPASS, JTEST(38) DOUBLE PRECISION DFAC,DQFAC LOGICAL PASS COMMON /COMBLA/ NPRINT, ICASE, N, INCX, INCY, MODE, PASS DATA SFAC,SDFAC,DFAC,DQFAC / .625E-1, .50, .625D-1, 0.625D-1/ DATA JTEST /1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1/ C***FIRST EXECUTABLE STATEMENT BLACHK NPRINT = LUN IPASS = 1 C IF (KPRINT.GE.2) WRITE (NPRINT,1005) 1005 FORMAT(1H1,50HQUICK CHECK OF 38 BASIC LINEAR ALGEBRA SUBROUTINES/) DO 60 ICASE=1,38 IF(JTEST(ICASE) .EQ. 0) GO TO 60 CALL HEADER (KPRINT) C C INITIALIZE PASS, INCX, INCY, AND MODE FOR A NEW CASE. C THE VALUE 9999 FOR INCX, INCY OR MODE WILL APPEAR IN THE C DETAILED OUTPUT, IF ANY, FOR CASES THAT DO NOT INVOLVE C THESE PARAMETERS. C PASS=.TRUE. INCX=9999 INCY=9999 MODE=9999 GO TO (12,12,12,12,12,12,12,12,12,12, A 12,10,10,12,12,10,10,12,12,12, B 12,12,12,12,12,11,11,11,11,11, C 11,11,11,11,11,11,11,11), ICASE C ICASE = 12-13 OR 16-17 10 CALL CHECK0(SFAC,DFAC,KPRINT) GO TO 50 C ICASE = 26-38 11 CALL CHECK1(SFAC,DFAC,KPRINT) GO TO 50 C ICASE = 1-11, 14-15, OR 18-25 12 CALL CHECK2(SFAC,SDFAC,DFAC,DQFAC,KPRINT) 50 CONTINUE C PRINT IF (KPRINT.GE.2 .AND. PASS) WRITE (NPRINT,1001) IF (.NOT.PASS) IPASS = 0 60 CONTINUE IF (KPRINT.GE.2 .AND. IPASS.EQ.1) WRITE (NPRINT,1006) IF (KPRINT.GE.1 .AND. IPASS.EQ.0) WRITE (NPRINT,1007) RETURN 1001 FORMAT(1H+,39X,4HPASS) 1006 FORMAT(/54H ****************BLAS PASSED ALL TESTS****************) 1007 FORMAT(/54H ****************BLAS FAILED SOME TESTS***************) END *DECK BSPCK SUBROUTINE BSPCK (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE BSPCK C***PURPOSE Quick check for the B-Spline package. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (BSPCK-S, DBSPCK-D) C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C BSPCK is a quick check routine for the B-Spline package which C tests consistency between results from higher level routines. C Those routines not explicitly called are exercised at some lower C level. The routines exercised are BFQAD, BINT4, BINTK, BNFAC, C BNSLV, BSGQ8, BSPDR, BSPEV, BSPPP, BSPVD, BSPVN, BSQAD, BVALU, C INTRV, PFQAD, PPGQ8, PPQAD and PPVAL. C C***ROUTINES CALLED BFQAD, BINT4, BINTK, BSPDR, BSPEV, BSPPP, BSPVD, C BSPVN, BSQAD, BVALU, FB, INTRV, PFQAD, PPQAD, C PPVAL, R1MACH C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 891004 Removed unreachable code. (WRB) C 891009 Removed unreferenced variables. (WRB) C 891009 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE BSPCK INTEGER I, IBCL, IBCR, ICNT, ID, IERR, IKNT, ILEFT, ILO, * INBV, INEV, INPPV, ITEST(7), IWORK, J, JHIGH, K, KK, KNT, KNTOPT, * LDC, LDCC, LUN, LXI, MFLAG, N, NDATA, NMK, NN REAL ADIF, ATOL, BC, BQUAD, BV, C, DEN, DN, ER, FBCL, FBCR, * PQUAD, PI, Q, QQ, QSAVE, QUAD, SPV, SV, T, TOL, W, X, XI, * XL, XX, X1, X2, Y, CC REAL BVALU, PPVAL, R1MACH, FB DIMENSION X(11), Y(11), QQ(77), BC(13), T(17), Q(3), QSAVE(2), * XI(11), C(4,10), SV(4), ADIF(52), W(65), CC(4,4) EXTERNAL FB C***FIRST EXECUTABLE STATEMENT BSPCK IF(KPRINT.GE.2) WRITE (LUN,99999) 99999 FORMAT (1H1, 1X, 31HQUICK CHECK FOR SPLINE ROUTINES//) PI = 3.14159265358979324E0 DO 5 I=1,7 5 ITEST(I)=0 ICNT=1 TOL = 1000.0E0*R1MACH(4) C GENERATE DATA NDATA = 11 DEN = NDATA-1 DO 10 I=1,NDATA X(I) = (I-1)/DEN Y(I) = SIN(PI*X(I)) 10 CONTINUE X(3) = 2.0/DEN Y(3) = SIN(PI*X(3)) C COMPUTE SPLINES FOR TWO KNOT ARRAYS DO 80 IKNT=1,2 KNT = 3 - IKNT IBCL = 1 IBCR = 2 FBCL = PI FBCR = 0.0E0 CALL BINT4(X, Y, NDATA, IBCL, IBCR, FBCL, FBCR, KNT, T, BC, N, * K, W) C ERROR TEST ON BINT4 INBV = 1 DO 20 I=1,NDATA XX = X(I) BV = BVALU(T,BC,N,K,0,XX,INBV,W) ER = ABS(Y(I)-BV) IF (ER.LE.TOL) GO TO 20 IF(KPRINT.GE.2) WRITE (LUN,99991) 99991 FORMAT (' ERROR TEST FOR INTERPOLATION BY BINT4 NOT SATISFIED') GO TO 30 20 CONTINUE ITEST(ICNT)=1 ICNT=2 30 CONTINUE INBV = 1 BV = BVALU(T,BC,N,K,1,X(1),INBV,W) ER = ABS(PI-BV) IF (ER.LE.TOL) GO TO 35 IF(KPRINT.GE.2) WRITE (LUN,99989) 99989 FORMAT (' ERROR TEST FOR INTERPOLATION BY BINT4 NOT SATISFIED ', * 'BY FIRST DERIVATIVE') GO TO 40 35 ITEST(ICNT)=1 ICNT=3 40 CONTINUE BV = BVALU(T,BC,N,K,2,X(NDATA),INBV,W) ER = ABS(BV) IF (ER.LE.TOL) GO TO 45 IF(KPRINT.GE.2) WRITE (LUN,99988) 99988 FORMAT (' ERROR TEST FOR INTERPOLATION BY BINT4 NOT SATISFIED ', * 'BY SECOND DERIVATIVE') GO TO 50 45 ITEST(ICNT)=1 ICNT=4 50 CONTINUE C TEST FOR EQUALITY OF AREA FROM 4 ROUTINES X1 = X(1) X2 = X(NDATA) CALL BSQAD(T, BC, N, K, X1, X2, BQUAD, W) LDC = 4 CALL BSPPP(T, BC, N, K, LDC, C, XI, LXI, W) CALL PPQAD(LDC, C, XI, LXI, K, X1, X2, Q(1)) CALL BFQAD(FB, T, BC, N, K, 0, X1, X2, TOL, Q(2), IERR, W) CALL PFQAD(FB, LDC, C, XI, LXI, K, 0, X1, X2, TOL, Q(3), IERR) C ERROR TEST FOR QUADRATURES DO 60 I=1,3 ER = ABS(BQUAD-Q(I)) IF (ER.LE.TOL) GO TO 60 IF(KPRINT.GE.2) WRITE (LUN,99996) 99996 FORMAT (1X, 26HERROR IN QUADRATURE CHECKS) GO TO 70 60 CONTINUE ITEST(ICNT)=1 ICNT=5 70 CONTINUE QSAVE(KNT) = BQUAD 80 CONTINUE ER = ABS(QSAVE(1)-QSAVE(2)) IF (ER.GT.TOL) GO TO 330 ITEST(ICNT)=1 ICNT=6 90 CONTINUE C CHECK BSPDR AND BSPEV AGAINST BVALU, PPVAL AND BSPVD CALL BSPDR(T, BC, N, K, K, ADIF) INEV = 1 INBV = 1 INPPV = 1 ILO = 1 DO 140 I=1,6 XX = X(I+I-1) CALL BSPEV(T, ADIF, N, K, K, XX, INEV, SV, W) ATOL = TOL DO 100 J=1,K SPV = BVALU(T,BC,N,K,J-1,XX,INBV,W) ER = ABS(SPV-SV(J)) X2 = ABS(SV(J)) IF (X2.GT.1.0E0) ER = ER/X2 IF (ER.GT.ATOL) GO TO 340 ATOL = ATOL*10.0E0 100 CONTINUE ATOL = TOL DO 110 J=1,K SPV = PPVAL(LDC,C,XI,LXI,K,J-1,XX,INPPV) ER = ABS(SPV-SV(J)) X2 = ABS(SV(J)) IF (X2.GT.1.0E0) ER = ER/X2 IF (ER.GT.ATOL) GO TO 350 ATOL = ATOL*10.E0 110 CONTINUE ATOL = TOL LDCC = 4 X1 = XX IF (I+I-1.EQ.NDATA) X1 = T(N) NN = N + K CALL INTRV(T, NN, X1, ILO, ILEFT, MFLAG) DO 130 J=1,K CALL BSPVD(T, K, J, XX, ILEFT, LDCC, CC, W) ER = 0.0E0 DO 120 JJ=1,K ER = ER + BC(ILEFT-K+JJ)*CC(JJ,J) 120 CONTINUE ER = ABS(ER-SV(J)) X2 = ABS(SV(J)) IF (X2.GT.1.0E0) ER = ER/X2 IF (ER.GT.ATOL) GO TO 360 ATOL = ATOL*10.0E0 130 CONTINUE 140 CONTINUE ITEST(ICNT)=1 ICNT=7 150 CONTINUE DO 190 K=2,4 N = NDATA NMK = N - K DO 160 I=1,K T(I) = X(1) T(N+I) = X(N) 160 CONTINUE XL = X(N) - X(1) DN = N - K + 1 DO 170 I=1,NMK T(K+I) = X(1) + I*XL/DN 170 CONTINUE CALL BINTK(X, Y, T, N, K, BC, QQ, W) C ERROR TEST ON BINTK INBV = 1 DO 180 I=1,N XX = X(I) BV = BVALU(T,BC,N,K,0,XX,INBV,W) ER = ABS(Y(I)-BV) IF (ER.GT.TOL) GO TO 380 180 CONTINUE 190 CONTINUE ITEST(ICNT)=1 200 CONTINUE IPASS=1 DO 2000 I=1,7 2000 IPASS=IPASS*ITEST(I) IF(KPRINT.LE.1) GO TO 3100 C C TRIGGER ERROR CONDITIONS C IF(KPRINT.GE.3) WRITE (LUN,99997) 99997 FORMAT (/, 1X, 27HTRIGGER 52 ERROR CONDITIONS/) C C W(1) = 11.0E0 W(2) = 4.0E0 W(3) = 2.0E0 W(4) = 0.5E0 W(5) = 4.0E0 ILO = 1 INEV = 1 INBV = 1 CALL INTRV(T, N+1, W(4), ILO, ILEFT, MFLAG) DO 280 I=1,5 W(I) = -W(I) N = INT(W(1)) K = INT(W(2)) ID = INT(W(3)) XX = W(4) LDC = INT(W(5)) IF (I.EQ.5) GO TO 210 BV = BVALU(T,BC,N,K,ID,XX,INBV,QQ) CALL BSPEV(T, ADIF, N, K, ID, XX, INEV, SV, QQ) JHIGH = N - 10 CALL BSPVN(T, JHIGH, K, ID, XX, ILEFT, SV, QQ, IWORK) CALL BFQAD(FB, T, BC, N, K, ID, XX, X2, TOL, QUAD, IERR, QQ) 210 CONTINUE IF (I.EQ.3 .OR. I.EQ.4) GO TO 220 CALL BSPPP(T, BC, N, K, LDC, C, XI, LXI, QQ) 220 CONTINUE IF (I.EQ.4 .OR. I.EQ.5) GO TO 230 CALL BSPDR(T, BC, N, K, ID, ADIF) 230 CONTINUE IF (I.EQ.3 .OR. I.EQ.5) GO TO 240 CALL BSQAD(T, BC, N, K, XX, X2, BQUAD, QQ) 240 CONTINUE IF (I.EQ.1) GO TO 250 CALL BSPVD(T, K, ID, XX, ILEFT, LDC, C, QQ) 250 CONTINUE IF (I.GT.2) GO TO 260 CALL BINTK(X, Y, T, N, K, BC, QQ, ADIF) 260 CONTINUE IF (I.EQ.4) GO TO 270 KNTOPT = LDC - 2 IBCL = K - 2 CALL BINT4(X, Y, N, IBCL, ID, FBCL, FBCR, KNTOPT, T, BC, NN, * KK, QQ) 270 CONTINUE W(I) = -W(I) 280 CONTINUE KNTOPT = 1 X(1) = 1.0E0 CALL BINT4(X, Y, N, IBCL, IBCR, FBCL, FBCR, KNTOPT, T, BC, N, K, * QQ) CALL BINTK(X, Y, T, N, K, BC, QQ, ADIF) X(1) = 0.0E0 ATOL = 1.0E0 KNTOPT = 3 DO 290 I=1,3 QQ(I) = -.30E0 + 0.10E0*(I-1) QQ(3+I) = 1.1E0 + 0.10E0*(I-1) 290 CONTINUE QQ(1) = 1.0E0 CALL BINT4(X, Y, NDATA, 1, 1, FBCL, FBCR, 3, T, BC, N, K, QQ) CALL BFQAD(FB, T, BC, N, K, ID, X1, X2, ATOL, QUAD, IERR, QQ) INPPV = 1 DO 310 I=1,5 W(I) = -W(I) LXI = INT(W(1)) K = INT(W(2)) ID = INT(W(3)) XX = W(4) LDC = INT(W(5)) SPV = PPVAL(LDC,C,XI,LXI,K,ID,XX,INPPV) CALL PFQAD(FB, LDC, C, XI, LXI, K, ID, XX, X2, TOL, QUAD, IERR) IF (I.EQ.3) GO TO 300 CALL PPQAD(LDC, C, XI, LXI, K, XX, X2, PQUAD) 300 CONTINUE W(I) = -W(I) 310 CONTINUE LDC = INT(W(5)) CALL PFQAD(FB, LDC, C, XI, LXI, K, ID, X1, X2, ATOL, QUAD, IERR) 3100 CONTINUE IF(IPASS.EQ.1.AND.KPRINT.GE.2) WRITE(LUN,99980) IF(IPASS.EQ.0.AND.KPRINT.GE.1) WRITE(LUN,99981) 99980 FORMAT(/54H **********B-SPLINE PACKAGE PASSED ALL TESTS**********) 99981 FORMAT(/54H *********B-SPLINE PACKAGE FAILED SOME TESTS**********) RETURN C C 330 CONTINUE IF(KPRINT.GE.2) WRITE (LUN,99995) 99995 FORMAT (1X, 49HERROR IN QUADRATURE CHECK USING TWO SETS OF KNOTS) GO TO 90 340 CONTINUE IF(KPRINT.GE.2) WRITE (LUN,99994) 99994 FORMAT (1X, 45HCOMPARISONS FROM BSPEV AND BVALU DO NOT AGREE) GO TO 150 350 CONTINUE IF(KPRINT.GE.2) WRITE (LUN,99993) 99993 FORMAT (1X, 45HCOMPARISONS FROM BSPEV AND PPVAL DO NOT AGREE) GO TO 150 360 CONTINUE IF(KPRINT.GE.2) WRITE (LUN,99992) 99992 FORMAT (1X, 45HCOMPARISONS FROM BSPEV AND BSPVD DO NOT AGREE) GO TO 150 380 CONTINUE IF(KPRINT.GE.2) WRITE(LUN,99990) 99990 FORMAT (' ERROR TEST FOR INTERPOLATION BY BINTK NOT SATISFIED') GO TO 200 END *DECK CCHQC SUBROUTINE CCHQC (LUN, KPRINT, NERR) C***BEGIN PROLOGUE CCHQC C***PURPOSE Quick check for CCHDC. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Voorhees, E. A., (LANL) C***DESCRIPTION C C QUICK CHECK FOR LINPACK SUBROUTINE CCHDC. C C THE CHOLESKY FACTORIZATION OF MATRIX A IS COMPARED TO C THE STORED PRE-COMPUTED FACTORIZATION OF A (ENTERED C WITH A DATA STATEMENT). FAILURE OF THE TEST OCCURS WHEN C AGREEMENT TO 3 SIGNIFICANT DIGITS IS NOT ACHIEVED AND AN C ERROR MESSAGE IS PRINTED. C C THE INTEGER VALUES OF JPVT AND INFO ARE SIMILARLY TESTED. C LACK OF AGREEMENT RESULTS IN AN ERROR MESSAGE. A SUMMARY C LINE IS ALWAYS PRINTED. C C NO INPUT ARGUMENTS ARE REQUIRED. ON RETURN, NERR (INTEGER C TYPE) CONTAINS THE TOTAL COUNT OF ALL FAILURES DETECTED. C C***ROUTINES CALLED CCHDC C***REVISION HISTORY (YYMMDD) C 801027 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF and cleaned up C FORMATs. (RWC) C***END PROLOGUE CCHQC COMPLEX A(4,4),WORK(4),AT(5,4),AF(4,4) INTEGER LDA,P,JPVT(4),JOB,INFO,JPVTT(4),I,J,INFOC,JPVTC(4) CHARACTER*20 KFAIL INTEGER INDX REAL DELX DATA A/(2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), 1 (0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 2 (0.E0,0.E0),(0.E0,0.E0),(3.E0,0.E0),(0.E0,1.E0), 3 (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/ DATA JPVT/0,-1,1,0/ DATA AF/(1.73205E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), 1 (0.E0,-.57735E0),(1.91485E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 2 (0.E0,0.E0),(0.E0,0.E0),(1.41421E0,0.E0),(0.E0,1.E0), 3 (0.E0,0.E0),(0.E0,0.E0),(0.E0,-.70711E0),(1.22475E0,0.E0)/ DATA INFOC/4/ DATA JPVTC/3,4,1,2/ DATA KFAIL/'FACTORING JPVT INFO '/ C***FIRST EXECUTABLE STATEMENT CCHQC JOB = 1 LDA = 5 P = 4 NERR = 0 C C FORM AT AND JPVTT. C DO 20 J=1,P JPVTT(J) = JPVT(J) DO 10 I=1,P AT(I,J) = A(I,J) 10 CONTINUE 20 CONTINUE C C TEST CCHDC. C CALL CCHDC(AT,LDA,P,WORK,JPVTT,JOB,INFO) INDX = 0 DO 40 J=1,P DO 30 I=1,P DELX =ABS(REAL(AT(I,J)-AF(I,J)))+ABS(AIMAG(AT(I,J)-AF(I,J))) IF (DELX .GT. .0001) INDX=INDX+1 30 CONTINUE 40 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KFAIL(1:9) NERR = NERR + 1 ENDIF C INDX = 0 DO 60 I=1,P IF (JPVTT(I) .NE. JPVTC(I)) INDX=INDX+1 60 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KFAIL(11:14) NERR = NERR + 1 ENDIF C IF (INFO .NE. INFOC) THEN WRITE (LUN,201) KFAIL(16:19) NERR = NERR + 1 ENDIF C IF (KPRINT.GE.2 .OR. NERR.NE.0) WRITE (LUN,200) NERR RETURN C 200 FORMAT (/' * CCHQC - TEST FOR CCHDC FOUND ', I1, ' ERRORS.'/ 1 6X, '(NO TEST FOR CCHUD, CCHDD OR CCHEX)'/) 201 FORMAT (/' *** CCHDC FAILURE - ERROR IN ', A) END *DECK CDQAG SUBROUTINE CDQAG (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CDQAG C***PURPOSE Quick check for DQAG. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (CQAG-S, CDQAG-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED D1MACH, DF1G, DF2G, DF3G, DPRIN, DQAG C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Added PASS/FAIL message and changed the name of the first C argument. (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C***END PROLOGUE CDQAG C C FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC C DOUBLE PRECISION A,ABSERR,B,D1MACH,EPMACH,EPSABS,EPSREL,ERROR, *EXACT1,EXACT2,EXACT3,DF1G,DF2G,DF3G,PI,RESULT,UFLOW,WORK INTEGER IER,IP,IPASS,IWORK,KEY,KPRINT,LAST,LENW,LIMIT, * NEVAL DIMENSION IERV(2),IWORK(100),WORK(400) EXTERNAL DF1G,DF2G,DF3G DATA PI/0.31415926535897932D+01/ DATA EXACT1/0.1154700538379252D+01/ DATA EXACT2/0.11780972450996172D+00/ DATA EXACT3/0.1855802D+02/ C***FIRST EXECUTABLE STATEMENT CDQAG IF (KPRINT.GE.2) WRITE (LUN, '(''1DQAG QUICK CHECK''/)') C C TEST ON IER = 0 C IPASS = 1 LIMIT = 100 LENW = LIMIT*4 EPSABS = 0.0D+00 EPMACH = D1MACH(4) KEY = 6 EPSREL = MAX(SQRT(EPMACH),0.1D-07) A = 0.0D+00 B = 0.1D+01 CALL DQAG(DF1G,A,B,EPSABS,EPSREL,KEY,RESULT,ABSERR,NEVAL,IER, *LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 ERROR = ABS(EXACT1-RESULT) IF(IER.EQ.0.AND.ERROR.LE.ABSERR.AND.ABSERR.LE.EPSREL*ABS(EXACT1)) * IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,0,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 1 C LIMIT = 1 LENW = LIMIT*4 B = PI*0.2D+01 CALL DQAG(DF2G,A,B,EPSABS,EPSREL,KEY,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,1,KPRINT,IP,EXACT2,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 2 OR 1 C UFLOW = D1MACH(1) LIMIT = 100 LENW = LIMIT*4 CALL DQAG(DF2G,A,B,UFLOW,0.0D+00,KEY,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 IF(IER.EQ.2.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,2,KPRINT,IP,EXACT2,RESULT,ABSERR,NEVAL,IERV,2) C C TEST ON IER = 3 OR 1 C B = 0.1D+01 CALL DQAG(DF3G,A,B,EPSABS,EPSREL,1,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 IF(IER.EQ.3.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,3,KPRINT,IP,EXACT3,RESULT,ABSERR,NEVAL,IERV,2) C C TEST ON IER = 6 C LENW = 1 CALL DQAG(DF1G,A,B,EPSABS,EPSREL,KEY,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.6.AND.RESULT.EQ.0.0D+00.AND.ABSERR.EQ.0.0D+00.AND. * NEVAL.EQ.0.AND.LAST.EQ.0) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,6,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) C IF (KPRINT.GE.1) THEN IF (IPASS.EQ.0) THEN WRITE(LUN, '(/'' SOME TEST(S) IN CDQAG FAILED''/)') ELSEIF (KPRINT.GE.2) THEN WRITE(LUN, '(/'' ALL TEST(S) IN CDQAG PASSED''/)') ENDIF ENDIF RETURN END *DECK CDQAGI SUBROUTINE CDQAGI (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CDQAGI C***PURPOSE Quick check for DQAGI. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (CQAGI-S, CDQAGI-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED D1MACH, DPRIN, DQAGI, DT0, DT1, DT2, DT3, DT4, DT5 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891009 Removed unreferenced variables. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Added PASS/FAIL message and changed the name of the first C argument. (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C***END PROLOGUE CDQAGI C C FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC C DOUBLE PRECISION ABSERR,BOUND,D1MACH,EPMACH,EPSABS, * EPSREL,ERROR,EXACT0,EXACT1,EXACT2,EXACT3,EXACT4, * OFLOW,RESULT,DT0,DT1,DT2,DT3,DT4,DT5,UFLOW,WORK INTEGER IER,IP,IPASS,IWORK,KPRINT,LAST,LENW,LIMIT,LUN,NEVAL DIMENSION WORK(800),IWORK(200),IERV(4) EXTERNAL DT0,DT1,DT2,DT3,DT4,DT5 DATA EXACT0/2.0D+00/,EXACT1/0.115470066904D1/ DATA EXACT2/0.909864525656D-02/ DATA EXACT3/0.31415926535897932D+01/ DATA EXACT4/0.19984914554328673D+04/ C***FIRST EXECUTABLE STATEMENT CDQAGI IF (KPRINT.GE.2) WRITE (LUN, '(''1DQAGI QUICK CHECK''/)') C C TEST ON IER = 0 C IPASS = 1 LIMIT = 200 LENW = LIMIT*4 EPSABS = 0.0D+00 EPMACH = D1MACH(4) EPSREL = MAX(SQRT(EPMACH),0.1D-07) BOUND = 0.0D+00 INF = 1 CALL DQAGI(DT0,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) ERROR = ABS(RESULT-EXACT0) IERV(1) = IER IP = 0 IF(IER.EQ.0.AND.ERROR.LE.EPSREL*ABS(EXACT0)) * IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 1 C CALL DQAGI(DT1,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, * 1,4,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,1,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 2 OR 4 OR 1 C UFLOW = D1MACH(1) CALL DQAGI(DT2,BOUND,INF,UFLOW,0.0D+00,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IP = 0 IF(IER.EQ.2.OR.IER.EQ.4.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,2,KPRINT,IP,EXACT2,RESULT,ABSERR,NEVAL,IERV,3) C C TEST ON IER = 3 OR 4 OR 1 OR 2 C CALL DQAGI(DT3,BOUND,INF,UFLOW,0.0D+00,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IERV(4) = 2 IP = 0 IF(IER.EQ.3.OR.IER.EQ.4.OR.IER.EQ.1.OR.IER.EQ.2) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,3,KPRINT,IP,EXACT3,RESULT,ABSERR,NEVAL,IERV,4) C C TEST ON IER = 4 OR 3 OR 1 OR 0 C CALL DQAGI(DT4,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 3 IERV(3) = 1 IERV(4) = 0 IP = 0 IF(IER.EQ.4.OR.IER.EQ.3.OR.IER.EQ.1.OR.IER.EQ.0) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,4,KPRINT,IP,EXACT4,RESULT,ABSERR,NEVAL,IERV,4) C C TEST ON IER = 5 C OFLOW = D1MACH(2) CALL DQAGI(DT5,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.5) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,5,KPRINT,IP,OFLOW,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 6 C CALL DQAGI(DT1,BOUND,INF,EPSABS,0.0D+00,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.6.AND.RESULT.EQ.0.0D+00.AND.ABSERR.EQ.0.0D+00.AND. * NEVAL.EQ.0.AND.LAST.EQ.0) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,6,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) C IF (KPRINT.GE.1) THEN IF (IPASS.EQ.0) THEN WRITE(LUN, '(/'' SOME TEST(S) IN CDQAGI FAILED''/)') ELSEIF (KPRINT.GE.2) THEN WRITE(LUN, '(/'' ALL TEST(S) IN CDQAGI PASSED''/)') ENDIF ENDIF RETURN END *DECK CDQAGP SUBROUTINE CDQAGP (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CDQAGP C***PURPOSE Quick check for DQAGP. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (CQAGP-S, CDQAGP-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED D1MACH, DF1P, DF2P, DF3P, DF4P, DPRIN, DQAGP C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Added PASS/FAIL message and changed the name of the first C argument. (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C***END PROLOGUE CDQAGP C C FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC C DOUBLE PRECISION A,ABSERR,B,D1MACH,EPMACH,EPSABS,EPSREL,ERROR, * EXACT1, * EXACT2,EXACT3,DF1P,DF2P,DF3P,DF4P,OFLOW,POINTS,P1,P2,RESULT, * UFLOW,WORK INTEGER IER,IP,IPASS,IWORK,KPRINT,LAST,LENIW,LENW,LIMIT,LUN, * NEVAL,NPTS2 DIMENSION IERV(4),IWORK(205),POINTS(5),WORK(405) EXTERNAL DF1P,DF2P,DF3P,DF4P DATA EXACT1/0.4285277667368085D+01/ DATA EXACT2/0.909864525656D-2/ DATA EXACT3/0.31415926535897932D+01/ DATA P1/0.1428571428571428D+00/ DATA P2/0.6666666666666667D+00/ C***FIRST EXECUTABLE STATEMENT CDQAGP IF (KPRINT.GE.2) WRITE (LUN, '(''1DQAGP QUICK CHECK''/)') C C TEST ON IER = 0 C IPASS = 1 NPTS2 = 4 LIMIT = 100 LENIW = LIMIT*2+NPTS2 LENW = LIMIT*4+NPTS2 EPSABS = 0.0D+00 EPMACH = D1MACH(4) EPSREL = MAX(SQRT(EPMACH),0.1D-07) A = 0.0D+00 B = 0.1D+01 POINTS(1) = P1 POINTS(2) = P2 CALL DQAGP(DF1P,A,B,NPTS2,POINTS,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,LENIW,LENW,LAST,IWORK,WORK) ERROR = ABS(RESULT-EXACT1) IERV(1) = IER IP=0 IF(IER.EQ.0.AND.ERROR.LE.EPSREL*ABS(EXACT1)) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,0,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 1 C LENIW = 10 LENW = LENIW*2-NPTS2 CALL DQAGP(DF1P,A,B,NPTS2,POINTS,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,LENIW,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,1,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 2, 4, 1 OR 3 C NPTS2 = 3 POINTS(1) = 0.1D+00 LENIW = LIMIT*2+NPTS2 LENW = LIMIT*4+NPTS2 UFLOW = D1MACH(1) A = 0.1D+00 CALL DQAGP(DF2P,A,B,NPTS2,POINTS,UFLOW,0.0D+00,RESULT,ABSERR, * NEVAL,IER,LENIW,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IERV(4) = 3 IP = 0 IF(IER.EQ.2.OR.IER.EQ.4.OR.IER.EQ.1.OR.IER.EQ.3) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,2,KPRINT,IP,EXACT2,RESULT,ABSERR,NEVAL,IERV,4) C C TEST ON IER = 3 OR 4 OR 1 OR 2 C NPTS2 = 2 LENIW = LIMIT*2+NPTS2 LENW = LIMIT*4+NPTS2 A = 0.0D+00 B = 0.5D+01 CALL DQAGP(DF3P,A,B,NPTS2,POINTS,UFLOW,0.0D+00,RESULT,ABSERR, * NEVAL,IER,LENIW,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IERV(4) = 2 IP = 0 IF(IER.EQ.3.OR.IER.EQ.4.OR.IER.EQ.1.OR.IER.EQ.2) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,3,KPRINT,IP,EXACT3,RESULT,ABSERR,NEVAL,IERV,4) C C TEST ON IER = 5 C B = 0.1D+01 CALL DQAGP(DF4P,A,B,NPTS2,POINTS,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,LENIW,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.5) IP = 1 IF(IP.EQ.0) IPASS = 0 OFLOW = D1MACH(2) CALL DPRIN(LUN,5,KPRINT,IP,OFLOW,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 6 C NPTS2 = 5 LENIW = LIMIT*2+NPTS2 LENW = LIMIT*4+NPTS2 POINTS(1) = P1 POINTS(2) = P2 POINTS(3) = 0.3D+01 CALL DQAGP(DF1P,A,B,NPTS2,POINTS,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,LENIW,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.6.AND.RESULT.EQ.0.0D+00.AND.ABSERR.EQ.0.0D+00.AND. * NEVAL.EQ.0.AND.LAST.EQ.0) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,6,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) C IF (KPRINT.GE.1) THEN IF (IPASS.EQ.0) THEN WRITE(LUN, '(/'' SOME TEST(S) IN CDQAGP FAILED''/)') ELSEIF (KPRINT.GE.2) THEN WRITE(LUN, '(/'' ALL TEST(S) IN CDQAGP PASSED''/)') ENDIF ENDIF RETURN END *DECK CDQAGS SUBROUTINE CDQAGS (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CDQAGS C***PURPOSE Quick check for DQAGS. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (CQAGS-S, CDQAGS-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED D1MACH, DF0S, DF1S, DF2S, DF3S, DF4S, DF5S, DPRIN, C DQAGS C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Added PASS/FAIL message and changed the name of the first C argument. (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C 911114 Modified test on IER=4 to allow IER=5. (WRB) C***END PROLOGUE CDQAGS C C FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC C DOUBLE PRECISION A,ABSERR,B,D1MACH,EPMACH,EPSABS, * EPSREL,ERROR,EXACT0,EXACT1,EXACT2,EXACT3,EXACT4, * DF0S,DF1S,DF2S,DF3S,DF4S,DF5S,OFLOW,RESULT,UFLOW,WORK INTEGER IER,IP,IPASS,IWORK,KPRINT,LAST,LENW,LIMIT,NEVAL DIMENSION IERV(5),IWORK(200),WORK(800) EXTERNAL DF0S,DF1S,DF2S,DF3S,DF4S,DF5S DATA EXACT0/0.2D+01/ DATA EXACT1/0.115470066904D+01/ DATA EXACT2/0.909864525656D-02/ DATA EXACT3/0.31415926535897932D+01/ DATA EXACT4/0.19984914554328673D+04/ C***FIRST EXECUTABLE STATEMENT CDQAGS IF (KPRINT.GE.2) WRITE (LUN, '(''1DQAGS QUICK CHECK''/)') C C TEST ON IER = 0 C IPASS = 1 LIMIT = 200 LENW = LIMIT*4 EPSABS = 0.0D+00 EPMACH = D1MACH(4) EPSREL = MAX(SQRT(EPMACH),0.1D-07) A = 0.0D+00 B = 0.1D+01 CALL DQAGS(DF0S,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) ERROR = ABS(RESULT-EXACT0) IERV(1) = IER IP = 0 IF(IER.EQ.0.AND.ERROR.LE.EPSREL*ABS(EXACT0)) * IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 1 C CALL DQAGS(DF1S,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, * 1,4,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.1)IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,1,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 2 OR 4 OR 1 C UFLOW = D1MACH(1) A = 0.1D+00 CALL DQAGS(DF2S,A,B,UFLOW,0.0D+00,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IP = 0 IF(IER.EQ.2.OR.IER.EQ.4.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,2,KPRINT,IP,EXACT2,RESULT,ABSERR,NEVAL,IERV,3) C C TEST ON IER = 3 OR 4 OR 1 OR 2 C A = 0.0D+00 B = 0.5D+01 CALL DQAGS(DF3S,A,B,UFLOW,0.0D+00,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IERV(4) = 2 IP = 0 IF(IER.EQ.3.OR.IER.EQ.4.OR.IER.EQ.1.OR.IER.EQ.2) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,3,KPRINT,IP,EXACT3,RESULT,ABSERR,NEVAL,IERV,4) C C TEST ON IER = 4, OR 5 OR 3 OR 1 OR 0 C B = 0.1D+01 CALL DQAGS(DF4S,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 5 IERV(3) = 3 IERV(4) = 1 IERV(5) = 0 IP = 0 IF(IER.EQ.5.OR.IER.EQ.4.OR.IER.EQ.3.OR.IER.EQ.1.OR.IER.EQ.0) * IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,4,KPRINT,IP,EXACT4,RESULT,ABSERR,NEVAL,IERV,5) C C TEST ON IER = 5 C OFLOW = D1MACH(2) CALL DQAGS(DF5S,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.5) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,5,KPRINT,IP,OFLOW,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 6 C CALL DQAGS(DF1S,A,B,EPSABS,0.0D+00,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.6.AND.RESULT.EQ.0.0D+00.AND.ABSERR.EQ.0.0D+00.AND. * NEVAL.EQ.0.AND.LAST.EQ.0) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,6,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) C IF (KPRINT.GE.1) THEN IF (IPASS.EQ.0) THEN WRITE(LUN, '(/'' SOME TEST(S) IN CDQAGS FAILED''/)') ELSEIF (KPRINT.GE.2) THEN WRITE(LUN, '(/'' ALL TEST(S) IN CDQAGS PASSED''/)') ENDIF ENDIF RETURN END *DECK CDQAWC SUBROUTINE CDQAWC (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CDQAWC C***PURPOSE Quick check for DQAWC. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (CQAWC-S, CDQAWC-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED D1MACH, DF0C, DF1C, DPRIN, DQAWC C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Added PASS/FAIL message and changed the name of the first C argument. (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C***END PROLOGUE CDQAWC C C FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC C DOUBLE PRECISION A,ABSERR,B,D1MACH,EPMACH,EPSABS, * EPSREL,ERROR,EXACT0,EXACT1,DF0C,DF1C,C, * RESULT,UFLOW,WORK INTEGER IER,IP,IPASS,IWORK,KPRINT,LAST,LENW,LIMIT,NEVAL DIMENSION WORK(800),IWORK(200),IERV(2) EXTERNAL DF0C,DF1C DATA EXACT0/-0.6284617285065624D+03/ DATA EXACT1/0.1855802D+01/ C***FIRST EXECUTABLE STATEMENT CDQAWC IF (KPRINT.GE.2) WRITE (LUN, '(''1DQAWC QUICK CHECK''/)') C C TEST ON IER = 0 C IPASS = 1 C = 0.5D+00 A = -1.0D+00 B = 1.0D+00 LIMIT = 200 LENW = LIMIT*4 EPSABS = 0.0D+00 EPMACH = D1MACH(4) EPSREL = MAX(SQRT(EPMACH),0.1D-07) CALL DQAWC(DF0C,A,B,C,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 ERROR = ABS(EXACT0-RESULT) IF(IER.EQ.0.AND.ERROR.LE.ABSERR.AND.ABSERR.LE.EPSREL*ABS(EXACT0)) * IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 1 C CALL DQAWC(DF0C,A,B,C,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,1,4,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,1,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 2 OR 1 C UFLOW = D1MACH(1) CALL DQAWC(DF0C,A,B,C,UFLOW,0.0D+00,RESULT,ABSERR, * NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 IF(IER.EQ.2.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,2,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,2) C C TEST ON IER = 3 OR 1 C CALL DQAWC(DF1C,0.0D+00,B,C,UFLOW,0.0D+00,RESULT,ABSERR, * NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 IF(IER.EQ.3.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,3,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,2) C C TEST ON IER = 6 C EPSABS = 0.0D+00 EPSREL = 0.0D+00 CALL DQAWC(DF0C,A,B,C,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.6) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,6,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C IF (KPRINT.GE.1) THEN IF (IPASS.EQ.0) THEN WRITE(LUN, '(/'' SOME TEST(S) IN CDQAWC FAILED''/)') ELSEIF (KPRINT.GE.2) THEN WRITE(LUN, '(/'' ALL TEST(S) IN CDQAWC PASSED''/)') ENDIF ENDIF RETURN END *DECK CDQAWF SUBROUTINE CDQAWF (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CDQAWF C***PURPOSE Quick check for DQAWF. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (CQAWF-S, CDQAWF-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED D1MACH, DF0F, DF1F, DPRIN, DQAWF C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Added PASS/FAIL message and changed the name of the first C argument. (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C***END PROLOGUE CDQAWF C C FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC C DOUBLE PRECISION A,ABSERR,D1MACH,EPSABS,EPMACH, * ERROR,EXACT0,DF0F,DF1F,OMEGA,PI,RESULT,UFLOW,WORK INTEGER IER,IP,IPASS,KPRINT,LENW,LIMIT,LIMLST,LST,NEVAL DIMENSION IERV(4),IWORK(450),WORK(1425) EXTERNAL DF0F,DF1F DATA EXACT0/0.1422552162575912D+01/ DATA PI/0.31415926535897932D+01/ C***FIRST EXECUTABLE STATEMENT CDQAWF IF (KPRINT.GE.2) WRITE (LUN, '(''1DQAWF QUICK CHECK''/)') C C TEST ON IER = 0 C IPASS = 1 MAXP1 = 21 LIMLST = 50 LIMIT = 200 LENIW = LIMIT*2+LIMLST LENW = LENIW*2+MAXP1*25 EPMACH = D1MACH(4) EPSABS = MAX(SQRT(EPMACH),0.1D-02) A = 0.0D+00 OMEGA = 0.8D+01 INTEGR = 2 CALL DQAWF(DF0F,A,OMEGA,INTEGR,EPSABS,RESULT,ABSERR,NEVAL, * IER,LIMLST,LST,LENIW,MAXP1,LENW,IWORK,WORK) IERV(1) = IER IP = 0 ERROR = ABS(EXACT0-RESULT) IF(IER.EQ.0.AND.ERROR.LE.ABSERR.AND.ABSERR.LE.EPSABS) * IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 1 C LIMLST = 3 LENIW = 403 LENW = LENIW*2+MAXP1*25 CALL DQAWF(DF0F,A,OMEGA,INTEGR,EPSABS,RESULT,ABSERR,NEVAL, * IER,LIMLST,LST,LENIW,MAXP1,LENW,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,1,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 3 OR 4 OR 1 OR 2 C LIMLST = 50 LENIW = LIMIT*2+LIMLST LENW = LENIW*2+MAXP1*25 UFLOW = D1MACH(1) CALL DQAWF(DF1F,A,0.0D+00,1,UFLOW,RESULT,ABSERR,NEVAL, * IER,LIMLST,LST,LENIW,MAXP1,LENW,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IERV(4) = 2 IP = 0 IF(IER.EQ.3.OR.IER.EQ.4.OR.IER.EQ.1.OR.IER.EQ.2) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,3,KPRINT,IP,PI,RESULT,ABSERR,NEVAL,IERV,4) C C TEST ON IER = 6 C LIMLST = 50 LENIW = 20 CALL DQAWF(DF0F,A,OMEGA,INTEGR,EPSABS,RESULT,ABSERR,NEVAL, * IER,LIMLST,LST,LENIW,MAXP1,LENW,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.6) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,6,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 7 C LIMLST = 50 LENIW = 52 LENW = LENIW*2+MAXP1*25 CALL DQAWF(DF0F,A,OMEGA,INTEGR,EPSABS,RESULT,ABSERR,NEVAL, * IER,LIMLST,LST,LENIW,MAXP1,LENW,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.7) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,7,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C IF (KPRINT.GE.1) THEN IF (IPASS.EQ.0) THEN WRITE(LUN, '(/'' SOME TEST(S) IN CDQAWF FAILED''/)') ELSEIF (KPRINT.GE.2) THEN WRITE(LUN, '(/'' ALL TEST(S) IN CDQAWF PASSED''/)') ENDIF ENDIF RETURN END *DECK CDQAWO SUBROUTINE CDQAWO (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CDQAWO C***PURPOSE Quick check for DQAWO. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (CQAWO-S, CDQAWO-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED D1MACH, DF0O, DF1O, DF2O, DPRIN, DQAWO C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Added PASS/FAIL message and changed the name of the first C argument. (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C***END PROLOGUE CDQAWO C C FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC C DOUBLE PRECISION A,ABSERR,B,EPMACH,EPSABS, * EPSREL,ERROR,EXACT0,DF0O,DF1O,DF2O, * OFLOW,OMEGA,PI,RESULT,D1MACH,UFLOW,WORK INTEGER IER,IERV,INTEGR,IP,IPASS,IWORK,KPRINT,LAST,LENW,LUN, * MAXP1,NEVAL DIMENSION WORK(1325),IWORK(400),IERV(4) EXTERNAL DF0O,DF1O,DF2O DATA EXACT0/0.1042872789432789D+05/ DATA PI/0.31415926535897932D+01/ C***FIRST EXECUTABLE STATEMENT CDQAWO IF (KPRINT.GE.2) WRITE (LUN, '(''1DQAWO QUICK CHECK''/)') C C TEST ON IER = 0 C IPASS = 1 MAXP1 = 21 LENIW = 400 LENW = LENIW*2+MAXP1*25 EPSABS = 0.0D+00 EPMACH = D1MACH(4) EPSREL = MAX(SQRT(EPMACH),0.1D-07) A = 0.0D+00 B = PI OMEGA = 0.1D+01 INTEGR = 2 CALL DQAWO(DF0O,A,B,OMEGA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 ERROR = ABS(EXACT0-RESULT) IF(IER.EQ.0.AND.ERROR.LE.ABSERR.AND.ABSERR.LE.EPSREL*ABS(EXACT0)) * IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 1 C LENIW = 2 LENW = LENIW*2+MAXP1*25 CALL DQAWO(DF0O,A,B,OMEGA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,1,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 2 OR 4 OR 1 C UFLOW = D1MACH(1) LENIW = 400 LENW = LENIW*2+MAXP1*25 CALL DQAWO(DF0O,A,B,OMEGA,INTEGR,UFLOW,0.0D+00,RESULT,ABSERR, * NEVAL,IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IP = 0 IF(IER.EQ.2.OR.IER.EQ.4.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,2,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,3) C C TEST ON IER = 3 OR 4 OR 1 OR 2 C B = 0.5D+01 OMEGA = 0.0D+00 INTEGR = 1 CALL DQAWO(DF1O,A,B,OMEGA,INTEGR,UFLOW,0.0D+00,RESULT,ABSERR, * NEVAL,IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IERV(4) = 2 IP = 0 IF(IER.EQ.3.OR.IER.EQ.4.OR.IER.EQ.1.OR.IER.EQ.2) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,3,KPRINT,IP,PI,RESULT,ABSERR,NEVAL,IERV,4) C C TEST ON IER = 5 C B = 0.1D+01 OFLOW = D1MACH(2) CALL DQAWO(DF2O,A,B,OMEGA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.5) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,5,KPRINT,IP,OFLOW,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 6 C INTEGR = 3 CALL DQAWO(DF0O,A,B,OMEGA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.6.AND.RESULT.EQ.0.0D+00.AND.ABSERR.EQ.0.0D+00.AND. * NEVAL.EQ.0.AND.LAST.EQ.0) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,6,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C IF (KPRINT.GE.1) THEN IF (IPASS.EQ.0) THEN WRITE(LUN, '(/'' SOME TEST(S) IN CDQAWO FAILED''/)') ELSEIF (KPRINT.GE.2) THEN WRITE(LUN, '(/'' ALL TEST(S) IN CDQAWO PASSED''/)') ENDIF ENDIF RETURN END *DECK CDQAWS SUBROUTINE CDQAWS (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CDQAWS C***PURPOSE Quick check for DQAWS. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (CQAWS-S, CDQAWS-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED D1MACH, DF0WS, DF1WS, DPRIN, DQAWS C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Added PASS/FAIL message and changed the name of the first C argument. (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C***END PROLOGUE CDQAWS C C FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC C DOUBLE PRECISION A,ABSERR,B,D1MACH,EPMACH,EPSABS, * EPSREL,ERROR,EXACT0,EXACT1,DF0WS,DF1WS,ALFA,BETA, * RESULT,UFLOW,WORK INTEGER IER,IP,IPASS,IWORK,KPRINT,LAST,LENW,LIMIT,NEVAL,INTEGR DIMENSION WORK(800),IWORK(200),IERV(2) EXTERNAL DF0WS,DF1WS DATA EXACT0/0.5350190569223644D+00/ DATA EXACT1/0.1998491554328673D+04/ C***FIRST EXECUTABLE STATEMENT CDQAWS IF (KPRINT.GE.2) WRITE (LUN, '(''1DQAWS QUICK CHECK''/)') C C TEST ON IER = 0 C IPASS = 1 ALFA = -0.5D+00 BETA = -0.5D+00 INTEGR = 1 A = 0.0D+00 B = 0.1D+01 LIMIT = 200 LENW = LIMIT*4 EPSABS = 0.0D+00 EPMACH = D1MACH(4) EPSREL = MAX(SQRT(EPMACH),0.1D-07) CALL DQAWS(DF0WS,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 ERROR = ABS(EXACT0-RESULT) IF(IER.EQ.0.AND.ERROR.LE.EPSREL*ABS(EXACT0)) * IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 1 C CALL DQAWS(DF0WS,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,2,8,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,1,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 2 OR 1 C UFLOW = D1MACH(1) CALL DQAWS(DF0WS,A,B,ALFA,BETA,INTEGR,UFLOW,0.0D+00,RESULT,ABSERR, * NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 IF(IER.EQ.2.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,2,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,2) C C TEST ON IER = 3 OR 1 C CALL DQAWS(DF1WS,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 IF(IER.EQ.3.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,3,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,2) C C TEST ON IER = 6 C INTEGR = 0 CALL DQAWS(DF1WS,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.6) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL DPRIN(LUN,6,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C IF (KPRINT.GE.1) THEN IF (IPASS.EQ.0) THEN WRITE(LUN, '(/'' SOME TEST(S) IN CDQAWS FAILED''/)') ELSEIF (KPRINT.GE.2) THEN WRITE(LUN, '(/'' ALL TEST(S) IN CDQAWS PASSED''/)') ENDIF ENDIF RETURN END *DECK CDQNG SUBROUTINE CDQNG (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CDQNG C***PURPOSE Quick check for DQNG. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (CQNG-S, CDQNG-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED D1MACH, DF1N, DF2N, DPRIN, DQNG C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Added PASS/FAIL message and changed the name of the first C argument. (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C***END PROLOGUE CDQNG C C FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC C DOUBLE PRECISION A,ABSERR,B,D1MACH,EPMACH,EPSABS,EPSREL,EXACT1, * ERROR,EXACT2,DF1N,DF2N,RESULT,UFLOW INTEGER IER,IERV,IP,IPASS,KPRINT,NEVAL DIMENSION IERV(1) EXTERNAL DF1N,DF2N DATA EXACT1/0.7281029132255818D+00/ DATA EXACT2/0.1D+02/ C***FIRST EXECUTABLE STATEMENT CDQNG IF (KPRINT.GE.2) WRITE (LUN, '(''1DQNG QUICK CHECK''/)') C C TEST ON IER = 0 C IPASS = 1 EPSABS = 0.0D+00 EPMACH = D1MACH(4) UFLOW = D1MACH(1) EPSREL = MAX(SQRT(EPMACH),0.1D-07) A=0.0D+00 B=0.1D+01 CALL DQNG(DF1N,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER) CALL DQNG(DF1N,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER) IERV(1)=IER IP = 0 ERROR = ABS(EXACT1-RESULT) IF(IER.EQ.0.AND.ERROR.LE.ABSERR.AND.ABSERR.LE.EPSREL*ABS(EXACT1)) * IP = 1 IF(IP.EQ.0) IPASS = 0 IF(KPRINT.NE.0) CALL DPRIN(LUN,0,KPRINT,IP,EXACT1,RESULT,ABSERR, * NEVAL,IERV,1) C C TEST ON IER = 1 C CALL DQNG(DF2N,A,B,UFLOW,0.0D+00,RESULT,ABSERR,NEVAL,IER) IERV(1) = IER IP=0 IF(IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 IF(KPRINT.NE.0) CALL DPRIN(LUN,1,KPRINT,IP,EXACT2,RESULT,ABSERR, * NEVAL,IERV,1) C C TEST ON IER = 6 C EPSABS = 0.0D+00 EPSREL = 0.0D+00 CALL DQNG(DF1N,A,B,EPSABS,0.0D+00,RESULT,ABSERR,NEVAL,IER) IERV(1) = IER IP = 0 IF(IER.EQ.6.AND.RESULT.EQ.0.0D+00.AND.ABSERR.EQ.0.0D+00.AND. * NEVAL.EQ.0) IP = 1 IF(IP.EQ.0) IPASS = 0 IF(KPRINT.NE.0) CALL DPRIN(LUN,6,KPRINT,IP,EXACT1,RESULT,ABSERR, * NEVAL,IERV,1) C IF (KPRINT.GE.1) THEN IF (IPASS.EQ.0) THEN WRITE(LUN, '(/'' SOME TEST(S) IN CDQNG FAILED''/)') ELSEIF (KPRINT.GE.2) THEN WRITE(LUN, '(/'' ALL TEST(S) IN CDQNG PASSED''/)') ENDIF ENDIF RETURN END *DECK CFNCK SUBROUTINE CFNCK (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CFNCK C***PURPOSE Quick check for the complex Fullerton special functions. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Boland, W. Robert, (LANL) C Chow, Jeff, (LANL) C Rivera, Shawn, (LANL) C***DESCRIPTION C C This subroutine does a quick check for the complex C routines in the Fullerton special function library. C C Parameter list- C C LUN input integer value to designate the external C device unit for message output C KPRINT input integer value to specify amount of C printing to be done by quick check C IPASS output value indicating whether tests passed or C failed C C***ROUTINES CALLED C0LGMC, CACOS, CACOSH, CASIN, CASINH, CATAN, C CATAN2, CATANH, CBETA, CCBRT, CCOSH, CCOT, CEXPRL, C CGAMMA, CGAMR, CLBETA, CLNGAM, CLNREL, CLOG10, C CPSI, CSINH, CTAN, CTANH, R1MACH C***REVISION HISTORY (YYMMDD) C 800901 DATE WRITTEN C 891115 REVISION DATE from Version 3.2 C 891120 Checks of remainder of FNLIB routines added and code C reorganized. (WRB) C 900330 Prologue converted to Version 4.0 format. (BAB) C 900727 Added EXTERNAL statement. (WRB) C***END PROLOGUE CFNCK INTEGER I,LUN,KPRINT,IPASS REAL SQRT2,SQRT3,PI,R1MACH, + ERRMAX,ERRTOL,ABSERR,RELERR COMPLEX C(48),W(48),C1,CI, + C0LGMC,CACOS,CACOSH,CASIN,CASINH,CATAN,CATAN2,CATANH, + CBETA,CCBRT,CCOSH,CCOT,CEXPRL,CGAMMA,CGAMR,CLBETA,CLNGAM, + CLNREL,CLOG10,CPSI,CSINH,CTAN,CTANH EXTERNAL CCOT, CGAMMA C C Constants to be used C DATA C1 /(1.E0,0.E0)/,CI /(0.E0,1.E0)/ DATA SQRT2 /.1414213562 3730950488E1/ DATA SQRT3 /.1732050807 5688772935E1/ DATA PI /3.1415926535 8979323846E0/ C C Complex values through different calculations are stored in C(*) C DATA C( 1) /( .121699028117870E 1, .326091563038355E 0)/ DATA C( 2) /( .866025403784438E 0, .500000000000000E 0)/ DATA C( 3) /( .520802437952465E 0,-.196048071390002E 1)/ DATA C( 4) /( .599865470357589E 0, .113287925945897E 1)/ DATA C( 5) /( .970930856437313E 0,-.113287925945897E 1)/ DATA C( 6) /( .104999388884240E 1, .196048071389998E 1)/ DATA C( 7) /( .313314753080534E-1, .541264220944095E-1)/ DATA C( 8) /(-.785398163397449E 0, .658478948462413E 0)/ DATA C( 9) /(-.785398163397449E 0,-.658478948462413E 0)/ DATA C(10) /( .785398163397449E 0,-.658478948462413E 0)/ DATA C(11) /( .313314753080534E-1, .541264220944095E-1)/ DATA C(12) /(-.313314753080534E-1, .541264220944095E-1)/ DATA C(13) /( .183048772171245E 1, .000000000000000E 0)/ DATA C(14) /(-.757236713834364E-1,-.961745759068982E 0)/ DATA C(15) /(-.813630257280238E-1, .103336966511721E 1)/ DATA C(16) /( .546302489843789E 0, .000000000000000E 0)/ DATA C(17) /( .150514997831990E 0,-.341094088460459E 0)/ DATA C(18) /( .301029995663980E 0, .227396058973639E 0)/ DATA C(19) /( .000000000000000E 0, .636619772367581E 0)/ DATA C(20) /( .137802461354738E 1, .909330673631480E 0)/ DATA C(21) /( .303123109082158E-1,-.244978663126864E 0)/ DATA C(22) /( .693147180559947E 0, .523598775598298E 0)/ DATA C(23) /(-.152857091948100E 1, .114371774040242E 1)/ DATA C(24) /( .144363547517882E 1, .157079632679490E 1)/ DATA C(25) /(-.100000000000000E 1, .000000000000000E 0)/ DATA C(26) /( .181878614736412E 1, .586225017697977E 0)/ DATA C(27) /( .402359478108525E 0, .101722196789785E 1)/ DATA C(28) /( .549306144334055E 0,-.157079632679490E 1)/ DATA C(29) /( .000000000000000E 0,-.117520119364380E 1)/ DATA C(30) /(-.642148124715515E 0,-.106860742138277E 1)/ DATA C(31) /( .397515306849130E 0, .104467701612914E 1)/ DATA C(32) /(-.117520119364380E 1, .000000000000000E 0)/ DATA C(33) /(-.116673625724091E 1,-.243458201185722E 0)/ DATA C(34) /( .761594155955766E 0, .000000000000000E 0)/ DATA C(35) /( .365427607174532E-1,-.612881308922810E-1)/ DATA C(36) /( .896860330225849E-2, .244804656578857E-1)/ DATA C(37) /( .177245385090552E 1, .000000000000000E 0)/ DATA C(38) /( .300694617260656E 0,-.424967879433124E 0)/ DATA C(39) /( .110951302025214E 1,-.156806064476794E 1)/ DATA C(40) /( .183074439659052E 1, .569607641036682E 0)/ DATA C(41) /(-.340863758923258E 1, .142127515954291E 1)/ DATA C(42) /(-.156059525546301E 1, .152533527872833E 1)/ DATA C(43) /(-.211272372936533E 0,-.765528316537801E 0)/ DATA C(44) /( .380273164249058E-1,-.286343074460341E 0)/ DATA C(45) /(-.268079774264798E 1, .130151697855085E 1)/ DATA C(46) /(-.164841998888369E 1, .785398163397448E 0)/ DATA C(47) /(-.196351002602143E 1, .000000000000000E 0)/ DATA C(48) /( .161278484461574E 1, .147079632679497E 1)/ C***FIRST EXECUTABLE STATEMENT CFNCK C C Compute functional values C C Exercise routines in Category C2. C W( 1) = CCBRT(SQRT2*(1.E0+CI)) W( 2) = CCBRT(CI) C C Exercise routines in Category C4A. C W( 3) = CACOS(PI+SQRT3*CI) W( 4) = CACOS(SQRT2-.25E0*PI*CI) W( 5) = CASIN(SQRT2-.25E0*PI*CI) W( 6) = CASIN(PI+SQRT3*CI) W( 7) = CATAN(.3125E-1+.541265877365273E-1*CI) W( 8) = CATAN(-.5E0+.866025403784438E0*CI) W( 9) = CATAN2(-.5E0-.866025403784438E0*CI,C1) W(10) = CATAN2(.5E0-.866025403784438E0*CI,C1) W(11) = CATAN2(.3125E-1+.541265877365273E-1*CI,C1) W(12) = CATAN2(-.3125E-1+.541265877365273E-1*CI,C1) W(13) = CCOT(.5E0+0.E0*CI) W(14) = CCOT(-1.E0+.5E0*PI*CI) W(15) = CTAN(-1.E0+.5E0*PI*CI) W(16) = CTAN(.5E0+0.E0*CI) C C Exercise routines in Category C4B. C W(17) = CLOG10(1.E0-CI) W(18) = CLOG10(SQRT3+CI) W(19) = CEXPRL(PI*CI) W(20) = CEXPRL(1.E0+CI) W(21) = CLNREL(-.25E0*CI) W(22) = CLNREL(SQRT3-1.E0+CI) C C Exercise routines in Category C4C. C W(23) = CACOSH(1.E0-2.E0*CI) W(24) = CACOSH(2.E0*CI) W(25) = CASINH(-.117520119364380E1+0.E0*CI) W(26) = CASINH(2.5E0+1.75E0*CI) W(27) = CATANH(1.E0+1.E0*CI) W(28) = CATANH(2.E0+0.E0*CI) W(29) = CCOSH(1.E0-.5E0*PI*CI) W(30) = CCOSH(-1.E0+2.E0*CI) W(31) = CSINH(1.E0-1.E0/PI+CI) W(32) = CSINH(1.E0+PI*CI) W(33) = CTANH(-1.E0+2.E0*CI) W(34) = CTANH(1.E0+PI*CI) C C Exercise routines in Category C7A. C W(35) = C0LGMC(.5E0+.5E0*CI) W(36) = C0LGMC(1.E0-1.E0*CI) W(37) = CGAMMA(.5E0+0.E0*CI) W(38) = CGAMMA(.5E0+CI) W(39) = CGAMR(.5E0-CI) W(40) = CGAMR(1.E0+CI) W(41) = CLNGAM(1.1E0+3.2E0*CI) W(42) = CLNGAM(1.9E0+2.4E0*CI) C C Exercise routines in Category C7B. C W(43) = CBETA(1.E0+CI,1.E0+CI) W(44) = CBETA(2.E0-CI,.5E0+CI) W(45) = CLBETA(2.E0+CI,1.E0-2.E0*CI) W(46) = CLBETA(1.E0-CI,2.E0+CI) C C Exercise routines in Category C7C. C W(47) = CPSI(.5E0+0.E0*CI) W(48) = CPSI(1.E0+5.E0*CI) C C Check for possible errors C ERRMAX = R1MACH(4) ERRTOL = SQRT(ERRMAX) DO 10 I = 1,48 ABSERR = ABS(C(I)-W(I)) RELERR = ABSERR/ABS(C(I)) ERRMAX = MAX(RELERR,ERRMAX) IF (RELERR.GT.ERRTOL .AND. KPRINT.GE.2) + WRITE (LUN,620) I,RELERR,ABSERR 10 CONTINUE IPASS = 0 IF (ERRMAX.LE.ERRTOL) IPASS = 1 IF (IPASS.NE.0 .AND. KPRINT.GE.2) WRITE (LUN,610) RETURN 610 FORMAT (' Complex Fullerton special function routines o.k.') 620 FORMAT (' For I = ', I3, ' test fails with RELERR = ', + E38.30, ' and ABSERR = ', E38.30) END *DECK CGBQC SUBROUTINE CGBQC (LUN, KPRINT, NERR) C***BEGIN PROLOGUE CGBQC C***PURPOSE Quick check for CGBFA, CGBCO, CGBSL and CGBDI. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Voorhees, E. A., (LANL) C***DESCRIPTION C C LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS C OF THE PROPER TYPE FOR THE LINPACK SUBROUTINES BEING TESTED. C THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF C C (THE SOLUTION VECTOR), DC (DETERMINANT OF A ), AND C RCND (RCOND) ARE ENTERED WITH DATA STATEMENTS. C C THE COMPUTED TEST RESULTS FOR X, RCOND AND THE DETER- C MINANT ARE COMPARED TO THE STORED PRE-COMPUTED VALUES. C FAILURE OF THE TEST OCCURS WHEN AGREEMENT TO 3 SIGNIFICANT C DIGITS IS NOT ACHIEVED AND AN ERROR MESSAGE INDICATING WHICH C LINPACK SUBROUTINE FAILED AND WHICH QUANTITY WAS INVOLVED IS C PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. C C NO INPUT ARGUMENTS ARE REQUIRED. C ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT OF C ALL FAILURES DETECTED BY CGBQC. C C***ROUTINES CALLED CGBCO, CGBDI, CGBFA, CGBSL C***REVISION HISTORY (YYMMDD) C 801015 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF, moved an ARITHMETIC C STATEMENT FUNCTION ahead of the FIRST EXECUTABLE STATEMENT C record and cleaned up FORMATs. (RWC) C***END PROLOGUE CGBQC COMPLEX ABD(6,4),AT(7,4),B(4),BT(4),C(4),DET(2),DC(2), 1 Z(4),XA,XB REAL R,RCOND,RCND,DELX CHARACTER KFAIL*39,KPROG*19 INTEGER LDA,N,IPVT(4),INFO,I,J,INDX,NERR INTEGER ML,MU DATA ABD/(0.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 1 (2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), 2 (0.E0,0.E0),(0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0), 3 (0.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 4 (3.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), 5 (0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0),(0.E0,0.E0)/ DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA DC/(3.3E0,0.E0),(1.0E0,0.E0)/ DATA KPROG/'GBFA GBCO GBSL GBDI'/ DATA KFAIL/'INFO RCOND SOLUTION DETERMINANT INVERSE'/ DATA RCND/.24099E0/ C DELX(XA,XB)=ABS(REAL(XA-XB))+ABS(AIMAG(XA-XB)) C***FIRST EXECUTABLE STATEMENT CGBQC LDA = 7 N = 4 ML = 1 MU = 3 NERR = 0 C C FORM AT FOR CGBFA AND BT FOR CGBSL, TEST CGBFA C DO 20 J=1,N BT(J) = B(J) DO 10 I=1,6 AT(I,J) = ABD(I,J) 10 CONTINUE 20 CONTINUE C CALL CGBFA(AT,LDA,N,ML,MU,IPVT,INFO) IF (INFO .NE. 0) THEN WRITE (LUN,201) KPROG(1:4),KFAIL(1:4) NERR = NERR + 1 ENDIF C C TEST CGBSL FOR JOB=0 C CALL CGBSL(AT,LDA,N,ML,MU,IPVT,BT,0) INDX = 0 DO 40 I=1,N IF (DELX(C(I),BT(I)) .GT. .0001) INDX=INDX+1 40 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ENDIF C C FORM AT FOR CGBCO AND BT FOR CGBSL, TEST CGBCO C DO 70 J=1,N BT(J) = B(J) DO 60 I=1,6 AT(I,J) = ABD(I,J) 60 CONTINUE 70 CONTINUE C CALL CGBCO(AT,LDA,N,ML,MU,IPVT,RCOND,Z) R = ABS(RCND-RCOND) IF (R .GE. .0001) THEN WRITE (LUN,201) KPROG(6:9),KFAIL(6:10) NERR = NERR + 1 ENDIF C C TEST CGBSL FOR JOB NOT EQUAL TO 0 C CALL CGBSL(AT,LDA,N,ML,MU,IPVT,BT,1) INDX = 0 DO 90 I=1,N IF (DELX(C(I),BT(I)) .GT. .0001) INDX=INDX+1 90 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ENDIF C C TEST CGBDI C CALL CGBDI(AT,LDA,N,ML,MU,IPVT,DET) INDX = 0 DO 110 I=1,2 IF (DELX(DC(I),DET(I)) .GT. .0001) INDX=INDX+1 110 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(16:19),KFAIL(21:31) NERR = NERR + 1 ENDIF C IF (KPRINT.GE.2 .OR. NERR.NE.0) WRITE (LUN,200) NERR RETURN C 200 FORMAT(/' * CGBQC - TEST FOR CGBFA, CGBCO, CGBSL AND CGBDI FOUND ' 1 , I1, ' ERRORS.'/) 201 FORMAT (/' *** C', A, ' FAILURE - ERROR IN ', A) END *DECK CGECK SUBROUTINE CGECK (LUN, KPRINT, NERR) C***BEGIN PROLOGUE CGECK C***PURPOSE Quick check for CGEFA, CGECO, CGESL and CGEDI. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Voorhees, E. A., (LANL) C***DESCRIPTION C C LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS C OF THE PROPER TYPE FOR THE LINPACK SUBROUTINES BEING TESTED. C THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF C C (THE SOLUTION VECTOR), AINV (INVERSE OF MATRIX A ), DC C (DETERMINANT OF A ), AND RCND ( RCOND ) ARE ENTERED C WITH DATA STATEMENTS. C C THE COMPUTED TEST RESULTS FOR X, RCOND, THE DETERMINANT, AND C THE INVERSE ARE COMPARED TO THE STORED PRE-COMPUTED VALUES. C FAILURE OF THE TEST OCCURS WHEN AGREEMENT TO 3 SIGNIFICANT C DIGITS IS NOT ACHIEVED AND AN ERROR MESSAGE INDICATING WHICH C LINPACK SUBROUTINE FAILED AND WHICH QUANTITY WAS INVOLVED IS C PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. C C NO INPUT ARGUMENTS ARE REQUIRED. C ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT OF C ALL FAILURES DETECTED BY CGECK. C C***ROUTINES CALLED CGECO, CGEDI, CGEFA, CGESL C***REVISION HISTORY (YYMMDD) C 801014 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF and cleaned up C FORMATs. (RWC) C***END PROLOGUE CGECK COMPLEX A(4,4),AT(5,4),B(4),BT(4),C(4),AINV(4,4),DET(2),DC(2), 1 Z(4),XA,XB REAL R,RCOND,RCND,DELX CHARACTER KPROG*19,KFAIL*39 INTEGER LDA,N,IPVT(4),INFO,I,J,INDX,NERR DATA A/(2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), 1 (0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 2 (0.E0,0.E0),(0.E0,0.E0),(3.E0,0.E0),(0.E0,1.E0), 3 (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/ DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA AINV/(.66667E0,0.E0),(0.E0,-.33333E0),(0.E0,0.E0),(0.E0, 1 0.E0), 2 (0.E0,.33333E0),(.66667E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 3 (0.E0,0.E0),(0.E0,0.E0),(.36364E0,0.E0),(0.E0,-.09091E0), 4 (0.E0,0.E0),(0.E0,0.E0),(0.E0,.09091E0),(.27273E0,0.E0)/ DATA DC/(3.3E0,0.E0),(1.0E0,0.E0)/ DATA KPROG/'GEFA GECO GESL GEDI'/ DATA KFAIL/'INFO RCOND SOLUTION DETERMINANT INVERSE'/ DATA RCND/.24099E0/ C DELX(XA,XB)=ABS(REAL(XA-XB))+ABS(AIMAG(XA-XB)) C***FIRST EXECUTABLE STATEMENT CGECK LDA = 5 N = 4 NERR = 0 C C FORM AT FOR CGEFA AND BT FOR CGESL, TEST CGEFA C DO 20 J=1,N BT(J) = B(J) DO 10 I=1,N AT(I,J) = A(I,J) 10 CONTINUE 20 CONTINUE C CALL CGEFA(AT,LDA,N,IPVT,INFO) IF (INFO .NE. 0) THEN WRITE (LUN,201) KPROG(1:4),KFAIL(1:4) NERR = NERR + 1 ENDIF C C TEST CGESL FOR JOB=0 C CALL CGESL(AT,LDA,N,IPVT,BT,0) INDX = 0 DO 40 I=1,N IF(DELX(C(I),BT(I)) .GT. .0001) INDX=INDX+1 40 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ENDIF C C FORM AT FOR CGECO AND BT FOR CGESL, TEST CGECO C DO 70 J=1,N BT(J) = B(J) DO 60 I=1,N AT(I,J) = A(I,J) 60 CONTINUE 70 CONTINUE C CALL CGECO(AT,LDA,N,IPVT,RCOND,Z) R = ABS(RCND-RCOND) IF (R .GE. .0001) THEN WRITE (LUN,201) KPROG(6:9),KFAIL(6:10) NERR = NERR + 1 ENDIF C C TEST CGESL FOR JOB NOT EQUAL TO 0 C CALL CGESL(AT,LDA,N,IPVT,BT,1) INDX = 0 DO 90 I=1,N IF (DELX(C(I),BT(I)) .GT. .0001) INDX=INDX+1 90 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ENDIF C C TEST CGEDI FOR JOB=11 C CALL CGEDI(AT,LDA,N,IPVT,DET,Z,11) INDX = 0 DO 110 I=1,2 IF (DELX(DC(I),DET(I)) .GT. .0001) INDX=INDX+1 110 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(16:19),KFAIL(21:31) NERR = NERR + 1 ENDIF C INDX = 0 DO 140 I=1,N DO 130 J=1,N IF (DELX(AINV(I,J),AT(I,J)) .GT. .0001) INDX=INDX+1 130 CONTINUE 140 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(16:19),KFAIL(33:39) NERR = NERR + 1 ENDIF C IF (KPRINT.GE.2 .OR. NERR.NE.0) WRITE (LUN,200) NERR RETURN C 200 FORMAT(/' * CGECK - TEST FOR CGEFA, CGECO, CGESL AND CGEDI FOUND ' 1 , I1, ' ERRORS.'/) 201 FORMAT (/' *** C', A, ' FAILURE - ERROR IN ', A) END *DECK CGEQC SUBROUTINE CGEQC (LUN, KPRINT, NERR) C***BEGIN PROLOGUE CGEQC C***PURPOSE Quick check for CGEFS and CGEIR. C***LIBRARY SLATEC C***TYPE COMPLEX (SGEQC-S, DGEQC-D, CGEQC-C) C***KEYWORDS QUICK CHECK C***AUTHOR Jacobsen, Nancy, (LANL) C***DESCRIPTION C C Let A*X=B be a COMPLEX linear system where the C matrix is of the proper type for the Linpack subroutines C being called. The values of A and B and the pre-computed C values of BXEX (the solution vector) are given in DATA C statements. The computed test results for X are compared to C the stored pre-computed values. Failure of the test occurs C when there is less than 80% agreement between the absolute C values. There are 2 tests - one for the normal case and one C for the singular case. A message is printed indicating C whether each subroutine has passed or failed for each case. C C On return, NERR (INTEGER type) contains the total count of C all failures detected. C C***ROUTINES CALLED CGEFS, CGEIR C***REVISION HISTORY (YYMMDD) C 801029 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920601 Code reworked and TYPE section added. (RWC, WRB) C***END PROLOGUE CGEQC C .. Scalar Arguments .. INTEGER KPRINT, LUN, NERR C .. Local Scalars .. COMPLEX XA, XB INTEGER I, IND, INDX, ITASK, J, KPROG, LDA, N C .. Local Arrays .. COMPLEX A(3,3), ATEMP(5,3), B(3), BTEMP(3), BXEX(3), WORK(12) INTEGER IWORK(3) CHARACTER LIST(2)*4 C .. External Subroutines .. EXTERNAL CGEFS, CGEIR C .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, REAL C .. Statement Functions .. REAL DELX C .. Data statements .. DATA A /(2., 3.), (1., 1.), (1., 2.), + (2., 0.), (1., -1.), (0., 0.), + (0., 0.), (2., 5.), (3., 2.)/ DATA B /(-1., 1.), (-5., 4.), (-4., 7.)/ DATA BXEX /(.21459E-01, .209012E+01), (.261373E+01, -.162231E+01), + (.785407E+00, .109871E+01)/ DATA LIST /'GEFS', 'GEIR'/ C .. Statement Function definitions .. DELX(XA,XB) = ABS(REAL(XA-XB)) + ABS(AIMAG(XA-XB)) C***FIRST EXECUTABLE STATEMENT CGEQC N = 3 LDA = 5 NERR = 0 IF (KPRINT .GE. 2) WRITE (LUN,9000) C DO 180 KPROG=1,2 C C First test case - normal C ITASK = 1 DO 100 I=1,N BTEMP(I) = B(I) 100 CONTINUE DO 120 J=1,N DO 110 I=1,N ATEMP(I,J) = A(I,J) 110 CONTINUE 120 CONTINUE IF (KPROG .EQ. 1) THEN CALL CGEFS (ATEMP, LDA, N, BTEMP, ITASK, IND, WORK, IWORK) ELSE CALL CGEIR (ATEMP, LDA, N, BTEMP, ITASK, IND, WORK, IWORK) ENDIF IF (IND .LT. 0) THEN IF (KPRINT .GE. 2) WRITE (LUN, FMT=9020) LIST(KPROG), IND NERR = NERR + 1 ENDIF C C Calculate error for first test C INDX = 0 DO 130 I=1,N IF (DELX(BXEX(I),BTEMP(I)) .GT. .0001) INDX = INDX + 1 130 CONTINUE IF (INDX .EQ. 0) THEN IF(KPRINT .GE. 3) WRITE (LUN, FMT=9010) LIST(KPROG) ELSE IF(KPRINT .GE. 2) WRITE (LUN, FMT=9020) LIST(KPROG) NERR = NERR + 1 ENDIF C C Second test case - singular matrix C ITASK = 1 DO 140 I=1,N BTEMP(I) = B(I) 140 CONTINUE DO 160 J=1,N DO 150 I=1,N ATEMP(I,J) = A(I,J) 150 CONTINUE 160 CONTINUE DO 170 J=1,N ATEMP(1,J) = (0.E0,0.E0) 170 CONTINUE IF (KPROG .EQ. 1) THEN CALL CGEFS (ATEMP, LDA, N, BTEMP, ITASK, IND, WORK, IWORK) ELSE CALL CGEIR (ATEMP, LDA, N, BTEMP, ITASK, IND, WORK, IWORK) ENDIF IF (IND .EQ. -4) THEN IF (KPRINT .GE. 3) WRITE (LUN, FMT=9030) LIST(KPROG) ELSE IF (KPRINT .GE. 2) WRITE (LUN, FMT=9040) LIST(KPROG), IND NERR = NERR + 1 ENDIF 180 CONTINUE C IF (KPRINT.GE.3 .AND. NERR.EQ.0) WRITE (LUN,9050) IF (KPRINT.GE.2 .AND. NERR.NE.0) WRITE (LUN,9060) RETURN C 9000 FORMAT (//, 2X, 'CGEFS and CGEIR Quick Check' /) 9010 FORMAT (/, 5X, 'C', A, ' Normal test PASSED') 9020 FORMAT (/, 5X, 'C', A, ' Test FAILED') 9030 FORMAT (/, 5X, 'C', A, ' Singular test PASSED') 9040 FORMAT (/, 5X, 'C', A, ' Singular test FAILED, IND=', I3) 9050 FORMAT (/, 2X, 'CGEFS and CGEIR Quick Check PASSED' /) 9060 FORMAT (/, 2X, 'CGEFS and CGEIR Quick Check FAILED' /) END *DECK CGTQC SUBROUTINE CGTQC (LUN, KPRINT, NERR) C***BEGIN PROLOGUE CGTQC C***PURPOSE Quick check for CGTSL. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Voorhees, E. A., (LANL) C***DESCRIPTION C C LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS C OF THE PROPER TYPE FOR THE LINPACK SUBROUTINE BEING TESTED. C THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF CX C (THE SOLUTION VECTOR) ARE ENTERED WITH DATA STATEMENTS. C C THE COMPUTED VALUES OF X ARE COMPARED TO THE STORED C PRE-COMPUTED VALUES OF CX. FAILURE OF THE TEST OCCURS WHEN C AGREEMENT TO 3 SIGNIFICANT DIGITS IS NOT ACHIEVED AND AN C ERROR MESSAGE IS PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. C C NO INPUT ARGUMENTS ARE REQUIRED. C ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT C OF ALL FAILURES DETECTED BY CGTQC. C C***ROUTINES CALLED CGTSL C***REVISION HISTORY (YYMMDD) C 801024 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF, moved an ARITHMETIC C STATEMENT FUNCTION ahead of the FIRST EXECUTABLE STATEMENT C record and cleaned up FORMATs. (RWC) C***END PROLOGUE CGTQC COMPLEX C(4),D(4),E(4),B(4),CX(4),CT(4),DT(4),ET(4),BT(4) CHARACTER KFAIL*13 INTEGER N,INFO,I,INDX,NERR REAL DELX DATA C/(0.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,1.E0)/ DATA D/(2.E0,0.E0),(2.E0,0.E0),(3.E0,0.E0),(4.E0,0.E0)/ DATA E/(0.E0,-1.E0),(0.E0,0.E0),(0.E0,-1.E0),(0.E0,0.E0)/ DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA CX/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA KFAIL/'INFO SOLUTION'/ C***FIRST EXECUTABLE STATEMENT CGTQC N = 4 NERR = 0 DO 10 I=1,N CT(I) = C(I) DT(I) = D(I) ET(I) = E(I) BT(I) = B(I) 10 CONTINUE C CALL CGTSL(N,CT,DT,ET,BT,INFO) IF (INFO .NE. 0) THEN WRITE (LUN,201) KFAIL(1:4) NERR = NERR + 1 ENDIF C INDX = 0 DO 30 I=1,N DELX = ABS(REAL(BT(I)-CX(I)))+ABS(AIMAG(BT(I)-CX(I))) IF (DELX .GT. .0001) INDX=INDX+1 30 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KFAIL(6:13) NERR = NERR + 1 ENDIF C IF (KPRINT.GE.2 .OR. NERR.NE.0) WRITE (LUN,200) NERR RETURN C 200 FORMAT (/' * CGTQC - TEST FOR CGTSL FOUND ', I1, ' ERRORS.'/) 201 FORMAT (/' *** CGTSL FAILURE - ERROR IN ', A) END *DECK CHECK0 SUBROUTINE CHECK0 (SFAC, DFAC, KPRINT) C***BEGIN PROLOGUE CHECK0 C***PURPOSE (UNKNOWN) C***LIBRARY SLATEC C***AUTHOR Lawson, C. L., (JPL) C Hanson, R. J., (SNLA) C Wisniewski, J. A., (SNLA) C***DESCRIPTION C C THIS SUBROUTINE TESTS SUBPROGRAMS 12-13 AND 16-17. C THESE SUBPROGRAMS HAVE NO ARRAY ARGUMENTS. C C C. L. LAWSON, JPL, 1975 MAR 07, MAY 28 C R. J. HANSON, J. A. WISNIEWSKI, SANDIA LABS, APRIL 25,1977. C C***ROUTINES CALLED DROTG, DROTMG, DTEST, SROTG, SROTMG, STEST C***COMMON BLOCKS COMBLA C***REVISION HISTORY (YYMMDD) C 750307 DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE CHECK0 COMMON /COMBLA/ NPRINT, ICASE, N, INCX, INCY, MODE, PASS LOGICAL PASS REAL STRUE(9),STEMP(9) DOUBLE PRECISION DC,DS,DA1(8),DB1(8),DC1(8),DS1(8) DOUBLE PRECISION DA,DATRUE(8),DBTRUE(8),DZERO,DFAC,DB DOUBLE PRECISION DAB(4,9),DTEMP(9),DTRUE(9,9),D12 DATA ZERO, DZERO / 0., 0.D0 / DATA DA1/ .3D0, .4D0, -.3D0, -.4D0, -.3D0, 0.D0, 0.D0, 1.D0/ DATA DB1/ .4D0, .3D0, .4D0, .3D0, -.4D0, 0.D0, 1.D0, 0.D0/ DATA DC1/ .6D0, .8D0, -.6D0, .8D0, .6D0, 1.D0, 0.D0, 1.D0/ DATA DS1/ .8D0, .6D0, .8D0, -.6D0, .8D0, 0.D0, 1.D0, 0.D0/ DATA DATRUE/ .5D0, .5D0, .5D0, -.5D0, -.5D0, 0.D0, 1.D0, 1.D0/ DATA DBTRUE/ 0.D0, .6D0, 0.D0, -.6D0, 0.D0, 0.D0, 1.D0, 0.D0/ C INPUT FOR MODIFIED GIVENS DATA DAB/ .1D0,.3D0,1.2D0,.2D0, A .7D0, .2D0, .6D0, 4.2D0, B 0.D0,0.D0,0.D0,0.D0, C 4.D0, -1.D0, 2.D0, 4.D0, D 6.D-10, 2.D-2, 1.D5, 10.D0, E 4.D10, 2.D-2, 1.D-5, 10.D0, F 2.D-10, 4.D-2, 1.D5, 10.D0, G 2.D10, 4.D-2, 1.D-5, 10.D0, H 4.D0, -2.D0, 8.D0, 4.D0 / C TRUE RESULTS FOR MODIFIED GIVENS DATA DTRUE/0.D0,0.D0, 1.3D0, .2D0, 0.D0,0.D0,0.D0, .5D0, 0.D0, A 0.D0,0.D0, 4.5D0, 4.2D0, 1.D0, .5D0, 0.D0,0.D0,0.D0, B 0.D0,0.D0,0.D0,0.D0, -2.D0, 0.D0,0.D0,0.D0,0.D0, C 0.D0,0.D0,0.D0, 4.D0, -1.D0, 0.D0,0.D0,0.D0,0.D0, D 0.D0, 15.D-3, 0.D0, 10.D0, -1.D0, 0.D0, -1.D-4, E 0.D0, 1.D0, F 0.D0,0.D0, 6144.D-5, 10.D0, -1.D0, 4096.D0, -1.D6, G 0.D0, 1.D0, H 0.D0,0.D0,15.D0,10.D0,-1.D0, 5.D-5, 0.D0,1.D0,0.D0, I 0.D0,0.D0, 15.D0, 10.D0, -1. D0, 5.D5, -4096.D0, J 1.D0, 4096.D-6, K 0.D0,0.D0, 7.D0, 4.D0, 0.D0,0.D0, -.5D0, -.25D0, 0.D0/ C 4096 = 2 ** 12 DATA D12 /4096.D0/ C***FIRST EXECUTABLE STATEMENT CHECK0 C C COMPUTE TRUE VALUES WHICH CANNOT BE PRESTORED C IN DECIMAL NOTATION. DTRUE(1,1) = 12.D0 / 130.D0 DTRUE(2,1) = 36.D0 / 130.D0 DTRUE(7,1) = -1.D0 / 6.D0 DTRUE(1,2) = 14.D0 / 75.D0 DTRUE(2,2) = 49.D0 / 75.D0 DTRUE(9,2) = 1.D0 / 7.D0 DTRUE(1,5) = 45.D-11 * (D12 * D12) DTRUE(3,5) = 4.D5 / (3.D0 * D12) DTRUE(6,5) = 1.D0 / D12 DTRUE(8,5) = 1.D4 / (3.D0 * D12) DTRUE(1,6) = 4.D10 / (1.5D0 * D12 * D12) DTRUE(2,6) = 2.D-2 / 1.5D0 DTRUE(8,6) = 5.D-7 * D12 DTRUE(1,7) = 4.D0 / 150.D0 DTRUE(2,7) = (2.D-10 / 1.5D0) * (D12 * D12) DTRUE(7,7) = -DTRUE(6,5) DTRUE(9,7) = 1.D4 / D12 DTRUE(1,8) = DTRUE(1,7) DTRUE(2,8) = 2.D10 / (1.5D0 * D12 * D12) DTRUE(1,9) = 32.D0 / 7.D0 DTRUE(2,9) = -16.D0 / 7.D0 DBTRUE(1) = 1.D0/.6D0 DBTRUE(3) = -1.D0/.6D0 DBTRUE(5) = 1.D0/.6D0 C JUMP= ICASE-11 DO 500 K = 1, 9 C SET N=K FOR IDENTIFICATION IN OUTPUT IF ANY. N=K C BRANCH TO SELECT SUBPROGRAM TO BE TESTED. C GO TO (120,130,999,999,160,170), JUMP C 12. SROTG 120 IF(K.GT.8) GO TO 600 SA = DA1(K) SB = DB1(K) CALL SROTG(SA,SB,SC,SS) CALL STEST(1,SA,REAL(DATRUE(K)),REAL(DATRUE(K)),SFAC,KPRINT) CALL STEST(1,SB,REAL(DBTRUE(K)),REAL(DBTRUE(K)),SFAC,KPRINT) CALL STEST(1,SC,REAL(DC1(K)),REAL(DC1(K)),SFAC,KPRINT) CALL STEST(1,SS,REAL(DS1(K)),REAL(DS1(K)),SFAC,KPRINT) GO TO 500 C 13. DROTG 130 IF(K.GT.8) GO TO 600 DA = DA1(K) DB = DB1(K) CALL DROTG(DA,DB,DC,DS) CALL DTEST(1,DA,DATRUE(K),DATRUE(K),DFAC,KPRINT) CALL DTEST(1,DB,DBTRUE(K),DBTRUE(K),DFAC,KPRINT) CALL DTEST(1,DC,DC1(K),DC1(K),DFAC,KPRINT) CALL DTEST(1,DS,DS1(K),DS1(K),DFAC,KPRINT) GO TO 500 C 16. SROTMG 160 CONTINUE DO 162 I = 1, 4 STEMP(I) = DAB(I,K) STEMP(I+4) = ZERO 162 CONTINUE STEMP(9) = ZERO CALL SROTMG(STEMP(1),STEMP(2),STEMP(3),STEMP(4),STEMP(5)) C DO 166 I = 1, 9 166 STRUE(I) = DTRUE(I,K) CALL STEST(9,STEMP,STRUE,STRUE,SFAC,KPRINT) GO TO 500 C 17. DROTMG 170 CONTINUE DO 172 I = 1, 4 DTEMP(I) = DAB(I,K) DTEMP(I+4) = DZERO 172 CONTINUE DTEMP(9) = DZERO CALL DROTMG(DTEMP(1),DTEMP(2),DTEMP(3),DTEMP(4),DTEMP(5)) CALL DTEST(9,DTEMP,DTRUE(1,K),DTRUE(1,K),DFAC,KPRINT) 500 CONTINUE 600 RETURN C THE FOLLOWING STOP SHOULD NEVER BE REACHED. 999 STOP END *DECK CHECK1 SUBROUTINE CHECK1 (SFAC, DFAC, KPRINT) C***BEGIN PROLOGUE CHECK1 C***PURPOSE (UNKNOWN) C***LIBRARY SLATEC C***AUTHOR Lawson, C. L., (JPL) C***DESCRIPTION C C THIS SUBPROGRAM TESTS THE INCREMENTING AND ACCURACY OF THE LINEAR C ALGEBRA SUBPROGRAMS 26 - 38 (SNRM2 TO ICAMAX). STORED RESULTS ARE C COMPARED WITH THE RESULT RETURNED BY THE SUBPROGRAM. C C THESE SUBPROGRAMS REQUIRE A SINGLE VECTOR ARGUMENT. C C ICASE DESIGNATES WHICH SUBPROGRAM TO TEST. C 26 .LE. ICASE .LE. 38 C C. L. LAWSON, JPL, 1974 DEC 10, MAY 28 C C***ROUTINES CALLED CSCAL, CSSCAL, DASUM, DNRM2, DSCAL, DTEST, ICAMAX, C IDAMAX, ISAMAX, ITEST, SASUM, SCASUM, SCNRM2, C SNRM2, SSCAL, STEST C***COMMON BLOCKS COMBLA C***REVISION HISTORY (YYMMDD) C 741210 DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE CHECK1 COMMON /COMBLA/ NPRINT, ICASE, N, INCX, INCY, MODE, PASS LOGICAL PASS INTEGER ITRUE2(5),ITRUE3(5) DOUBLE PRECISION DA,DX(8) DOUBLE PRECISION DV(8,5,2) DOUBLE PRECISION DFAC DOUBLE PRECISION DNRM2,DASUM DOUBLE PRECISION DTRUE1(5),DTRUE3(5),DTRUE5(8,5,2) REAL STRUE2(5),STRUE4(5),STRUE(8),SX(8) COMPLEX CA,CV(8,5,2),CTRUE5(8,5,2),CTRUE6(8,5,2),CX(8) C DATA SA, DA, CA / .3, .3D0, (.4,-.7) / DATA DV/.1D0,2.D0,2.D0,2.D0,2.D0,2.D0,2.D0,2.D0, 1 .3D0,3.D0,3.D0,3.D0,3.D0,3.D0,3.D0,3.D0, 2 .3D0,-.4D0,4.D0,4.D0,4.D0,4.D0,4.D0,4.D0, 3 .2D0,-.6D0,.3D0,5.D0,5.D0,5.D0,5.D0,5.D0, 4 .1D0,-.3D0,.5D0,-.1D0,6.D0,6.D0,6.D0,6.D0, 5 .1D0,8.D0,8.D0,8.D0,8.D0,8.D0,8.D0,8.D0, 6 .3D0,9.D0,9.D0,9.D0,9.D0,9.D0,9.D0,9.D0, 7 .3D0,2.D0,-.4D0,2.D0,2.D0,2.D0,2.D0,2.D0, 8 .2D0,3.D0,-.6D0,5.D0,.3D0,2.D0,2.D0,2.D0, 9 .1D0,4.D0,-.3D0,6.D0,-.5D0,7.D0,-.1D0, 3.D0/ C COMPLEX TEST VECTORS DATA CV/ 1(.1,.1),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.), 2(.3,-.4),(3.,4.),(3.,4.),(3.,4.),(3.,4.),(3.,4.),(3.,4.),(3.,4.), 3(.1,-.3),(.5,-.1),(5.,6.),(5.,6.),(5.,6.),(5.,6.),(5.,6.),(5.,6.), 4(.1,.1),(-.6,.1),(.1,-.3),(7.,8.),(7.,8.),(7.,8.),(7.,8.),(7.,8.), 5(.3,.1),(.1,.4),(.4,.1),(.1,.2),(2.,3.),(2.,3.),(2.,3.),(2.,3.), 6(.1,.1),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.), 7(.3,-.4),(6.,7.),(6.,7.),(6.,7.),(6.,7.),(6.,7.),(6.,7.),(6.,7.), 8(.1,-.3),(8.,9.),(.5,-.1),(2.,5.),(2.,5.),(2.,5.),(2.,5.),(2.,5.), 9(.1,.1),(3.,6.),(-.6,.1),(4.,7.),(.1,-.3),(7.,2.),(7.,2.),(7.,2.), T(.3,.1),(5.,8.),(.1,.4),(6.,9.),(.4,.1),(8.,3.),(.1,.2),(9.,4.) / C DATA STRUE2/.0,.5,.6,.7,.7/ DATA STRUE4/.0,.7,1.,1.3,1.7/ DATA DTRUE1/.0D0,.3D0,.5D0,.7D0,.6D0/ DATA DTRUE3/.0D0,.3D0,.7D0,1.1D0,1.D0/ DATA DTRUE5/.10D0,2.D0,2.D0,2.D0,2.D0,2.D0,2.D0,2.D0, 1 .09D0,3.D0,3.D0,3.D0,3.D0,3.D0,3.D0,3.D0, 2 .09D0,-.12D0,4.D0,4.D0,4.D0,4.D0,4.D0,4.D0, 3 .06D0,-.18D0,.09D0,5.D0,5.D0,5.D0,5.D0,5.D0, 4 .03D0,-.09D0,.15D0,-.03D0,6.D0,6.D0,6.D0,6.D0, 5 .10D0,8.D0,8.D0,8.D0,8.D0,8.D0,8.D0,8.D0, 6 .09D0,9.D0,9.D0,9.D0,9.D0,9.D0,9.D0,9.D0, 7 .09D0,2.D0,-.12D0,2.D0,2.D0,2.D0,2.D0,2.D0, 8 .06D0,3.D0,-.18D0,5.D0,.09D0,2.D0,2.D0,2.D0, 9 .03D0,4.D0, -.09D0,6.D0, -.15D0,7.D0, -.03D0, 3.D0/ C DATA CTRUE5/ A(.1,.1),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.), B(-.16,-.37),(3.,4.),(3.,4.),(3.,4.),(3.,4.),(3.,4.),(3.,4.), C (3.,4.), D(-.17,-.19),(.13,-.39),(5.,6.),(5.,6.),(5.,6.),(5.,6.),(5.,6.), E (5.,6.), F(.11,-.03),(-.17,.46),(-.17,-.19),(7.,8.),(7.,8.),(7.,8.),(7.,8.), G (7.,8.), H(.19,-.17),(.32,.09),(.23,-.24),(.18,.01),(2.,3.),(2.,3.),(2.,3.), I (2.,3.), J(.1,.1),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.), K(-.16,-.37),(6.,7.),(6.,7.),(6.,7.),(6.,7.),(6.,7.),(6.,7.), L (6.,7.), M(-.17,-.19),(8.,9.),(.13,-.39),(2.,5.),(2.,5.),(2.,5.),(2.,5.), N (2.,5.), O(.11,-.03),(3.,6.),(-.17,.46),(4.,7.),(-.17,-.19),(7.,2.),(7.,2.), P (7.,2.), Q(.19,-.17),(5.,8.),(.32,.09),(6.,9.),(.23,-.24),(8.,3.),(.18,.01), R (9.,4.) / C DATA CTRUE6/ A(.1,.1),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.), B(.09,-.12),(3.,4.),(3.,4.),(3.,4.),(3.,4.),(3.,4.),(3.,4.), C (3.,4.), D(.03,-.09),(.15,-.03),(5.,6.),(5.,6.),(5.,6.),(5.,6.),(5.,6.), E (5.,6.), F(.03,.03),(-.18,.03),(.03,-.09),(7.,8.),(7.,8.),(7.,8.),(7.,8.), G (7.,8.), H(.09,.03),(.03,.12),(.12,.03),(.03,.06),(2.,3.),(2.,3.),(2.,3.), I (2.,3.), J(.1,.1),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.), K(.09,-.12),(6.,7.),(6.,7.),(6.,7.),(6.,7.),(6.,7.),(6.,7.), L (6.,7.), M(.03,-.09),(8.,9.),(.15,-.03),(2.,5.),(2.,5.),(2.,5.),(2.,5.), N (2.,5.), O(.03,.03),(3.,6.),(-.18,.03),(4.,7.),(.03,-.09),(7.,2.),(7.,2.), P (7.,2.), Q(.09,.03),(5.,8.),(.03,.12),(6.,9.),(.12,.03),(8.,3.),(.03,.06), R (9.,4.) / C C DATA ITRUE2/ 0, 1, 2, 2, 3/ DATA ITRUE3/ 0, 1, 2, 2, 2/ C***FIRST EXECUTABLE STATEMENT CHECK1 JUMP=ICASE-25 DO 520 INCX=1,2 DO 500 NP1=1,5 N=NP1-1 LEN= 2*MAX(N,1) C SET VECTOR ARGUMENTS. DO 22 I = 1, LEN SX(I) = DV(I,NP1,INCX) DX(I) = DV(I,NP1,INCX) 22 CX(I) = CV(I,NP1,INCX) C C BRANCH TO INVOKE SUBPROGRAM TO BE TESTED. C GO TO (260,270,280,290,300,310,320, * 330,340,350,360,370,380),JUMP C 26. SNRM2 260 STEMP = DTRUE1(NP1) CALL STEST(1,SNRM2(N,SX,INCX),STEMP,STEMP,SFAC,KPRINT) GO TO 500 C 27. DNRM2 270 CALL DTEST(1,DNRM2(N,DX,INCX),DTRUE1(NP1),DTRUE1(NP1),DFAC, 1 KPRINT) GO TO 500 C 28. SCNRM2 280 CALL STEST(1,SCNRM2(N,CX,INCX),STRUE2(NP1),STRUE2(NP1), 1 SFAC,KPRINT) GO TO 500 C 29. SASUM 290 STEMP = DTRUE3(NP1) CALL STEST(1,SASUM(N,SX,INCX),STEMP,STEMP,SFAC,KPRINT) GO TO 500 C 30. DASUM 300 CALL DTEST(1,DASUM(N,DX,INCX),DTRUE3(NP1),DTRUE3(NP1),DFAC, 1 KPRINT) GO TO 500 C 31. SCASUM 310 CALL STEST(1,SCASUM(N,CX,INCX),STRUE4(NP1),STRUE4(NP1),SFAC, 1 KPRINT) GO TO 500 C 32. SSCALE 320 CALL SSCAL(N,SA,SX,INCX) DO 322 I = 1, LEN 322 STRUE(I) = DTRUE5(I,NP1,INCX) CALL STEST(LEN,SX,STRUE,STRUE,SFAC,KPRINT) GO TO 500 C 33. DSCALE 330 CALL DSCAL(N,DA,DX,INCX) CALL DTEST(LEN,DX,DTRUE5(1,NP1,INCX),DTRUE5(1,NP1,INCX), 1 DFAC,KPRINT) GO TO 500 C 34. CSCALE 340 CALL CSCAL(N,CA,CX,INCX) CALL STEST(2*LEN,CX,CTRUE5(1,NP1,INCX),CTRUE5(1,NP1,INCX), 1 SFAC,KPRINT) GO TO 500 C 35. CSSCAL 350 CALL CSSCAL(N,SA,CX,INCX) CALL STEST(2*LEN,CX,CTRUE6(1,NP1,INCX),CTRUE6(1,NP1,INCX), 1 SFAC,KPRINT) GO TO 500 C 36. ISAMAX 360 CALL ITEST(1,ISAMAX(N,SX,INCX),ITRUE2(NP1),KPRINT) GO TO 500 C 37. IDAMAX 370 CALL ITEST(1,IDAMAX(N,DX,INCX),ITRUE2(NP1),KPRINT) GO TO 500 C 38. ICAMAX 380 CALL ITEST(1,ICAMAX(N,CX,INCX),ITRUE3(NP1),KPRINT) C 500 CONTINUE 520 CONTINUE RETURN END *DECK CHECK2 SUBROUTINE CHECK2 (SFAC, SDFAC, DFAC, DQFAC, KPRINT) C***BEGIN PROLOGUE CHECK2 C***PURPOSE (UNKNOWN) C***LIBRARY SLATEC C***AUTHOR Lawson, C. L., (JPL) C***DESCRIPTION C C THIS SUBPROGRAM TESTS THE BASIC LINEAR ALGEBRA SUBPROGRAMS 1-11, C 14-15, AND 18-25. SUBPROGRAMS IN THIS SET EACH REQUIRE TWO ARRAYS C IN THE PARAMETER LIST. C C C. L. LAWSON, JPL, 1975 FEB 26, APR 29, MAY 8, MAY 28 C C***ROUTINES CALLED CAXPY, CCOPY, CDOTC, CDOTU, CSWAP, DAXPY, DCOPY, C DDOT, DQDOTA, DQDOTI, DROT, DROTM, DSDOT, DSWAP, C DTEST, SAXPY, SCOPY, SDOT, SDSDOT, SROT, SROTM, C SSWAP, STEST C***COMMON BLOCKS COMBLA C***REVISION HISTORY (YYMMDD) C 750226 DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE CHECK2 COMMON /COMBLA/ NPRINT, ICASE, N, INCX, INCY, MODE, PASS C LOGICAL PASS INTEGER INCXS(4),INCYS(4),LENS(4,2),NS(4) REAL SX(7),SY(7),STX(7),STY(7),SSIZE1(4),SSIZE2(14,2) REAL SSIZE(7),QC(10),SPARAM(5),ST7B(4,4),SSIZE3(4) DOUBLE PRECISION DX(7),DA,DX1(7),DY1(7),DY(7),DT7(4,4),DT8(7,4,4) DOUBLE PRECISION DX2(7), DY2(7), DT2(4,4,2), DPARAM(5), DPAR(5,4) DOUBLE PRECISION DSDOT,DDOT,DQDOTI,DQDOTA,DFAC,DQFAC DOUBLE PRECISION DT10X(7,4,4),DT10Y(7,4,4),DB DOUBLE PRECISION DSIZE1(4),DSIZE2(7,2),DSIZE(7) DOUBLE PRECISION DC,DS,DT9X(7,4,4),DT9Y(7,4,4),DTX(7),DTY(7) DOUBLE PRECISION DT19X(7,4,16),DT19XA(7,4,4),DT19XB(7,4,4) DOUBLE PRECISION DT19XC(7,4,4),DT19XD(7,4,4),DT19Y(7,4,16) DOUBLE PRECISION DT19YA(7,4,4),DT19YB(7,4,4),DT19YC(7,4,4) DOUBLE PRECISION DT19YD(7,4,4) C EQUIVALENCE (DT19X(1,1,1),DT19XA(1,1,1)),(DT19X(1,1,5), A DT19XB(1,1,1)),(DT19X(1,1,9),DT19XC(1,1,1)), B (DT19X(1,1,13),DT19XD(1,1,1)) EQUIVALENCE (DT19Y(1,1,1),DT19YA(1,1,1)),(DT19Y(1,1,5), A DT19YB(1,1,1)),(DT19Y(1,1,9),DT19YC(1,1,1)), B (DT19Y(1,1,13),DT19YD(1,1,1)) COMPLEX CX(7),CA,CX1(7),CY1(7),CY(7),CT6(4,4),CT7(4,4) COMPLEX CT8(7,4,4),CSIZE1(4),CSIZE2(7,2) COMPLEX CT10X(7,4,4), CT10Y(7,4,4) COMPLEX CDOTC,CDOTU DATA SA,DA,CA,DB,SB/.3,.3D0,(.4,-.7),.25D0,.1/ DATA INCXS/ 1, 2, -2, -1 / DATA INCYS/ 1, -2, 1, -2 / DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/ DATA NS / 0, 1, 2, 4 / DATA SC,SS,DC,DS/ .8,.6,.8D0,.6D0/ DATA DX1/ .6D0, .1D0,-.5D0, .8D0, .9D0,-.3D0,-.4D0/ DATA DY1/ .5D0,-.9D0, .3D0, .7D0,-.6D0, .2D0, .8D0/ DATA DX2/ 1.D0,.01D0, .02D0,1.D0,.06D0, 2.D0, 1.D0/ DATA DY2/ 1.D0,.04D0,-.03D0,-1.D0,.05D0,3.D0,-1.D0/ C THE TERMS D11(3,2) AND D11(4,2) WILL BE SET BY C COMPUTATION AT RUN TIME. DATA CX1/(.7,-.8),(-.4,-.7),(-.1,-.9),(.2,-.8),(-.9,-.4),(.1,.4), * (-.6,.6)/ DATA CY1/(.6,-.6),(-.9,.5),(.7,-.6),(.1,-.5),(-.1,-.2),(-.5,-.3), * (.8,-.7) / C C FOR DQDOTI AND DQDOTA C DATA DT2/0.25D0,1.25D0,1.2504D0,0.2498D0, A 0.25D0,1.25D0,0.24D0,0.2492D0, B 0.25D0,1.25D0,0.31D0,0.2518D0, C 0.25D0,1.25D0,1.2497D0,0.2507D0, D 0.D0,2.D0,2.0008D0,-.0004D0, E 0.D0,2.D0,-.02D0,-.0016D0, F 0.D0,2.D0,.12D0,.0036D0, G 0.D0,2.D0,1.9994D0,.0014D0/ DATA DT7/ 0.D0,.30D0,.21D0,.62D0, 0.D0,.30D0,-.07D0,.85D0, * 0.D0,.30D0,-.79D0,-.74D0, 0.D0,.30D0,.33D0,1.27D0/ DATA ST7B/ .1, .4, .31, .72, .1, .4, .03, .95, * .1, .4, -.69, -.64, .1, .4, .43, 1.37/ C C FOR CDOTU C DATA CT7/(0.,0.),(-.06,-.90),(.65,-.47),(-.34,-1.22), 1 (0.,0.),(-.06,-.90),(-.59,-1.46),(-1.04,-.04), 2 (0.,0.),(-.06,-.90),(-.83,.59), ( .07,-.37), 3 (0.,0.),(-.06,-.90),(-.76,-1.15),(-1.33,-1.82)/ C C FOR CDOTC C DATA CT6/(0.,0.),(.90,0.06), (.91,-.77), (1.80,-.10), A (0.,0.),(.90,0.06), (1.45,.74), (.20,.90), B (0.,0.),(.90,0.06), (-.55,.23), (.83,-.39), C (0.,0.),(.90,0.06), (1.04,0.79), (1.95,1.22)/ C DATA DT8/.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, 1 .68D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, 2 .68D0,-.87D0, 0.D0,0.D0,0.D0,0.D0,0.D0, 3 .68D0,-.87D0,.15D0,.94D0, 0.D0,0.D0,0.D0, 4 .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, 5 .68D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, 6 .35D0,-.9D0,.48D0, 0.D0,0.D0,0.D0,0.D0, 7 .38D0,-.9D0,.57D0,.7D0,-.75D0,.2D0,.98D0, 8 .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, 9 .68D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .35D0,-.72D0, 0.D0,0.D0,0.D0,0.D0,0.D0, B .38D0,-.63D0,.15D0,.88D0, 0.D0,0.D0,0.D0, C .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, D .68D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E .68D0,-.9D0,.33D0, 0.D0,0.D0,0.D0,0.D0, F .68D0,-.9D0,.33D0,.7D0,-.75D0,.2D0,1.04D0/ C DATA CT8/ A(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), B(.32,-1.41),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), C(.32,-1.41),(-1.55,.5),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), D(.32,-1.41),(-1.55,.5),(.03,-.89),(-.38,-.96),(0.,0.),(0.,0.), E (0.,0.), F(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), G(.32,-1.41),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), H(-.07,-.89),(-.9,.5),(.42,-1.41),(0.,0.),(0.,0.),(0.,0.),(0.,0.), I(.78,.06),(-.9,.5),(.06,-.13),(.1,-.5),(-.77,-.49),(-.5,-.3), J (.52,-1.51), K(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), L(.32,-1.41),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), M(-.07,-.89),(-1.18,-.31),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), N(.78,.06),(-1.54,.97),(.03,-.89),(-.18,-1.31),(0.,0.),(0.,0.), O(0.,0.),(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), P(.32,-1.41),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), Q(.32,-1.41),(-.9,.5),(.05,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.), R(.32,-1.41),(-.9,.5),(.05,-.6),(.1,-.5),(-.77,-.49),(-.5,-.3), S (.32,-1.16) / C C C TRUE X VALUES AFTER ROTATION USING SROT OR DROT. DATA DT9X/.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .78D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .78D0,-.46D0, 0.D0,0.D0,0.D0,0.D0,0.D0, C .78D0,-.46D0,-.22D0,1.06D0, 0.D0,0.D0,0.D0, D .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E .78D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F .66D0,.1D0,-.1D0, 0.D0,0.D0,0.D0,0.D0, G .96D0,.1D0,-.76D0,.8D0,.90D0,-.3D0,-.02D0, H .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, I .78D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, J -.06D0,.1D0,-.1D0, 0.D0,0.D0,0.D0,0.D0, K .90D0,.1D0,-.22D0,.8D0,.18D0,-.3D0,-.02D0, L .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, M .78D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, N .78D0,.26D0, 0.D0,0.D0,0.D0,0.D0,0.D0, O .78D0,.26D0,-.76D0,1.12D0, 0.D0,0.D0,0.D0/ C C TRUE Y VALUES AFTER ROTATION USING SROT OR DROT. C DATA DT9Y/ .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .04D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .04D0,-.78D0, 0.D0,0.D0,0.D0,0.D0,0.D0, C .04D0,-.78D0, .54D0, .08D0, 0.D0,0.D0,0.D0, D .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E .04D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F .7D0,-.9D0,-.12D0, 0.D0,0.D0,0.D0,0.D0, G .64D0,-.9D0,-.30D0, .7D0,-.18D0, .2D0, .28D0, H .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, I .04D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, J .7D0,-1.08D0, 0.D0,0.D0,0.D0,0.D0,0.D0, K .64D0,-1.26D0,.54D0, .20D0, 0.D0,0.D0,0.D0, L .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, M .04D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, N .04D0,-.9D0, .18D0, 0.D0,0.D0,0.D0,0.D0, O .04D0,-.9D0, .18D0, .7D0,-.18D0, .2D0, .16D0/ C DATA DT10X/.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .5D0,-.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0, C .5D0,-.9D0,.3D0,.7D0, 0.D0,0.D0,0.D0, D .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F .3D0,.1D0 ,.5D0, 0.D0,0.D0,0.D0,0.D0, G .8D0,.1D0 ,-.6D0,.8D0 ,.3D0,-.3D0,.5D0, H .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, I .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, J -.9D0,.1D0,.5D0, 0.D0,0.D0,0.D0,0.D0, K .7D0, .1D0,.3D0, .8D0,-.9D0,-.3D0,.5D0, L .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, M .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, N .5D0,.3D0, 0.D0,0.D0,0.D0,0.D0,0.D0, O .5D0,.3D0,-.6D0,.8D0, 0.D0,0.D0,0.D0/ C DATA DT10Y/.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .6D0,.1D0, 0.D0,0.D0,0.D0,0.D0,0.D0, C .6D0,.1D0,-.5D0,.8D0, 0.D0,0.D0,0.D0, D .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F -.5D0,-.9D0,.6D0, 0.D0,0.D0,0.D0,0.D0, G -.4D0,-.9D0,.9D0, .7D0,-.5D0, .2D0,.6D0, H .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, I .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, J -.5D0,.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0, K -.4D0,.9D0,-.5D0,.6D0, 0.D0,0.D0,0.D0, L .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, M .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, N .6D0,-.9D0,.1D0, 0.D0,0.D0,0.D0,0.D0, O .6D0,-.9D0,.1D0, .7D0,-.5D0, .2D0, .8D0/ C DATA CT10X/ A(.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), B(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), C(.6,-.6),(-.9,.5),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), D(.6,-.6),(-.9,.5),(.7,-.6),(.1,-.5),(0.,0.),(0.,0.),(0.,0.), E(.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), F(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), G(.7,-.6),(-.4,-.7),(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.), H(.8,-.7),(-.4,-.7),(-.1,-.2),(.2,-.8),(.7,-.6),(.1,.4),(.6,-.6), I(.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), J(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), K(-.9,.5),(-.4,-.7),(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.), L(.1,-.5),(-.4,-.7),(.7,-.6),(.2,-.8),(-.9,.5),(.1,.4),(.6,-.6), M(.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), N(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), O(.6,-.6),(.7,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), P(.6,-.6),(.7,-.6),(-.1,-.2),(.8,-.7),(0.,0.),(0.,0.),(0.,0.) / C DATA CT10Y/ A(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), B(.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), C(.7,-.8),(-.4,-.7),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), D(.7,-.8),(-.4,-.7),(-.1,-.9),(.2,-.8),(0.,0.),(0.,0.),(0.,0.), E(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), F(.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), G(-.1,-.9),(-.9,.5),(.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.), H(-.6,.6),(-.9,.5),(-.9,-.4),(.1,-.5),(-.1,-.9),(-.5,-.3),(.7,-.8), I(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), J(.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), K(-.1,-.9),(.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), L(-.6,.6),(-.9,-.4),(-.1,-.9),(.7,-.8),(0.,0.),(0.,0.),(0.,0.), M(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), N(.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), O(.7,-.8),(-.9,.5),(-.4,-.7),(0.,0.),(0.,0.),(0.,0.),(0.,0.), P(.7,-.8),(-.9,.5),(-.4,-.7),(.1,-.5),(-.1,-.9),(-.5,-.3),(.2,-.8)/ C TRUE X RESULTS F0R ROTATIONS SROTM AND DROTM DATA DT19XA/.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, C .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, D .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, G 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, H .6D0, .1D0, 0.D0,0.D0,0.D0,0.D0,0.D0, I -.8D0, 3.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, J -.9D0, 2.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, K 3.5D0, -.4D0, 0.D0,0.D0,0.D0,0.D0,0.D0, L .6D0, .1D0, -.5D0, .8D0, 0.D0,0.D0,0.D0, M -.8D0, 3.8D0, -2.2D0, -1.2D0, 0.D0,0.D0,0.D0, N -.9D0, 2.8D0, -1.4D0, -1.3D0, 0.D0,0.D0,0.D0, O 3.5D0, -.4D0, -2.2D0, 4.7D0, 0.D0,0.D0,0.D0/ C DATA DT19XB/.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, C .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, D .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, G 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, H .6D0, .1D0, -.5D0, 0.D0,0.D0,0.D0,0.D0, I 0.D0, .1D0, -3.0D0, 0.D0,0.D0,0.D0,0.D0, J -.3D0, .1D0, -2.0D0, 0.D0,0.D0,0.D0,0.D0, K 3.3D0, .1D0, -2.0D0, 0.D0,0.D0,0.D0,0.D0, L .6D0, .1D0, -.5D0, .8D0, .9D0, -.3D0, -.4D0, M -2.0D0, .1D0, 1.4D0, .8D0, .6D0, -.3D0, -2.8D0, N -1.8D0, .1D0, 1.3D0, .8D0, 0.D0, -.3D0, -1.9D0, O 3.8D0, .1D0, -3.1D0, .8D0, 4.8D0, -.3D0, -1.5D0 / C DATA DT19XC/.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, C .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, D .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, G 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, H .6D0, .1D0, -.5D0, 0.D0,0.D0,0.D0,0.D0, I 4.8D0, .1D0, -3.0D0, 0.D0,0.D0,0.D0,0.D0, J 3.3D0, .1D0, -2.0D0, 0.D0,0.D0,0.D0,0.D0, K 2.1D0, .1D0, -2.0D0, 0.D0,0.D0,0.D0,0.D0, L .6D0, .1D0, -.5D0, .8D0, .9D0, -.3D0, -.4D0, M -1.6D0, .1D0, -2.2D0, .8D0, 5.4D0, -.3D0, -2.8D0, N -1.5D0, .1D0, -1.4D0, .8D0, 3.6D0, -.3D0, -1.9D0, O 3.7D0, .1D0, -2.2D0, .8D0, 3.6D0, -.3D0, -1.5D0 / C DATA DT19XD/.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, C .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, D .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, G 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, H .6D0, .1D0, 0.D0,0.D0,0.D0,0.D0,0.D0, I -.8D0, -1.0D0, 0.D0,0.D0,0.D0,0.D0,0.D0, J -.9D0, -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, K 3.5D0, .8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, L .6D0, .1D0, -.5D0, .8D0, 0.D0,0.D0,0.D0, M -.8D0, -1.0D0, 1.4D0, -1.6D0, 0.D0,0.D0,0.D0, N -.9D0, -.8D0, 1.3D0, -1.6D0, 0.D0,0.D0,0.D0, O 3.5D0, .8D0, -3.1D0, 4.8D0, 0.D0,0.D0,0.D0/ C TRUE Y RESULTS FOR ROTATIONS SROTM AND DROTM DATA DT19YA/.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, C .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, D .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E .7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F 1.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, G -2.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, H .5D0, -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0, I .7D0, -4.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, J 1.7D0, -.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0, K -2.6D0, 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0, L .5D0, -.9D0, .3D0, .7D0, 0.D0,0.D0,0.D0, M .7D0, -4.8D0, 3.0D0, 1.1D0, 0.D0,0.D0,0.D0, N 1.7D0, -.7D0, -.7D0, 2.3D0, 0.D0,0.D0,0.D0, O -2.6D0, 3.5D0, -.7D0, -3.6D0, 0.D0,0.D0,0.D0/ C DATA DT19YB/.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, C .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, D .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E .7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F 1.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, G -2.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, H .5D0, -.9D0, .3D0, 0.D0,0.D0,0.D0,0.D0, I 4.0D0, -.9D0, -.3D0, 0.D0,0.D0,0.D0,0.D0, J -.5D0, -.9D0, 1.5D0, 0.D0,0.D0,0.D0,0.D0, K -1.5D0, -.9D0, -1.8D0, 0.D0,0.D0,0.D0,0.D0, L .5D0, -.9D0, .3D0, .7D0, -.6D0, .2D0, .8D0, M 3.7D0, -.9D0, -1.2D0, .7D0, -1.5D0, .2D0, 2.2D0, N -.3D0, -.9D0, 2.1D0, .7D0, -1.6D0, .2D0, 2.0D0, O -1.6D0, -.9D0, -2.1D0, .7D0, 2.9D0, .2D0, -3.8D0 / C DATA DT19YC/.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, C .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, D .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E .7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F 1.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, G -2.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, H .5D0, -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0, I 4.0D0, -6.3D0, 0.D0,0.D0,0.D0,0.D0,0.D0, J -.5D0, .3D0, 0.D0,0.D0,0.D0,0.D0,0.D0, K -1.5D0, 3.0D0, 0.D0,0.D0,0.D0,0.D0,0.D0, L .5D0, -.9D0, .3D0, .7D0, 0.D0,0.D0,0.D0, M 3.7D0, -7.2D0, 3.0D0, 1.7D0, 0.D0,0.D0,0.D0, N -.3D0, .9D0, -.7D0, 1.9D0, 0.D0,0.D0,0.D0, O -1.6D0, 2.7D0, -.7D0, -3.4D0, 0.D0,0.D0,0.D0/ C DATA DT19YD/.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, C .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, D .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E .7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F 1.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, G -2.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, H .5D0, -.9D0, .3D0, 0.D0,0.D0,0.D0,0.D0, I .7D0, -.9D0, 1.2D0, 0.D0,0.D0,0.D0,0.D0, J 1.7D0, -.9D0, .5D0, 0.D0,0.D0,0.D0,0.D0, K -2.6D0, -.9D0, -1.3D0, 0.D0,0.D0,0.D0,0.D0, L .5D0, -.9D0, .3D0, .7D0, -.6D0, .2D0, .8D0, M .7D0, -.9D0, 1.2D0, .7D0, -1.5D0, .2D0, 1.6D0, N 1.7D0, -.9D0, .5D0, .7D0, -1.6D0, .2D0, 2.4D0, O -2.6D0, -.9D0, -1.3D0, .7D0, 2.9D0, .2D0, -4.0D0 / C DATA SSIZE1/ 0. , .3 , 1.6 , 3.2 / DATA DSIZE1/ 0.D0, .3D0, 1.6D0, 3.2D0 / DATA SSIZE3/ .1, .4, 1.7, 3.3 / C C FOR CDOTC AND CDOTU C DATA CSIZE1/ (0.,0.), (.9,.9), (1.63,1.73), (2.90,2.78) / DATA SSIZE2/0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0., A 1.17,1.17,1.17,1.17,1.17,1.17,1.17, B 1.17,1.17,1.17,1.17,1.17,1.17,1.17/ DATA DSIZE2/0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A 1.17D0,1.17D0,1.17D0,1.17D0,1.17D0,1.17D0,1.17D0/ C C FOR CAXPY C DATA CSIZE2/ A (0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), B (1.54,1.54),(1.54,1.54),(1.54,1.54),(1.54,1.54),(1.54,1.54), C (1.54,1.54),(1.54,1.54) / C C FOR SROTM AND DROTM C DATA DPAR/-2.D0, 0.D0,0.D0,0.D0,0.D0, A -1.D0, 2.D0, -3.D0, -4.D0, 5.D0, B 0.D0, 0.D0, 2.D0, -3.D0, 0.D0, C 1.D0, 5.D0, 2.D0, 0.D0, -4.D0/ C***FIRST EXECUTABLE STATEMENT CHECK2 DO 520 KI = 1, 4 INCX = INCXS(KI) INCY = INCYS(KI) MX = ABS(INCX) MY = ABS(INCY) C DO 500 KN=1,4 N= NS(KN) KSIZE=MIN(2,KN) LENX = LENS(KN,MX) LENY = LENS(KN,MY) C INITIALIZE ALL ARGUMENT ARRAYS. DO 5 I = 1, 7 SX(I) = DX1(I) SY(I) = DY1(I) DX(I) = DX1(I) DY(I) = DY1(I) CX(I) = CX1(I) 5 CY(I) = CY1(I) C C BRANCH TO SELECT SUBPROGRAM TO BE TESTED. C GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, 90,100, A 110,999,999,140,150,999,999,180,190,200, B 210,220,230,240,250), ICASE C 1. SDOT 10 CALL STEST(1,SDOT(N,SX,INCX,SY,INCY),REAL(DT7(KN,KI)), * SSIZE1(KN),SFAC,KPRINT) GO TO 500 C 2. DSDOT 20 CALL STEST(1,REAL(DSDOT(N,SX,INCX,SY,INCY)), * REAL(DT7(KN,KI)),SSIZE1(KN),SFAC,KPRINT) GO TO 500 C 3. SDSDOT 30 CALL STEST(1,SDSDOT(N,SB,SX,INCX,SY,INCY), * ST7B(KN,KI),SSIZE3(KN),SFAC,KPRINT) GO TO 500 C 4. DDOT 40 CALL DTEST(1,DDOT(N,DX,INCX,DY,INCY),DT7(KN,KI), * DSIZE1(KN),DFAC,KPRINT) GO TO 500 C 5. DQDOTI 50 CONTINUE C DQDOTI AND DQDOTA ARE SUPPOSED TO USE EXTENDED C PRECISION ARITHMETIC INTERNALLY. C SET MODE = 1 OR 2 TO DISTINGUISH TESTS OF DQDOTI OR DQDOTA C IN THE DIAGNOSTIC OUTPUT. C MODE = 1 CALL DTEST(1,DQDOTI(N,DB,QC,DX2,INCX,DY2,INCY), * DT2(KN,KI,1),DT2(KN,KI,1),DQFAC,KPRINT) GO TO 500 C 6. DQDOTA 60 CONTINUE C TO TEST DQDOTA WE ACTUALLY TEST BOTH DQDOTI AND DQDOTA. C THE OUTPUT VALUE OF QX FROM DQDOTI WILL BE USED AS INPUT C TO DQDOTA. QX IS SUPPOSED TO BE IN A MACHINE-DEPENDENT C EXTENDED PRECISION FORM. C MODE IS SET TO 1 OR 2 TO DISTINGUISH TESTS OF C DQDOTI OR DQDOTA IN THE DIAGNOSTIC OUTPUT. C MODE = 1 CALL DTEST(1,DQDOTI(N,DB,QC,DX2,INCX,DY2,INCY), * DT2(KN,KI,1),DT2(KN,KI,1),DQFAC,KPRINT) MODE = 2 CALL DTEST(1,DQDOTA(N,-DB,QC,DX2,INCX,DY2,INCY), * DT2(KN,KI,2),DT2(KN,KI,2),DQFAC,KPRINT) GO TO 500 C 7. CDOTC 70 CALL STEST(2, CDOTC(N,CX,INCX,CY,INCY), * CT6(KN,KI),CSIZE1(KN),SFAC,KPRINT) GO TO 500 C 8. CDOTU 80 CALL STEST(2,CDOTU(N,CX,INCX,CY,INCY), * CT7(KN,KI),CSIZE1(KN),SFAC,KPRINT) GO TO 500 C 9. SAXPY 90 CALL SAXPY(N,SA,SX,INCX,SY,INCY) DO 95 J = 1, LENY 95 STY(J) = DT8(J,KN,KI) CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC,KPRINT) GO TO 500 C 10. DAXPY 100 CALL DAXPY(N,DA,DX,INCX,DY,INCY) CALL DTEST(LENY,DY,DT8(1,KN,KI),DSIZE2(1,KSIZE),DFAC,KPRINT) GO TO 500 C 11. CAXPY 110 CALL CAXPY(N,CA,CX,INCX,CY,INCY) CALL STEST(2*LENY,CY,CT8(1,KN,KI),CSIZE2(1,KSIZE),SFAC,KPRINT) GO TO 500 C 14. SROT 140 CONTINUE DO 144 I = 1, 7 SX(I) = DX1(I) SY(I) = DY1(I) STX(I) = DT9X(I,KN,KI) STY(I) = DT9Y(I,KN,KI) 144 CONTINUE CALL SROT (N,SX,INCX,SY,INCY,SC,SS) CALL STEST(LENX,SX,STX,SSIZE2(1,KSIZE),SFAC,KPRINT) CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC,KPRINT) GO TO 500 C 15. DROT 150 CONTINUE DO 154 I = 1, 7 DX(I) = DX1(I) DY(I) = DY1(I) 154 CONTINUE CALL DROT (N,DX,INCX,DY,INCY,DC,DS) CALL DTEST(LENX,DX,DT9X(1,KN,KI),DSIZE2(1,KSIZE),DFAC,KPRINT) CALL DTEST(LENY,DY,DT9Y(1,KN,KI),DSIZE2(1,KSIZE),DFAC,KPRINT) GO TO 500 C 18. SROTM 180 KNI = KN + 4*(KI-1) DO 189 KPAR=1,4 DO 182 I = 1, 7 SX(I) = DX1(I) SY(I) = DY1(I) STX(I) = DT19X(I,KPAR,KNI) 182 STY(I) = DT19Y(I,KPAR,KNI) C DO 186 I = 1, 5 186 SPARAM(I) = DPAR(I,KPAR) C SET MODE TO IDENTIFY DIAGNOSTIC OUTPUT, C IF ANY MODE = INT(SPARAM(1)) C DO 187 I = 1, LENX 187 SSIZE(I) = STX(I) C THE TRUE RESULTS DT19X(1,2,7) AND C DT19X(5,3,8) ARE ZERO DUE TO CANCELLATION. C DT19X(1,2,7) = 2.*.6 - 4.*.3 = 0 C DT19X(5,3,8) = .9 - 3.*.3 = 0 C FOR THESE CASES RESPECTIVELY SET SIZE( ) C EQUAL TO 2.4 AND 1.8 IF ((KPAR .EQ. 2) .AND. (KNI .EQ. 7)) 1 SSIZE(1) = 2.4E0 IF ((KPAR .EQ. 3) .AND. (KNI .EQ. 8)) 1 SSIZE(5) = 1.8E0 C CALL SROTM(N,SX,INCX,SY,INCY,SPARAM) CALL STEST(LENX,SX,STX,SSIZE,SFAC,KPRINT) CALL STEST(LENY,SY,STY,STY,SFAC,KPRINT) 189 CONTINUE GO TO 500 C 19. DROTM 190 KNI = KN + 4*(KI-1) DO 199 KPAR=1,4 DO 192 I = 1, 7 DX(I) = DX1(I) DY(I) = DY1(I) DTX(I) = DT19X(I,KPAR,KNI) 192 DTY(I) = DT19Y(I,KPAR,KNI) C DO 196 I = 1, 5 196 DPARAM(I) = DPAR(I,KPAR) C SET MODE TO IDENTIFY DIAGNOSTIC OUTPUT, C IF ANY MODE = INT(DPARAM(1)) C DO 197 I = 1, LENX 197 DSIZE(I) = DTX(I) C SEE REMARK ABOVE ABOUT DT11X(1,2,7) C AND DT11X(5,3,8). IF ((KPAR .EQ. 2) .AND. (KNI .EQ. 7)) 1 DSIZE(1) = 2.4D0 IF ((KPAR .EQ. 3) .AND. (KNI .EQ. 8)) 1 DSIZE(5) = 1.8D0 C CALL DROTM(N,DX,INCX,DY,INCY,DPARAM) CALL DTEST(LENX,DX,DTX,DSIZE,DFAC,KPRINT) CALL DTEST(LENY,DY,DTY,DTY,DFAC,KPRINT) 199 CONTINUE GO TO 500 C 20. SCOPY 200 DO 205 I = 1, 7 205 STY(I) = DT10Y(I,KN,KI) CALL SCOPY(N,SX,INCX,SY,INCY) CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.,KPRINT) GO TO 500 C 21. DCOPY 210 CALL DCOPY(N,DX,INCX,DY,INCY) CALL DTEST(LENY,DY,DT10Y(1,KN,KI),DSIZE2(1,1),1.D0,KPRINT) GO TO 500 C 22. CCOPY 220 CALL CCOPY(N,CX,INCX,CY,INCY) CALL STEST(2*LENY,CY,CT10Y(1,KN,KI),SSIZE2(1,1),1.,KPRINT) GO TO 500 C 23. SSWAP 230 CALL SSWAP(N,SX,INCX,SY,INCY) DO 235 I = 1, 7 STX(I) = DT10X(I,KN,KI) 235 STY(I) = DT10Y(I,KN,KI) CALL STEST(LENX,SX,STX,SSIZE2(1,1),1.,KPRINT) CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.,KPRINT) GO TO 500 C 24. DSWAP 240 CALL DSWAP(N,DX,INCX,DY,INCY) CALL DTEST(LENX,DX,DT10X(1,KN,KI),DSIZE2(1,1),1.D0,KPRINT) CALL DTEST(LENY,DY,DT10Y(1,KN,KI),DSIZE2(1,1),1.D0,KPRINT) GO TO 500 C 25. CSWAP 250 CALL CSWAP(N,CX,INCX,CY,INCY) CALL STEST(2*LENX,CX,CT10X(1,KN,KI),SSIZE2(1,1),1.,KPRINT) CALL STEST(2*LENY,CY,CT10Y(1,KN,KI),SSIZE2(1,1),1.,KPRINT) C C C 500 CONTINUE 520 CONTINUE RETURN C THE FOLLOWING STOP SHOULD NEVER BE REACHED. 999 STOP END *DECK CHIQC SUBROUTINE CHIQC (LUN, KPRINT, NERR) C***BEGIN PROLOGUE CHIQC C***PURPOSE Quick check for CHIFA, CHICO, CHISL and CHIDI. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Voorhees, E. A., (LANL) C***DESCRIPTION C C LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS C OF THE PROPER TYPE FOR THE LINPACK SUBROUTINES BEING TESTED. C THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF C C (THE SOLUTION VECTOR), AINV (INVERSE OF MATRIX A ), DC C (DETERMINANT OF A ), AND RCND ( RCOND ) ARE ENTERED C WITH DATA STATEMENTS. C C THE COMPUTED TEST RESULTS FOR X, RCOND, THE DETERMINANT, AND C THE INVERSE ARE COMPARED TO THE STORED PRE-COMPUTED VALUES. C FAILURE OF THE TEST OCCURS WHEN AGREEMENT TO 3 SIGNIFICANT C DIGITS IS NOT ACHIEVED AND AN ERROR MESSAGE INDICATING WHICH C LINPACK SUBROUTINE FAILED AND WHICH QUANTITY WAS INVOLVED IS C PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. C C NO INPUT ARGUMENTS ARE REQUIRED. C ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT OF C ALL FAILURES DETECTED BY CHIQC. C C***ROUTINES CALLED CHICO, CHIDI, CHIFA, CHISL C***REVISION HISTORY (YYMMDD) C 801022 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF and cleaned up C FORMATs. (RWC) C***END PROLOGUE CHIQC COMPLEX A(4,4),AT(5,4),B(4),BT(4),C(4),AINV(4,4), 1 Z(4),XA,XB REAL R,RCOND,RCND,DELX,DET(2),DC(2) CHARACTER KPROG*19,KFAIL*47 INTEGER LDA,N,IPVT(4),INFO,I,J,INDX,NERR INTEGER INERT(3),IRT(3) DATA A/(2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), 1 (0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 2 (0.E0,0.E0),(0.E0,0.E0),(3.E0,0.E0),(0.E0,1.E0), 3 (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/ DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA AINV/(.66667E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0, 1 0.E0), 2 (0.E0,.33333E0),(.66667E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 3 (0.E0,0.E0),(0.E0,0.E0),(.36364E0,0.E0),(0.E0,1.E0), 4 (0.E0,0.E0),(0.E0,0.E0),(0.E0,.09091E0),(.27273E0,0.E0)/ DATA DC/3.3E0,1.0E0/ DATA KPROG/'HIFA HICO HISL HIDI'/ DATA KFAIL/'INFO RCOND SOLUTION DETERMINANT INVERSE INERTIA'/ DATA RCND/.24099E0/ DATA IRT/4,0,0/ C DELX(XA,XB)=ABS(REAL(XA-XB))+ABS(AIMAG(XA-XB)) C***FIRST EXECUTABLE STATEMENT CHIQC LDA = 5 N = 4 NERR = 0 C C FORM AT FOR CHIFA AND BT FOR CHISL, TEST CHIFA C DO 20 J=1,N BT(J) = B(J) DO 10 I=1,N AT(I,J) = A(I,J) 10 CONTINUE 20 CONTINUE C CALL CHIFA(AT,LDA,N,IPVT,INFO) IF (INFO .NE. 0) THEN WRITE (LUN,201) KPROG(1:4),KFAIL(1:4) NERR = NERR + 1 ENDIF C C TEST CHISL C CALL CHISL(AT,LDA,N,IPVT,BT) INDX = 0 DO 40 I=1,N IF (DELX(C(I),BT(I)) .GT. .0001) INDX=INDX+1 40 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ENDIF C C FORM AT FOR CHICO, TEST CHICO C DO 70 J=1,N DO 60 I=1,N AT(I,J) = A(I,J) 60 CONTINUE 70 CONTINUE C CALL CHICO(AT,LDA,N,IPVT,RCOND,Z) R = ABS(RCND-RCOND) IF (R .GE. .0001) THEN WRITE (LUN,201) KPROG(6:9),KFAIL(6:10) NERR = NERR + 1 ENDIF C C TEST CHIDI FOR JOB=111 C CALL CHIDI(AT,LDA,N,IPVT,DET,INERT,Z,111) INDX = 0 DO 110 I=1,2 IF (ABS(DC(I)-DET(I)) .GT. .0001) INDX=INDX+1 110 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(16:19),KFAIL(21:31) NERR = NERR + 1 ENDIF C INDX = 0 DO 140 I=1,N DO 130 J=1,N IF (DELX(AINV(I,J),AT(I,J)) .GT. .0001) INDX=INDX+1 130 CONTINUE 140 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(16:19),KFAIL(33:39) NERR = NERR + 1 ENDIF C INDX = 0 DO 160 I=1,3 IF((INERT(I)-IRT(I)) .NE. 0) INDX=INDX+1 160 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(16:19),KFAIL(41:47) NERR = NERR + 1 ENDIF C IF (KPRINT.GE.2 .OR. NERR.NE.0) WRITE (LUN,200) NERR RETURN C 200 FORMAT(/' * CHIQC - TEST FOR CHIFA, CHICO, CHISL AND CHIDI FOUND ' 1 , I1, ' ERRORS.'/) 201 FORMAT (/' *** C', A, ' FAILURE - ERROR IN ', A) END *DECK CHPQC SUBROUTINE CHPQC (LUN, KPRINT, NERR) C***BEGIN PROLOGUE CHPQC C***PURPOSE Quick check for CHPFA, CHPCO, CHPSL and CHPDI. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Voorhees, E. A., (LANL) C***DESCRIPTION C C LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS C OF THE PROPER TYPE FOR THE LINPACK SUBROUTINES BEING TESTED. C THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF C C (THE SOLUTION VECTOR), AINV (INVERSE OF MATRIX A ), DC C (DETERMINANT OF A ), AND RCND ( RCOND ) ARE ENTERED C WITH DATA STATEMENTS. C C THE COMPUTED TEST RESULTS FOR X, RCOND, THE DETERMINANT, AND C THE INVERSE ARE COMPARED TO THE STORED PRE-COMPUTED VALUES. C FAILURE OF THE TEST OCCURS WHEN AGREEMENT TO 3 SIGNIFICANT C DIGITS IS NOT ACHIEVED AND AN ERROR MESSAGE INDICATING WHICH C LINPACK SUBROUTINE FAILED AND WHICH QUANTITY WAS INVOLVED IS C PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. C C NO INPUT ARGUMENTS ARE REQUIRED. C ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT OF C ALL FAILURES DETECTED BY CHPQC. C C***ROUTINES CALLED CHPCO, CHPDI, CHPFA, CHPSL C***REVISION HISTORY (YYMMDD) C 801022 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF and cleaned up C FORMATs. (RWC) C***END PROLOGUE CHPQC COMPLEX AP(10),AT(10),B(4),BT(4),C(4),AINV(10), 1 Z(4),XA,XB REAL R,RCOND,RCND,DELX,DET(2),DC(2) CHARACTER KPROG*19, KFAIL*47 INTEGER N,IPVT(4),INFO,I,J,INDX,NERR INTEGER INERT(3),IRT(3) DATA AP/(2.E0,0.E0),(0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0), 1 (0.E0,0.E0),(3.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 2 (0.E0,-1.E0),(4.E0,0.E0)/ DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA AINV/(.66667E0,0.E0),(0.E0,.33333E0),(.66667E0,0.E0), 1 (0.E0,0.E0), 2 (0.E0,0.E0),(.36364E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 3 (0.E0,.09091E0),(.27273E0,0.E0)/ DATA DC/3.3E0,1.0E0/ DATA KPROG/'HPFA HPCO HPSL HPDI'/ DATA KFAIL/'INFO RCOND SOLUTION DETERMINANT INVERSE INERTIA'/ DATA RCND/.24099E0/ DATA IRT/4,0,0/ C DELX(XA,XB)=ABS(REAL(XA-XB))+ABS(AIMAG(XA-XB)) C***FIRST EXECUTABLE STATEMENT CHPQC N = 4 NERR = 0 C C FORM AT FOR CHPFA AND BT FOR CHPSL, TEST CHPFA C DO 10 J=1,N BT(J) = B(J) 10 CONTINUE C DO 20 I=1,10 AT(I) = AP(I) 20 CONTINUE C CALL CHPFA(AT,N,IPVT,INFO) IF (INFO .NE. 0) THEN WRITE (LUN,201) KPROG(1:4),KFAIL(1:4) NERR = NERR + 1 ENDIF C C TEST CHPSL C CALL CHPSL(AT,N,IPVT,BT) INDX = 0 DO 40 I=1,N IF (DELX(C(I),BT(I)) .GT. .0001) INDX=INDX+1 40 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ENDIF C C FORM AT FOR CHPCO, TEST CHPCO C DO 70 I=1,10 AT(I) = AP(I) 70 CONTINUE C CALL CHPCO(AT,N,IPVT,RCOND,Z) R = ABS(RCND-RCOND) IF (R .GE. .0001) THEN WRITE (LUN,201) KPROG(6:9),KFAIL(6:10) NERR = NERR + 1 ENDIF C C TEST CHPDI FOR JOB=111 C CALL CHPDI(AT,N,IPVT,DET,INERT,Z,111) INDX = 0 DO 110 I=1,2 IF (ABS(DC(I)-DET(I)) .GT. .0001) INDX=INDX+1 110 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(16:19),KFAIL(21:31) NERR = NERR + 1 ENDIF C INDX = 0 DO 140 I=1,10 IF (DELX(AINV(I),AT(I)) .GT. .0001) INDX=INDX+1 140 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(16:19),KFAIL(33:39) NERR = NERR + 1 ENDIF C INDX = 0 DO 160 I=1,3 IF ((INERT(I)-IRT(I)) .NE. 0) INDX=INDX+1 160 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(16:19),KFAIL(41:47) NERR = NERR + 1 ENDIF C IF (KPRINT.GE.2 .OR. NERR.NE.0) WRITE (LUN,200) NERR RETURN C 200 FORMAT(/' * CHPQC - TEST FOR CHPFA, CHPCO, CHPSL AND CHPDI FOUND ' 1 , I1, ' ERRORS.'/) 201 FORMAT (/' *** C', A, ' FAILURE - ERROR IN ', A) END *DECK CMPARE SUBROUTINE CMPARE (ICNT, ITEST) C***BEGIN PROLOGUE CMPARE C***PURPOSE Compare values in COMMON block CHECK for quick check C routine PFITQX. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (CMPARE-S, DCMPAR-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***COMMON BLOCKS CHECK C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890921 Realigned order of variables in the COMMON block. C (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 920214 Minor improvements to code for readability. (WRB) C***END PROLOGUE CMPARE C .. Scalar Arguments .. INTEGER ICNT C .. Array Arguments .. INTEGER ITEST(9) C .. Scalars in Common .. REAL EPS, RP, SVEPS, TOL INTEGER IERP, IERR, NORD, NORDP C .. Arrays in Common .. REAL R(11) C .. Local Scalars .. REAL RPP, SS INTEGER IERPP, NRDP C .. Local Arrays .. INTEGER ITEMP(4) C .. Intrinsic Functions .. INTRINSIC ABS C .. Common blocks .. COMMON /CHECK/ EPS, R, RP, SVEPS, TOL, NORDP, NORD, IERP, IERR C***FIRST EXECUTABLE STATEMENT CMPARE ICNT = ICNT + 1 ITEMP(1) = 0 ITEMP(2) = 0 ITEMP(3) = 0 ITEMP(4) = 0 SS = SVEPS - EPS NRDP = NORDP - NORD RPP = RP - R(11) IERPP = IERP - IERR IF (ABS(SS).LE.TOL .OR. ICNT.LE.2 .OR. ICNT.GE.6) ITEMP(1) = 1 IF (ABS(NRDP) .EQ. 0) ITEMP(2) = 1 IF (ABS(RPP) .LE. TOL) ITEMP(3) = 1 IF (ABS(IERPP) .EQ. 0) ITEMP(4) = 1 C C Check to see if all four tests were good. C If so, set the test number equal to 1. C ITEST(ICNT) = ITEMP(1)*ITEMP(2)*ITEMP(3)*ITEMP(4) RETURN END *DECK COMP LOGICAL FUNCTION COMP (IERACT, IEREXP, LOUT, KPRINT) C***BEGIN PROLOGUE COMP C***SUBSIDIARY C***PURPOSE Compare actual and expected values of error flag. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK SERVICE ROUTINE C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C COMPARE ACTUAL VALUE OF IERR WITH EXPECTED VALUE. C PRINT ERROR MESSAGE IF THEY DON'T AGREE. C C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 820601 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 890706 Cosmetic changes to prologue. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 Revised prologue. (FNF) C 900316 Minor modification to format 5010. (FNF) C 910708 Minor modifications in use of KPRINT. (WRB) C***END PROLOGUE COMP INTEGER IERACT, IEREXP, LOUT, KPRINT C***FIRST EXECUTABLE STATEMENT COMP IF (IERACT .EQ. IEREXP) THEN COMP = .TRUE. IF (KPRINT .GE. 3) WRITE (LOUT, 5010) 5010 FORMAT (' OK.') ELSE COMP = .FALSE. IF (KPRINT .GE. 3) WRITE (LOUT, 5020) IERACT 5020 FORMAT (' *** COMPARE FAILED -- IERR =',I5) ENDIF C RETURN C------------- LAST LINE OF COMP FOLLOWS ----------------------------- END *DECK CPBQC SUBROUTINE CPBQC (LUN, KPRINT, NERR) C***BEGIN PROLOGUE CPBQC C***PURPOSE Quick check for CPBFA, CPBCO, CPBSL and CPBDI. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Voorhees, E. A., (LANL) C***DESCRIPTION C C LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS C OF THE PROPER TYPE FOR THE LINPACK SUBROUTINES BEING TESTED. C THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF C C (THE SOLUTION VECTOR), DC (DETERMINANT OF A ), AND C RCND (RCOND) ARE ENTERED WITH DATA STATEMENTS. C C THE COMPUTED TEST RESULTS FOR X, RCOND AND THE DETER- C MINANT ARE COMPARED TO THE STORED PRE-COMPUTED VALUES. C FAILURE OF THE TEST OCCURS WHEN AGREEMENT TO 3 SIGNIFICANT C DIGITS IS NOT ACHIEVED AND AN ERROR MESSAGE INDICATING WHICH C LINPACK SUBROUTINE FAILED AND WHICH QUANTITY WAS INVOLVED IS C PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. C C NO INPUT ARGUMENTS ARE REQUIRED. C ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT OF C ALL FAILURES DETECTED BY CPBQC. C C***ROUTINES CALLED CPBCO, CPBDI, CPBFA, CPBSL C***REVISION HISTORY (YYMMDD) C 801020 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF and cleaned up C FORMATs. (RWC) C***END PROLOGUE CPBQC COMPLEX ABD(2,4),AT(3,4),B(4),BT(4),C(4), 1 Z(4),XA,XB REAL R,RCOND,RCND,DELX,DET(2),DC(2) CHARACTER KPROG*19, KFAIL*39 INTEGER LDA,N,INFO,I,J,INDX,NERR,M DATA ABD/(0.E0,0.E0),(2.E0,0.E0),(0.E0,-1.E0),(2.E0,0.E0), 1 (0.E0,0.E0),(3.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/ DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA DC/3.3E0,1.0E0/ DATA KPROG/'PBFA PBCO PBSL PBDI'/ DATA KFAIL/'INFO RCOND SOLUTION DETERMINANT INVERSE'/ DATA RCND/.24099E0/ C DELX(XA,XB)=ABS(REAL(XA-XB))+ABS(AIMAG(XA-XB)) C***FIRST EXECUTABLE STATEMENT CPBQC LDA = 3 N = 4 M = 1 NERR = 0 C C FORM AT FOR CPBFA AND BT FOR CPBSL, TEST CPBFA C DO 20 J=1,N BT(J) = B(J) DO 10 I=1,2 AT(I,J) = ABD(I,J) 10 CONTINUE 20 CONTINUE C CALL CPBFA(AT,LDA,N,M,INFO) IF (INFO .NE. 0) THEN WRITE (LUN,201) KPROG(1:4),KFAIL(1:4) NERR = NERR + 1 ENDIF C C TEST CPBSL C CALL CPBSL(AT,LDA,N,M,BT) INDX = 0 DO 40 I=1,N IF (DELX(C(I),BT(I)) .GT. .0001) INDX=INDX+1 40 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ENDIF C C FORM AT FOR CPBCO, TEST CPBCO C DO 70 J=1,N DO 60 I=1,2 AT(I,J) = ABD(I,J) 60 CONTINUE 70 CONTINUE C CALL CPBCO(AT,LDA,N,M,RCOND,Z,INFO) R = ABS(RCND-RCOND) IF (R .GE. .0001) THEN WRITE (LUN,201) KPROG(6:9),KFAIL(6:10) NERR = NERR + 1 ENDIF C IF (INFO .NE. 0) THEN WRITE (LUN,201) KPROG(6:9),KFAIL(1:4) NERR = NERR + 1 ENDIF C C TEST CPBDI C CALL CPBDI(AT,LDA,N,M,DET) INDX = 0 DO 110 I=1,2 IF (ABS(DC(I)-DET(I)) .GT. .0001) INDX=INDX+1 110 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(16:19),KFAIL(21:31) NERR = NERR + 1 ENDIF C IF (KPRINT.GE.2 .OR. NERR.NE.0) WRITE (LUN,200) NERR RETURN C 200 FORMAT(/' * CPBQC - TEST FOR CPBFA, CPBCO, CPBSL AND CPBDI FOUND ' 1 , I1, ' ERRORS.'/) 201 FORMAT (/' *** C', A, ' FAILURE - ERROR IN ', A) END *DECK CPOQC SUBROUTINE CPOQC (LUN, KPRINT, NERR) C***BEGIN PROLOGUE CPOQC C***PURPOSE Quick check for CPOFA, CPOCO, CPOSL and CPODI. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Voorhees, E. A., (LANL) C***DESCRIPTION C C LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS C OF THE PROPER TYPE FOR THE LINPACK SUBROUTINES BEING TESTED. C THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF C C (THE SOLUTION VECTOR), AINV (INVERSE OF MATRIX A ), DC C (DETERMINANT OF A ), AND RCND ( RCOND ) ARE ENTERED C WITH DATA STATEMENTS. C C THE COMPUTED TEST RESULTS FOR X, RCOND, THE DETERMINANT, AND C THE INVERSE ARE COMPARED TO THE STORED PRE-COMPUTED VALUES. C FAILURE OF THE TEST OCCURS WHEN AGREEMENT TO 3 SIGNIFICANT C DIGITS IS NOT ACHIEVED AND AN ERROR MESSAGE INDICATING WHICH C LINPACK SUBROUTINE FAILED AND WHICH QUANTITY WAS INVOLVED IS C PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. C C NO INPUT ARGUMENTS ARE REQUIRED. C ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT OF C ALL FAILURES DETECTED BY CPOQC. C C***ROUTINES CALLED CPOCO, CPODI, CPOFA, CPOSL C***REVISION HISTORY (YYMMDD) C 801016 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF and cleaned up C FORMATs. (RWC) C***END PROLOGUE CPOQC COMPLEX A(4,4),AT(5,4),B(4),BT(4),C(4),AINV(4,4), 1 Z(4),XA,XB REAL R,RCOND,RCND,DELX,DET(2),DC(2) CHARACTER KPROG*19,KFAIL*39 INTEGER LDA,N,INFO,I,J,INDX,NERR DATA A/(2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), 1 (0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 2 (0.E0,0.E0),(0.E0,0.E0),(3.E0,0.E0),(0.E0,1.E0), 3 (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/ DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA AINV/(.66667E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0, 1 0.E0), 2 (0.E0,.33333E0),(.66667E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 3 (0.E0,0.E0),(0.E0,0.E0),(.36364E0,0.E0),(0.E0,1.E0), 4 (0.E0,0.E0),(0.E0,0.E0),(0.E0,.09091E0),(.27273E0,0.E0)/ DATA DC/3.3E0,1.0E0/ DATA KPROG/'POFA POCO POSL PODI'/ DATA KFAIL/'INFO RCOND SOLUTION DETERMINANT INVERSE'/ DATA RCND/.24099E0/ C DELX(XA,XB)=ABS(REAL(XA-XB))+ABS(AIMAG(XA-XB)) C***FIRST EXECUTABLE STATEMENT CPOQC LDA = 5 N = 4 NERR = 0 C C FORM AT FOR CPOFA AND BT FOR CPOSL, TEST CPOFA C DO 20 J=1,N BT(J) = B(J) DO 10 I=1,N AT(I,J) = A(I,J) 10 CONTINUE 20 CONTINUE C CALL CPOFA(AT,LDA,N,INFO) IF (INFO .NE. 0) THEN WRITE (LUN,201) KPROG(1:4),KFAIL(1:4) NERR = NERR + 1 ENDIF C C TEST CPOSL C CALL CPOSL(AT,LDA,N,BT) INDX = 0 DO 40 I=1,N IF (DELX(C(I),BT(I)) .GT. .0001) INDX=INDX+1 40 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ENDIF C C FORM AT FOR CPOCO, TEST CPOCO C DO 70 J=1,N DO 60 I=1,N AT(I,J) = A(I,J) 60 CONTINUE 70 CONTINUE C CALL CPOCO(AT,LDA,N,RCOND,Z,INFO) R = ABS(RCND-RCOND) IF (R .GE. .0001) THEN WRITE (LUN,201) KPROG(6:9),KFAIL(6:10) NERR = NERR + 1 ENDIF C IF (INFO .NE. 0) THEN WRITE (LUN,201) KPROG(6:9),KFAIL(1:4) NERR = NERR + 1 ENDIF C C TEST CPODI FOR JOB=11 C CALL CPODI(AT,LDA,N,DET,11) INDX = 0 DO 110 I=1,2 IF (ABS(DC(I)-DET(I)) .GT. .0001) INDX=INDX+1 110 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(16:19),KFAIL(21:31) NERR = NERR + 1 ENDIF C INDX = 0 DO 140 I=1,N DO 130 J=1,N IF (DELX(AINV(I,J),AT(I,J)) .GT. .0001) INDX=INDX+1 130 CONTINUE 140 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(16:19),KFAIL(33:39) NERR = NERR + 1 ENDIF C C IF (KPRINT.GE.2 .OR. NERR.NE.0) WRITE (LUN,200) NERR RETURN C 200 FORMAT(/' * CPOQC - TEST FOR CPOFA, CPOCO, CPOSL AND CPODI FOUND ' 1 , I1, ' ERRORS.'/) 201 FORMAT (/' *** C', A, ' FAILURE - ERROR IN ', A) END *DECK CPPQC SUBROUTINE CPPQC (LUN, KPRINT, NERR) C***BEGIN PROLOGUE CPPQC C***PURPOSE Quick check for CPPFA, CPPCO, CPPSL and CPPDI. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Voorhees, E. A., (LANL) C***DESCRIPTION C C LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS C OF THE PROPER TYPE FOR THE LINPACK SUBROUTINES BEING TESTED. C THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF C C (THE SOLUTION VECTOR), AINV (INVERSE OF MATRIX A ), DC C (DETERMINANT OF A ), AND RCND ( RCOND ) ARE ENTERED C WITH DATA STATEMENTS. C C THE COMPUTED TEST RESULTS FOR X, RCOND, THE DETERMINANT, AND C THE INVERSE ARE COMPARED TO THE STORED PRE-COMPUTED VALUES. C FAILURE OF THE TEST OCCURS WHEN AGREEMENT TO 3 SIGNIFICANT C DIGITS IS NOT ACHIEVED AND AN ERROR MESSAGE INDICATING WHICH C LINPACK SUBROUTINE FAILED AND WHICH QUANTITY WAS INVOLVED IS C PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. C C NO INPUT ARGUMENTS ARE REQUIRED. C ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT OF C ALL FAILURES DETECTED BY CPPQC. C C***ROUTINES CALLED CPPCO, CPPDI, CPPFA, CPPSL C***REVISION HISTORY (YYMMDD) C 801016 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF and cleaned up C FORMATs. (RWC) C***END PROLOGUE CPPQC COMPLEX AP(10),AT(10),B(4),BT(4),C(4),AINV(10), 1 Z(4),XA,XB REAL R,RCOND,RCND,DELX,DET(2),DC(2) CHARACTER KPROG*19, KFAIL*39 INTEGER N,INFO,I,J,INDX,NERR DATA AP/(2.E0,0.E0),(0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0), 1 (0.E0,0.E0),(3.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 2 (0.E0,-1.E0),(4.E0,0.E0)/ DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA AINV/(.66667E0,0.E0),(0.E0,.33333E0),(.66667E0,0.E0),(0.E0,0. 1E0), 2 (0.E0,0.E0),(.36364E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 3 (0.E0,.09091E0),(.27273E0,0.E0)/ DATA DC/3.3E0,1.0E0/ DATA KPROG/'PPFA PPCO PPSL PPDI'/ DATA KFAIL/'INFO RCOND SOLUTION DETERMINANT INVERSE'/ DATA RCND/.24099E0/ C DELX(XA,XB)=ABS(REAL(XA-XB))+ABS(AIMAG(XA-XB)) C***FIRST EXECUTABLE STATEMENT CPPQC N = 4 NERR = 0 C C FORM AT FOR CPPFA AND BT FOR CPPSL, TEST CPPFA C DO 10 J=1,N BT(J) = B(J) 10 CONTINUE C DO 20 I=1,10 AT(I) = AP(I) 20 CONTINUE C CALL CPPFA(AT,N,INFO) IF (INFO .NE. 0) THEN WRITE (LUN,201) KPROG(1:4),KFAIL(1:4) NERR = NERR + 1 ENDIF C C TEST CPPSL C CALL CPPSL(AT,N,BT) INDX = 0 DO 40 I=1,N IF (DELX(C(I),BT(I)) .GT. .0001) INDX=INDX+1 40 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ENDIF C C FORM AT FOR CPPCO, TEST CPPCO C DO 60 I=1,10 AT(I) = AP(I) 60 CONTINUE C CALL CPPCO(AT,N,RCOND,Z,INFO) R = ABS(RCND-RCOND) IF (R .GE. .0001) THEN WRITE (LUN,201) KPROG(6:9),KFAIL(6:10) NERR = NERR + 1 ENDIF C IF (INFO .NE. 0) THEN WRITE (LUN,201) KPROG(6:9),KFAIL(1:4) NERR = NERR + 1 ENDIF C C TEST CPPDI FOR JOB=11 C CALL CPPDI(AT,N,DET,11) INDX = 0 DO 110 I=1,2 IF (ABS(DC(I)-DET(I)) .GT. .0001) INDX=INDX+1 110 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(16:19),KFAIL(21:31) NERR = NERR + 1 ENDIF C INDX = 0 DO 140 I=1,10 IF(DELX(AINV(I),AT(I)) .GT. .0001) INDX=INDX+1 140 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(16:19),KFAIL(33:39) NERR = NERR + 1 ENDIF C IF (KPRINT.GE.2 .OR. NERR.NE.0) WRITE (LUN,200) NERR RETURN C 200 FORMAT(/' * CPPQC - TEST FOR CPPFA, CPPCO, CPPSL AND CPPDI FOUND ' 1 , I1, ' ERRORS.'/) 201 FORMAT (/' *** C', A, ' FAILURE - ERROR IN ', A) END *DECK CPRIN SUBROUTINE CPRIN (LUN, NUM1, KPRINT, IP, EXACT, RESULT, ABSERR, + NEVAL, IERV, LIERV) C***BEGIN PROLOGUE CPRIN C***SUBSIDIARY C***PURPOSE Subsidiary to CQAG, CQAG, CQAGI, CQAGP, CQAGS, CQAWC, C CQAWF, CQAWO, CQAWS, and CQNG. C***LIBRARY SLATEC C***AUTHOR Piessens, Robert C Applied Mathematics and Programming Division C K. U. Leuven C de Doncker, Elise C Applied Mathematics and Programming Division C K. U. Leuven C***DESCRIPTION C C This program is called by the (single precision) Quadpack quick C check routines for printing out their messages. C C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 810401 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 910627 Code completely rewritten. (WRB) C***END PROLOGUE CPRIN C .. Scalar Arguments .. REAL ABSERR, EXACT, RESULT INTEGER IP, KPRINT, LIERV, LUN, NEVAL, NUM1 C .. Array Arguments .. INTEGER IERV(*) C .. Local Scalars .. REAL ERROR INTEGER IER, K C .. Intrinsic Functions .. INTRINSIC ABS C***FIRST EXECUTABLE STATEMENT CPRIN IER = IERV(1) ERROR = ABS(EXACT-RESULT) C IF (KPRINT .GE. 2) THEN IF (IP.EQ.1) THEN IF (KPRINT .GE. 3) THEN C C Write PASS message. C WRITE (UNIT=LUN, FMT=9000) NUM1 ENDIF ELSE C C Write failure messages. C WRITE (UNIT=LUN, FMT=9010) NUM1 IF (NUM1 .EQ. 0) WRITE (UNIT=LUN, FMT=9020) IF (NUM1 .GT. 0) WRITE (UNIT=LUN, FMT=9030) NUM1 IF (LIERV .GT. 1) WRITE (UNIT=LUN, FMT=9040) (IERV(K), + K=2,LIERV) IF (NUM1 .EQ. 6) WRITE (UNIT=LUN, FMT=9050) WRITE (UNIT=LUN, FMT=9060) WRITE (UNIT=LUN, FMT=9070) IF (NUM1 .NE. 5) THEN WRITE (UNIT=LUN, FMT=9080) EXACT,RESULT,ERROR,ABSERR,IER, + NEVAL ELSE WRITE (LUN,FMT=9090) RESULT,ABSERR,IER,NEVAL ENDIF ENDIF ENDIF C RETURN C 9000 FORMAT (' TEST ON IER = ', I2, ' PASSED') 9010 FORMAT (' TEST ON IER = ', I1, ' FAILED.') 9020 FORMAT (' WE MUST HAVE IER = 0, ERROR.LE.ABSERR AND ABSERR.LE', + '.MAX(EPSABS,EPSREL*ABS(EXACT))') 9030 FORMAT (' WE MUST HAVE IER = ', I1) 9040 FORMAT (' OR IER = ', 8(I1,2X)) 9050 FORMAT (' RESULT, ABSERR, NEVAL AND EVENTUALLY LAST SHOULD BE', + ' ZERO') 9060 FORMAT (' WE HAVE ') 9070 FORMAT (7X, 'EXACT', 11X, 'RESULT', 6X, 'ERROR', 4X, 'ABSERR', + 4X, 'IER NEVAL', /, ' ', 42X, + '(EST.ERR.)(FLAG)(NO F-EVAL)') 9080 FORMAT (' ', 2(E15.7,1X), 2(E9.2,1X), I4, 4X, I6) 9090 FORMAT (5X, 'INFINITY', 4X, E15.7, 11X, E9.2, I5, 4X, I6) END *DECK CPRPQX SUBROUTINE CPRPQX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CPRPQX C***PURPOSE Quick check for CPZERO and RPZERO. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Kahaner, D. K., (NBS) C***DESCRIPTION C C THIS QUICK CHECK ROUTINE IS WRITTEN FOR CPZERO AND RPZERO. C THE ZEROS OF POLYNOMIAL WITH COEFFICIENTS A(.) ARE STORED C IN ZK(.). RELERR IS THE RELATIVE ACCURACY REQUIRED FOR C THEM TO PASS. C C***ROUTINES CALLED CPZERO, R1MACH, RPZERO C***REVISION HISTORY (YYMMDD) C 810223 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE CPRPQX INTEGER KPRINT,IPASS,LUN INTEGER IDEG,IDEGP1,INFO,I,J,ID REAL A(6),ERR,ERRI,RELERR COMPLEX AC(6),Z(5),ZK(5),W(21) DATA IDEG / 5 / DATA A / 1., -3.7, 7.4, -10.8, 10.8, -6.8 / DATA ZK / (1.7,0.), (1.,1.), (1.,-1.), + (0.,1.414213562 3730950488), + (0.,-1.414213562 3730950488) / C***FIRST EXECUTABLE STATEMENT CPRPQX IPASS = 1 IDEGP1 = IDEG+1 RELERR = SQRT(R1MACH(4)) DO 10 J=1,IDEGP1 AC(J) = CMPLX(A(J),0.) 10 CONTINUE INFO = 0 CALL CPZERO(IDEG,AC,Z,W(4),INFO,W) IF(INFO .EQ. 0) GO TO 15 IPASS=0 IF(INFO .EQ. 1 .AND. KPRINT .GE .1) WRITE(LUN,630) IF(INFO .EQ. 2 .AND. KPRINT .GE .1) WRITE(LUN,640) 15 DO 30 J=1,IDEG ERR = ABS(Z(J) - ZK(1)) ID = 1 DO 20 I=2,IDEG ERRI = ABS(Z(J) - ZK(I)) IF (ERRI .LT. ERR) ID = I ERR = MIN(ERRI,ERR) 20 CONTINUE IF (ABS(Z(J) - ZK(ID))/ABS(ZK(ID)) .GE. RELERR) IPASS = 0 30 CONTINUE INFO = 0 CALL RPZERO(IDEG,A,Z,W(4),INFO,W) IF(INFO .EQ. 0) GO TO 35 IPASS=0 IF(INFO .EQ. 1 .AND. KPRINT .GE .1) WRITE(LUN,650) IF(INFO .EQ. 2 .AND. KPRINT .GE .1) WRITE(LUN,660) 35 DO 50 J=1,IDEG ERR = ABS(Z(J) - ZK(1)) ID = 1 DO 40 I=2,IDEG ERRI = ABS(Z(J) - ZK(I)) IF (ERRI .LT. ERR) ID = I ERR = MIN(ERRI,ERR) 40 CONTINUE IF (ABS(Z(J) - ZK(ID))/ABS(ZK(ID)) .GE. RELERR) IPASS = 0 50 CONTINUE IF (KPRINT.GE.2 .AND. IPASS.NE.0) WRITE (LUN,670) IF (KPRINT.GE.1 .AND. IPASS.EQ.0) WRITE (LUN,680) RETURN C 630 FORMAT(' CPZERO TEST FAILS: LEADING COEFFICIENT OR DEGREE OF', 1 ' POLYNOMIAL IS ZERO') 640 FORMAT(' CPZERO TEST FAILS: NON-CONVERGENCE IN 125 ITERATIONS') 650 FORMAT(' RPZERO TEST FAILS: LEADING COEFFICIENT OR DEGREE OF', 1 ' POLYNOMIAL IS ZERO') 660 FORMAT(' RPZERO TEST FAILS: NON-CONVERGENCE IN 125 ITERATIONS') 670 FORMAT(25H CPRPQX PASSES ALL TESTS.) 680 FORMAT(25H CPRPQX FAILS SOME TESTS.) END *DECK CPTQC SUBROUTINE CPTQC (LUN, KPRINT, NERR) C***BEGIN PROLOGUE CPTQC C***PURPOSE Quick check for CPTSL. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Voorhees, E. A., (LANL) C***DESCRIPTION C C LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS C OF THE PROPER TYPE FOR THE LINPACK SUBROUTINE BEING TESTED. C THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF CX C (THE SOLUTION VECTOR) ARE ENTERED WITH DATA STATEMENTS. C C THE COMPUTED VALUES OF X ARE COMPARED TO THE STORED C PRE-COMPUTED VALUES OF CX. FAILURE OF THE TEST OCCURS WHEN C AGREEMENT TO 3 SIGNIFICANT DIGITS IS NOT ACHIEVED AND AN C ERROR MESSAGE IS PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. C C NO INPUT ARGUMENTS ARE REQUIRED. C ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT C OF ALL FAILURES DETECTED BY CPTQC. C C***ROUTINES CALLED CPTSL C***REVISION HISTORY (YYMMDD) C 801024 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF and cleaned up C FORMATs. (RWC) C***END PROLOGUE CPTQC COMPLEX D(4),E(4),B(4),CX(4),DT(4),ET(4),BT(4) INTEGER N,I,INDX,NERR REAL DELX DATA D/(2.E0,0.E0),(2.E0,0.E0),(3.E0,0.E0),(4.E0,0.E0)/ DATA E/(0.E0,-1.E0),(0.E0,0.E0),(0.E0,-1.E0),(0.E0,0.E0)/ DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA CX/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ C***FIRST EXECUTABLE STATEMENT CPTQC N = 4 NERR = 0 DO 10 I=1,N DT(I) = D(I) ET(I) = E(I) BT(I) = B(I) 10 CONTINUE C CALL CPTSL(N,DT,ET,BT) INDX = 0 DO 20 I=1,N DELX = ABS(REAL(BT(I)-CX(I)))+ABS(AIMAG(BT(I)-CX(I))) IF (DELX .GT. .0001) INDX=INDX+1 20 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) NERR = NERR + 1 ENDIF C IF (KPRINT.GE.2 .OR. NERR.NE.0) WRITE (LUN,200) NERR RETURN C 200 FORMAT (/' * CPTQC - TEST FOR CPTSL FOUND ', I1, ' ERRORS.'/) 201 FORMAT (/' *** CPTSL FAILURE - ERROR IN SOLUTION') END *DECK CQAG SUBROUTINE CQAG (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CQAG C***PURPOSE Quick check for QAG. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (CQAG-S, CDQAG-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED CPRIN, F1G, F2G, F3G, QAG, R1MACH C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Added PASS/FAIL message and changed the name of the first C argument. (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C***END PROLOGUE CQAG C C FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC C REAL A,ABSERR,B,R1MACH,EPMACH,EPSABS,EPSREL,ERROR,EXACT1, * EXACT2,EXACT3,F1G,F2G,F3G,PI,RESULT,UFLOW,WORK INTEGER IER,IP,IPASS,IWORK,KEY,KPRINT,LAST,LENW,LIMIT, * NEVAL DIMENSION IERV(2),IWORK(100),WORK(400) EXTERNAL F1G,F2G,F3G DATA PI/0.31415926535897932E+01/ DATA EXACT1/0.1154700538379252E+01/ DATA EXACT2/0.11780972450996172E+00/ DATA EXACT3/0.1855802E+02/ C***FIRST EXECUTABLE STATEMENT CQAG IF (KPRINT.GE.2) WRITE (LUN, '(''1QAG QUICK CHECK''/)') C C TEST ON IER = 0 C IPASS = 1 LIMIT = 100 LENW = LIMIT*4 EPSABS = 0.0E+00 EPMACH = R1MACH(4) KEY = 6 EPSREL = MAX(SQRT(EPMACH),0.1E-07) A = 0.0E+00 B = 0.1E+01 CALL QAG(F1G,A,B,EPSABS,EPSREL,KEY,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 ERROR = ABS(EXACT1-RESULT) IF(IER.EQ.0.AND.ERROR.LE.ABSERR.AND.ABSERR.LE.EPSREL*ABS(EXACT1)) * IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,0,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 1 C LIMIT = 1 LENW = LIMIT*4 B = PI*0.2E+01 CALL QAG(F2G,A,B,EPSABS,EPSREL,KEY,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,1,KPRINT,IP,EXACT2,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 2 OR 1 C UFLOW = R1MACH(1) LIMIT = 100 LENW = LIMIT*4 CALL QAG(F2G,A,B,UFLOW,0.0E+00,KEY,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 IF(IER.EQ.2.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,2,KPRINT,IP,EXACT2,RESULT,ABSERR,NEVAL,IERV,2) C C TEST ON IER = 3 OR 1 C B = 0.1E+01 CALL QAG(F3G,A,B,EPSABS,EPSREL,1,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 IF(IER.EQ.3.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,3,KPRINT,IP,EXACT3,RESULT,ABSERR,NEVAL,IERV,2) C C TEST ON IER = 6 C LENW = 1 CALL QAG(F1G,A,B,EPSABS,EPSREL,KEY,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.6.AND.RESULT.EQ.0.0E+00.AND.ABSERR.EQ.0.0E+00.AND. * NEVAL.EQ.0.AND.LAST.EQ.0) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,6,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) C IF (KPRINT.GE.1) THEN IF (IPASS.EQ.0) THEN WRITE(LUN, '(/'' SOME TEST(S) IN CQAG FAILED''/)') ELSEIF (KPRINT.GE.2) THEN WRITE(LUN, '(/'' ALL TEST(S) IN CQAG PASSED''/)') ENDIF ENDIF RETURN END *DECK CQAGI SUBROUTINE CQAGI (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CQAGI C***PURPOSE Quick check for QAGI. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (CQAGI-S, CDQAGI-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED CPRIN, QAGI, R1MACH, T0, T1, T2, T3, T4, T5 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891009 Removed unreferenced variables. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Added PASS/FAIL message and changed the name of the first C argument. (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C***END PROLOGUE CQAGI C C FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC C REAL ABSERR,BOUND,R1MACH,EPMACH,EPSABS, * EPSREL,ERROR,EXACT0,EXACT1,EXACT2,EXACT3,EXACT4, * OFLOW,RESULT,T0,T1,T2,T3,T4,T5,UFLOW,WORK INTEGER IER,IP,IPASS,IWORK,KPRINT,LAST,LENW,LIMIT,LUN,NEVAL DIMENSION WORK(800),IWORK(200),IERV(4) EXTERNAL T0,T1,T2,T3,T4,T5 DATA EXACT0/2.0E+00/,EXACT1/0.115470066904E1/ DATA EXACT2/0.909864525656E-02/ DATA EXACT3/0.31415926535897932E+01/ DATA EXACT4/0.19984914554328673E+04/ C***FIRST EXECUTABLE STATEMENT CQAGI IF (KPRINT.GE.2) WRITE (LUN, '(''1QAGI QUICK CHECK''/)') C C TEST ON IER = 0 C IPASS = 1 LIMIT = 200 LENW = LIMIT*4 EPSABS = 0.0E+00 EPMACH = R1MACH(4) EPSREL = MAX(SQRT(EPMACH),0.1E-07) BOUND = 0.0E+00 INF = 1 CALL QAGI(T0,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) ERROR = ABS(RESULT-EXACT0) IERV(1) = IER IP = 0 IF(IER.EQ.0.AND.ERROR.LE.ABSERR.AND.ABSERR.LE.EPSREL*ABS(EXACT0)) * IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 1 C CALL QAGI(T1,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, * 1,4,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,1,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 2 OR 4 OR 1 C UFLOW = R1MACH(1) CALL QAGI(T2,BOUND,INF,UFLOW,0.0E+00,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IP = 0 IF(IER.EQ.2.OR.IER.EQ.4.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,2,KPRINT,IP,EXACT2,RESULT,ABSERR,NEVAL,IERV,3) C C TEST ON IER = 3 OR 4 OR 1 C CALL QAGI(T3,BOUND,INF,UFLOW,0.0E+00,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IP = 0 IF(IER.EQ.3.OR.IER.EQ.4.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,3,KPRINT,IP,EXACT3,RESULT,ABSERR,NEVAL,IERV,3) C C TEST ON IER = 4 OR 3 OR 1 C CALL QAGI(T4,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 3 IERV(3) = 1 IERV(4)=2 IP = 0 IF(IER.EQ.4.OR.IER.EQ.3.OR.IER.EQ.1.OR.IER.EQ.2) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,4,KPRINT,IP,EXACT4,RESULT,ABSERR,NEVAL,IERV,4) C C TEST ON IER = 5 C OFLOW = R1MACH(2) CALL QAGI(T5,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.5) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,5,KPRINT,IP,OFLOW,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 6 C CALL QAGI(T1,BOUND,INF,EPSABS,0.0E+00,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.6.AND.RESULT.EQ.0.0E+00.AND.ABSERR.EQ.0.0E+00.AND. * NEVAL.EQ.0.AND.LAST.EQ.0) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,6,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) C IF (KPRINT.GE.1) THEN IF (IPASS.EQ.0) THEN WRITE(LUN, '(/'' SOME TEST(S) IN CQAGI FAILED''/)') ELSEIF (KPRINT.GE.2) THEN WRITE(LUN, '(/'' ALL TEST(S) IN CQAGI PASSED''/)') ENDIF ENDIF RETURN END *DECK CQAGP SUBROUTINE CQAGP (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CQAGP C***PURPOSE Quick check for QAGP. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (CQAGP-S, CDQAGP-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED CPRIN, F1P, F2P, F3P, F4P, QAGP, R1MACH C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Added PASS/FAIL message and changed the name of the first C argument. (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C***END PROLOGUE CQAGP C C FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC C REAL A,ABSERR,B,R1MACH,EPMACH,EPSABS,EPSREL,ERROR,EXACT1, * EXACT2,EXACT3,F1P,F2P,F3P,F4P,OFLOW,POINTS,P1,P2,RESULT, * UFLOW,WORK INTEGER IER,IP,IPASS,IWORK,KPRINT,LAST,LENIW,LENW,LIMIT,LUN, * NEVAL,NPTS2 DIMENSION IERV(4),IWORK(205),POINTS(5),WORK(405) EXTERNAL F1P,F2P,F3P,F4P DATA EXACT1/0.4285277667368085E+01/ DATA EXACT2/0.909864525656E-2/ DATA EXACT3/0.31415926535897932E+01/ DATA P1/0.1428571428571428E+00/ DATA P2/0.6666666666666667E+00/ C***FIRST EXECUTABLE STATEMENT CQAGP IF (KPRINT.GE.2) WRITE (LUN, '(''1QAGP QUICK CHECK''/)') C C TEST ON IER = 0 C IPASS = 1 NPTS2 = 4 LIMIT = 100 LENIW = LIMIT*2+NPTS2 LENW = LIMIT*4+NPTS2 EPSABS = 0.0E+00 EPMACH = R1MACH(4) EPSREL = MAX(SQRT(EPMACH),0.1E-07) A = 0.0E+00 B = 0.1E+01 POINTS(1) = P1 POINTS(2) = P2 CALL QAGP(F1P,A,B,NPTS2,POINTS,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, * IER,LENIW,LENW,LAST,IWORK,WORK) ERROR = ABS(RESULT-EXACT1) IERV(1) = IER IP = 0 IF(IER.EQ.0.AND.ERROR.LE.EPSREL*ABS(EXACT1)) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,0,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 1 C LENIW = 10 LENW = LENIW*2-NPTS2 CALL QAGP(F1P,A,B,NPTS2,POINTS,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, * IER,LENIW,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,1,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 2, 4, 1 OR 3 C NPTS2 = 3 POINTS(1) = 0.1E+00 LENIW = LIMIT*2+NPTS2 LENW = LIMIT*4+NPTS2 UFLOW = R1MACH(1) A = 0.1E+00 CALL QAGP(F2P,A,B,NPTS2,POINTS,UFLOW,0.0E+00,RESULT,ABSERR,NEVAL, * IER,LENIW,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IERV(4) = 3 IP = 0 IF(IER.EQ.2.OR.IER.EQ.4.OR.IER.EQ.1.OR.IER.EQ.3) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,2,KPRINT,IP,EXACT2,RESULT,ABSERR,NEVAL,IERV,4) C C TEST ON IER = 3 OR 4 OR 1 OR 2 C NPTS2 = 2 LENIW = LIMIT*2+NPTS2 LENW = LIMIT*4+NPTS2 A = 0.0E+00 B = 0.5E+01 CALL QAGP(F3P,A,B,NPTS2,POINTS,UFLOW,0.0E+00,RESULT,ABSERR,NEVAL, * IER,LENIW,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IERV(4)=2 IP = 0 IF(IER.EQ.3.OR.IER.EQ.4.OR.IER.EQ.1.OR.IER.EQ.2) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,3,KPRINT,IP,EXACT3,RESULT,ABSERR,NEVAL,IERV,4) C C TEST ON IER = 5 C B = 0.1E+01 CALL QAGP(F4P,A,B,NPTS2,POINTS,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, * IER,LENIW,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.5) IP = 1 IF(IP.EQ.0) IPASS = 0 OFLOW = R1MACH(2) CALL CPRIN(LUN,5,KPRINT,IP,OFLOW,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 6 C NPTS2 = 5 LENIW = LIMIT*2+NPTS2 LENW = LIMIT*4+NPTS2 POINTS(1) = P1 POINTS(2) = P2 POINTS(3) = 0.3E+01 CALL QAGP(F1P,A,B,NPTS2,POINTS,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, * IER,LENIW,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.6.AND.RESULT.EQ.0.0E+00.AND.ABSERR.EQ.0.0E+00.AND. * NEVAL.EQ.0.AND.LAST.EQ.0) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,6,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) C IF (KPRINT.GE.1) THEN IF (IPASS.EQ.0) THEN WRITE(LUN, '(/'' SOME TEST(S) IN CQAGP FAILED''/)') ELSEIF (KPRINT.GE.2) THEN WRITE(LUN, '(/'' ALL TEST(S) IN CQAGP PASSED''/)') ENDIF ENDIF RETURN END *DECK CQAGS SUBROUTINE CQAGS (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CQAGS C***PURPOSE Quick check for QAGS. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (CQAGS-S, CDQAGS-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED CPRIN, F0S, F1S, F2S, F3S, F4S, F5S, QAGS, R1MACH C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Added PASS/FAIL message and changed the name of the first C argument. (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C 911114 Modified test on IER=4 to allow IER=5. (WRB) C***END PROLOGUE CQAGS C C FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC C REAL A,ABSERR,B,R1MACH,EPMACH,EPSABS, * EPSREL,ERROR,EXACT0,EXACT1,EXACT2,EXACT3,EXACT4, * F0S,F1S,F2S,F3S,F4S,F5S,OFLOW,RESULT,UFLOW,WORK INTEGER IER,IP,IPASS,IWORK,KPRINT,LAST,LENW,LIMIT,NEVAL DIMENSION IERV(5),IWORK(200),WORK(800) EXTERNAL F0S,F1S,F2S,F3S,F4S,F5S DATA EXACT0/0.2E+01/ DATA EXACT1/0.115470066904E+01/ DATA EXACT2/0.909864525656E-02/ DATA EXACT3/0.31415926535897932E+01/ DATA EXACT4/0.19984914554328673E+04/ C***FIRST EXECUTABLE STATEMENT CQAGS IF (KPRINT.GE.2) WRITE (LUN, '(''1QAGS QUICK CHECK''/)') C C TEST ON IER = 0 C IPASS = 1 LIMIT = 200 LENW = LIMIT*4 EPSABS = 0.0E+00 EPMACH = R1MACH(4) EPSREL = MAX(SQRT(EPMACH),0.1E-07) A = 0.0E+00 B = 0.1E+01 CALL QAGS(F0S,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) ERROR = ABS(RESULT-EXACT0) IERV(1) = IER IP = 0 IF(IER.EQ.0.AND.ERROR.LE.ABSERR.AND.ABSERR.LE.EPSREL*ABS(EXACT0)) * IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 1 C CALL QAGS(F1S,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, * 1,4,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,1,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 2 OR 4 OR 1 C UFLOW = R1MACH(1) A = 0.1E+00 CALL QAGS(F2S,A,B,UFLOW,0.0E+00,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IP = 0 IF(IER.EQ.2.OR.IER.EQ.4.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,2,KPRINT,IP,EXACT2,RESULT,ABSERR,NEVAL,IERV,3) C C TEST ON IER = 3 OR 4 OR 1 OR 2 C A = 0.0E+00 B = 0.5E+01 CALL QAGS(F3S,A,B,UFLOW,0.0E+00,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IERV(4) = 2 IP = 0 IF(IER.EQ.3.OR.IER.EQ.4.OR.IER.EQ.1.OR.IER.EQ.2) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,3,KPRINT,IP,EXACT3,RESULT,ABSERR,NEVAL,IERV,4) C C TEST ON IER = 4, OR 5 OR 3 OR 1 OR 0 C B = 0.1E+01 EPSREL=1.E-4 CALL QAGS(F4S,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) C IER=4 IERV(1) = IER IERV(2) = 5 IERV(3) = 3 IERV(4) = 1 IERV(5) = 0 IP = 0 IF(IER.EQ.5.OR.IER.EQ.4.OR.IER.EQ.3.OR.IER.EQ.1.OR.IER.EQ.0) * IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,4,KPRINT,IP,EXACT4,RESULT,ABSERR,NEVAL,IERV,5) C C TEST ON IER = 5 C OFLOW = R1MACH(2) CALL QAGS(F5S,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.5) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,5,KPRINT,IP,OFLOW,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 6 C CALL QAGS(F1S,A,B,EPSABS,0.0E+00,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.6.AND.RESULT.EQ.0.0E+00.AND.ABSERR.EQ.0.0E+00.AND. * NEVAL.EQ.0.AND.LAST.EQ.0) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,6,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) C IF (KPRINT.GE.1) THEN IF (IPASS.EQ.0) THEN WRITE(LUN, '(/'' SOME TEST(S) IN CQAGS FAILED''/)') ELSEIF (KPRINT.GE.2) THEN WRITE(LUN, '(/'' ALL TEST(S) IN CQAGS PASSED''/)') ENDIF ENDIF RETURN END *DECK CQAWC SUBROUTINE CQAWC (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CQAWC C***PURPOSE Quick check for QAWC. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (CQAWC-S, CDQAWC-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED CPRIN, F0C, F1C, QAWC, R1MACH C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Added PASS/FAIL message and changed the name of the first C argument. (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C***END PROLOGUE CQAWC C C FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC C REAL A,ABSERR,B,R1MACH,EPMACH,EPSABS, * EPSREL,ERROR,EXACT0,EXACT1,F0C,F1C,C, * RESULT,UFLOW,WORK INTEGER IER,IP,IPASS,IWORK,KPRINT,LAST,LENW,LIMIT,NEVAL DIMENSION WORK(800),IWORK(200),IERV(2) EXTERNAL F0C,F1C DATA EXACT0/-0.6284617285065624E+03/ DATA EXACT1/0.1855802E+01/ C***FIRST EXECUTABLE STATEMENT CQAWC IF (KPRINT.GE.2) WRITE (LUN, '(''1QAWC QUICK CHECK''/)') C C TEST ON IER = 0 C IPASS = 1 C = 0.5E+00 A = -1.0E+00 B = 1.0E+00 LIMIT = 200 LENW = LIMIT*4 EPSABS = 0.0E+00 EPMACH = R1MACH(4) EPSREL = MAX(SQRT(EPMACH),0.1E-07) CALL QAWC(F0C,A,B,C,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 ERROR = ABS(EXACT0-RESULT) IF(IER.EQ.0.AND.ERROR.LE.ABSERR.AND.ABSERR.LE.EPSREL*ABS(EXACT0)) * IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 1 C CALL QAWC(F0C,A,B,C,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,1,4,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,1,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 2 OR 1 C UFLOW = R1MACH(1) CALL QAWC(F0C,A,B,C,UFLOW,0.0E+00,RESULT,ABSERR, * NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 IF(IER.EQ.2.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,2,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,2) C C TEST ON IER = 3 OR 1 C CALL QAWC(F1C,0.0E+00,B,C,UFLOW,0.0E+00,RESULT,ABSERR, * NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 IF(IER.EQ.3.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,3,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,2) C C TEST ON IER = 6 C EPSABS = 0.0E+00 EPSREL = 0.0E+00 CALL QAWC(F0C,A,B,C,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.6) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,6,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C IF (KPRINT.GE.1) THEN IF (IPASS.EQ.0) THEN WRITE(LUN, '(/'' SOME TEST(S) IN CQAWC FAILED''/)') ELSEIF (KPRINT.GE.2) THEN WRITE(LUN, '(/'' ALL TEST(S) IN CQAWC PASSED''/)') ENDIF ENDIF RETURN END *DECK CQAWF SUBROUTINE CQAWF (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CQAWF C***PURPOSE Quick check for QAWF. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (CQAWF-S, CDQAWF-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED CPRIN, F0F, F1F, QAWF, R1MACH C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Added PASS/FAIL message and changed the name of the first C argument. (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C***END PROLOGUE CQAWF C C FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC C REAL A,ABSERR,R1MACH,EPSABS,EPMACH, * ERROR,EXACT0,F0F,F1F,OMEGA,PI,RESULT,UFLOW,WORK INTEGER IER,IP,IPASS,KPRINT,LENW,LIMIT,LIMLST,LST,NEVAL DIMENSION IERV(3),IWORK(450),WORK(1425) EXTERNAL F0F,F1F DATA EXACT0/0.1422552162575912E+01/ DATA PI/0.31415926535897932E+01/ C***FIRST EXECUTABLE STATEMENT CQAWF IF (KPRINT.GE.2) WRITE (LUN, '(''1QAWF QUICK CHECK''/)') C C TEST ON IER = 0 C IPASS = 1 MAXP1 = 21 LIMLST = 50 LIMIT = 200 LENIW = LIMIT*2+LIMLST LENW = LENIW*2+MAXP1*25 EPMACH = R1MACH(4) EPSABS = MAX(SQRT(EPMACH),0.1E-02) A = 0.0E+00 OMEGA = 0.8E+01 INTEGR = 2 CALL QAWF(F0F,A,OMEGA,INTEGR,EPSABS,RESULT,ABSERR,NEVAL, * IER,LIMLST,LST,LENIW,MAXP1,LENW,IWORK,WORK) IERV(1) = IER IP = 0 ERROR = ABS(EXACT0-RESULT) IF(IER.EQ.0.AND.ERROR.LE.ABSERR.AND.ABSERR.LE.EPSABS) * IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 1 C LIMLST = 3 LENIW = 403 LENW = LENIW*2+MAXP1*25 CALL QAWF(F0F,A,OMEGA,INTEGR,EPSABS,RESULT,ABSERR,NEVAL, * IER,LIMLST,LST,LENIW,MAXP1,LENW,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,1,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 3 OR 4 OR 1 C LIMLST = 50 LENIW = LIMIT*2+LIMLST LENW = LENIW*2+MAXP1*25 UFLOW = R1MACH(1) CALL QAWF(F1F,A,0.0E+00,1,UFLOW,RESULT,ABSERR,NEVAL, * IER,LIMLST,LST,LENIW,MAXP1,LENW,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IP = 0 IF(IER.EQ.3.OR.IER.EQ.4.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,3,KPRINT,IP,PI,RESULT,ABSERR,NEVAL,IERV,3) C C TEST ON IER = 6 C LIMLST = 50 LENIW = 20 CALL QAWF(F0F,A,OMEGA,INTEGR,EPSABS,RESULT,ABSERR,NEVAL, * IER,LIMLST,LST,LENIW,MAXP1,LENW,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.6) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,6,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 7 C LIMLST = 50 LENIW = 52 LENW = LENIW*2+MAXP1*25 CALL QAWF(F0F,A,OMEGA,INTEGR,EPSABS,RESULT,ABSERR,NEVAL, * IER,LIMLST,LST,LENIW,MAXP1,LENW,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.7) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,7,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C IF (KPRINT.GE.1) THEN IF (IPASS.EQ.0) THEN WRITE(LUN, '(/'' SOME TEST(S) IN CQAWF FAILED''/)') ELSEIF (KPRINT.GE.2) THEN WRITE(LUN, '(/'' ALL TEST(S) IN CQAWF PASSED''/)') ENDIF ENDIF RETURN END *DECK CQAWO SUBROUTINE CQAWO (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CQAWO C***PURPOSE Quick check for QAWO. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (CQAWO-S, CDQAWO-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED CPRIN, F0O, F1O, F2O, QAWO, R1MACH C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Added PASS/FAIL message and changed the name of the first C argument. (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C***END PROLOGUE CQAWO C C FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC C REAL A,ABSERR,B,EPMACH,EPSABS, * EPSREL,ERROR,EXACT0,F0O,F1O,F2O, * OFLOW,OMEGA,PI,RESULT,R1MACH,UFLOW,WORK INTEGER IER,IERV,INTEGR,IP,IPASS,IWORK,KPRINT,LAST,LENW,LUN, * MAXP1,NEVAL DIMENSION WORK(1325),IWORK(400),IERV(4) EXTERNAL F0O,F1O,F2O DATA EXACT0/0.1042872789432789E+05/ DATA PI/0.31415926535897932E+01/ C***FIRST EXECUTABLE STATEMENT CQAWO IF (KPRINT.GE.2) WRITE (LUN, '(''1QAWO QUICK CHECK''/)') C C TEST ON IER = 0 C IPASS = 1 MAXP1 = 21 LENIW = 400 LENW = LENIW*2+MAXP1*25 EPSABS = 0.0E+00 EPMACH = R1MACH(4) EPSREL = MAX(SQRT(EPMACH),0.1E-07) A = 0.0E+00 B = PI OMEGA = 0.1E+01 INTEGR = 2 CALL QAWO(F0O,A,B,OMEGA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, * IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 ERROR = ABS(EXACT0-RESULT) IF(IER.EQ.0.AND.ERROR.LE.ABSERR.AND.ABSERR.LE.EPSREL*ABS(EXACT0)) * IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 1 C LENIW = 2 LENW = LENIW*2+MAXP1*25 CALL QAWO(F0O,A,B,OMEGA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, * IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,1,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 2 OR 4 OR 1 C UFLOW = R1MACH(1) LENIW = 400 LENW = LENIW*2+MAXP1*25 CALL QAWO(F0O,A,B,OMEGA,INTEGR,UFLOW,0.0E+00,RESULT,ABSERR,NEVAL, * IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IP = 0 IF(IER.EQ.2.OR.IER.EQ.4.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,2,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,3) C C TEST ON IER = 3 OR 4 OR 1 C B = 0.5E+01 OMEGA = 0.0E+00 INTEGR = 1 CALL QAWO(F1O,A,B,OMEGA,INTEGR,UFLOW,0.0E+00,RESULT,ABSERR,NEVAL, * IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IP = 0 IF(IER.EQ.3.OR.IER.EQ.4.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,3,KPRINT,IP,PI,RESULT,ABSERR,NEVAL,IERV,3) C C TEST ON IER = 5 C B = 0.1E+01 OFLOW = R1MACH(2) CALL QAWO(F2O,A,B,OMEGA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, * IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.5) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,5,KPRINT,IP,OFLOW,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 6 C INTEGR = 3 CALL QAWO(F0O,A,B,OMEGA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, * IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.6.AND.RESULT.EQ.0.0E+00.AND.ABSERR.EQ.0.0E+00.AND. * NEVAL.EQ.0.AND.LAST.EQ.0) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,6,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C IF (KPRINT.GE.1) THEN IF (IPASS.EQ.0) THEN WRITE(LUN, '(/'' SOME TEST(S) IN CQAWO FAILED''/)') ELSEIF (KPRINT.GE.2) THEN WRITE(LUN, '(/'' ALL TEST(S) IN CQAWO PASSED''/)') ENDIF ENDIF RETURN END *DECK CQAWS SUBROUTINE CQAWS (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CQAWS C***PURPOSE Quick check for QAWS. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (CQAWS-S, CDQAWS-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED CPRIN, F0WS, F1WS, QAWS, R1MACH C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Added PASS/FAIL message and changed the name of the first C argument. (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C***END PROLOGUE CQAWS C C FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC REAL A,ABSERR,B,R1MACH,EPMACH,EPSABS, * EPSREL,ERROR,EXACT0,EXACT1,F0WS,F1WS,ALFA,BETA, * RESULT,UFLOW,WORK INTEGER IER,IP,IPASS,IWORK,KPRINT,LAST,LENW,LIMIT,NEVAL,INTEGR DIMENSION WORK(800),IWORK(200),IERV(2) EXTERNAL F0WS,F1WS DATA EXACT0/0.5350190569223644E+00/ DATA EXACT1/0.1998491554328673E+04/ C***FIRST EXECUTABLE STATEMENT CQAWS IF (KPRINT.GE.2) WRITE (LUN, '(''1QAWS QUICK CHECK''/)') C C TEST ON IER = 0 C IPASS = 1 ALFA = -0.5E+00 BETA = -0.5E+00 INTEGR = 1 A = 0.0E+00 B = 0.1E+01 LIMIT = 200 LENW = LIMIT*4 EPSABS = 0.0E+00 EPMACH = R1MACH(4) EPSREL = MAX(SQRT(EPMACH),0.1E-07) CALL QAWS(F0WS,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 ERROR = ABS(EXACT0-RESULT) IF(IER.EQ.0.AND.ERROR.LE.EPSREL*ABS(EXACT0)) * IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 1 C CALL QAWS(F0WS,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,2,8,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,1,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 2 OR 1 C UFLOW = R1MACH(1) CALL QAWS(F0WS,A,B,ALFA,BETA,INTEGR,UFLOW,0.0E+00,RESULT,ABSERR, * NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 IF(IER.EQ.2.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,2,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,2) C C TEST ON IER = 3 OR 1 C CALL QAWS(F1WS,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 IF(IER.EQ.3.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,3,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,2) C C TEST ON IER = 6 C INTEGR = 0 CALL QAWS(F1WS,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.6) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,6,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C IF (KPRINT.GE.1) THEN IF (IPASS.EQ.0) THEN WRITE(LUN, '(/'' SOME TEST(S) IN CQAWS FAILED''/)') ELSEIF (KPRINT.GE.2) THEN WRITE(LUN, '(/'' ALL TEST(S) IN CQAWS PASSED''/)') ENDIF ENDIF RETURN END *DECK CQCK SUBROUTINE CQCK (LUN, KPRINT, NERR) C***BEGIN PROLOGUE CQCK C***PURPOSE Quick check for CPOFS, CPOIR, CNBFS and CNBIR. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Voorhees, E. A., (LANL) C***DESCRIPTION C C QUICK CHECK SUBROUTINE CQCK TESTS THE EXECUTION OF THE C SLATEC SUBROUTINES CPOFS, CPOIR, CNBFS AND CNBIR. C A TITLE LINE AND A SUMMARY LINE ARE ALWAYS OUTPUTTED. C C THE SUMMARY LINE GIVES A COUNT OF THE NUMBER OF C PROBLEMS ENCOUNTERED IN THE TEST IF ANY EXIST. CQCK C CHECKS COMPUTED VS. EXACT SOLUTIONS TO AGREE TO C WITHIN 0.8 TIMES THE WORD LENGTH OF THE COMPUTER C (1.6 IF DOUBLE PRECISION) FOR CASE 1. CQCK ALSO C TESTS ERROR HANDLING BY THE SUBROUTINE (CALLS TO C XERMSG (CQCK SETS IFLAG/KONTRL TO 0)) C USING A SINGULAR MATRIX FOR CASE 2. EACH EXECUTION C PROBLEM DETECTED BY CQCK RESULTS IN AN ADDITIONAL C EXPLANATORY LINE OF OUTPUT. C C CQCK REQUIRES NO INPUT ARGUMENTS. C ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT C OF ALL PROBLEMS DETECTED BY CQCK. C C***ROUTINES CALLED CNBFS, CNBIR, CPOFS, CPOIR, R1MACH C***REVISION HISTORY (YYMMDD) C 801002 DATE WRITTEN C 891009 Removed unreferenced statement labels. (WRB) C 891009 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901009 Restructured using IF-THEN-ELSE-ENDIF, cleaned up FORMATs, C including removing an illegal character from column 1, and C editorial changes. (RWC) C***END PROLOGUE CQCK REAL R,DELX,DELMAX,R1MACH COMPLEX A(4,4),AT(5,4),ABE(5,7),ABET(5,7),B(4),BT(4),C(4),WORK(35) CHARACTER*4 LIST(4) INTEGER LDA,N,ML,MU,IND,IWORK(4),NERR,I,J,J1,J2,JD,MLP,K,KCASE, 1 KPROG DATA A/(2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), 1 (0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 2 (0.E0,0.E0),(0.E0,0.E0),(3.E0,0.E0),(0.E0,1.E0), 3 (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/ DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA LIST/'POFS', 'POIR', 'NBFS', 'NBIR'/ C***FIRST EXECUTABLE STATEMENT CQCK IF (KPRINT.GE.3) WRITE (LUN,800) LDA = 5 N = 4 ML = 2 MU = 1 JD = 2*ML+MU+1 NERR = 0 R = R1MACH(4)**0.8E0 C C FORM ABE(NB ARRAY) FROM MATRIX A. C DO 30 J=1,JD DO 20 I=1,N ABE(I,J) = (0.0E0,0.0E0) 20 CONTINUE 30 CONTINUE C MLP = ML+1 DO 50 I=1,N J1 = MAX(1,I-ML) J2 = MIN(N,I+MU) DO 40 J=J1,J2 K = J-I+MLP ABE(I,K) = A(I,J) 40 CONTINUE 50 CONTINUE C C CASE 1 FOR WELL-CONDITIONED MATRIX, CASE 2 FOR SINGULAR MATRIX C DO 170 KCASE=1,2 DO 140 KPROG=1,4 C FORM BT FROM B, AT FROM A, AND ABET FROM ABE. DO 60 I=1,N BT(I) = B(I) DO 58 J=1,N AT(I,J) = A(I,J) 58 CONTINUE 60 CONTINUE C DO 80 J=1,JD DO 70 I=1,N ABET(I,J) = ABE(I,J) 70 CONTINUE 80 CONTINUE C C MAKE AT AND ABET SINGULAR FOR CASE = 2 C IF (KCASE.EQ.2) THEN DO 88 J=1,N AT(1,J) = (0.0E0,0.0E0) 88 CONTINUE C DO 90 J=1,JD ABET(1,J) = (0.0E0,0.0E0) 90 CONTINUE ENDIF C C SOLVE FOR X C IF (KPROG.EQ.1) CALL CPOFS (AT,LDA,N,BT,1,IND,WORK) IF (KPROG.EQ.2) CALL CPOIR (AT,LDA,N,BT,1,IND,WORK) IF (KPROG.EQ.3) CALL CNBFS (ABET,LDA,N,ML,MU,BT,1,IND,WORK, * IWORK) IF (KPROG.EQ.4) CALL CNBIR (ABET,LDA,N,ML,MU,BT,1,IND,WORK, * IWORK) C C COMPARE EXACT AND COMPUTED SOLUTIONS FOR CASE 1 C IF (KCASE.EQ.1) THEN DELMAX = 0.0E0 DO 110 I=1,N DELX = ABS(REAL(BT(I))-REAL(C(I))) DELMAX = MAX(DELMAX,DELX) DELX = ABS(AIMAG(BT(I))-AIMAG(C(I))) DELMAX = MAX(DELMAX,DELX) 110 CONTINUE C IF (R.LE.DELMAX) THEN NERR = NERR+1 WRITE (LUN,801) LIST(KPROG),KCASE,DELMAX ENDIF ELSE C CHECK CONTROL FOR SINGULAR MATRIX FOR CASE 2 C IF (IND.NE.-4) THEN NERR = NERR+1 WRITE (LUN,802) LIST(KPROG),KCASE,IND ENDIF ENDIF 140 CONTINUE 170 CONTINUE C C SUMMARY PRINT C IF (NERR.NE.0) WRITE (LUN,803) NERR IF (KPRINT.GE.2 .AND. NERR.EQ.0) WRITE (LUN,804) RETURN C 800 FORMAT (/' * CQCK - QUICK CHECK FOR CPOFS, CPOIR, CNBFS AND ', 1 'CNBIR'/) 801 FORMAT (' PROBLEM WITH C', A, ', CASE ', I1, 1 '. MAX ABS ERROR OF', E11.4/) 802 FORMAT (' PROBLEM WITH C', A, ', CASE ', I1, '. IND = ', I2, 1 ' INSTEAD OF -4'/) 803 FORMAT (/' **** CQCK DETECTED A TOTAL OF ', I2,' PROBLEMS. ****'/) 804 FORMAT (' CQCK DETECTED NO PROBLEMS.'/) END *DECK CQNG SUBROUTINE CQNG (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CQNG C***PURPOSE Quick check for QNG. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (CQNG-S, CDQNG-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED CPRIN, F1N, F2N, QNG, R1MACH C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Added PASS/FAIL message and changed the name of the first C argument. (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C***END PROLOGUE CQNG C C FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC C REAL A,ABSERR,B,R1MACH,EPMACH,EPSABS,EPSREL,EXACT1,ERROR, * EXACT2,F1N,F2N,RESULT,UFLOW INTEGER IER,IERV,IP,IPASS,KPRINT,NEVAL DIMENSION IERV(1) EXTERNAL F1N,F2N DATA EXACT1/0.7281029132255818E+00/ DATA EXACT2/0.1E+02/ C***FIRST EXECUTABLE STATEMENT CQNG IF (KPRINT.GE.2) WRITE (LUN, '(''1QNG QUICK CHECK''/)') C C TEST ON IER = 0 C IPASS = 1 EPSABS = 0.0E+00 EPMACH = R1MACH(4) UFLOW = R1MACH(1) EPSREL = MAX(SQRT(EPMACH),0.1E-07) A = 0.0E+00 B = 0.1E+01 CALL QNG(F1N,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER) IERV(1) = IER IP = 0 ERROR = ABS(EXACT1-RESULT) IF(IER.EQ.0.AND.ERROR.LE.ABSERR.AND.ABSERR.LE.EPSREL*ABS(EXACT1)) * IP = 1 IF(IP.EQ.0) IPASS = 0 IF(KPRINT.NE.0) CALL CPRIN(LUN,0,KPRINT,IP,EXACT1,RESULT,ABSERR, * NEVAL,IERV,1) C C TEST ON IER = 1 C CALL QNG(F2N,A,B,UFLOW,0.0E+00,RESULT,ABSERR,NEVAL,IER) IERV(1) = IER IP = 0 IF(IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 IF(KPRINT.NE.0) CALL CPRIN(LUN,1,KPRINT,IP,EXACT2,RESULT,ABSERR, * NEVAL,IERV,1) C C TEST ON IER = 6 C EPSABS = 0.0E+00 EPSREL = 0.0E+00 CALL QNG(F1N,A,B,EPSABS,0.0E+00,RESULT,ABSERR,NEVAL,IER) IERV(1) = IER IP = 0 IF(IER.EQ.6.AND.RESULT.EQ.0.0E+00.AND.ABSERR.EQ.0.0E+00.AND. * NEVAL.EQ.0) IP = 1 IF(IP.EQ.0) IPASS = 0 IF(KPRINT.NE.0) CALL CPRIN(LUN,6,KPRINT,IP,EXACT1,RESULT,ABSERR, * NEVAL,IERV,1) C IF (KPRINT.GE.1) THEN IF (IPASS.EQ.0) THEN WRITE(LUN, '(/'' SOME TEST(S) IN CQNG FAILED''/)') ELSEIF (KPRINT.GE.2) THEN WRITE(LUN, '(/'' ALL TEST(S) IN CQNG PASSED''/)') ENDIF ENDIF RETURN END *DECK CQRQC SUBROUTINE CQRQC (LUN, KPRINT, NERR) C***BEGIN PROLOGUE CQRQC C***PURPOSE Quick check for CQRDC and CQRSL. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Voorhees, E. A., (LANL) C***DESCRIPTION C C THE RETURNED FLOATING POINT VALUES FROM CQRDC AND CQRSL FOR C FACTORED X, QRAUX, QY, QTY, B, RSD, AND XB ARE COMPARED TO C THEIR CORRESPONDING STORED PRE-COMPUTED VALUES (ENTERED C WITH DATA STATEMENTS). FAILURE OF THE TEST OCCURS WHEN C AGREEMENT TO 3 SIGNIFICANT DIGITS IS NOT ACHIEVED AND AN C ERROR MESSAGE IS THEN PRINTED. C C THE RETURNED INTEGER VALUES OF JPVT AND INFO ARE ALSO CHECKED. C LACK OF AGREEMENT RESULTS IN AN ERROR MESSAGE. A SUMMARY C LINE IS ALWAYS PRINTED. C C NO INPUT ARGUMENTS ARE REQUIRED. ON RETURN, NERR (INTEGER C TYPE) CONTAINS THE TOTAL COUNT OF ALL FAILURES DETECTED. C C***ROUTINES CALLED CQRDC, CQRSL C***REVISION HISTORY (YYMMDD) C 801029 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF, moved an ARITHMETIC C STATEMENT FUNCTION ahead of the FIRST EXECUTABLE STATEMENT C record and cleaned up FORMATs. (RWC) C***END PROLOGUE CQRQC COMPLEX A(4,4),QRAUX(4),WORK(4),Y(4),QY(4),QTY(4),B(4),RSD(4),XB(4 1) COMPLEX AT(5,4),AC(4,4),QRAUXC(4),QYC(4),QTYC(4),BC(4),RSDC(4),XBC 1(4),X1,X2 CHARACTER KPROG*9,KFAIL*75 INTEGER LDX,N,P,JPVT(4),JOB,K,INFO INTEGER JPVTT(4),JPVTC(4),I,J,INDX(5),NERR,L REAL DELX DATA A/(2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), 1 (0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 2 (0.E0,0.E0),(0.E0,0.E0),(3.E0,0.E0),(0.E0,1.E0), 3 (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/ DATA JPVT/0,-1,1,0/ DATA Y/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA AC/(-3.16228E0,0.E0),(0.E0,0.E0),(.94868E0,0.E0), 1 (0.E0,.31623E0),(0.E0,2.21359E0),(-3.47851E0,0.E0), 2 (0.E0,.31623E0),(.94868E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 3 (2.23607E0,0.E0),(0.E0,.70711E0),(0.E0,0.E0),(0.E0,0.E0), 4 (0.E0,-1.78885E0),(-1.34164E0,0.E0)/ DATA QRAUXC/(1.E0,0.E0),(1.E0,0.E0),(1.70711E0,0.E0),(0.E0,0.E0)/ DATA JPVTC/3,4,1,2/ DATA QYC/(0.E0,-5.81378E0),(-2.68328E0,0.E0),(-1.89737E0,-1.58114E 10), 2 (1.58114E0,-3.79473E0)/ DATA QTYC/(0.E0,5.37587E0),(-3.47851E0,0.E0),(4.02492E0,2.23607E0) 1, 2 (0.E0,-1.34164E0)/ DATA BC/(0.E0,-1.E0),(1.E0,0.E0),(1.E0,1.E0),(0.E0,1.E0)/ DATA RSDC/(0.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0)/ DATA XBC/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA KPROG/'QRDC QRSL'/ DATA KFAIL/'FACTOR QRAUX JPVT QY QTY SOLUTION RSD 1 XB INFO'/ C DELX(X1,X2) = ABS(REAL(X1-X2))+ABS(AIMAG(X1-X2)) C***FIRST EXECUTABLE STATEMENT CQRQC LDX = 5 N = 4 P = 4 K = 4 NERR = 0 C C FORM AT AND JPVTT C DO 20 J=1,N JPVTT(J) = JPVT(J) DO 10 I=1,N AT(I,J) = A(I,J) 10 CONTINUE 20 CONTINUE C C TEST CQRDC (FACTOR, QRAUX, JPVT) C JOB = 1 CALL CQRDC(AT,LDX,N,P,QRAUX,JPVTT,WORK,JOB) INDX(1) = 0 DO 40 J=1,N DO 30 I=1,N IF (DELX(AT(I,J),AC(I,J)) .GT. .0001) INDX(1) = INDX(1)+1 30 CONTINUE 40 CONTINUE C IF (INDX(1) .NE. 0) THEN WRITE (LUN, 501) KPROG(1:4),KFAIL(1:6) NERR = NERR + 1 ENDIF C DO 60 I=1,2 INDX(I) = 0 60 CONTINUE C DO 70 I=1,N IF (DELX(QRAUX(I),QRAUXC(I)) .GT. .0001) INDX(1) = INDX(1)+1 IF (JPVTT(I) .NE. JPVTC(I)) INDX(2) = INDX(2)+1 70 CONTINUE C DO 90 I=1,2 L = 7*I+1 IF (INDX(I) .NE. 0) THEN WRITE (LUN,501) KPROG(1:4),KFAIL(L:L+4) NERR = NERR + 1 ENDIF 90 CONTINUE C C TEST CQRSL (QY, QTY, SOLUTION, RSD, XB, INFO) C JOB = 11111 DO 100 I=1,5 INDX(I) = 0 100 CONTINUE C CALL CQRSL(AT,LDX,N,K,QRAUX,Y,QY,QTY,B,RSD,XB,JOB,INFO) DO 110 I=1,N IF (DELX(QY(I),QYC(I)) .GT. .0001) INDX(1) = INDX(1)+1 IF (DELX(QTY(I),QTYC(I)) .GT. .0001) INDX(2) = INDX(2)+1 IF (DELX(B(I),BC(I)) .GT. .0001) INDX(3) = INDX(3)+1 IF (DELX(RSD(I),RSDC(I)) .GT. .0001) INDX(4) = INDX(4)+1 IF (DELX(XB(I),XBC(I)) .GT. .0001) INDX(5) = INDX(5)+1 110 CONTINUE C DO 130 I=1,5 L = 10*I+11 IF (INDX(I) .NE. 0) THEN WRITE (LUN,501) KPROG(6:9),KFAIL(L:L+8) NERR = NERR + 1 ENDIF 130 CONTINUE C IF (INFO .NE. 0) THEN WRITE (LUN,501) KPROG(6:9),KFAIL(71:74) NERR = NERR + 1 ENDIF C IF (KPRINT.GE.2 .OR. NERR.NE.0) WRITE (LUN,500) NERR RETURN C 500 FORMAT(/' * CQRQC - TEST FOR CQRDC AND CQRSL FOUND ', I1, * ' ERRORS.'/) 501 FORMAT (/' *** C', A, ' FAILURE - ERROR IN ', A) END *DECK CQRTST SUBROUTINE CQRTST (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CQRTST C***PURPOSE Quick check for CPQR79. C***LIBRARY SLATEC C***TYPE COMPLEX (RQRTST-S, CQRTST-C) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED CPQR79, NUMXER, PASS, R1MACH, XERCLR, XGETF, XSETF C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Changed usage of R1MACH(3) to R1MACH(4). (RWC) C 911010 Code reworked and simplified. (RWC and WRB) C***END PROLOGUE CQRTST INTEGER ITEST(2), ITMP(7) REAL WORK(144) COMPLEX COEFF1(9), COEFF2(2), COEFF3(2), ROOT(8), CHK1(8), CHK2 LOGICAL FATAL C DATA COEFF1 / (1.0,0.0), (-7.0,-2.0), (8.0,6.0), (28.0, 8.0), * (-49.0,-24.0), (7.0,2.0), (-8.0,-6.0), * (-28.0,-8.0), (48.0,24.0)/ DATA COEFF2 / (1.0,1.0), (1.0,3.0) / DATA COEFF3 / (0.0,0.0), (1.0,3.0) / DATA CHK1 / (4.0,2.0), (3.0,0.0), (-2.0,0.0), (2.0,0.0), * (0.0,-1.0), (-1.0,0.0), (0.0,1.0), (1.0,0.0) / DATA CHK2 / (-2.0,-1.0) / C***FIRST EXECUTABLE STATEMENT CQRTST IF (KPRINT .GE. 2) WRITE (LUN, 90000) TOL = SQRT(R1MACH(4)) IPASS = 1 C C First test. C CALL CPQR79 (8, COEFF1, ROOT, IERR, WORK) C C Check to see if test passed. C DO 10 I=1,7 ITMP(I) = 0 10 CONTINUE C C Check for roots in any order. C DO 30 I=1,7 DO 20 J=1,7 IF (ABS(ROOT(I)-CHK1(J)) .LE. TOL) THEN ITMP(J) = 1 GOTO 30 ENDIF 20 CONTINUE 30 CONTINUE C C Check that we found all 7 roots. C ITEST(1) = 1 DO 40 I=1,7 ITEST(1) = ITEST(1)*ITMP(I) 40 CONTINUE C C Print test results. C IF (KPRINT.GE.3 .OR. (KPRINT.GE.2.AND.ITEST(1).EQ.0)) THEN WRITE (LUN, 90010) WRITE (LUN, 90020) (J,COEFF1(J), J=1,9) WRITE (LUN, 90030) WRITE (LUN, 90040) (J,ROOT(J), J=1,7) ENDIF IF (KPRINT .GE. 2) THEN CALL PASS (LUN, 1, ITEST(1)) ENDIF C C Set up next problem. C CALL CPQR79 (1, COEFF2, ROOT, IERR, WORK) C C Check to see if test passed. C ITEST(2) = 1 IF (ABS(ROOT(1)-CHK2) .GT. TOL) ITEST(2) = 0 C C Print test results for second test. C IF (KPRINT.GE.3 .OR. (KPRINT.GE.2.AND.ITEST(1).EQ.0)) THEN WRITE (LUN, 90050) WRITE (LUN, 90010) WRITE (LUN, 90020) (J,COEFF2(J), J=1,2) WRITE (LUN, 90030) WRITE (LUN, 90040) (J,ROOT(J), J=1,1) ENDIF IF (KPRINT .GE. 2) THEN CALL PASS (LUN, 2, ITEST(2)) ENDIF C C Trigger 2 error conditions C CALL XGETF (KONTRL) IF (KPRINT .LE. 2) THEN CALL XSETF (0) ELSE CALL XSETF (1) ENDIF FATAL = .FALSE. CALL XERCLR IF (KPRINT .GE. 3) WRITE (LUN, 90060) C C CALL CPQR79 with 0 degree polynomial. C CALL CPQR79 (0, COEFF2, ROOT, IERR, WORK) IF (NUMXER(NERR) .NE. 3) THEN FATAL = .TRUE. ENDIF CALL XERCLR C C CALL CPQR79 with zero leading coefficient. C CALL CPQR79 (2, COEFF3, ROOT, IERR, WORK) IF (NUMXER(NERR) .NE. 2) THEN FATAL = .TRUE. ENDIF CALL XERCLR C CALL XSETF (KONTRL) IF (FATAL) THEN IPASS = 0 IF (KPRINT .GE. 2) THEN WRITE (LUN, 90070) ENDIF ELSE IF (KPRINT .GE. 3) THEN WRITE (LUN, 90080) ENDIF ENDIF C C See if all tests passed. C IPASS = IPASS*ITEST(1)*ITEST(2) C IF (IPASS.EQ.1 .AND. KPRINT.GT.1) WRITE (LUN,90100) IF (IPASS.EQ.0 .AND. KPRINT.NE.0) WRITE (LUN,90110) RETURN C 90000 FORMAT ('1', /,' CPQR79 QUICK CHECK') 90010 FORMAT (/, ' CHECK REAL AND IMAGINARY PARTS OF ROOT' / * ' COEFFICIENTS') 90020 FORMAT (/ (I6, 3X, 1P, 2E22.14)) 90030 FORMAT (// 25X, 'TABLE of ROOTS' // * ' ROOT REAL PART', 12X, 'IMAG PART' / * ' NUMBER', 8X, 2(' of ZERO ', 12X)) 90040 FORMAT (I6, 3X, 1P, 2E22.14) 90050 FORMAT (/, ' TEST SUBSEQUENT RELATED CALL') 90060 FORMAT (// ' TRIGGER 2 ERROR CONDITIONS' //) 90070 FORMAT (/ ' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED') 90080 FORMAT (/ ' ALL INCORRECT ARGUMENT TESTS PASSED') 90100 FORMAT (/' **************CPQR79 PASSED ALL TESTS**************') 90110 FORMAT (/' **************CPQR79 FAILED SOME TESTS*************') END *DECK CSIQC SUBROUTINE CSIQC (LUN, KPRINT, NERR) C***BEGIN PROLOGUE CSIQC C***PURPOSE Quick check for CSIFA, CSICO, CSISL and CSIDI. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Voorhees, E. A., (LANL) C***DESCRIPTION C C LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS C OF THE PROPER TYPE FOR THE LINPACK SUBROUTINES BEING TESTED. C THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF C C (THE SOLUTION VECTOR), AINV (INVERSE OF MATRIX A ), DC C (DETERMINANT OF A ), AND RCND ( RCOND ) ARE ENTERED C WITH DATA STATEMENTS. C C THE COMPUTED TEST RESULTS FOR X, RCOND, THE DETERMINANT, AND C THE INVERSE ARE COMPARED TO THE STORED PRE-COMPUTED VALUES. C FAILURE OF THE TEST OCCURS WHEN AGREEMENT TO 3 SIGNIFICANT C DIGITS IS NOT ACHIEVED AND AN ERROR MESSAGE INDICATING WHICH C LINPACK SUBROUTINE FAILED AND WHICH QUANTITY WAS INVOLVED IS C PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. C C NO INPUT ARGUMENTS ARE REQUIRED. C ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT OF C ALL FAILURES DETECTED BY CSIQC. C C***ROUTINES CALLED CSICO, CSIDI, CSIFA, CSISL C***REVISION HISTORY (YYMMDD) C 801021 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF and cleaned up C FORMATs. (RWC) C***END PROLOGUE CSIQC COMPLEX A(4,4),AT(5,4),B(4),BT(4),C(4),AINV(4,4),DET(2),DC(2), 1 Z(4),XA,XB REAL R,RCOND,RCND,DELX CHARACTER KPROG*19, KFAIL*39 INTEGER LDA,N,IPVT(4),INFO,I,J,INDX,NERR DATA A/(2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), 1 (0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 2 (0.E0,0.E0),(0.E0,0.E0),(3.E0,0.E0),(0.E0,1.E0), 3 (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/ DATA B/(3.E0,2.E0),(1.E0,1.E0),(0.E0,-4.E0),(3.E0,0.E0)/ DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA AINV/(.40000E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0, 1 0.E0), 2 (0.E0,.20000E0),(.40000E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 3 (0.E0,0.E0),(0.E0,0.E0),(.30769E0,0.E0),(0.E0,1.E0), 4 (0.E0,0.E0),(0.E0,0.E0),(0.E0,.07692E0),(.23077E0,0.E0)/ DATA DC/(6.5E0,0.E0),(1.0E0,0.E0)/ DATA KPROG/'SIFA SICO SISL SIDI'/ DATA KFAIL/'INFO RCOND SOLUTION DETERMINANT INVERSE'/ DATA RCND/.58692E0/ C DELX(XA,XB)=ABS(REAL(XA-XB))+ABS(AIMAG(XA-XB)) C***FIRST EXECUTABLE STATEMENT CSIQC LDA = 5 N = 4 NERR = 0 C C FORM AT FOR CSIFA AND BT FOR CSISL, TEST CSIFA C DO 20 J=1,N BT(J) = B(J) DO 10 I=1,N AT(I,J) = A(I,J) 10 CONTINUE 20 CONTINUE C CALL CSIFA(AT,LDA,N,IPVT,INFO) IF (INFO .NE. 0) THEN WRITE (LUN,201) KPROG(1:4),KFAIL(1:4) NERR = NERR + 1 ENDIF C C TEST CSISL C CALL CSISL(AT,LDA,N,IPVT,BT) INDX = 0 DO 40 I=1,N IF (DELX(C(I),BT(I)) .GT. .0001) INDX=INDX+1 40 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ENDIF C C FORM AT FOR CSICO, TEST CSICO C DO 70 J=1,N DO 60 I=1,N AT(I,J) = A(I,J) 60 CONTINUE 70 CONTINUE C CALL CSICO(AT,LDA,N,IPVT,RCOND,Z) R = ABS(RCND-RCOND) IF (R .GE. .0001) THEN WRITE (LUN,201) KPROG(6:9),KFAIL(6:10) NERR = NERR + 1 ENDIF C C TEST CSIDI FOR JOB=11 C CALL CSIDI(AT,LDA,N,IPVT,DET,Z,11) INDX = 0 DO 110 I=1,2 IF (DELX(DC(I),DET(I)) .GT. .0001) INDX=INDX+1 110 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(16:19),KFAIL(21:31) NERR = NERR + 1 ENDIF C INDX = 0 DO 140 I=1,N DO 130 J=1,N IF (DELX(AINV(I,J),AT(I,J)) .GT. .0001) INDX=INDX+1 130 CONTINUE 140 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(16:19),KFAIL(33:39) NERR = NERR + 1 ENDIF C IF (KPRINT.GE.2 .OR. NERR.NE.0) WRITE (LUN,200) NERR RETURN C 200 FORMAT(/' * CSIQC - TEST FOR CSIFA, CSICO, CSISL AND CSIDI FOUND ' 1 , I1, ' ERRORS.'/) 201 FORMAT (/' *** C', A, ' FAILURE - ERROR IN ', A) END *DECK CSPQC SUBROUTINE CSPQC (LUN, KPRINT, NERR) C***BEGIN PROLOGUE CSPQC C***PURPOSE Quick check for CSPFA, CSPCO, CSPSL and CSPDI. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Voorhees, E. A., (LANL) C***DESCRIPTION C C LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS C OF THE PROPER TYPE FOR THE LINPACK SUBROUTINES BEING TESTED. C THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF C C (THE SOLUTION VECTOR), AINV (INVERSE OF MATRIX A ), DC C (DETERMINANT OF A ), AND RCND ( RCOND ) ARE ENTERED C WITH DATA STATEMENTS. C C THE COMPUTED TEST RESULTS FOR X, RCOND, THE DETERMINANT, AND C THE INVERSE ARE COMPARED TO THE STORED PRE-COMPUTED VALUES. C FAILURE OF THE TEST OCCURS WHEN AGREEMENT TO 3 SIGNIFICANT C DIGITS IS NOT ACHIEVED AND AN ERROR MESSAGE INDICATING WHICH C LINPACK SUBROUTINE FAILED AND WHICH QUANTITY WAS INVOLVED IS C PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. C C NO INPUT ARGUMENTS ARE REQUIRED. C ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT OF C ALL FAILURES DETECTED BY CSPQC. C C***ROUTINES CALLED CSPCO, CSPDI, CSPFA, CSPSL C***REVISION HISTORY (YYMMDD) C 801021 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF and cleaned up C FORMATs. (RWC) C***END PROLOGUE CSPQC COMPLEX AP(10),AT(10),B(4),BT(4),C(4),AINV(10),DET(2),DC(2), 1 Z(4),XA,XB REAL R,RCOND,RCND,DELX CHARACTER KPROG*19, KFAIL*39 INTEGER N,IPVT(4),INFO,I,J,INDX,NERR DATA AP/(2.E0,0.E0),(0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0), 1 (0.E0,0.E0),(3.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 2 (0.E0,-1.E0),(4.E0,0.E0)/ DATA B/(3.E0,2.E0),(1.E0,1.E0),(0.E0,-4.E0),(3.E0,0.E0)/ DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA AINV/(.4E0,0.E0),(0.E0,.2E0),(.4E0,0.E0),(0.E0,0.E0), 1 (0.E0,0.E0),(.30769E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 2 (0.E0,.07692E0),(.23077E0,0.E0)/ DATA DC/(6.5E0,0.E0),(1.0E0,0.E0)/ DATA KPROG/'SPFA SPCO SPSL SPDI'/ DATA KFAIL/'INFO RCOND SOLUTION DETERMINANT INVERSE'/ DATA RCND/.58692E0/ C DELX(XA,XB)=ABS(REAL(XA-XB))+ABS(AIMAG(XA-XB)) C***FIRST EXECUTABLE STATEMENT CSPQC N = 4 NERR = 0 C C FORM AT FOR CSPFA AND BT FOR CSPSL, TEST CSPFA C DO 10 J=1,N BT(J) = B(J) 10 CONTINUE C DO 20 I=1,10 AT(I) = AP(I) 20 CONTINUE C CALL CSPFA(AT,N,IPVT,INFO) IF (INFO .NE. 0) THEN WRITE (LUN,201) KPROG(1:4),KFAIL(1:4) NERR = NERR + 1 ENDIF C C TEST CSPSL C CALL CSPSL(AT,N,IPVT,BT) INDX = 0 DO 40 I=1,N IF (DELX(C(I),BT(I)) .GT. .0001) INDX=INDX+1 40 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ENDIF C C FORM AT FOR CSPCO, TEST CSPCO C DO 60 I=1,10 AT(I) = AP(I) 60 CONTINUE C CALL CSPCO(AT,N,IPVT,RCOND,Z) R = ABS(RCND-RCOND) IF (R .GE. .0001) THEN WRITE (LUN,201) KPROG(6:9),KFAIL(6:10) NERR = NERR + 1 ENDIF C C TEST CSPDI FOR JOB=11 C CALL CSPDI(AT,N,IPVT,DET,Z,11) INDX = 0 DO 110 I=1,2 IF (DELX(DC(I),DET(I)) .GT. .0001) INDX=INDX+1 110 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(16:19),KFAIL(21:31) NERR = NERR + 1 ENDIF C INDX = 0 DO 140 I=1,10 IF (DELX(AINV(I),AT(I)) .GT. .0001) INDX=INDX+1 140 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(16:19),KFAIL(33:39) NERR = NERR + 1 ENDIF C IF (KPRINT.GE.2 .OR. NERR.NE.0) WRITE (LUN,200) NERR RETURN C 200 FORMAT(/' * CSPQC - TEST FOR CSPFA, CSPCO, CSPSL AND CSPDI FOUND ' 1 , I1, ' ERRORS.'/) 201 FORMAT (/'*** C', A, ' FAILURE - ERROR IN ', A) END *DECK CSVQC SUBROUTINE CSVQC (LUN, KPRINT, NERR) C***BEGIN PROLOGUE CSVQC C***PURPOSE Quick check for CSVDC. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Voorhees, E. A., (LANL) C***DESCRIPTION C C THE RETURNED FLOATING POINT VALUES FROM CSVDC FOR C S, E, U, AND V ARE COMPARED TO THEIR C CORRESPONDING STORED PRE-COMPUTED VALUES (ENTERED C WITH DATA STATEMENTS). FAILURE OF THE TEST OCCURS WHEN C AGREEMENT TO 3 SIGNIFICANT DIGITS IS NOT ACHIEVED AND C AN ERROR MESSAGE IS THEN PRINTED. C C THE RETURNED INTEGER VALUE OF INFO IS ALSO CHECKED. C LACK OF AGREEMENT RESULTS IN AN ERROR MESSAGE. A SUMMARY C LINE IS ALWAYS PRINTED. C C NO INPUT ARGUMENTS ARE REQUIRED. ON RETURN, NERR (INTEGER C TYPE) CONTAINS THE TOTAL COUNT OF ALL FAILURES DETECTED. C C***ROUTINES CALLED CSVDC C***REVISION HISTORY (YYMMDD) C 801031 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF, moved an ARITHMETIC C STATEMENT FUNCTION ahead of the FIRST EXECUTABLE STATEMENT C record and cleaned up FORMATs. (RWC) C***END PROLOGUE CSVQC COMPLEX A(4,4),WORK(4),S(4),E(4),U(4,4),V(4,4) COMPLEX AT(5,4),SC(4),EC(4),UVC(4,4),X1,X2 INTEGER LDX,N,P,LDU,LDV,JOB,INFO CHARACTER KFAIL*12 INTEGER I,J,INDX(4) REAL DELX DATA A/(2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), 1 (0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 2 (0.E0,0.E0),(0.E0,0.E0),(3.E0,0.E0),(0.E0,1.E0), 3 (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/ DATA KFAIL/'S E U V INFO'/ DATA SC/(4.61803E0,0.E0),(3.0E0,0.E0),(2.38197E0,0.E0),(1.E0,0.E0) 1/ DATA EC/(0.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0)/ DATA UVC/(0.E0,0.E0),(0.E0,0.E0),(-.52573E0,0.E0),(0.E0,-.85065E0) 1, 2 (.70711E0,0.E0),(0.E0,.70711E0),(0.E0,0.E0),(0.E0,0.E0), 3 (0.E0,0.E0),(0.E0,0.E0),(-.85065E0,0.E0),(0.E0,.52573E0), 4 (-.70711E0,0.E0),(0.E0,.70711E0),(0.E0,0.E0),(0.E0,0.E0)/ C DELX(X1,X2) = ABS(REAL(X1-X2))+ABS(AIMAG(X1-X2)) C***FIRST EXECUTABLE STATEMENT CSVQC N = 4 P = 4 LDX = 5 LDU = 4 LDV = 4 NERR = 0 JOB = 11 C C FORM AT C DO 20 J=1,N DO 10 I=1,N AT(I,J) = A(I,J) 10 CONTINUE 20 CONTINUE C C TEST CSVDC (S, E, U, V, INFO) C DO 30 I=1,4 INDX(I) = 0 30 CONTINUE C CALL CSVDC(AT,LDX,N,P,S,E,U,LDU,V,LDV,WORK,JOB,INFO) DO 50 J=1,N IF (DELX(S(J),SC(J)) .GT. .0001) INDX(1) = INDX(1)+1 IF (DELX(E(J),EC(J)) .GT. .0001) INDX(2) = INDX(2)+1 DO 40 I=1,N IF (DELX(U(I,J),UVC(I,J)) .GT. .0001) INDX(3) = INDX(3)+1 IF (DELX(V(I,J),UVC(I,J)) .GT. .0001) INDX(4) = INDX(4)+1 40 CONTINUE 50 CONTINUE C DO 70 I=1,4 KONE=2*I-1 IF (INDX(I) .NE. 0) THEN WRITE (LUN,201) KFAIL(KONE:KONE) NERR = NERR + 1 ENDIF 70 CONTINUE C IF (INFO .NE. 0) THEN WRITE (LUN,201) KFAIL(9:12) NERR = NERR + 1 ENDIF C IF (KPRINT.GE.2 .OR. NERR.NE.0) WRITE (LUN,200) NERR RETURN C 200 FORMAT (/' * CSVQC - TEST FOR CSVDC FOUND ', I1, ' ERRORS.'/) 201 FORMAT (/' *** CSVQC FAILURE - ERROR IN ', A) END *DECK CTRQC SUBROUTINE CTRQC (LUN, KPRINT, NERR) C***BEGIN PROLOGUE CTRQC C***PURPOSE Quick check for CTRFA, CTRCO, CTRSL and CTRDI. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Voorhees, E. A., (LANL) C***DESCRIPTION C C LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS C OF THE PROPER TYPE FOR THE LINPACK SUBROUTINES BEING TESTED. C THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF C C (THE SOLUTION VECTOR), AINV (INVERSE OF MATRIX A ), DC C (DETERMINANT OF A ), AND RCND ( RCOND ) ARE ENTERED C WITH DATA STATEMENTS. C C THE COMPUTED TEST RESULTS FOR X, RCOND, THE DETERMINANT, AND C THE INVERSE ARE COMPARED TO THE STORED PRE-COMPUTED VALUES. C FAILURE OF THE TEST OCCURS WHEN AGREEMENT TO 3 SIGNIFICANT C DIGITS IS NOT ACHIEVED AND AN ERROR MESSAGE INDICATING WHICH C LINPACK SUBROUTINE FAILED AND WHICH QUANTITY WAS INVOLVED IS C PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. C C NO INPUT ARGUMENTS ARE REQUIRED. C ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT OF C ALL FAILURES DETECTED BY CTRQC. C C***ROUTINES CALLED CTRCO, CTRDI, CTRSL C***REVISION HISTORY (YYMMDD) C 801023 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF and cleaned up C FORMATs. (RWC) C***END PROLOGUE CTRQC COMPLEX A(4,4),AT(5,4),B(4,2),BT(4),C(4),AINV(4,4,2),DET(2), 1 DC(2),Z(4),XA,XB REAL R,RCOND,RCND(2),DELX CHARACTER KPROG*19, KFAIL*39 INTEGER LDA,N,INFO,I,J,INDX,NERR INTEGER JOB,K,KK DATA A/(2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), 1 (0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 2 (0.E0,0.E0),(0.E0,0.E0),(3.E0,0.E0),(0.E0,1.E0), 3 (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/ DATA B/(2.E0,2.E0),(-1.E0,3.E0),(0.E0,-3.E0),(5.E0,0.E0), 1 (3.E0,2.E0),(0.E0,2.E0),(0.E0,-4.E0),(4.E0,0.E0)/ DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA AINV/(.50000E0,0.E0),(0.E0,-.25000E0),(0.E0,0.E0),(0.E0,0.E0) 1, 2 (0.E0,-1.00000E0),(.50000E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 3 (0.E0,0.E0),(0.E0,0.E0),(.33333E0,0.E0),(0.E0,-.083333E0), 4 (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.00000E0),(.25000E0,0.E0), 5 (.50000E0,0.E0),(0.E0,1.00000E0),(0.E0,0.E0),(0.E0,0.E0), 6 (0.E0,.25000E0),(.50000E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 7 (0.E0,0.E0),(0.E0,0.E0),(.33333E0,0.E0),(0.E0,1.00000E0), 8 (0.E0,0.E0),(0.E0,0.E0),(0.E0,.083333E0),(.25000E0,0.E0)/ DATA DC/(4.8E0,0.E0),(1.0E0,0.E0)/ DATA KPROG/'TRFA TRCO TRSL TRDI'/ DATA KFAIL/'INFO RCOND SOLUTION DETERMINANT INVERSE'/ DATA RCND/.45695E0,.37047E0/ C DELX(XA,XB)=ABS(REAL(XA-XB))+ABS(AIMAG(XA-XB)) C***FIRST EXECUTABLE STATEMENT CTRQC LDA = 5 N = 4 NERR = 0 C C K=1 FOR LOWER, K=2 FOR UPPER C DO 160 K=1,2 C C FORM AT FOR CTRCO AND BT FOR CTRSL, TEST CTRCO C DO 20 J=1,N BT(J) = B(J,K) DO 10 I=1,N AT(I,J) = A(I,J) 10 CONTINUE 20 CONTINUE C JOB = K - 1 CALL CTRCO(AT,LDA,N,RCOND,Z,JOB) R = ABS(RCND(K)-RCOND) IF (R .GE. .0001) THEN WRITE (LUN,201) KPROG(6:9),KFAIL(6:10) NERR = NERR + 1 ENDIF C C TEST CTRSL FOR JOB= 0 OR 1 C CALL CTRSL(AT,LDA,N,BT,JOB,INFO) IF (INFO .NE. 0) THEN WRITE (LUN,201) KPROG(11:14),KFAIL(1:4) NERR = NERR + 1 ENDIF C INDX = 0 DO 50 I=1,N IF (DELX(C(I),BT(I)) .GT. .0001) INDX=INDX+1 50 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ENDIF C C FORM BT FOR CTRSL C KK = 3 - K DO 70 J=1,N BT(J) = B(J,KK) 70 CONTINUE C C TEST CTRSL FOR JOB EQUAL TO 10 OR 11 C JOB = 9 + K CALL CTRSL(AT,LDA,N,BT,JOB,INFO) IF (INFO .NE. 0) THEN WRITE (LUN,201) KPROG(11:14),KFAIL(1:4) NERR = NERR + 1 ENDIF C INDX = 0 DO 90 I=1,N IF (DELX(C(I),BT(I)) .GT. .0001) INDX=INDX+1 90 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ENDIF C C TEST CTRDI FOR JOB= 110 OR 111 C JOB = 109 + K CALL CTRDI(AT,LDA,N,DET,JOB,INFO) IF (INFO .NE. 0) THEN WRITE (LUN,201) KPROG(16:19),KFAIL(1:4) NERR = NERR + 1 ENDIF C INDX = 0 DO 110 I=1,2 IF (DELX(DC(I),DET(I)) .GT. .0001) INDX=INDX+1 110 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(16:19),KFAIL(21:31) NERR = NERR + 1 ENDIF C INDX = 0 DO 140 I=1,N DO 130 J=1,N IF (DELX(AINV(I,J,K),AT(I,J)) .GT. .0001) INDX=INDX+1 130 CONTINUE 140 CONTINUE C IF (INDX .NE. 0) THEN WRITE (LUN,201) KPROG(16:19),KFAIL(33:39) NERR = NERR + 1 ENDIF 160 CONTINUE C IF (KPRINT.GE.2 .OR. NERR.NE.0) WRITE (LUN,200) NERR RETURN C 200 FORMAT(/' * CTRQC - TEST FOR CTRCO, CTRSL AND CTRDI FOUND ' 1 , I2, ' ERRORS.'/) 201 FORMAT (/' *** C', A, ' FAILURE - ERROR IN ', A) END *DECK DAVNTS SUBROUTINE DAVNTS (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DAVNTS C***PURPOSE Quick check for DAVINT. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (AVNTST-S, DAVNTS-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED D1MACH, DAVINT, XERCLR, XGETF, XSETF C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Changed usage of D1MACH(3) to D1MACH(4). (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C 910708 Minor modifications in use of KPRINT. (WRB) C 920210 Code restructured and revised to test error returns for all C values of KPRINT. (WRB) C***END PROLOGUE DAVNTS DOUBLE PRECISION D1MACH INTEGER I, IERR, IPASS, KPRINT, LUN, N DOUBLE PRECISION A, ANS, B, DEL, RN1, SQB, TOL, TOL1, X(501), + XINT, Y(501) LOGICAL FATAL C***FIRST EXECUTABLE STATEMENT DAVNTS IF (KPRINT .GE. 2) WRITE (LUN,9000) IPASS = 1 TOL = MAX(.0001D0,SQRT(D1MACH(4))) TOL1 = 1.0D-2*TOL C C Perform first accuracy test. C A = 0.0D0 B = 5.0D0 XINT = EXP(5.0D0) - 1.0D0 N = 500 RN1 = N - 1 SQB = SQRT(B) DEL = 0.4D0*(B-A)/(N-1) DO 100 I = 1,N X(I) = SQB*SQRT(A+(I-1)*(B-A)/RN1) + DEL Y(I) = EXP(X(I)) 100 CONTINUE CALL DAVINT (X, Y, N, A, B, ANS, IERR) C C See if test was passed. C IF (ABS(ANS-XINT) .GT. TOL) THEN IPASS = 0 IF (KPRINT .GE. 3) WRITE (LUN,9010) IERR, ANS, XINT ENDIF C C Perform second accuracy test. C X(1) = 0.0D0 X(2) = 5.0D0 Y(1) = 1.0D0 Y(2) = 0.5D0 A = -0.5D0 B = 0.5D0 XINT = 1.0D0 CALL DAVINT (X, Y, 2, A, B, ANS, IERR) C C See if test was passed. C IF (ABS(ANS-XINT) .GT. TOL1) THEN IPASS = 0 IF (KPRINT .GE. 3) WRITE (LUN,9010) IERR, ANS, XINT ENDIF C C Send message indicating passage or failure of tests. C IF (KPRINT .GE. 2) THEN IF (IPASS .EQ. 1) THEN IF (KPRINT .GE. 3) WRITE (LUN,9020) ELSE WRITE (LUN,9030) ENDIF ENDIF C C Test error returns. C CALL XGETF (KONTRL) IF (KPRINT .LE. 2) THEN CALL XSETF (0) ELSE CALL XSETF (1) ENDIF FATAL = .FALSE. CALL XERCLR C IF (KPRINT .GE. 3) THEN WRITE (LUN,9040) ENDIF DO 110 I = 1,20 X(I) = (I-1)/19.0D0 - 0.01D0 IF (I .NE. 1) Y(I) = X(I)/(EXP(X(I))-1.0) 110 CONTINUE C C Test IERR = 1 error return. C Y(1) = 1.0D0 CALL DAVINT (X, Y, 20, 0.0D0, 1.0D0, ANS, IERR) IF (IERR .NE. 1) THEN IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 3) WRITE (LUN,9060) IERR, 1 ENDIF CALL XERCLR C C Test IERR = 2 error return. C CALL DAVINT (X, Y, 20, 1.0D0, 0.0D0, ANS, IERR) IF (IERR .NE. 2) THEN IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 3) WRITE (LUN,9060) IERR, 2 ENDIF IF (ANS .NE. 0.0D0) THEN IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 3) WRITE (LUN,9070) ENDIF CALL XERCLR C C Test IERR = 5 error return. C CALL DAVINT (X, Y, 1, 0.0D0, 1.0D0, ANS, IERR) IF (IERR .NE. 5) THEN IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 3) WRITE (LUN,9060) IERR, 5 ENDIF IF (ANS .NE. 0.0D0) THEN IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 3) WRITE (LUN,9070) ENDIF CALL XERCLR C C Test IERR = 4 error return. C X(1) = 1.0D0/19.0D0 X(2) = 0.0D0 CALL DAVINT (X, Y, 20, 0.0D0, 1.0D0, ANS, IERR) IF (IERR .NE. 4) THEN IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 3) WRITE (LUN,9060) IERR, 4 ENDIF IF (ANS .NE. 0.0D0) THEN IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 3) WRITE (LUN,9070) ENDIF CALL XERCLR C C Test IERR = 3 error return. C X(1) = 0.0D0 X(2) = 1.0D0/19.0D0 CALL DAVINT (X, Y, 20, 0.0D0, .01D0, ANS, IERR) IF (IERR .NE. 3) THEN IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 3) WRITE (LUN,9060) IERR, 3 ENDIF IF (ANS .NE. 0.0D0) THEN IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 3) WRITE (LUN,9070) ENDIF CALL XERCLR C C Reset XERMSG control variables and write summary. C CALL XSETF (KONTRL) IF (FATAL) THEN IF (KPRINT .GE. 2) THEN WRITE (LUN, 9080) ENDIF ELSE IF (KPRINT .GE. 3) THEN WRITE (LUN, 9090) ENDIF ENDIF C C Write PASS/FAIL message. C IF (IPASS.EQ.1 .AND. KPRINT.GE.3) WRITE (LUN,9100) IF (IPASS.EQ.0 .AND. KPRINT.GE.2) WRITE (LUN,9110) RETURN 9000 FORMAT ('1' / ' DAVINT Quick Check') 9010 FORMAT (/' FAILED ACCURACY TEST' / + ' IERR=', I2, 5X, 'COMPUTED ANS=', E20.11 / 14X, + 'CORRECT ANS=', D20.11, 5X, 'REQUESTED ERR=', D10.2) 9020 FORMAT (/ ' DAVINT passed both accuracy tests.') 9030 FORMAT (/ ' DAVINT failed at least one accuracy test.') 9040 FORMAT (/ ' Test error returns from DAVINT' / + ' 4 error messages expected' /) 9060 FORMAT (/' IERR =', I2, ' and it should =', I2 /) 9070 FORMAT (1X, 'ANS .NE. 0') 9080 FORMAT (/ ' At least one incorrect argument test FAILED') 9090 FORMAT (/ ' All incorrect argument tests PASSED') 9100 FORMAT (/' ***************DAVINT PASSED ALL TESTS***************') 9110 FORMAT (/' ***************DAVINT FAILED SOME TESTS**************') END *DECK DBIKCK SUBROUTINE DBIKCK (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DBIKCK C***PURPOSE Quick check for DBESI and DBESK. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (BIKCK-S, DBIKCK-D) C***KEYWORDS QUICK CHECK C***AUTHOR Amos, D. E., (SNLA) C***DESCRIPTION C C DBIKCK is a quick check routine for DBESI and DBESK. The main loops C evaluate the Wronskian and test the error. Underflow and overflow C diagnostics are checked in addition to illegal arguments. C C***ROUTINES CALLED D1MACH, DBESI, DBESK, NUMXER, XERCLR, XGETF, XSETF C***REVISION HISTORY (YYMMDD) C 750101 DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 891004 Removed unreachable code. (WRB) C 891004 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Changed usage of D1MACH(3) to D1MACH(4). (RWC) C 910121 Editorial Changes. (RWC) C 910501 Added TYPE record. (WRB) C 910708 Code revised to test error returns for all values of C KPRINT. (WRB) C 910801 Editorial changes, some restructing and modifications to C obtain more information when there is failure of the C Wronskian. (WRB) C***END PROLOGUE DBIKCK INTEGER I, IPASS, IX, K, KODE, KONTRL, LUN, M, N, NERR, NU, NW, NY DOUBLE PRECISION ALP, DEL, ER, FNU, FNUP, RX, TOL, X DOUBLE PRECISION FN(3), W(5), XX(5), Y(5) DOUBLE PRECISION D1MACH LOGICAL FATAL C***FIRST EXECUTABLE STATEMENT DBIKCK IF (KPRINT .GE. 2) WRITE (LUN,90000) C IPASS = 1 XX(1) = 0.49D0 XX(2) = 1.3D0 XX(3) = 5.3D0 XX(4) = 13.3D0 XX(5) = 21.3D0 FN(1) = 0.095D0 FN(2) = 0.70D0 FN(3) = 0.0D0 TOL = MAX(500.0D0*D1MACH(4), 7.1D-12) DO 60 KODE=1,2 DO 50 M=1,3 DO 40 N=1,4 DO 30 NU=1,4 FNU = FN(M) + 12*(NU-1) DO 20 IX=1,5 IF (IX.LT.2 .AND. NU.GT.3) GO TO 20 X = XX(IX) RX = 1.0D0/X CALL DBESI(X, FNU, KODE, N, Y, NY) IF (NY.NE.0) GO TO 20 CALL DBESK(X, FNU, KODE, N, W, NW) IF (NW.NE.0) GO TO 20 FNUP = FNU + N CALL DBESI(X,FNUP,KODE,1,Y(N+1),NY) IF (NY.NE.0) GO TO 20 CALL DBESK(X,FNUP,KODE,1,W(N+1),NW) IF (NW.NE.0) GO TO 20 DO 10 I=1,N ER = Y(I+1)*W(I) + W(I+1)*Y(I) - RX ER = ABS(ER)*X IF (ER.GT.TOL) THEN IPASS = 0 IF (KPRINT.GE.2) WRITE (LUN,90010) KODE,M,N, * NU,IX,I,X,ER,TOL, * Y(I),Y(I+1),W(I),W(I+1) ENDIF 10 CONTINUE 20 CONTINUE 30 CONTINUE 40 CONTINUE 50 CONTINUE 60 CONTINUE C C Check small values of X and order C N = 2 FNU = 1.0D0 X = D1MACH(4) DO 80 I=1,3 DO 70 KODE=1,2 CALL DBESI(X, FNU, KODE, N, Y, NY) CALL DBESK(X, FNU, KODE, N, W, NW) ER = Y(2)*W(1) + W(2)*Y(1) - 1.0D0/X ER = ABS(ER)*X IF (ER.GT.TOL) THEN IPASS = 0 IF (KPRINT.GE.2) WRITE (LUN,90020) I,KODE,FNU,X,ER,TOL, + Y(1),Y(2),W(1),W(2) GO TO 700 ENDIF 70 CONTINUE C 700 FNU = D1MACH(4)/100.0D0 X = XX(2*I-1) 80 CONTINUE C C Check large values of X and order C KODE = 2 DO 76 K=1,2 DEL = 30*(K-1) FNU = 45.0D0+DEL DO 75 N=1,2 X = 20.0D0 + DEL DO 71 I=1,5 RX = 1.0D0/X CALL DBESI(X, FNU, KODE, N, Y, NY) IF (NY.NE.0) GO TO 71 CALL DBESK(X, FNU, KODE, N, W, NW) IF (NW.NE.0) GO TO 71 IF (N.EQ.1) THEN FNUP = FNU + 1.0D0 CALL DBESI(X,FNUP,KODE,1,Y(2),NY) IF (NY.NE.0) GO TO 71 CALL DBESK(X,FNUP,KODE,1,W(2),NW) IF (NW.NE.0) GO TO 71 ENDIF ER = Y(2)*W(1) + Y(1)*W(2) - RX ER = ABS(ER)*X IF (ER.GT.TOL) THEN IPASS = 0 IF (KPRINT.GE.2) WRITE (LUN,90030) K,N,I,FNUP,X, + ER,TOL,Y(1),Y(2),W(1),W(2) GO TO 760 ENDIF X = X + 10.0D0 71 CONTINUE 75 CONTINUE 76 CONTINUE C C Check underflow flags C 760 X = D1MACH(1)*10.0D0 ALP = 12.3D0 N = 3 CALL DBESI(X, ALP, 1, N, Y, NY) IF (NY.NE.3) THEN IPASS = 0 IF (KPRINT.GE.2) WRITE (LUN,90040) ENDIF C X = LOG(D1MACH(2)/10.0D0) + 20.0D0 ALP = 1.3D0 N = 3 CALL DBESK(X, ALP, 1, N, W, NW) IF (NW.NE.3) THEN IPASS = 0 IF (KPRINT.GE.2) WRITE (LUN,90050) ENDIF C C Trigger 10 error conditions C CALL XGETF (KONTRL) IF (KPRINT .LE. 2) THEN CALL XSETF (0) ELSE CALL XSETF (1) ENDIF FATAL = .FALSE. CALL XERCLR C IF (KPRINT .GE. 3) WRITE (LUN,90060) XX(1) = 1.0D0 XX(2) = 1.0D0 XX(3) = 1.0D0 XX(4) = 1.0D0 C C Illegal arguments C DO 90 I=1,4 XX(I) = -XX(I) K = INT(XX(3)) N = INT(XX(4)) CALL DBESI(XX(1), XX(2), K, N, Y, NY) IF (NUMXER(NERR) .NE. 2) THEN IPASS = 0 FATAL = .TRUE. ENDIF CALL XERCLR CALL DBESK(XX(1), XX(2), K, N, W, NW) IF (NUMXER(NERR) .NE. 2) THEN IPASS = 0 FATAL = .TRUE. ENDIF CALL XERCLR XX(I) = -XX(I) 90 CONTINUE C C Trigger overflow C X = LOG(D1MACH(2)/10.0D0) + 20.0D0 N = 3 ALP = 2.3D0 CALL DBESI(X, ALP, 1, N, Y, NY) IF (NUMXER(NERR) .NE. 6) THEN IPASS = 0 FATAL = .TRUE. ENDIF CALL XERCLR C X = D1MACH(1)*10.0D0 CALL DBESK(X, ALP, 1, N, W, NW) IF (NUMXER(NERR) .NE. 6) THEN IPASS = 0 FATAL = .TRUE. ENDIF CALL XERCLR C CALL XSETF (KONTRL) IF (FATAL) THEN IF (KPRINT .GE. 2) THEN WRITE (LUN, 90070) ENDIF ELSE IF (KPRINT .GE. 3) THEN WRITE (LUN, 90080) ENDIF ENDIF C IF (IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN,90100) IF (IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN,90110) RETURN 90000 FORMAT (/ ' QUICK CHECKS FOR DBESI AND DBESK' //) 90010 FORMAT (/ ' ERROR IN QUICK CHECK OF WRONSKIAN', 1P / + ' KODE = ', I1,', M = ', I1, ', N = ', I1, ', NU = ', I1, + ', IX = ', I1, ', I = ', I1 / + ' X = ', E14.7, ', ER = ', E14.7, ', TOL = ', E14.7 / + ' Y(I) = ', E14.7, ', Y(I+1) = ', E14.7 / + ' W(I) = ', E14.7, ', W(I+1) = ', E14.7) 90020 FORMAT (/ ' ERROR IN QUICK CHECK OF SMALL X AND ORDER', 1P / + ' I = ', I1,', KODE = ', I1, ', FNU = ', E14.7 / + ' X = ', E14.7, ', ER = ', E14.7, ', TOL = ', E14.7 / + ' Y(1) = ', E14.7, ', Y(2) = ', E14.7 / + ' W(1) = ', E14.7, ', W(2) = ', E14.7) 90030 FORMAT (/ ' ERROR IN QUICK CHECK OF LARGE X AND ORDER', 1P / + ' K = ', I1,', N = ', I1, ', I = ', I1, + ', FNUP = ', E14.7 / + ' X = ', E14.7, ', ER = ', E14.7, ', TOL = ', E14.7 / + ' Y(1) = ', E14.7, ', Y(2) = ', E14.7 / + ' W(1) = ', E14.7, ', W(2) = ', E14.7) 90040 FORMAT (/ ' ERROR IN DBESI UNDERFLOW TEST' /) 90050 FORMAT (/ ' ERROR IN DBESK UNDERFLOW TEST' /) 90060 FORMAT (// ' TRIGGER 10 ERROR CONDITIONS' //) 90070 FORMAT (/ ' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED') 90080 FORMAT (/ ' ALL INCORRECT ARGUMENT TESTS PASSED') 90100 FORMAT (/' *********DBESI AND DBESK PASSED ALL TESTS***********') 90110 FORMAT (/' *********DBESI OR DBESK FAILED SOME TESTS***********') END *DECK DBJYCK SUBROUTINE DBJYCK (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DBJYCK C***PURPOSE Quick check for DBESJ and DBESY. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (BJYCK-S, DBJYCK-D) C***KEYWORDS QUICK CHECK C***AUTHOR Amos, D. E., (SNLA) C***DESCRIPTION C C DBJYCK is a quick check routine for DBESJ and DBESY. The main loops C evaluate the Wronskian and test the error. Underflow and overflow C diagnostics are checked in addition to illegal arguments. C C***ROUTINES CALLED D1MACH, DBESJ, DBESY, NUMXER, XERCLR, XGETF, XSETF C***REVISION HISTORY (YYMMDD) C 750101 DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 891004 Removed unreachable code. (WRB) C 891004 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Changed usage of D1MACH(3) to D1MACH(4). (RWC) C 910121 Editorial Changes. (RWC) C 910501 Added TYPE record. (WRB) C 910708 Code revised to test error returns for all values of C KPRINT. (WRB) C 910801 Editorial changes, some restructing and modifications to C obtain more information when there is failure of the C Wronskian. (WRB) C***END PROLOGUE DBJYCK INTEGER I, IPASS, IX, K, KONTRL, LUN, M, N, NERR, NU, NY DOUBLE PRECISION ALP, DEL, ER, FNU, FNUP, RHPI, RX, TOL, X DOUBLE PRECISION FN(3), W(5), XX(5), Y(5) DOUBLE PRECISION D1MACH LOGICAL FATAL C***FIRST EXECUTABLE STATEMENT DBJYCK IF (KPRINT.GE.2) WRITE (LUN,90000) C IPASS = 1 RHPI = 0.5D0/ATAN(1.0D0) XX(1) = 0.49D0 XX(2) = 1.3D0 XX(3) = 5.3D0 XX(4) = 13.3D0 XX(5) = 21.3D0 FN(1) = 0.095D0 FN(2) = 0.70D0 FN(3) = 0.0D0 TOL = MAX(500.0D0*D1MACH(4), 7.1D-12) DO 50 M=1,3 DO 40 N=1,4 DO 30 NU=1,4 FNU = FN(M) + 12*(NU-1) DO 20 IX=1,5 IF (IX.LT.2 .AND. NU.GT.3) GO TO 20 X = XX(IX) RX = RHPI/X CALL DBESJ(X, FNU, N, Y, NY) IF (NY.NE.0) GO TO 20 CALL DBESY(X, FNU, N, W) FNUP = FNU + N CALL DBESJ(X,FNUP,1,Y(N+1),NY) IF (NY.NE.0) GO TO 20 CALL DBESY(X,FNUP,1,W(N+1)) DO 10 I=1,N ER = Y(I+1)*W(I) - W(I+1)*Y(I) - RX ER = ABS(ER)/RX IF (ER.GT.TOL) THEN IPASS = 0 IF (KPRINT.GE.2) WRITE (LUN,90010) M,N,NU,IX,I, * X,ER,TOL,Y(I),Y(I+1),W(I),W(I+1) ENDIF 10 CONTINUE 20 CONTINUE 30 CONTINUE 40 CONTINUE 50 CONTINUE C C Check small values of X and order C N = 2 FNU = 1.0D0 X = D1MACH(4)/5.0D0 RX = RHPI/X DO 60 I=1,3 CALL DBESJ(X, FNU, N, Y, NY) CALL DBESY(X, FNU, N, W) ER = Y(2)*W(1) - W(2)*Y(1) - RX ER = ABS(ER)/RX IF (ER.GT.TOL) THEN IPASS = 0 IF (KPRINT.GE.2) WRITE (LUN,90020) I,FNU,X,ER,TOL, + Y(I),Y(I+1),W(I),W(I+1) GO TO 600 ENDIF FNU = D1MACH(4)/100.0D0 X = XX(2*I-1) RX = RHPI/X 60 CONTINUE C C Check large values of X and order C 600 DO 76 K=1,2 DEL = 30*(K-1) FNU = 70.0D0+DEL DO 75 N=1,2 X = 50.0D0 + DEL DO 70 I=1,5 RX = RHPI/X CALL DBESJ(X, FNU, N, Y, NY) IF (NY.NE.0) GO TO 70 CALL DBESY(X, FNU, N, W) IF (N.EQ.1) THEN FNUP = FNU + 1.0D0 CALL DBESJ(X,FNUP,1,Y(2),NY) IF (NY.NE.0) GO TO 70 CALL DBESY(X,FNUP,1,W(2)) ENDIF ER = Y(2)*W(1) - Y(1)*W(2) - RX ER = ABS(ER)/RX IF (ER.GT.TOL) THEN IPASS = 0 IF (KPRINT.GE.2) WRITE (LUN,90030) K,N,I,X,ER,TOL, * Y(1),Y(2),W(1),W(2) GO TO 800 ENDIF X = X + 10.0D0 70 CONTINUE 75 CONTINUE 76 CONTINUE C C Check underflow flags C 800 X = D1MACH(1)*10.0D0 ALP = 12.3D0 N = 3 CALL DBESJ(X, ALP, N, Y, NY) IF (NY.NE.3) THEN IPASS = 0 IF (KPRINT.GE.2) WRITE (LUN,90040) ENDIF C C Trigger 7 error conditions C CALL XGETF (KONTRL) IF (KPRINT .LE. 2) THEN CALL XSETF (0) ELSE CALL XSETF (1) ENDIF FATAL = .FALSE. CALL XERCLR C IF (KPRINT .GE. 3) WRITE (LUN,90050) XX(1) = 1.0D0 XX(2) = 1.0D0 XX(3) = 1.0D0 C C Illegal arguments C DO 80 I=1,3 XX(I) = -XX(I) N = INT(XX(3)) CALL DBESJ(XX(1), XX(2), N, Y, NY) IF (NUMXER(NERR) .NE. 2) THEN IPASS = 0 FATAL = .TRUE. ENDIF CALL XERCLR CALL DBESY(XX(1), XX(2), N, W) IF (NUMXER(NERR) .NE. 2) THEN IPASS = 0 FATAL = .TRUE. ENDIF CALL XERCLR XX(I) = -XX(I) 80 CONTINUE C C Trigger overflow C X = D1MACH(1)*10.0D0 N = 3 ALP = 2.3D0 CALL DBESY(X, ALP, N, W) IF (NUMXER(NERR) .NE. 6) THEN IPASS = 0 FATAL = .TRUE. ENDIF CALL XERCLR CALL XSETF (KONTRL) IF (FATAL) THEN IF (KPRINT .GE. 2) THEN WRITE (LUN, 90070) ENDIF ELSE IF (KPRINT .GE. 3) THEN WRITE (LUN, 90080) ENDIF ENDIF C IF (IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN,90100) IF (IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN,90110) RETURN 90000 FORMAT (/ ' QUICK CHECKS FOR DBESJ AND DBESY' //) 90010 FORMAT (/ ' ERROR IN QUICK CHECK OF WRONSKIAN', 1P / + ' M = ', I1,', N = ', I1, ', NU = ', I1, ', IX = ', I1, + ', I = ', I1, / + ' X = ', E14.7, ', ER = ', E14.7, ', TOL = ', E14.7 / + ' Y(I) = ', E14.7, ', Y(I+1) = ', E14.7 / + ' W(I) = ', E14.7, ', W(I+1) = ', E14.7) 90020 FORMAT (/ ' ERROR IN QUICK CHECK OF SMALL X AND ORDER', 1P / + ' I = ', I1,', FNU = ', E14.7 / + ' X = ', E14.7, ', ER = ', E14.7, ', TOL = ', E14.7 / + ' Y(1) = ', E14.7, ', Y(2) = ', E14.7 / + ' W(1) = ', E14.7, ', W(2) = ', E14.7) 90030 FORMAT (/ ' ERROR IN QUICK CHECK OF LARGE X AND ORDER', 1P / + ' K = ', I1,', N = ', I1, ', I = ', I1 / + ' X = ', E14.7, ', ER = ', E14.7, ', TOL = ', E14.7 / + ' Y(1) = ', E14.7, ', Y(2) = ', E14.7 / + ' W(1) = ', E14.7, ', W(2) = ', E14.7) 90040 FORMAT (/ ' ERROR IN DBESJ UNDERFLOW TEST' /) 90050 FORMAT (// ' TRIGGER 7 ERROR CONDITIONS' //) 90070 FORMAT (/ ' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED') 90080 FORMAT (/ ' ALL INCORRECT ARGUMENT TESTS PASSED') 90100 FORMAT (/' *********DBESJ AND DBESY PASSED ALL TESTS*********') 90110 FORMAT (/' *********DBESJ OR DBESY FAILED SOME TESTS*********') END *DECK DBOCQX SUBROUTINE DBOCQX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DBOCQX C***PURPOSE Quick check for DBOCLS. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (SBOCQX-S, DBOCQX-D) C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C MINIMAL TEST DRIVER FOR DBOCLS, BOUNDED CONSTRAINED LEAST C SQUARES SOLVER. DELIVERS THE VALUE IPASS=1 IF 8 TESTS WERE C PASSED. DELIVER THE VALUE IPASS=0 IF ANY ONE OF THEM FAILED. C C RUN FOUR BOUNDED LEAST SQUARES PROBLEMS THAT COME FROM THE C DIPLOME WORK OF P. ZIMMERMANN. C C***ROUTINES CALLED D1MACH, DBOCLS, DBOLS, DCOPY, DNRM2 C***REVISION HISTORY (YYMMDD) C 850310 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Added PASS/FAIL message. (RWC) C***END PROLOGUE DBOCQX IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION * D(6,5),W(11,11),BL(5,2),BU(5,2),X(30),RW(55),XTRUE(9) DOUBLE PRECISION C(5,5) DOUBLE PRECISION BL1(10),BU1(10) INTEGER IND(10),IW(20),IOPT(40) DOUBLE PRECISION RHS(6,2) CHARACTER*4 MSG C DATA ((C(I,J),I=1,5),J=1,5)/1.D0,10.D0,4.D0,8.D0,1.D0,1.D0,10.D0, + 2.D0,-1.D0,1.D0,1.D0,-3.D0,-3.D0,2.D0,1.D0,1.D0,5.D0,5.D0, + 5.D0,1.D0,1.D0,4.D0,-1.D0,-3.D0,1.D0/ DATA ((D(I,J),I=1,6),J=1,5)/-74.D0,14.D0,66.D0,-12.D0,3.D0,4.D0, + 80.D0,-69.D0,-72.D0,66.D0,8.D0,-12.D0,18.D0,21.D0,-5.D0, + -30.D0,-7.D0,4.D0,-11.D0,28.D0,7.D0,-23.D0,-4.D0,4.D0,-4.D0, + 0.D0,1.D0,3.D0,1.D0,0.D0/ DATA ((BL(I,J),I=1,5),J=1,2)/1.D0,0.D0,-1.D0,1.D0,-4.D0,-1.D0, + 0.D0,-3.D0,1.D0,-6.D0/ DATA ((BU(I,J),I=1,5),J=1,2)/3.D0,2.D0,1.D0,3.D0,-2.D0,3.D0,4.D0, + 1.D0,5.D0,-2.D0/ DATA ((RHS(I,J),I=1,6),J=1,2)/51.D0,-61.D0,-56.D0,69.D0,10.D0, + -12.D0,-5.D0,-9.D0,708.D0,4165.D0,-13266.D0,8409.D0/ DATA (XTRUE(J),J=1,9)/1.D0,2.D0,-1.D0,3.D0,-4.D0,1.D0,32.D0,30.D0, + 31.D0/ C***FIRST EXECUTABLE STATEMENT DBOCQX MDW = 11 MROWS = 6 NCOLS = 5 MCON = 4 IOPT(1) = 99 IPASS = 1 ITEST = 0 C IF (KPRINT.GE.2) WRITE (LUN, 99998) C DO 50 IB = 1,2 DO 40 IRHS = 1,2 C C TRANSFER DATA TO WORKING ARRAY W(*,*). C DO 10 J = 1,NCOLS CALL DCOPY(MROWS,D(1,J),1,W(1,J),1) 10 CONTINUE C CALL DCOPY(MROWS,RHS(1,IRHS),1,W(1,NCOLS+1),1) C C SET BOUND INDICATOR FLAGS. C DO 20 J = 1,NCOLS IND(J) = 3 20 CONTINUE C CALL DBOLS(W,MDW,MROWS,NCOLS,BL(1,IB),BU(1,IB),IND,IOPT,X, * RNORM,MODE,RW,IW) DO 30 J = 1,NCOLS X(J) = X(J) - XTRUE(J) 30 CONTINUE C SR = DNRM2(NCOLS,X,1) MPASS = 1 IF (SR.GT.10.D2*SQRT(D1MACH(4))) MPASS = 0 IPASS = IPASS*MPASS IF (KPRINT.GE.2) THEN MSG = 'PASS' IF (MPASS.EQ.0) MSG = 'FAIL' ITEST = ITEST + 1 WRITE (LUN, 99999) ITEST, IB, IRHS, SR, MSG ENDIF 40 CONTINUE 50 CONTINUE C C RUN STOER'S PROBLEM FROM 1971 SIAM J. N. ANAL. PAPER. C DO 90 IB = 1,2 DO 80 IRHS = 1,2 CALL DCOPY(11*10,0.D0,0,W,1) CALL DCOPY(NCOLS,BL(1,IB),1,BL1,1) CALL DCOPY(NCOLS,BU(1,IB),1,BU1,1) IND(NCOLS+1) = 2 IND(NCOLS+2) = 1 IND(NCOLS+3) = 2 IND(NCOLS+4) = 3 BU1(NCOLS+1) = 5. BL1(NCOLS+2) = 20. BU1(NCOLS+3) = 30. BL1(NCOLS+4) = 11. BU1(NCOLS+4) = 40. DO 60 J = 1,NCOLS CALL DCOPY(MCON,C(1,J),1,W(1,J),1) CALL DCOPY(MROWS,D(1,J),1,W(MCON+1,J),1) 60 CONTINUE C CALL DCOPY(MROWS,RHS(1,IRHS),1,W(MCON+1,NCOLS+1),1) C C CHECK LENGTHS OF REQD. ARRAYS. C IOPT(01) = 2 IOPT(02) = 11 IOPT(03) = 11 IOPT(04) = 10 IOPT(05) = 30 IOPT(06) = 55 IOPT(07) = 20 IOPT(08) = 40 IOPT(09) = 99 CALL DBOCLS(W,MDW,MCON,MROWS,NCOLS,BL1,BU1,IND,IOPT,X, * RNORMC,RNORM,MODE,RW,IW) DO 70 J = 1,NCOLS + MCON X(J) = X(J) - XTRUE(J) 70 CONTINUE C SR = DNRM2(NCOLS+MCON,X,1) MPASS = 1 IF (SR.GT.10.D2*SQRT(D1MACH(4))) MPASS = 0 IPASS = IPASS*MPASS IF (KPRINT.GE.2) THEN MSG = 'PASS' IF (MPASS.EQ.0) MSG = 'FAIL' ITEST = ITEST + 1 WRITE (LUN, 99999) ITEST, IB, IRHS, SR, MSG ENDIF 80 CONTINUE 90 CONTINUE C C HERE THE VALUE OF IPASS=1 SAYS THAT DBOCLS HAS PASSED ITS TESTS. C THE VALUE OF IPASS=0 SAYS THAT DBOCLS HAS NOT PASSED. C IF(KPRINT.GE.3) *WRITE(LUN,'('' IPASS VALUE. (A 1 IS GOOD, 0 IS BAD.)'',I4)')IPASS IF(KPRINT.GE.2.AND.IPASS.EQ.0) WRITE(LUN,10789) RETURN C 10789 FORMAT (' ERROR IN DBOCLS OR DBOLS') 99998 FORMAT (' TEST IB IRHS SR') 99999 FORMAT (3I5, 1P,E20.6, ' TEST ', A, 'ED.') END *DECK DBSPCK SUBROUTINE DBSPCK (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DBSPCK C***PURPOSE Quick check for the B-spline package. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (BSPCK-S, DBSPCK-D) C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C DBSPCK is a quick check routine for the B-Spline package which C tests consistency between results from higher level routines. C Those routines not explicitly called are exercised at some lower C level. The routines exercised are DBFQAD, DBINT4, DBINTK, DBNFAC, C DBNSLV, DBSGQ8, DBSPDR, DBSPEV, DBSPPP, DBSPVD, DBSPVN, DBSQAD, C DBVALU, DINTRV, DPFQAD, DPPGQ8, DPPQAD and DPPVAL. C C***ROUTINES CALLED D1MACH, DBFQAD, DBINT4, DBINTK, DBSPDR, DBSPEV, C DBSPPP, DBSPVD, DBSPVN, DBSQAD, DBVALU, DFB, C DINTRV, DPFQAD, DPPQAD, DPPVAL C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 891004 Removed unreachable code. (WRB) C 891009 Removed unreferenced variables. (WRB) C 891009 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DBSPCK INTEGER I, IBCL, IBCR, ICNT, ID, IERR, IKNT, ILEFT, ILO, * INBV, INEV, INPPV, ITEST(7), IWORK, J, JHIGH, K, KK, KNT, KNTOPT, * LDC, LDCC, LUN, LXI, MFLAG, N, NDATA, NMK, NN DOUBLE PRECISION ADIF, ATOL, BC, BQUAD, BV, C, DEN, DN, ER, FBCL, * FBCR, PQUAD, PI, Q, QQ, QSAVE, QUAD, SPV, SV, T, TOL, W, X, * XI, XL, XX, X1, X2, Y, QTOL, CC DOUBLE PRECISION DBVALU, DPPVAL, D1MACH, DFB DIMENSION X(11), Y(11), QQ(77), BC(13), T(17), Q(3), QSAVE(2), * XI(11), C(4,10), SV(4), ADIF(52), W(65), CC(4,4) EXTERNAL DFB C***FIRST EXECUTABLE STATEMENT DBSPCK IF(KPRINT.GE.2) WRITE (LUN,99999) 99999 FORMAT (1H1, 1X, 45HQUICK CHECK FOR DOUBLE PRECISION SPLINE ROUTI, * 3HNES//) DO 5 I=1,7 5 ITEST(I)=0 ICNT=1 PI = 3.14159265358979324D0 TOL = 1000.0D0*D1MACH(4) QTOL = D1MACH(4) QTOL = 1000.0D0*MAX(QTOL,1.0D-18) C GENERATE DATA NDATA = 11 DEN = NDATA - 1 DO 10 I=1,NDATA X(I) = (I-1)/DEN Y(I) = SIN(PI*X(I)) 10 CONTINUE X(3) = 2.0D0/DEN + 0.1D0/DEN Y(3) = SIN(PI*X(3)) C COMPUTE SPLINES FOR TWO KNOT ARRAYS DO 80 IKNT=1,2 KNT = 3 - IKNT IBCL = 1 IBCR = 2 FBCL = PI FBCR = 0.0D0 CALL DBINT4(X, Y, NDATA, IBCL, IBCR, FBCL, FBCR, KNT, T, BC, N, * K, W) C ERROR TEST ON DBINT4 INBV = 1 DO 20 I=1,NDATA XX = X(I) BV = DBVALU(T,BC,N,K,0,XX,INBV,W) ER = ABS(Y(I)-BV) IF (ER.LE.TOL) GO TO 20 IF(KPRINT.GE.2) WRITE (LUN,99991) 99991 FORMAT (' ERROR TEST FOR INTERPOLATION BY DBINT4 NOT SATISFIED') GO TO 30 20 CONTINUE ITEST(ICNT)=1 ICNT=2 30 CONTINUE INBV = 1 BV = DBVALU(T,BC,N,K,1,X(1),INBV,W) ER = ABS(PI-BV) IF (ER.LE.TOL) GO TO 35 IF(KPRINT.GE.2) WRITE (LUN,99989) 99989 FORMAT (' ERROR TEST FOR INTERPOLATION BY DBINT4 NOT SATISFIED ', * 'BY FIRST DERIVATIVE') GO TO 40 35 ITEST(ICNT)=1 ICNT=3 40 CONTINUE BV = DBVALU(T,BC,N,K,2,X(NDATA),INBV,W) ER = ABS(BV) IF (ER.LE.TOL) GO TO 45 IF(KPRINT.GE.2) WRITE (LUN,99988) 99988 FORMAT (' ERROR TEST FOR INTERPOLATION BY DBINT4 NOT SATISFIED' , * 'BY SECOND DERIVATIVE') GO TO 50 45 ITEST(ICNT)=1 ICNT=4 50 CONTINUE C TEST FOR EQUALITY OF AREA FROM 4 ROUTINES X1 = X(1) X2 = X(NDATA) CALL DBSQAD(T, BC, N, K, X1, X2, BQUAD, W) LDC = 4 CALL DBSPPP(T, BC, N, K, LDC, C, XI, LXI, W) CALL DPPQAD(LDC, C, XI, LXI, K, X1, X2, Q(1)) CALL DBFQAD(DFB, T, BC, N, K, 0, X1, X2, QTOL, Q(2), IERR, W) CALL DPFQAD(DFB, LDC, C, XI, LXI, K, 0, X1, X2, QTOL, Q(3), * IERR) C ERROR TEST FOR QUADRATURES DO 60 I=1,3 ER = ABS(BQUAD-Q(I)) IF (ER.LE.QTOL) GO TO 60 IF(KPRINT.GE.2) WRITE (LUN,99996) 99996 FORMAT (1X, 26HERROR IN QUADRATURE CHECKS) GO TO 70 60 CONTINUE ITEST(ICNT)=1 ICNT=5 70 CONTINUE QSAVE(KNT) = BQUAD 80 CONTINUE ER = ABS(QSAVE(1)-QSAVE(2)) IF (ER.GT.TOL) GO TO 330 ITEST(ICNT)=1 ICNT=6 90 CONTINUE C CHECK DBSPDR AND DBSPEV AGAINST DBVALU, DPPVAL AND DBSPVD CALL DBSPDR(T, BC, N, K, K, ADIF) INEV = 1 INBV = 1 INPPV = 1 ILO = 1 DO 140 I=1,6 XX = X(I+I-1) CALL DBSPEV(T, ADIF, N, K, K, XX, INEV, SV, W) ATOL = TOL DO 100 J=1,K SPV = DBVALU(T,BC,N,K,J-1,XX,INBV,W) ER = ABS(SPV-SV(J)) X2 = ABS(SV(J)) IF (X2.GT.1.0D0) ER = ER/X2 IF (ER.GT.ATOL) GO TO 340 ATOL = ATOL*10.0D0 100 CONTINUE ATOL = TOL DO 110 J=1,K SPV = DPPVAL(LDC,C,XI,LXI,K,J-1,XX,INPPV) ER = ABS(SPV-SV(J)) X2 = ABS(SV(J)) IF (X2.GT.1.0D0) ER = ER/X2 IF (ER.GT.ATOL) GO TO 350 ATOL = ATOL*10.D0 110 CONTINUE ATOL = TOL LDCC = 4 X1 = XX IF (I+I-1.EQ.NDATA) X1 = T(N) NN = N + K CALL DINTRV(T, NN, X1, ILO, ILEFT, MFLAG) DO 130 J=1,K CALL DBSPVD(T, K, J, XX, ILEFT, LDCC, CC, W) ER = 0.0D0 DO 120 JJ=1,K ER = ER + BC(ILEFT-K+JJ)*CC(JJ,J) 120 CONTINUE ER = ABS(ER-SV(J)) X2 = ABS(SV(J)) IF (X2.GT.1.0D0) ER = ER/X2 IF (ER.GT.ATOL) GO TO 360 ATOL = ATOL*10.0D0 130 CONTINUE 140 CONTINUE ITEST(ICNT)=1 ICNT=7 150 CONTINUE DO 190 K=2,4 N = NDATA NMK = N - K DO 160 I=1,K T(I) = X(1) T(N+I) = X(N) 160 CONTINUE XL = X(N) - X(1) DN = N - K + 1 DO 170 I=1,NMK T(K+I) = X(1) + I*XL/DN 170 CONTINUE CALL DBINTK(X, Y, T, N, K, BC, QQ, W) C ERROR TEST ON DBINTK INBV = 1 DO 180 I=1,N XX = X(I) BV = DBVALU(T,BC,N,K,0,XX,INBV,W) ER = ABS(Y(I)-BV) IF (ER.GT.TOL) GO TO 380 180 CONTINUE 190 CONTINUE ITEST(ICNT)=1 200 CONTINUE IPASS=1 DO 2000 I=1,7 2000 IPASS=IPASS*ITEST(I) IF(KPRINT.LE.1) GO TO 3100 C C TRIGGER ERROR CONDITIONS C IF(KPRINT.GE.3) WRITE (LUN,99997) 99997 FORMAT (/, 1X, 27HTRIGGER 52 ERROR CONDITIONS/) C C W(1) = 11.0D0 W(2) = 4.0D0 W(3) = 2.0D0 W(4) = 0.5D0 W(5) = 4.0D0 ILO = 1 INEV = 1 INBV = 1 CALL DINTRV(T, N+1, W(4), ILO, ILEFT, MFLAG) DO 280 I=1,5 W(I) = -W(I) N = INT(W(1)) K = INT(W(2)) ID = INT(W(3)) XX = W(4) LDC = INT(W(5)) IF (I.EQ.5) GO TO 210 BV = DBVALU(T,BC,N,K,ID,XX,INBV,QQ) CALL DBSPEV(T, ADIF, N, K, ID, XX, INEV, SV, QQ) JHIGH = N - 10 CALL DBSPVN(T, JHIGH, K, ID, XX, ILEFT, SV, QQ, IWORK) CALL DBFQAD(DFB, T, BC, N, K, ID, XX, X2, TOL, QUAD, IERR, QQ) 210 CONTINUE IF (I.EQ.3 .OR. I.EQ.4) GO TO 220 CALL DBSPPP(T, BC, N, K, LDC, C, XI, LXI, QQ) 220 CONTINUE IF (I.EQ.4 .OR. I.EQ.5) GO TO 230 CALL DBSPDR(T, BC, N, K, ID, ADIF) 230 CONTINUE IF (I.EQ.3 .OR. I.EQ.5) GO TO 240 CALL DBSQAD(T, BC, N, K, XX, X2, BQUAD, QQ) 240 CONTINUE IF (I.EQ.1) GO TO 250 CALL DBSPVD(T, K, ID, XX, ILEFT, LDC, C, QQ) 250 CONTINUE IF (I.GT.2) GO TO 260 CALL DBINTK(X, Y, T, N, K, BC, QQ, ADIF) 260 CONTINUE IF (I.EQ.4) GO TO 270 KNTOPT = LDC - 2 IBCL = K - 2 CALL DBINT4(X, Y, N, IBCL, ID, FBCL, FBCR, KNTOPT, T, BC, NN, * KK, QQ) 270 CONTINUE W(I) = -W(I) 280 CONTINUE KNTOPT = 1 X(1) = 1.0D0 CALL DBINT4(X, Y, N, IBCL, IBCR, FBCL, FBCR, KNTOPT, T, BC, N, K, * QQ) CALL DBINTK(X, Y, T, N, K, BC, QQ, ADIF) X(1) = 0.0D0 ATOL = 1.0D0 KNTOPT = 3 DO 290 I=1,3 QQ(I) = -.30D0 + 0.10D0*(I-1) QQ(3+I) = 1.1D0 + 0.10D0*(I-1) 290 CONTINUE QQ(1) = 1.0D0 CALL DBINT4(X, Y, NDATA, 1, 1, FBCL, FBCR, 3, T, BC, N, K, QQ) CALL DBFQAD(DFB, T, BC, N, K, ID, X1, X2, ATOL, QUAD, IERR, QQ) INPPV = 1 DO 310 I=1,5 W(I) = -W(I) LXI = INT(W(1)) K = INT(W(2)) ID = INT(W(3)) XX = W(4) LDC = INT(W(5)) SPV = DPPVAL(LDC,C,XI,LXI,K,ID,XX,INPPV) CALL DPFQAD(DFB, LDC, C, XI, LXI, K, ID, XX, X2, TOL, QUAD, * IERR) IF (I.EQ.3) GO TO 300 CALL DPPQAD(LDC, C, XI, LXI, K, XX, X2, PQUAD) 300 CONTINUE W(I) = -W(I) 310 CONTINUE LDC = INT(W(5)) CALL DPFQAD(DFB, LDC, C, XI, LXI, K, ID, X1, X2, ATOL, QUAD, IERR) 3100 CONTINUE IF(IPASS.EQ.1.AND.KPRINT.GT.1) WRITE(LUN,99980) IF(IPASS.EQ.0.AND.KPRINT.NE.0) WRITE(LUN,99981) 99980 FORMAT(/54H *****DBLE PREC B-SPLINE PACKAGE PASSED ALL TESTS*****) 99981 FORMAT(/54H *****DBLE PREC B-SPLINE PACKAGE FAILED SOME TEST*****) RETURN C C 330 CONTINUE IF(KPRINT.GE.2) WRITE (LUN,99995) 99995 FORMAT (1X, 49HERROR IN QUADRATURE CHECK USING TWO SETS OF KNOTS) GO TO 90 340 CONTINUE IF(KPRINT.GE.2) WRITE (LUN,99994) 99994 FORMAT (1X, 47HCOMPARISONS FROM DBSPEV AND DBVALU DO NOT AGREE) GO TO 150 350 CONTINUE IF(KPRINT.GE.2) WRITE (LUN,99993) 99993 FORMAT (1X, 47HCOMPARISONS FROM DBSPEV AND DPPVAL DO NOT AGREE) GO TO 150 360 CONTINUE IF(KPRINT.GE.2) WRITE (LUN,99992) 99992 FORMAT (1X, 47HCOMPARISONS FROM DBSPEV AND DBSPVD DO NOT AGREE) GO TO 150 380 CONTINUE IF(KPRINT.GE.2) WRITE (LUN,99990) 99990 FORMAT (' ERROR TEST FOR INTERPOLATION BY DBINTK NOT SATISFIED') GO TO 200 END *DECK DCMPAR SUBROUTINE DCMPAR (ICNT, ITEST) C***BEGIN PROLOGUE DCMPAR C***PURPOSE Compare values in COMMON block DCHECK for quick check C routine DPFITT. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (CMPARE-S, DCMPAR-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***COMMON BLOCKS DCHECK C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890921 Realigned order of variables in the COMMON block. C (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 920214 Minor improvements to code for readability. (WRB) C***END PROLOGUE DCMPAR C .. Scalar Arguments .. INTEGER ICNT C .. Array Arguments .. INTEGER ITEST(9) C .. Scalars in Common .. DOUBLE PRECISION EPS, RP, SVEPS, TOL INTEGER IERP, IERR, NORD, NORDP C .. Arrays in Common .. DOUBLE PRECISION R(11) C .. Local Scalars .. DOUBLE PRECISION RPP, SS INTEGER IERPP, NRDP C .. Local Arrays .. INTEGER ITEMP(4) C .. Intrinsic Functions .. INTRINSIC ABS C .. Common blocks .. COMMON /DCHECK/ EPS, R, RP, SVEPS, TOL, NORDP, NORD, IERP, IERR C***FIRST EXECUTABLE STATEMENT DCMPAR ICNT = ICNT + 1 ITEMP(1) = 0 ITEMP(2) = 0 ITEMP(3) = 0 ITEMP(4) = 0 SS = SVEPS - EPS NRDP = NORDP - NORD RPP = RP - R(11) IERPP = IERP - IERR IF (ABS(SS).LE.TOL .OR. ICNT.LE.2 .OR. ICNT.GE.6) ITEMP(1) = 1 IF (ABS(NRDP) .EQ. 0) ITEMP(2) = 1 IF (ICNT .EQ. 2) ITEMP(2) = 1 IF (ABS(RPP) .LE. TOL) ITEMP(3) = 1 IF (ABS(IERPP) .EQ. 0) ITEMP(4) = 1 C C Check to see if all four tests were good. C If so, set the test number equal to 1. C ITEST(ICNT) = ITEMP(1)*ITEMP(2)*ITEMP(3)*ITEMP(4) RETURN END *DECK DEG8CK SUBROUTINE DEG8CK (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DEG8CK C***PURPOSE Quick check for DEXINT and DGAUS8. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (EG8CK-S, DEG8CK-D) C***KEYWORDS QUICK CHECK C***AUTHOR Amos, D. E., (SNLA) C***DESCRIPTION C C DEG8CK is a quick check routine for DEXINT and DGAUS8. Exponential C integrals from DEXINT are checked against quadratures from DGAUS8. C C***ROUTINES CALLED D1MACH, DEXINT, DFEIN, DGAUS8 C***COMMON BLOCKS DFEINX C***REVISION HISTORY (YYMMDD) C 800501 DATE WRITTEN C 890718 Added check when testing error conditions. (WRB) C 890718 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 910708 Code revised to test error returns for all values of C KPRINT. (WRB) C 920206 Corrected argument list in CALL to DEXINT. (WRB) C***END PROLOGUE DEG8CK COMMON /DFEINX/ X, A, FKM INTEGER I, ICASE, IE, IERR, II, IK, IPASS, IX, IY, K, KE, KK, * KODE, KX, LUN, M, N, NM, NZ DOUBLE PRECISION A, ANS, ATOL, BB, EN, ER, EX, FKM, SIG, SUM, * TOL, T1, T2, X, XX, Y DOUBLE PRECISION D1MACH, DFEIN DIMENSION EN(4), Y(4), XX(5) LOGICAL FATAL EXTERNAL DFEIN C***FIRST EXECUTABLE STATEMENT DEG8CK IF (KPRINT .GE. 2) WRITE (LUN, 90000) IPASS=1 TOL = SQRT(MAX(D1MACH(4),1.0D-18)) DO 150 KODE=1,2 IK = KODE - 1 FKM = IK DO 140 N=1,25,8 DO 130 M=1,4 NM = N + M - 1 DO 120 IX=1,25,8 X = IX- 0.20D0 CALL DEXINT(X, N, KODE, M, TOL, EN, NZ, IERR) KX = X+0.5D0 IF (KX.EQ.0) KX = 1 ICASE = 1 A = N IF (KX.LE.N) GO TO 10 ICASE = 2 A = NM IF (KX.GE.NM) GO TO 10 ICASE = 3 A = KX 10 CONTINUE SIG = 3.0D0/X T2 = 1.0D0 SUM = 0.0D0 20 CONTINUE T1 = T2 T2 = T2 + SIG ATOL = TOL CALL DGAUS8(DFEIN, T1, T2, ATOL, ANS, IERR) SUM = SUM + ANS IF (ABS(ANS).LT.ABS(SUM)*TOL) GO TO 30 GO TO 20 30 CONTINUE EX = 1.0D0 IF (KODE.EQ.1) EX = EXP(-X) BB = A IF (ICASE.NE.3) GO TO 40 IY = KX - N + 1 Y(IY) = SUM KE = M - IY IE = IY - 1 KK = IY II = IY GO TO 60 40 CONTINUE IF (ICASE.NE.2) GO TO 50 Y(M) = SUM IF (M.EQ.1) GO TO 100 IE = M - 1 II = M GO TO 80 50 CONTINUE Y(1) = SUM IF (M.EQ.1) GO TO 100 KE = M - 1 KK = 1 60 CONTINUE C C Forward recur C DO 70 K=1,KE Y(KK+1) = (EX-X*Y(KK))/BB BB = BB + 1.0D0 KK = KK + 1 70 CONTINUE IF (ICASE.NE.3) GO TO 100 80 BB = A - 1.0D0 C C Backward recur C DO 90 I=1,IE Y(II-1) = (EX-BB*Y(II))/X BB = BB - 1.0D0 II = II - 1 90 CONTINUE 100 CONTINUE DO 110 I=1,M ER = ABS((Y(I)-EN(I))/Y(I)) IF (ER .GT. TOL) THEN WRITE (LUN,90010) IPASS = 0 GO TO 160 ENDIF 110 CONTINUE 120 CONTINUE 130 CONTINUE 140 CONTINUE 150 CONTINUE C C Trigger 6 error conditions. C 160 FATAL = .FALSE. C IF (KPRINT .GE. 3) WRITE (LUN, 90020) XX(1) = 1.0D0 XX(2) = 1.0D0 XX(3) = 1.0D0 XX(4) = 1.0D0 XX(5) = 0.01D0 DO 170 I=1,5 XX(I) = -XX(I) K = XX(2) N = XX(3) M = XX(4) CALL DEXINT (XX(I), N, K, M, XX(5), EN, NZ, IERR) IF (IERR .NE. 1) THEN IPASS = 0 FATAL = .TRUE. WRITE (LUN, 90030) I ENDIF XX(I) = -XX(I) 170 CONTINUE X = 0.0D0 TOL = 1.0D-2 CALL DEXINT (X, 1, 1, 1, TOL, EN, NZ, IERR) IF (IERR .NE. 1) THEN IPASS = 0 FATAL = .TRUE. WRITE (LUN, 90040) ENDIF IF (FATAL) THEN IF (KPRINT .GE. 2) THEN WRITE (LUN, 90070) ENDIF ELSE IF (KPRINT .GE. 3) THEN WRITE (LUN, 90080) ENDIF ENDIF C IF(IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN, 90100) IF(IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN, 90110) RETURN C 90000 FORMAT ('1' / ' QUICK CHECK FOR DEXINT AND DGAUS8' /) 90010 FORMAT (// ' ERROR IN DEG8CK COMPARISON TEST' /) 90020 FORMAT (/ ' TRIGGER 6 ERROR CONDITIONS' /) 90030 FORMAT (' Error occurred with DO index I =', I2) 90040 FORMAT (' Error occurred with X = 0.0') 90070 FORMAT (/' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED') 90080 FORMAT (/' ALL INCORRECT ARGUMENT TESTS PASSED') 90100 FORMAT (/ ' *********DEXINT AND DGAUS8 PASSED ALL TESTS*********') 90110 FORMAT (/ ' *********DEXINT OR DGAUS8 FAILED SOME TESTS*********') END *DECK DEVCHK SUBROUTINE DEVCHK (LOUT, KPRINT, NPTS, XEV, FEV, DEV, FEV2, FAIL) C***BEGIN PROLOGUE DEVCHK C***SUBSIDIARY C***PURPOSE Test evaluation accuracy of DCHFDV and DCHFEV for DPCHQ1. C***LIBRARY SLATEC (PCHIP) C***TYPE DOUBLE PRECISION (EVCHCK-S, DEVCHK-D) C***KEYWORDS PCHIP EVALUATOR QUICK CHECK C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C -------- CODE TO TEST EVALUATION ACCURACY OF DCHFDV AND DCHFEV ------- C C USING FUNCTION AND DERIVATIVE VALUES FROM A CUBIC (COMPUTED IN C DOUBLE PRECISION) AT NINT DIFFERENT (X1,X2) PAIRS: C 1. CHECKS THAT DCHFDV AND DCHFEV BOTH REPRODUCE ENDPOINT VALUES. C 2. EVALUATES AT NPTS POINTS, 10 OF WHICH ARE OUTSIDE THE INTERVAL C AND: C A. CHECKS ACCURACY OF DCHFDV FUNCTION AND DERIVATIVE VALUES C AGAINST EXACT VALUES. C B. CHECKS THAT RETURNED VALUES OF NEXT SUM TO 10. C C. CHECKS THAT FUNCTION VALUES FROM DCHFEV AGREE WITH THOSE C FROM DCHFDV. C C C FORTRAN INTRINSICS USED: ABS, MAX, MIN. C FORTRAN LIBRARY ROUTINES USED: SQRT, (READ), (WRITE). C SLATEC LIBRARY ROUTINES USED: DCHFDV, DCHFEV, D1MACH, RAND. C OTHER ROUTINES USED: DFDTRU. C C***ROUTINES CALLED D1MACH, DCHFDV, DCHFEV, DFDTRU, RAND C***REVISION HISTORY (YYMMDD) C 820601 DATE WRITTEN C 820624 CONVERTED TO QUICK CHECK FOR SLATEC LIBRARY. C 820630 1. MODIFIED DEFINITIONS OF RELATIVE ERROR AND TEST C TOLERANCES. C 2. VARIOUS IMPROVEMENTS TO OUTPUT FORMATS. C 820716 1. SET MACHEP VIA A CALL TO D1MACH. C 2. CHANGED FROM FORTLIB'S RANF TO SLATEC'S RAND. C 890628 1. Removed unnecessary IMPLICIT declaration. C 2. Removed unnecessary variable NEV. C 3. Other changes to reduce S.P./D.P. differences. C 890629 Added RERR to DOUBLE PRECISION declaration. C 890706 Cosmetic changes to prologue. (WRB) C 890831 Modified array declarations. (WRB) C 890911 Removed unnecessary intrinsics. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 Revised prologue and improved some output formats. (FNF) C Also moved formats to end to be consistent with other PCHIP C quick checks. C 900316 Additional minor cosmetic changes. (FNF) C 900321 Changed name of DFTRUE to DFDTRU and made additional minor C cosmetic changes. (FNF) C 901130 Added 1P's to formats and revised some to reduce maximum C line length. (FNF) C 910708 Minor modifications in use of KPRINT. (WRB) C 910801 Added EXTERNAL statement for RAND due to problem on IBM C RS 6000. (WRB) C 910819 Changed argument to RAND function from a D.P. zero to a C S.P. zero. (WRB) C***END PROLOGUE DEVCHK C C Declare arguments. C INTEGER LOUT, KPRINT, NPTS DOUBLE PRECISION XEV(*), FEV(*), DEV(*), FEV2(*) LOGICAL FAIL C C DECLARATIONS. C INTEGER I, IERR, IINT, NEXT(2), NEXT2(2), NINT DOUBLE PRECISION * AED, AED2, AEDMAX, AEDMIN, AEF, AEF2, AEFMAX, AEFMIN, * CHECK(2), CHECKF(2), CHECKD(2), D1, D2, DERMAX, DTRUE, DX, * EPS1, EPS2, F1, F2, FACT, FERMAX, FLOORD, FLOORF, FOUR, * FTRUE, LEFT(3), MACHEP, * ONE, RED, RED2, REDMAX, REDMIN, REF, REF2, REFMAX, * REFMIN, RIGHT(3), SMALL, TEN, TOL1, TOL2, * X1, X2, XADMAX, XADMIN, XAFMAX, XAFMIN, XRDMAX, * XRDMIN, XRFMAX, XRFMIN, ZERO LOGICAL FAILOC, FAILNX C DOUBLE PRECISION D1MACH C The following should stay REAL (no D.P. equivalent). REAL RAND EXTERNAL RAND C C DEFINE RELATIVE ERROR WITH FLOOR. C DOUBLE PRECISION RERR, ERR, VALUE, FLOOR RERR(ERR,VALUE,FLOOR) = ERR / MAX(ABS(VALUE), FLOOR) C C INITIALIZE. C DATA ZERO /0.D0/, ONE /1.D0/, FOUR /4.D0/, TEN /10.D0/ DATA SMALL /1.0D-10/ DATA NINT /3/ DATA LEFT /-1.5D0, 2.0D-10, 1.0D0 / DATA RIGHT / 2.5D0, 3.0D-10, 1.0D+8/ C C***FIRST EXECUTABLE STATEMENT DEVCHK MACHEP = D1MACH(4) EPS1 = FOUR*MACHEP EPS2 = TEN*MACHEP C FAIL = .FALSE. C IF (KPRINT .GE. 2) WRITE (LOUT, 3000) C C CYCLE OVER INTERVALS. C DO 90 IINT = 1, NINT X1 = LEFT(IINT) X2 = RIGHT(IINT) C FACT = MAX(SQRT(X2-X1), ONE) TOL1 = EPS1 * FACT TOL2 = EPS2 * FACT C C COMPUTE AND PRINT ENDPOINT VALUES. C CALL DFDTRU (X1, F1, D1) CALL DFDTRU (X2, F2, D2) C IF (KPRINT .GE. 3) THEN IF (IINT .EQ. 1) WRITE (LOUT, 2000) WRITE (LOUT, '(/)') WRITE (LOUT, 2001) 'X1', X1, 'X2', X2 WRITE (LOUT, 2001) 'F1', F1, 'F2', F2 WRITE (LOUT, 2001) 'D1', D1, 'D2', D2 ENDIF C IF (KPRINT .GE. 2) WRITE (LOUT, 3001) X1, X2 C C COMPUTE FLOORS FOR RELATIVE ERRORS. C FLOORF = MAX( MIN(ABS(F1),ABS(F2)), SMALL) FLOORD = MAX( MIN(ABS(D1),ABS(D2)), SMALL) C C CHECK REPRODUCTION OF ENDPOINT VALUES. C XEV(1) = X1 XEV(2) = X2 C ----------------------------------------------------------- CALL DCHFDV (X1, X2, F1, F2, D1, D2, 2, XEV, CHECKF, CHECKD, * NEXT, IERR) C ----------------------------------------------------------- AEF = CHECKF(1)-F1 REF = RERR(AEF , F1, FLOORF) AEF2 = CHECKF(2)-F2 REF2 = RERR(AEF2, F2, FLOORF) AED = CHECKD(1)-D1 RED = RERR(AED , D1, FLOORD) AED2 = CHECKD(2)-D2 RED2 = RERR(AED2, D2, FLOORD) C FAILOC = MAX(ABS(REF),ABS(REF2),ABS(RED),ABS(RED2)) .GT. TOL1 FAIL = FAIL .OR. FAILOC C IF (KPRINT .GE. 3) THEN WRITE (LOUT, 2002) NEXT, AEF, AEF2, AED, AED2 WRITE (LOUT, 2003) REF, REF2, RED, RED2 ENDIF C IF (FAILOC .AND. (KPRINT.GE.2)) WRITE (LOUT, 3002) C C DCHFEV SHOULD AGREE EXACTLY WITH DCHFDV. C ------- C -------------------------------------------------------------- CALL DCHFEV (X1, X2, F1, F2, D1, D2, 2, XEV, CHECK, NEXT, IERR) C -------------------------------------------------------------- FAILOC = (CHECK(1).NE.CHECKF(1)) .OR. (CHECK(2).NE.CHECKF(2)) FAIL = FAIL .OR. FAILOC C IF (FAILOC .AND. (KPRINT.GE.2)) WRITE (LOUT, 3003) C C EVALUATE AT NPTS 'UNIFORMLY RANDOM' POINTS IN (X1,X2). C THIS VERSION EXTENDS EVALUATION DOMAIN BY ADDING 4 SUBINTERVALS C TO LEFT AND 6 TO RIGHT OF [X1,X2]. C DX = (X2-X1)/(NPTS-10) DO 20 I = 1, NPTS XEV(I) = (X1 + (I-5)*DX) + DX*RAND(0.0E0) 20 CONTINUE C -------------------------------------------------------- CALL DCHFDV (X1, X2, F1, F2, D1, D2, NPTS, XEV, FEV, DEV, * NEXT, IERR) C -------------------------------------------------------- IF (IERR .NE. 0) THEN FAILOC = .TRUE. IF (KPRINT .GE. 2) WRITE (LOUT, 4003) IERR ELSE C C CUMULATE LARGEST AND SMALLEST ERRORS FOR SUMMARY. C DO 30 I = 1, NPTS CALL DFDTRU (XEV(I), FTRUE, DTRUE) AEF = FEV(I) - FTRUE REF = RERR(AEF, FTRUE, FLOORF) AED = DEV(I) - DTRUE RED = RERR(AED, DTRUE, FLOORD) C IF (I .EQ. 1) THEN C INITIALIZE. AEFMIN = AEF AEFMAX = AEF AEDMIN = AED AEDMAX = AED REFMIN = REF REFMAX = REF REDMIN = RED REDMAX = RED XAFMIN = XEV(1) XAFMAX = XEV(1) XADMIN = XEV(1) XADMAX = XEV(1) XRFMIN = XEV(1) XRFMAX = XEV(1) XRDMIN = XEV(1) XRDMAX = XEV(1) ELSE C SELECT. IF (AEF .LT. AEFMIN) THEN AEFMIN = AEF XAFMIN = XEV(I) ELSE IF (AEF .GT. AEFMAX) THEN AEFMAX = AEF XAFMAX = XEV(I) ENDIF IF (AED .LT. AEDMIN) THEN AEDMIN = AED XADMIN = XEV(I) ELSE IF (AED .GT. AEDMAX) THEN AEDMAX = AED XADMAX = XEV(I) ENDIF IF (REF .LT. REFMIN) THEN REFMIN = REF XRFMIN = XEV(I) ELSE IF (REF .GT. REFMAX) THEN REFMAX = REF XRFMAX = XEV(I) ENDIF IF (RED .LT. REDMIN) THEN REDMIN = RED XRDMIN = XEV(I) ELSE IF (RED .GT. REDMAX) THEN REDMAX = RED XRDMAX = XEV(I) ENDIF ENDIF 30 CONTINUE C FERMAX = MAX (ABS(REFMAX), ABS(REFMIN)) DERMAX = MAX (ABS(REDMAX), ABS(REDMIN)) C FAILNX = (NEXT(1) + NEXT(2)) .NE. 10 FAILOC = FAILNX .OR. (MAX(FERMAX, DERMAX) .GT. TOL2) ENDIF FAIL = FAIL .OR. FAILOC C C PRINT SUMMARY. C IF (KPRINT .GE. 3) THEN WRITE (LOUT, 2004) NPTS-10, NEXT C WRITE (LOUT, 2005) 'MIN', AEFMIN, REFMIN, AEDMIN, REDMIN WRITE (LOUT, 2006) XAFMIN, XRFMIN, XADMIN, XRDMIN WRITE (LOUT, 2005) 'MAX', AEFMAX, REFMAX, AEDMAX, REDMAX WRITE (LOUT, 2006) XAFMAX, XRFMAX, XADMAX, XRDMAX ENDIF C IF (KPRINT .GE. 2) THEN IF (FAILOC) THEN IF (FERMAX .GT. TOL2) WRITE (LOUT, 3006) 'F', FERMAX, TOL2 IF (DERMAX .GT. TOL2) WRITE (LOUT, 3006) 'D', DERMAX, TOL2 IF (FAILNX) WRITE (LOUT, 4006) NEXT ELSE WRITE (LOUT, 5006) ENDIF ENDIF C C CHECK THAT DCHFEV AGREES WITH DCHFDV. C C ----------------------------------------------------------------- CALL DCHFEV (X1, X2, F1, F2, D1, D2, NPTS, XEV, FEV2, NEXT2, IERR) C ----------------------------------------------------------------- IF (IERR .NE. 0) THEN FAILOC = .TRUE. IF (KPRINT .GE. 2) WRITE (LOUT, 3007) IERR ELSE AEFMAX = ABS(FEV2(1) - FEV(1)) XAFMAX = XEV(1) DO 40 I = 2, NPTS AEF = ABS(FEV2(I) - FEV(I)) IF (AEF .GT. AEFMAX) THEN AEFMAX = AEF XAFMAX = XEV(I) ENDIF 40 CONTINUE FAILNX = (NEXT2(1).NE.NEXT(1)) .OR. (NEXT2(2).NE.NEXT(2)) FAILOC = FAILNX .OR. (AEFMAX.NE.ZERO) IF (KPRINT .GE. 2) THEN IF (FAILOC) THEN WRITE (LOUT, 3008) IF (AEFMAX.NE.ZERO) WRITE (LOUT, 3009) AEFMAX, XAFMAX IF (FAILNX) WRITE (LOUT, 4009) NEXT2, NEXT ELSE WRITE (LOUT, 5009) ENDIF ENDIF ENDIF C FAIL = FAIL .OR. FAILOC C C GO BACK FOR ANOTHER INTERVAL. C 90 CONTINUE C RETURN C C FORMATS. C 2000 FORMAT (/10X,'DCHFDV ACCURACY TEST') 2001 FORMAT (10X,A2,' =',1P,D18.10,5X,A2,' =',D18.10) 2002 FORMAT (/' ERRORS AT ENDPOINTS:',40X,'(NEXT =',2I3,')' * // 1P,4X,'F1:',D13.5,4X,'F2:',D13.5, * 4X,'D1:',D13.5,4X,'D2:',D13.5) 2003 FORMAT (1P,4(7X,D13.5)) 2004 FORMAT (/' ERRORS AT ',I5,' INTERIOR POINTS + 10 OUTSIDE:', * 15X,'(NEXT =',2I3,')' * //30X,'FUNCTION',17X,'DERIVATIVE' * /15X,2(11X,'ABS',9X,'REL') ) 2005 FORMAT (/5X,A3,'IMUM ERROR: ',1P,2D12.4,2X,2D12.4) 2006 FORMAT ( 5X,'LOCATED AT X = ',1P,2D12.4,2X,2D12.4) 3000 FORMAT (//10X,'DEVCHK RESULTS'/10X,'--------------') 3001 FORMAT (/10X,'INTERVAL = (',1P,D12.5,',',D12.5,' ):' ) 3002 FORMAT (/' ***** DCHFDV FAILED TO REPRODUCE ENDPOINT VALUES.') 3003 FORMAT (/' ***** DCHFEV DOES NOT AGREE WITH DCHFDV AT ENDPOINTS.') 3006 FORMAT (/' ***** MAXIMUM RELATIVE ERROR IN ',A1,' =',1P,D12.5,',' * / 17X,'EXCEEDS TOLERANCE =',D12.5) 3007 FORMAT (/' ***** ERROR ***** DCHFEV RETURNED IERR =',I5) 3008 FORMAT (/' ***** DCHFEV DID NOT AGREE WITH DCHFDV:') 3009 FORMAT (7X,'MAXIMUM DIFFERENCE ',1P,D12.5, * '; OCCURRED AT X =',D12.5) 4003 FORMAT (/' ***** ERROR ***** DCHFDV RETURNED IERR =',I5) 4006 FORMAT (/' ***** REPORTED NEXT =',2I5,' RATHER THAN 4 6') 4009 FORMAT (7X,'REPORTED NEXT =',2I3,' RATHER THAN ',2I3) 5006 FORMAT (/' DCHFDV RESULTS OK.') 5009 FORMAT (/' DCHFEV AGREES WITH DCHFDV.') C------------- LAST LINE OF DEVCHK FOLLOWS ----------------------------- END *DECK DEVERK SUBROUTINE DEVERK (LOUT, KPRINT, FAIL) C***BEGIN PROLOGUE DEVERK C***SUBSIDIARY C***PURPOSE Test error returns from DPCHIP evaluators for DPCHQ1. C***LIBRARY SLATEC (PCHIP) C***TYPE DOUBLE PRECISION (EVERCK-S, DEVERK-D) C***KEYWORDS PCHIP EVALUATOR QUICK CHECK C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C --------- CODE TO TEST ERROR RETURNS FROM DPCHIP EVALUATORS. --------- C C C FORTRAN LIBRARY ROUTINES USED: (WRITE). C SLATEC LIBRARY ROUTINES USED: DCHFDV, DCHFEV, DPCHFD, DPCHFE, C XERDMP, XGETF, XSETF. C OTHER ROUTINES USED: COMP. C C***ROUTINES CALLED COMP, DCHFDV, DCHFEV, DPCHFD, DPCHFE, XERDMP, C XGETF, XSETF C***REVISION HISTORY (YYMMDD) C 820601 DATE WRITTEN C 820715 CONVERTED TO QUICK CHECK FOR SLATEC LIBRARY. C 890207 ADDED CALLS TO ERROR HANDLER. C 890316 Added call to XERDMP if KPRINT.GT.2 (FNF). C 890706 Cosmetic changes to prologue. (WRB) C 890911 Removed unnecessary intrinsics. (WRB) C 891009 Removed unreferenced statement label. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900309 Added COMP to list of routines called. (FNF) C 900315 Revised prologue and improved some output formats. (FNF) C 900316 Deleted INCFD tests because some compilers object to them, C and made additional minor cosmetic changes. (FNF) C 900322 Made miscellaneous cosmetic changes. (FNF) C 910708 Minor modifications in use of KPRINT. (WRB) C***END PROLOGUE DEVERK C C Declare arguments. C INTEGER LOUT, KPRINT LOGICAL FAIL C C DECLARATIONS. C INTEGER I, IERR, KONTRL, N, NERR, NEXT(2) DOUBLE PRECISION D(10), DUM, F(10), TEMP, X(10) LOGICAL COMP, SKIP C C INITIALIZE. C PARAMETER (N = 10) C***FIRST EXECUTABLE STATEMENT DEVERK NERR = 0 C CALL XGETF (KONTRL) IF (KPRINT .LE. 2) THEN CALL XSETF (0) ELSE CALL XSETF (1) ENDIF C IF (KPRINT .GE. 3) WRITE (LOUT, 2000) IF (KPRINT .GE. 2) WRITE (LOUT, 5000) C C FIRST, TEST DCHFEV AND DCHFDV. C IF (KPRINT .GE. 3) WRITE (LOUT, 5001) (-1) CALL DCHFEV (0.D0, 1.D0, 3.D0, 7.D0, 3.D0, 6.D0, 0, DUM, DUM, * NEXT, IERR) IF (.NOT. COMP (IERR, -1, LOUT, KPRINT) ) NERR = NERR + 1 C IF (KPRINT .GE. 3) WRITE (LOUT, 5001) (-2) CALL DCHFEV (1.D0, 1.D0, 3.D0, 7.D0, 3.D0, 6.D0, 1, DUM, DUM, * NEXT, IERR) IF (.NOT. COMP (IERR, -2, LOUT, KPRINT) ) NERR = NERR + 1 C IF (KPRINT .GE. 3) WRITE (LOUT, 5001) (-1) CALL DCHFDV (0.D0, 1.D0, 3.D0, 7.D0, 3.D0, 6.D0, 0, DUM, DUM, * DUM, NEXT, IERR) IF (.NOT. COMP (IERR, -1, LOUT, KPRINT) ) NERR = NERR + 1 C IF (KPRINT .GE. 3) WRITE (LOUT, 5001) (-2) CALL DCHFDV (1.D0, 1.D0, 3.D0, 7.D0, 3.D0, 6.D0, 1, DUM, DUM, * DUM, NEXT, IERR) IF (.NOT. COMP (IERR, -2, LOUT, KPRINT) ) NERR = NERR + 1 C C SET UP PCH DEFINITION. C DO 10 I = 1, N X(I) = I F(I) = I + 2 D(I) = 1.D0 10 CONTINUE C C SWAP POINTS 4 AND 7, SO X-ARRAY IS OUT OF ORDER. C TEMP = X(4) X(4) = X(7) X(7) = TEMP C C NOW, TEST DPCHFE AND DPCHFD. C IF (KPRINT .GE. 3) WRITE (LOUT, 5001) (-1) SKIP = .FALSE. CALL DPCHFE (1, X, F, D, 1, SKIP, 0, DUM, DUM, IERR) IF (.NOT. COMP (IERR, -1, LOUT, KPRINT) ) NERR = NERR + 1 C IF (KPRINT .GE. 3) WRITE (LOUT, 5001) (-3) SKIP = .FALSE. CALL DPCHFE (N, X, F, D, 1, SKIP, 0, DUM, DUM, IERR) IF (.NOT. COMP (IERR, -3, LOUT, KPRINT) ) NERR = NERR + 1 C IF (KPRINT .GE. 3) WRITE (LOUT, 5001) (-4) SKIP = .TRUE. CALL DPCHFE (N, X, F, D, 1, SKIP, 0, DUM, DUM, IERR) IF (.NOT. COMP (IERR, -4, LOUT, KPRINT) ) NERR = NERR + 1 C IF (KPRINT .GE. 3) WRITE (LOUT, 5001) (-1) SKIP = .FALSE. CALL DPCHFD (1, X, F, D, 1, SKIP, 0, DUM, DUM, DUM, IERR) IF (.NOT. COMP (IERR, -1, LOUT, KPRINT) ) NERR = NERR + 1 C IF (KPRINT .GE. 3) WRITE (LOUT, 5001) (-3) SKIP = .FALSE. CALL DPCHFD (N, X, F, D, 1, SKIP, 0, DUM, DUM, DUM, IERR) IF (.NOT. COMP (IERR, -3, LOUT, KPRINT) ) NERR = NERR + 1 C IF (KPRINT .GE. 3) WRITE (LOUT, 5001) (-4) SKIP = .TRUE. CALL DPCHFD (N, X, F, D, 1, SKIP, 0, DUM, DUM, DUM, IERR) IF (.NOT. COMP (IERR, -4, LOUT, KPRINT) ) NERR = NERR + 1 C C SUMMARIZE RESULTS. C IF (KPRINT .GT. 2) CALL XERDMP IF (NERR .EQ. 0) THEN FAIL = .FALSE. IF (KPRINT .GE. 2) WRITE (LOUT, 5002) ELSE FAIL = .TRUE. IF (KPRINT .GE. 2) WRITE (LOUT, 5003) NERR ENDIF C C TERMINATE. C CALL XSETF (KONTRL) RETURN C C FORMATS. C 2000 FORMAT ('1'//10X,'TEST ERROR RETURNS') 5000 FORMAT (//10X,'DEVERK RESULTS'/10X,'--------------') 5001 FORMAT (/' THIS CALL SHOULD RETURN IERR =',I3) 5002 FORMAT (/' ALL ERROR RETURNS OK.') 5003 FORMAT (//' ***** TROUBLE IN DEVERK *****' * //5X,I5,' TESTS FAILED TO GIVE EXPECTED RESULTS.') C------------- LAST LINE OF DEVERK FOLLOWS ----------------------------- END *DECK DEVPCK SUBROUTINE DEVPCK (LOUT, KPRINT, X, Y, F, FX, FY, XE, YE, FE, DE, + FE2, FAIL) C***BEGIN PROLOGUE DEVPCK C***SUBSIDIARY C***PURPOSE Test usage of increment argument in DPCHFD and DPCHFE for C DPCHQ1. C***LIBRARY SLATEC (PCHIP) C***TYPE DOUBLE PRECISION (EVPCCK-S, DEVPCK-D) C***KEYWORDS PCHIP EVALUATOR QUICK CHECK C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C ---- CODE TO TEST USAGE OF INCREMENT ARGUMENT IN DPCHFD AND DPCHFE --- C C EVALUATES A BICUBIC FUNCTION AND ITS FIRST PARTIAL DERIVATIVES C ON A 4X6 MESH CONTAINED IN A 10X10 ARRAY. C C INTERPOLATION OF THESE DATA ALONG MESH LINES IN EITHER DIMENSION C SHOULD AGREE WITH CORRECT FUNCTION WITHIN ROUNDOFF ERROR. C C ARRAYS ARE ARGUMENTS ONLY TO ALLOW SHARING STORAGE WITH OTHER C TEST ROUTINES. C C NOTE: RUN WITH KPRINT=4 FOR FULL GORY DETAILS (10 PAGES WORTH). C C C FORTRAN INTRINSICS USED: ABS. C FORTRAN LIBRARY ROUTINES USED: (WRITE). C SLATEC LIBRARY ROUTINES USED: DPCHFD, DPCHFE, D1MACH. C C***ROUTINES CALLED D1MACH, DPCHFD, DPCHFE C***REVISION HISTORY (YYMMDD) C 820601 DATE WRITTEN C 820714 CONVERTED TO QUICK CHECK FOR SLATEC LIBRARY. C 820715 1. CORRECTED SOME FORMATS. C 2. ADDED CALL TO D1MACH TO SET MACHEP. C 890406 1. Modified to make sure final elements of X and XE C agree, to avoid possible failure due to roundoff C error. C 2. Added printout of TOL in case of failure. C 3. Removed unnecessary IMPLICIT declaration. C 4. Corrected a few S.P. constants to D.P. C 5. Minor cosmetic changes. C 890706 Cosmetic changes to prologue. (WRB) C 890911 Removed unnecessary intrinsics. (WRB) C 891004 Cosmetic changes to prologue. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 Revised prologue and improved some output formats. (FNF) C 900316 Additional minor cosmetic changes. (FNF) C 900321 Made miscellaneous cosmetic changes. (FNF) C 901130 Made many changes to output: (FNF) C 1. Reduced amount of output for KPRINT=3. (Now need to C use KPRINT=4 for full output.) C 2. Added 1P's to formats and revised some to reduce maximum C line length. C 910708 Minor modifications in use of KPRINT. (WRB) C***END PROLOGUE DEVPCK C C Declare arguments. C INTEGER LOUT, KPRINT LOGICAL FAIL DOUBLE PRECISION * X(10), Y(10), F(10,10), FX(10,10), FY(10,10), * XE(51), YE(51), FE(51), DE(51), FE2(51) C C DECLARATIONS. C INTEGER I, IER2, IERR, INC, J, K, NE, NERR, NMAX, NX, NY LOGICAL FAILD, FAILE, FAILOC, SKIP DOUBLE PRECISION * DERMAX, DERR, DTRUE, DX, FDIFF, FDIFMX, FERMAX, FERR, * FTRUE, MACHEP, TOL, PDERMX, PDIFMX, PFERMX, ZERO DOUBLE PRECISION D1MACH C C DEFINE TEST FUNCTION AND DERIVATIVES. C DOUBLE PRECISION AX, AY, FCN, DFDX, DFDY FCN (AX,AY) = AX*(AY*AY)*(AX*AX + 1.D0) DFDX(AX,AY) = (AY*AY)*(3.D0*AX*AX + 1.D0) DFDY(AX,AY) = 2.D0*AX*AY*(AX*AX + 1.D0) C DATA NMAX /10/, NX /4/, NY /6/ DATA NE /51/ DATA ZERO /0.D0/ C C INITIALIZE. C C***FIRST EXECUTABLE STATEMENT DEVPCK MACHEP = D1MACH(4) C Following tolerance is looser than S.P. version to avoid C spurious failures on some systems. TOL = 25.D0*MACHEP C FAIL = .FALSE. C C SET UP 4-BY-6 MESH IN A 10-BY-10 ARRAY: C X = 0.25(0.25)1. ; C Y = -0.75(0.5 )1.75 . C DO 1 I = 1, NX-1 X(I) = 0.25D0*I 1 CONTINUE X(NX) = 1.D0 DO 5 J = 1, NY Y(J) = 0.5D0*J - 1.25D0 DO 4 I = 1, NX F(I,J) = FCN (X(I), Y(J)) FX(I,J) = DFDX(X(I), Y(J)) FY(I,J) = DFDY(X(I), Y(J)) 4 CONTINUE 5 CONTINUE C C SET UP EVALUATION POINTS: C XE = 0.(0.02)1. ; C YE = -2.(0.08)2. . C DX = 1.D0/(NE-1) DO 8 K = 1, NE-1 XE(K) = DX*(K-1) YE(K) = 4.D0*XE(K) - 2.D0 8 CONTINUE XE(NE) = 1.D0 YE(NE) = 2.D0 C IF (KPRINT .GE. 2) WRITE (LOUT, 1000) IF (KPRINT .GE. 3) WRITE (LOUT, 1001) C C EVALUATE ON HORIZONTAL MESH LINES (Y FIXED, X RUNNING) .............. C NERR = 0 INC = 1 SKIP = .FALSE. DO 20 J = 1, NY C -------------------------------------------------------------- CALL DPCHFD (NX, X, F(1,J), FX(1,J), INC, SKIP, NE, XE, FE, DE, * IERR) C -------------------------------------------------------------- IF (KPRINT .GE. 3) * WRITE (LOUT, 2000) INC, 'J', J, 'Y', Y(J), IERR IF (IERR .LT. 0) GO TO 15 IF (KPRINT .GT. 3) WRITE (LOUT, 2001) 'X' C C DPCHFE SHOULD AGREE EXACTLY WITH DPCHFD. C C ----------------------------------------------------------- CALL DPCHFE (NX, X, F(1,J), FX(1,J), INC, SKIP, NE, XE, FE2, * IER2) C ----------------------------------------------------------- C DO 10 K = 1, NE FTRUE = FCN(XE(K), Y(J)) FERR = FE(K) - FTRUE DTRUE = DFDX(XE(K), Y(J)) DERR = DE(K) - DTRUE IF (KPRINT .GT. 3) * WRITE (LOUT, 2002) XE(K), FTRUE, FE(K), FERR, * DTRUE, DE(K), DERR IF (K .EQ. 1) THEN C INITIALIZE. FERMAX = ABS(FERR) PFERMX = XE(1) DERMAX = ABS(DERR) PDERMX = XE(1) FDIFMX = ABS(FE2(1) - FE(1)) PDIFMX = XE(1) ELSE C SELECT. FERR = ABS(FERR) IF (FERR .GT. FERMAX) THEN FERMAX = FERR PFERMX = XE(K) ENDIF DERR = ABS(DERR) IF (DERR .GT. DERMAX) THEN DERMAX = DERR PDERMX = XE(K) ENDIF FDIFF = ABS(FE2(K) - FE(K)) IF (FDIFF .GT. FDIFMX) THEN FDIFMX = FDIFF PDIFMX = XE(K) ENDIF ENDIF 10 CONTINUE C FAILD = (FERMAX.GT.TOL) .OR. (DERMAX.GT.TOL) FAILE = FDIFMX .NE. ZERO FAILOC = FAILD .OR. FAILE .OR. (IERR.NE.13) .OR. (IER2.NE.IERR) C IF (FAILOC .AND. (KPRINT.GE.2)) * WRITE (LOUT, 2003) 'J', J, 'Y', Y(J) C IF ((KPRINT.GE.3) .OR. (FAILD.AND.(KPRINT.EQ.2)) ) * WRITE (LOUT, 2004) FERMAX, PFERMX, DERMAX, PDERMX IF (FAILD .AND. (KPRINT.GE.2)) WRITE (LOUT, 2014) TOL C IF ((KPRINT.GE.3) .OR. (FAILE.AND.(KPRINT.EQ.2)) ) * WRITE (LOUT, 2005) FDIFMX, PDIFMX C IF ((IERR.NE.13) .AND. (KPRINT.GE.2)) * WRITE (LOUT, 2006) 'D', IERR, 13 C IF ((IER2.NE.IERR) .AND. (KPRINT.GE.2)) * WRITE (LOUT, 2006) 'E', IER2, IERR GO TO 19 C 15 CONTINUE FAILOC = .TRUE. IF (KPRINT .GE. 2) WRITE (LOUT, 3000) IERR C 19 CONTINUE IF (FAILOC) NERR = NERR + 1 FAIL = FAIL .OR. FAILOC 20 CONTINUE C IF (KPRINT .GE. 2) THEN IF (NERR .GT. 0) THEN WRITE (LOUT, 3001) NERR, 'J' ELSE WRITE (LOUT, 4000) 'J' ENDIF ENDIF C C EVALUATE ON VERTICAL MESH LINES (X FIXED, Y RUNNING) ................ C NERR = 0 INC = NMAX SKIP = .FALSE. DO 40 I = 1, NX C -------------------------------------------------------------- CALL DPCHFD (NY, Y, F(I,1), FY(I,1), INC, SKIP, NE, YE, FE, DE, * IERR) C -------------------------------------------------------------- IF (KPRINT .GE. 3) * WRITE (LOUT, 2000) INC, 'I', I, 'X', X(I), IERR IF (IERR .LT. 0) GO TO 35 IF (KPRINT .GT. 3) WRITE (LOUT, 2001) 'Y' C C DPCHFE SHOULD AGREE EXACTLY WITH DPCHFD. C C ----------------------------------------------------------- CALL DPCHFE (NY, Y, F(I,1), FY(I,1), INC, SKIP, NE, YE, FE2, * IER2) C ----------------------------------------------------------- C DO 30 K = 1, NE FTRUE = FCN(X(I), YE(K)) FERR = FE(K) - FTRUE DTRUE = DFDY(X(I), YE(K)) DERR = DE(K) - DTRUE IF (KPRINT .GT. 3) * WRITE (LOUT, 2002) YE(K), FTRUE, FE(K), FERR, * DTRUE, DE(K), DERR IF (K .EQ. 1) THEN C INITIALIZE. FERMAX = ABS(FERR) PFERMX = YE(1) DERMAX = ABS(DERR) PDERMX = YE(1) FDIFMX = ABS(FE2(1) - FE(1)) PDIFMX = YE(1) ELSE C SELECT. FERR = ABS(FERR) IF (FERR .GT. FERMAX) THEN FERMAX = FERR PFERMX = YE(K) ENDIF DERR = ABS(DERR) IF (DERR .GT. DERMAX) THEN DERMAX = DERR PDERMX = YE(K) ENDIF FDIFF = ABS(FE2(K) - FE(K)) IF (FDIFF .GT. FDIFMX) THEN FDIFMX = FDIFF PDIFMX = YE(K) ENDIF ENDIF 30 CONTINUE C FAILD = (FERMAX.GT.TOL) .OR. (DERMAX.GT.TOL) FAILE = FDIFMX .NE. ZERO FAILOC = FAILD .OR. FAILE .OR. (IERR.NE.20) .OR. (IER2.NE.IERR) C IF (FAILOC .AND. (KPRINT.GE.2)) * WRITE (LOUT, 2003) 'I', I, 'X', X(I) C IF ((KPRINT.GE.3) .OR. (FAILD.AND.(KPRINT.EQ.2)) ) * WRITE (LOUT, 2004) FERMAX, PFERMX, DERMAX, PDERMX IF (FAILD .AND. (KPRINT.GE.2)) WRITE (LOUT, 2014) TOL C IF ((KPRINT.GE.3) .OR. (FAILE.AND.(KPRINT.EQ.2)) ) * WRITE (LOUT, 2005) FDIFMX, PDIFMX C IF ((IERR.NE.20) .AND. (KPRINT.GE.2)) * WRITE (LOUT, 2006) 'D', IERR, 20 C IF ((IER2.NE.IERR) .AND. (KPRINT.GE.2)) * WRITE (LOUT, 2006) 'E', IER2, IERR GO TO 39 C 35 CONTINUE FAILOC = .TRUE. IF (KPRINT .GE. 2) WRITE (LOUT, 3000) IERR C 39 CONTINUE IF (FAILOC) NERR = NERR + 1 FAIL = FAIL .OR. FAILOC 40 CONTINUE C IF (KPRINT .GE. 2) THEN IF (NERR .GT. 0) THEN WRITE (LOUT, 3001) NERR, 'I' ELSE WRITE (LOUT, 4000) 'I' ENDIF ENDIF C C TERMINATE. C RETURN C C FORMATS. C 1000 FORMAT (//10X,'DEVPCK RESULTS'/10X,'--------------') 1001 FORMAT ('1'//10X,'TEST DPCHFE AND DPCHFD') 2000 FORMAT (//20X,'DPCHFD INCREMENT TEST -- INCFD = ',I2 * /15X,'ON ',A1,'-LINE ',I2,', ',A1,' =',F8.4, * ' -- IERR =',I3) 2001 FORMAT ( /3X,A1,'E',10X,'F',8X,'FE',9X,'DIFF', * 13X,'D',8X,'DE',9X,'DIFF') 2002 FORMAT (F7.2,2(2X,2F10.5,1P,E15.5,0P)) 2003 FORMAT (/' ***** DPCHFD AND/OR DPCHFE FAILED ON ',A1,'-LINE ',I1, * ', ',A1,' =',F8.4) 2004 FORMAT (/19X,' MAXIMUM ERROR IN FUNCTION =',1P, * 1P,D13.5,0P,' (AT',F6.2,'),' * /33X, 'IN DERIVATIVE =',1P,D13.5,0P,' (AT',F6.2,').' ) 2005 FORMAT ( ' MAXIMUM DIFFERENCE BETWEEN DPCHFE AND DPCHFD =', * 1P,D13.5,0P,' (AT',F6.2,').' ) 2006 FORMAT (/' DPCHF',A1,' RETURNED IERR = ',I2,' INSTEAD OF ',I2) 2014 FORMAT (' *** BOTH SHOULD BE .LE. TOL =',1P,D12.5,' ***') 3000 FORMAT (//' ***** ERROR ***** DPCHFD RETURNED IERR =',I5//) 3001 FORMAT (//' ***** ERROR ***** DPCHFD AND/OR DPCHFE FAILED ON',I2, * 1X, A1,'-LINES.'//) 4000 FORMAT (/' DPCHFD AND DPCHFE OK ON ',A1,'-LINES.') C------------- LAST LINE OF DEVPCK FOLLOWS ----------------------------- END *DECK DF0C DOUBLE PRECISION FUNCTION DF0C (X) C***BEGIN PROLOGUE DF0C C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF0C DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT DF0C DF0C = 1.D0/(X*X+1.D-4) RETURN END *DECK DF0F DOUBLE PRECISION FUNCTION DF0F (X) C***BEGIN PROLOGUE DF0F C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF0F DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT DF0F DF0F = 0.0D+00 IF(X.NE.0.0D+00) DF0F = SIN(0.5D+02*X)/(X*SQRT(X)) RETURN END *DECK DF0O DOUBLE PRECISION FUNCTION DF0O (X) C***BEGIN PROLOGUE DF0O C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF0O DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT DF0O DF0O = (0.2D+01*SIN(X))**14 RETURN END *DECK DF0S DOUBLE PRECISION FUNCTION DF0S (X) C***BEGIN PROLOGUE DF0S C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF0S DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT DF0S DF0S = 0.0D+00 IF(X.NE.0.0D+00) DF0S = 0.1D+01/SQRT(X) RETURN END *DECK DF0WS DOUBLE PRECISION FUNCTION DF0WS (X) C***BEGIN PROLOGUE DF0WS C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF0WS DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT DF0WS DF0WS = SIN(0.1D+02*X) RETURN END *DECK DF1C DOUBLE PRECISION FUNCTION DF1C (X) C***BEGIN PROLOGUE DF1C C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF1C DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT DF1C DF1C = 0.0D+00 IF(X.NE.0.33D+00) DF1C = (X-0.5D+00)*ABS(X-0.33D+00)**(-0.9D+00) RETURN END *DECK DF1F DOUBLE PRECISION FUNCTION DF1F (X) C***BEGIN PROLOGUE DF1F C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF1F DOUBLE PRECISION X,X1,Y C***FIRST EXECUTABLE STATEMENT DF1F X1 = X+0.1D+01 DF1F = 0.5D+01/X1/X1 Y = 0.5D+01/X1 IF(Y .GT. 3.1415926535897932D0) DF1F = 0.0D0 RETURN END *DECK DF1G DOUBLE PRECISION FUNCTION DF1G (X) C***BEGIN PROLOGUE DF1G C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF1G DOUBLE PRECISION PI,X DATA PI /3.1415926535897932D0/ C***FIRST EXECUTABLE STATEMENT DF1G DF1G = 2.0D0/(2.0D0+SIN(10.0D0*PI*X)) RETURN END *DECK DF1N DOUBLE PRECISION FUNCTION DF1N (X) C***BEGIN PROLOGUE DF1N C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF1N DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT DF1N DF1N=1.0D0/(X**4+X**2+1.0D0) RETURN END *DECK DF1O DOUBLE PRECISION FUNCTION DF1O (X) C***BEGIN PROLOGUE DF1O C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF1O DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT DF1O DF1O = 0.1D+01 IF(X.GT.0.31415926535897932D+01) DF1O = 0.0D+00 RETURN END *DECK DF1P DOUBLE PRECISION FUNCTION DF1P (X) C***BEGIN PROLOGUE DF1P C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF1P DOUBLE PRECISION ALFA1,ALFA2,P1,P2,X,D1,D2 C***FIRST EXECUTABLE STATEMENT DF1P C P1 = 1/7, P2 = 2/3 DATA P1/0.1428571428571428D+00/ DATA P2/0.6666666666666667D+00/ ALFA1 = -0.25D0 ALFA2 = -0.5D0 D1=ABS(X-P1) D2=ABS(X-P2) DF1P = 0.0D+00 IF(D1.NE.0.0D+00.AND.D2.NE.0.0D+00) DF1P = D1**ALFA1+D2**ALFA2 RETURN END *DECK DF1S DOUBLE PRECISION FUNCTION DF1S (X) C***BEGIN PROLOGUE DF1S C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF1S DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT DF1S DF1S = 0.2D+01/(0.2D+01+SIN(0.314159D+02*X)) RETURN END *DECK DF1WS DOUBLE PRECISION FUNCTION DF1WS (X) C***BEGIN PROLOGUE DF1WS C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF1WS DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT DF1WS DF1WS = 0.00D+00 IF(X-0.33D+00 .NE. 0.00D+00) DF1WS=ABS(X-0.33D+00)**(-0.999D+00) RETURN END *DECK DF2G DOUBLE PRECISION FUNCTION DF2G (X) C***BEGIN PROLOGUE DF2G C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF2G DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT DF2G DF2G = X*SIN(0.3D+02*X)*COS(0.5D+02*X) RETURN END *DECK DF2N DOUBLE PRECISION FUNCTION DF2N (X) C***BEGIN PROLOGUE DF2N C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF2N DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT DF2N DF2N=X**(-0.9D+00) RETURN END *DECK DF2O DOUBLE PRECISION FUNCTION DF2O (X) C***BEGIN PROLOGUE DF2O C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF2O DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT DF2O DF2O = 0.0D+00 IF(X.NE.0.0D+00) DF2O = 0.1D+01/(X*X*SQRT(X)) RETURN END *DECK DF2P DOUBLE PRECISION FUNCTION DF2P (X) C***BEGIN PROLOGUE DF2P C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF2P DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT DF2P DF2P = SIN(0.314159D+03*X)/(0.314159D+01*X) RETURN END *DECK DF2S DOUBLE PRECISION FUNCTION DF2S (X) C***BEGIN PROLOGUE DF2S C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF2S DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT DF2S DF2S = 0.1D+03 IF(X.NE.0.0D+00) DF2S = SIN(0.314159D+03*X)/(0.314159D+01*X) RETURN END *DECK DF3G DOUBLE PRECISION FUNCTION DF3G (X) C***BEGIN PROLOGUE DF3G C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF3G DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT DF3G DF3G=ABS(X-0.33D+00)**(-.90D+00) RETURN END *DECK DF3P DOUBLE PRECISION FUNCTION DF3P (X) C***BEGIN PROLOGUE DF3P C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF3P DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT DF3P DF3P = 0.1D+01 IF(X.GT.0.31415926535897932D+01) DF3P = 0.0D+00 RETURN END *DECK DF3S DOUBLE PRECISION FUNCTION DF3S (X) C***BEGIN PROLOGUE DF3S C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF3S DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT DF3S DF3S = 0.1D+01 IF(X.GT.0.31415926535897932D+01) DF3S = 0.0D+00 RETURN END *DECK DF4P DOUBLE PRECISION FUNCTION DF4P (X) C***BEGIN PROLOGUE DF4P C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF4P DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT DF4P DF4P = 0.0D+00 IF(X.GT.0.0D+00) DF4P = 0.1D+01/(X*SQRT(X)) RETURN END *DECK DF4S DOUBLE PRECISION FUNCTION DF4S (X) C***BEGIN PROLOGUE DF4S C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF4S DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT DF4S DF4S = 0.00D+00 IF(X-0.33D+00 .NE. 0.00D+00) DF4S=ABS(X-0.33D+00)**(-0.999D+00) RETURN END *DECK DF5S DOUBLE PRECISION FUNCTION DF5S (X) C***BEGIN PROLOGUE DF5S C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DF5S DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT DF5S DF5S = 0.0D+00 IF(X.NE.0.0D+00) DF5S = 1.0D+00/(X*SQRT(X)) RETURN END *DECK DFB DOUBLE PRECISION FUNCTION DFB (X) C***BEGIN PROLOGUE DFB C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DFB DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT DFB DFB = 1.0D0 RETURN END *DECK DFCN1 SUBROUTINE DFCN1 (IFLAG, M, N, X, FVEC, FJAC, LDFJAC) C***BEGIN PROLOGUE DFCN1 C***PURPOSE C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C SUBROUTINE WHICH EVALUATES THE FUNCTION FOR TEST C PROGRAM USED IN QUICK CHECK OF SNLS1E. C NUMERICAL APPROXIMATION OF JACOBIAN IS USED. C C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DFCN1 DOUBLE PRECISION X,FVEC,FJAC,TWO,TEMP DIMENSION X(*),FVEC(*) DATA TWO/2.D0/ C***FIRST EXECUTABLE STATEMENT DFCN1 IF(IFLAG.NE.1) RETURN DO 100 I=1,M TEMP=I FVEC(I)=TWO+TWO*TEMP-EXP(TEMP*X(1))-EXP(TEMP*X(2)) 100 CONTINUE RETURN END *DECK DFCN2 SUBROUTINE DFCN2 (IFLAG, M, N, X, FVEC, FJAC, LDFJAC) C***BEGIN PROLOGUE DFCN2 C***PURPOSE C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C SUBROUTINE TO EVALUATE FUNCTION AND FULL JACOBIAN C FOR TEST PROBLEM IN QUICK CHECK OF SNLS1E. C C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DFCN2 DOUBLE PRECISION X,FVEC,FJAC,TWO,TEMP DIMENSION X(*),FVEC(*),FJAC(LDFJAC,*) DATA TWO/2.D0/ IF(IFLAG.EQ.0) RETURN C***FIRST EXECUTABLE STATEMENT DFCN2 C C SHOULD WE EVALUATE FUNCTION OR JACOBIAN C IF(IFLAG.NE.1) GO TO 150 C C EVALUATE FUNCTIONS C DO 100 I=1,M TEMP=I FVEC(I)=TWO+TWO*TEMP-EXP(TEMP*X(1))-EXP(TEMP*X(2)) 100 CONTINUE RETURN C C EVALUATE JACOBIAN C 150 CONTINUE IF(IFLAG.NE.2) RETURN DO 200 I=1,M TEMP=I FJAC(I,1)=-TEMP*EXP(TEMP*X(1)) FJAC(I,2)=-TEMP*EXP(TEMP*X(2)) 200 CONTINUE RETURN END *DECK DFCN3 SUBROUTINE DFCN3 (IFLAG, M, N, X, FVEC, FJROW, NROW) C***BEGIN PROLOGUE DFCN3 C***PURPOSE C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C SUBROUTINE TO EVALUATE THE JACOBIAN, ONE ROW AT A TIME, FOR C TEST PROBLEM USED IN QUICK CHECK OF SNLS1E. C C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DFCN3 DOUBLE PRECISION X,FVEC,FJROW,TWO,TEMP DIMENSION X(*),FVEC(*),FJROW(*) DATA TWO/2.D0/ C***FIRST EXECUTABLE STATEMENT DFCN3 IF(IFLAG.EQ.0) RETURN C C SHOULD WE EVALUATE FUNCTIONS OR JACOBIAN. C IF(IFLAG.NE.1) GO TO 150 C C EVALUATE FUNCTIONS. C DO 100 I=1,M TEMP=I FVEC(I)=TWO+TWO*TEMP-EXP(TEMP*X(1))-EXP(TEMP*X(2)) 100 CONTINUE RETURN C C EVALUATE ONE ROW OF JACOBIAN. C 150 CONTINUE IF(IFLAG.NE.3) RETURN TEMP=NROW FJROW(1)=-TEMP*EXP(TEMP*X(1)) FJROW(2)=-TEMP*EXP(TEMP*X(2)) RETURN END *DECK DFCQX SUBROUTINE DFCQX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DFCQX C***PURPOSE Quick check for DFC. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (FCQX-S, DFCQX-D) C***KEYWORDS QUICK CHECK C***AUTHOR Hanson, R. J., (SNLA) C***DESCRIPTION C C QUICK CHECK SUBPROGRAM FOR THE SUBROUTINE DFC. C C FIT DISCRETE DATA BY AN S-SHAPED CURVE. EVALUATE THE FITTED CURVE, C ITS FIRST TWO DERIVATIVES, AND PROBABLE ERROR CURVE. C C USE SUBPROGRAM DFC TO OBTAIN THE CONSTRAINED CUBIC B-SPLINE C REPRESENTATION OF THE CURVE. C C THE VALUES OF THE COEFFICIENTS OF THE B-SPLINE AS COMPUTED C BY DFC AND THE VALUES OF THE FITTED CURVE AS COMPUTED BY DBVALU C IN THE DE BOOR PACKAGE ARE TESTED FOR ACCURACY WITH THE EXPECTED C VALUES. SEE EXAMPLE PROGRAM SAND78-1291, PP. 22-27. C C THE DIMENSIONS IN THE FOLLOWING ARRAYS ARE AS SMALL C AS POSSIBLE FOR THE PROBLEM BEING SOLVED. C C***ROUTINES CALLED D1MACH, DBVALU, DCOPY, DCV, DFC, DMOUT, DVOUT, C IVOUT C***REVISION HISTORY (YYMMDD) C 780801 DATE WRITTEN C 890718 Changed references from DBVLUE to DBVALU. (WRB) C 890911 Removed unnecessary intrinsics. (WRB) C 891004 Changed computation of XVAL. (WRB) C 891004 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF, modified tolerances C to use R1MACH(4) rather than R1MACH(3) and cleaned up C FORMATs. (RWC) C***END PROLOGUE DFCQX IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION XDATA(9), YDATA(9), SDDATA(9), BKPT(13), XCONST(11), * YCONST(11), COEFF(9), V(51,5), W(529), WORK(12), CHECK(51), * COEFCK(9) INTEGER ICNT, IPASS, ITEST(38), NDERIV(11), IW(30) C DATA XDATA(1),XDATA(2),XDATA(3),XDATA(4),XDATA(5),XDATA(6), + XDATA(7),XDATA(8),XDATA(9)/0.15D0,0.27D0,0.33D0,0.40D0, + 0.43D0,0.47D0,0.53D0,0.58D0,0.63D0/ DATA YDATA(1),YDATA(2),YDATA(3),YDATA(4),YDATA(5),YDATA(6), + YDATA(7),YDATA(8),YDATA(9)/0.025D0,0.05D0,0.13D0,0.27D0, + 0.37D0,0.47D0,0.64D0,0.77D0,0.87D0/ DATA SDDATA(1)/0.015D0/,NDATA/9/,NORD/4/,NBKPT/13/,LAST/10/ DATA BKPT(1),BKPT(2),BKPT(3),BKPT(4),BKPT(5),BKPT(6),BKPT(7), + BKPT(8),BKPT(9),BKPT(10),BKPT(11),BKPT(12),BKPT(13)/-0.6D0, + -0.4D0,-0.2D0,0.D0,0.2D0,0.4D0,0.6D0,0.8D0,0.9D0,1.0D0,1.1D0, + 1.2D0,1.3D0/ C C STORE THE DATA TO BE USED TO CHECK THE ACCURACY OF THE C COMPUTED RESULTS. SEE SAND78-1291, P.26. C DATA COEFCK(1),COEFCK(2),COEFCK(3),COEFCK(4),COEFCK(5), 1 COEFCK(6),COEFCK(7),COEFCK(8),COEFCK(9)/ 1.186380846D-13, 2 -2.826166426D-14, -4.333929094D-15, 1.722113311D-01, 3 9.421965984D-01, 9.684708719D-01, 9.894902905D-01, 4 1.005254855D+00, 9.894902905D-01/ DATA CHECK(1), CHECK(2), CHECK(3), CHECK(4), CHECK(5), 1 CHECK(6), CHECK(7), CHECK(8), CHECK(9)/ 2 2.095830752D-16, 2.870188850D-05, 2.296151081D-04, 3 7.749509897D-04, 1.836920865D-03, 3.587736064D-03, 4 6.199607918D-03, 9.844747759D-03, 1.469536692D-02/ DATA CHECK(10), CHECK(11), CHECK(12), CHECK(13), CHECK(14), 1 CHECK(15), CHECK(16), CHECK(17), CHECK(18)/ 2 2.092367672D-02, 2.870188851D-02, 3.824443882D-02, 3 4.993466504D-02, 6.419812979D-02, 8.146039566D-02, 4 1.021470253D-01, 1.266835812D-01, 1.554956261D-01/ DATA CHECK(19), CHECK(20), CHECK(21), CHECK(22), CHECK(23), 1 CHECK(24), CHECK(25), CHECK(26), CHECK(27)/ 2 1.890087225D-01, 2.276484331D-01, 2.718403204D-01, 3 3.217163150D-01, 3.762338189D-01, 4.340566020D-01, 4 4.938484342D-01, 5.542730855D-01, 6.139943258D-01/ DATA CHECK(28), CHECK(29), CHECK(30), CHECK(31), CHECK(32), 1 CHECK(33), CHECK(34), CHECK(35), CHECK(36)/ 2 6.716759250D-01, 7.259816530D-01, 7.755752797D-01, 3 8.191205752D-01, 8.556270903D-01, 8.854875002D-01, 4 9.094402609D-01, 9.282238286D-01, 9.425766596D-01/ DATA CHECK(37), CHECK(38), CHECK(39), CHECK(40), CHECK(41), 1 CHECK(42), CHECK(43), CHECK(44), CHECK(45)/ 2 9.532372098D-01, 9.609439355D-01, 9.664352927D-01, 3 9.704497377D-01, 9.737257265D-01, 9.768786393D-01, 4 9.800315521D-01, 9.831844649D-01, 9.863373777D-01/ DATA CHECK(46), CHECK(47), CHECK(48), CHECK(49), CHECK(50), 1 CHECK(51)/ 9.894902905D-01, 9.926011645D-01, 2 9.954598055D-01, 9.978139804D-01, 9.994114563D-01, 3 1.000000000D+00/ C***FIRST EXECUTABLE STATEMENT DFCQX C C BROADCAST SDDATA(1) VALUE TO ALL OF SDDATA(*). C CALL DCOPY(NDATA,SDDATA,0,SDDATA,1) ZERO = 0.D0 ONE = 1.D0 NDEG = NORD-1 C C WRITE THE VARIOUS CONSTRAINTS FOR C THE FITTED CURVE. C NCONST = 0 T = BKPT(NORD) C C CONSTRAIN FUNCTION TO BE ZERO AT LEFT-MOST BREAKPOINT. C NCONST = NCONST+1 XCONST(NCONST) = T YCONST(NCONST) = ZERO NDERIV(NCONST) = 2+4*0 C C CONSTRAIN FIRST DERIVATIVE TO BE C NONNEGATIVE AT LEFT-MOST BREAKPOINT. C NCONST = NCONST+1 XCONST(NCONST) = T YCONST(NCONST) = ZERO NDERIV(NCONST) = 1+4*1 C C CONSTRAIN SECOND DERIVATIVES TO BE C NONNEGATIVE AT LEFT SET OF BREAKPOINTS. C DO 10 I = 1, 3 L = NDEG+I T = BKPT(L) NCONST=NCONST+1 XCONST(NCONST) = T YCONST(NCONST) = ZERO NDERIV(NCONST) = 1+4*2 10 CONTINUE C C CONSTRAIN FUNCTION VALUE AT RIGHT-MOST C BREAKPOINT TO BE ONE. C NCONST = NCONST+1 T = BKPT(LAST) XCONST(NCONST) = T YCONST(NCONST) = ONE NDERIV(NCONST) = 2+4*0 C C CONSTRAIN SLOPE TO AGREE AT LEFT AND C RIGHT-MOST BREAKPOINTS. C NCONST = NCONST+1 XCONST(NCONST) = BKPT(NORD) YCONST(NCONST) = BKPT(LAST) NDERIV(NCONST) = 3+4*1 C C CONSTRAIN SECOND DERIVATIVES TO BE C NONPOSITIVE AT RIGHT SET OF BREAKPOINTS. C DO 20 I = 1, 4 NCONST = NCONST+1 L = LAST-4+I XCONST(NCONST) = BKPT(L) YCONST(NCONST) = ZERO NDERIV(NCONST) = 0+4*2 20 CONTINUE C IF (KPRINT.GE.2) WRITE (LUN,1000) 1000 FORMAT ('1TEST OF SUBROUTINE DFC/') ICNT = 1 IDIGIT = -4 C IF (KPRINT.GE.3) THEN CALL DVOUT (NBKPT, BKPT, '('' ARRAY OF KNOTS.'')', IDIGIT) CALL DVOUT (NDATA, XDATA, '('' INDEP. VAR. VALUES'')', * IDIGIT) CALL DVOUT (NDATA, YDATA, '('' DEPEND. VAR. VALUES'')', IDIGIT) CALL DVOUT (NDATA, SDDATA, '('' DEPEND. VAR. UNCERTAINTY'')', * IDIGIT) C CALL DVOUT (NCONST, XCONST, '('' INDEP. VAR. CONST. VALS.'')', * IDIGIT) CALL DVOUT (NCONST, YCONST, '('' CONST. VALUES'')', IDIGIT) CALL IVOUT (NCONST, NDERIV, '('' CONST. INDICATOR'')', IDIGIT) ENDIF C C DECLARE AMOUNT OF WORKING STORAGE ALLOCATED TO DFC. C IW(1) = 529 IW(2) = 30 C C SET MODE TO INDICATE A NEW PROBLEM C AND REQUEST THE VARIANCE FUNCTION. C MODE = 2 C C OBTAIN THE COEFFICIENTS OF THE B-SPLINE. C CALL DFC(NDATA,XDATA,YDATA,SDDATA, 1 NORD,NBKPT,BKPT, 2 NCONST,XCONST,YCONST,NDERIV, 3 MODE, 4 COEFF, 5 W,IW) C C CHECK COEFFICIENTS C TOL = MAX(7.0D0*SQRT(D1MACH(4)),1.D-8) DO 40 I = 1, NDATA DIFF = ABS(COEFF(I)-COEFCK(I)) IF (DIFF .GT. TOL) GO TO 50 40 CONTINUE C ITEST(ICNT) = 1 IF (KPRINT.GE.3) WRITE (LUN,1001) 1001 FORMAT (/' DFC PASSED TEST 1') GO TO 60 C 50 ITEST(ICNT) = 0 IF (KPRINT.GE.2) WRITE (LUN,1002) 1002 FORMAT (/' DFC FAILED TEST 1') C 60 K = ITEST(ICNT) IF (KPRINT.NE.2 .OR. K.EQ.0) THEN IF (KPRINT.GE.2) THEN CALL DVOUT (NDATA, COEFCK, * '(/'' PREDICTED COEFFICIENTS OF THE B-SPLINE FROM SAMPLE'')', * IDIGIT) CALL DVOUT (NDATA, COEFF, * '(/'' COEFFICIENTS OF THE B-SPLINE COMPUTED BY DFC'')', * IDIGIT) ENDIF ENDIF C ICNT=ICNT+1 C C COMPUTE VALUE, FIRST TWO DERIVS., AND PROBABLE UNCERTAINTY. C N = NBKPT-NORD NVAL = 51 DO 90 I = 1, NVAL C C THE FUNCTION DBVALU( ) IS IN THE DE BOOR B-SPLINE PACKAGE. C XVAL = DBLE(I-1)/(NVAL-1) II = 1 DO 80 J = 1, 3 V(I,J+1) = DBVALU(BKPT,COEFF,N,NORD,J-1,XVAL,II,WORK) 80 CONTINUE V(I,1) = XVAL C C THE VARIANCE FUNCTION DCV IS A COMPANION SUBPROGRAM TO DFC. C V(I,5) = SQRT(DCV(XVAL,NDATA,NCONST,NORD,NBKPT,BKPT,W)) 90 CONTINUE C DO 100 I = 1, NVAL DIFF = ABS(V(I,2)-CHECK(I)) IF (DIFF .GT. TOL) GO TO 110 100 CONTINUE C ITEST(ICNT) = 1 IF (KPRINT.GE.3) WRITE (LUN,1003) 1003 FORMAT (/' DFC (AND DBVALU) PASSED TEST 2') GO TO 120 C 110 ITEST(ICNT) = 0 IF (KPRINT.GE.2) WRITE (LUN,1004) 1004 FORMAT (/' DFC (AND DBVALU) FAILED TEST 2') C 120 K = ITEST(ICNT) IF (KPRINT.NE.2 .OR. K.EQ.0) THEN IF (KPRINT.GE.2) THEN C C PRINT THESE VALUES. C CALL DMOUT (NVAL, 5, NVAL, V, 1 '(''1'',15X,''X'',10X,''FNCN'',8X,''1ST D'',7X,''2ND D'', * 7X, ''ERROR'')', IDIGIT) WRITE (LUN,1005) 1005 FORMAT (/' VALUES SHOULD CORRESPOND TO THOSE IN ', * 'SAND78-1291, P. 26') ENDIF ENDIF C C CHECK ERROR PROCESSOR C IF (KPRINT.GE.2) THEN WRITE (LUN,1006) 1006 FORMAT (/ ' 6 ERROR MESSAGES EXPECTED') CALL DFC(NDATA,XDATA,YDATA,SDDATA,0,NBKPT,BKPT,NCONST,XCONST, 1 YCONST,NDERIV,MODE,COEFF,W,IW) CALL DFC(NDATA,XDATA,YDATA,SDDATA,NORD,0,BKPT,NCONST,XCONST, 1 YCONST,NDERIV,MODE,COEFF,W,IW) CALL DFC(-1,XDATA,YDATA,SDDATA,NORD,NBKPT,BKPT,NCONST,XCONST, 1 YCONST,NDERIV,MODE,COEFF,W,IW) MMODE = 0 CALL DFC(NDATA,XDATA,YDATA,SDDATA,NORD,NBKPT,BKPT,NCONST, 1 XCONST,YCONST,NDERIV,MMODE,COEFF,W,IW) IW(1) = 10 CALL DFC(NDATA,XDATA,YDATA,SDDATA,NORD,NBKPT,BKPT,NCONST, 1 XCONST,YCONST,NDERIV,MODE,COEFF,W,IW) IW(1) = 529 IW(2) = 2 CALL DFC(NDATA,XDATA,YDATA,SDDATA,NORD,NBKPT,BKPT,NCONST, 1 XCONST,YCONST,NDERIV,MODE,COEFF,W,IW) ENDIF C IP = 1 DO 150 I = 1, ICNT IP = IP*ITEST(I) 150 CONTINUE C IPASS = IP IF (IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN,1007) IF (IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN,1008) RETURN C 1007 FORMAT (/' ****************DFC PASSED ALL TESTS*****************') 1008 FORMAT (/' ***************DFC FAILED SOME TESTS*****************') END *DECK DFDEQC SUBROUTINE DFDEQC (T, U, UPRIME, RPAR, IPAR) C***BEGIN PROLOGUE DFDEQC C***SUBSIDIARY C***PURPOSE Derivative evaluator for DDEPAC quick checks. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (FDEQC-S, DFDEQC-D) C***AUTHOR Chow, Jeff, (LANL) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 810801 DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 900415 Name changed from DDF to DFDEQC. (WRB) C***END PROLOGUE DFDEQC C C Declare arguments. C INTEGER IPAR(*) DOUBLE PRECISION RPAR(*), T, U(*), UPRIME(*) C C Declare local variables. C DOUBLE PRECISION R, RSQ, R3 C***FIRST EXECUTABLE STATEMENT DFDEQC RSQ = U(1)*U(1) + U(2)*U(2) R = SQRT(RSQ) R3 = RSQ*R UPRIME(1) = U(3) UPRIME(2) = U(4) UPRIME(3) = -(U(1)/R3) UPRIME(4) = -(U(2)/R3) RETURN END *DECK DFDTRU SUBROUTINE DFDTRU (X, F, D) C***BEGIN PROLOGUE DFDTRU C***SUBSIDIARY C***PURPOSE Compute exact function values for DEVCHK. C***LIBRARY SLATEC (PCHIP) C***TYPE DOUBLE PRECISION (FDTRUE-S, DFDTRU-D) C***KEYWORDS PCHIP EVALUATOR QUICK CHECK C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C COMPUTE EXACT FUNCTION VALUES IN DOUBLE PRECISION. C C F(X) = X*(X+1)*(X-2) C C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 820601 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 890706 Cosmetic changes to prologue. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 Revised prologue. (FNF) C 900316 Deleted variables ONE and TWO. (FNF) C 900321 Changed name of d.p. version from DFTRUE to DFDTRU. C***END PROLOGUE DFDTRU DOUBLE PRECISION X, F, D DOUBLE PRECISION FACT1, FACT2, XX C C***FIRST EXECUTABLE STATEMENT DFDTRU XX = X FACT1 = XX + 1 FACT2 = XX - 2 F = XX * FACT1 * FACT2 D = FACT1*FACT2 + XX*(FACT1 + FACT2) C RETURN C------------- LAST LINE OF DFDTRU FOLLOWS ----------------------------- END *DECK DFEIN DOUBLE PRECISION FUNCTION DFEIN (T) C***BEGIN PROLOGUE DFEIN C***PURPOSE Subsidiary to DEG8CK. C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***COMMON BLOCKS DFEINX C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DFEIN COMMON /DFEINX/ X, A, FKM DOUBLE PRECISION X, A, FKM, T, ALN C***FIRST EXECUTABLE STATEMENT DFEIN ALN = (FKM-T)*X - A*LOG(T) DFEIN = EXP(ALN) RETURN END *DECK DFMAT SUBROUTINE DFMAT (X, Y, YP) C***BEGIN PROLOGUE DFMAT C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***COMMON BLOCKS DSAVEX C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DFMAT DOUBLE PRECISION X,Y,YP,XSAVE,TERM,TANX DIMENSION Y(*),YP(*) COMMON /DSAVEX/ XSAVE, TERM C***FIRST EXECUTABLE STATEMENT DFMAT YP(1) = Y(2) IF (X .EQ. XSAVE) GO TO 10 XSAVE=X TANX= TAN(X/57.2957795130823D0) TERM= 3.0D0/TANX+2.0D0*TANX 10 YP(2) = -TERM*Y(2)-0.7D0*Y(1) RETURN END *DECK DFNCK SUBROUTINE DFNCK (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DFNCK C***PURPOSE Quick check for the double precision Fullerton C special functions. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Boland, W. Robert, (LANL) C Chow, Jeff, (LANL) C***DESCRIPTION C C This subroutine does a quick check for the double precision C routines in the Fullerton special function library. C C Parameter list- C C LUN input integer value to designate the external C device unit for message output C KPRINT input integer value to specify amount of C printing to be done by quick check C IPASS output value indicating whether tests passed or C failed C C***ROUTINES CALLED D1MACH, D9ATN1, D9LN2R, DACOSH, DAI, DAIE, DASINH, C DATANH, DBESI0, DBESI1, DBESJ0, DBESJ1, DBESK0, C DBESK1, DBESKS, DBESY0, DBESY1, DBETA, DBETAI, DBI, C DBIE, DBINOM, DBSI0E, DBSI1E, DBSK0E, DBSK1E, C DBSKES, DCBRT, DCHU, DCOSDG, DCOT, DDAWS, DE1, DEI, C DERF, DEXPRL, DFAC, DGAMI, DGAMIC, DGAMIT, DGAMMA, C DGAMR, DLI, DLNREL, DPOCH, DPOCH1, DPSI, DSINDG, C DSPENC C***REVISION HISTORY (YYMMDD) C 800801 DATE WRITTEN C 891115 REVISION DATE from Version 3.2 C 891120 Checks of remainder of FNLIB routines added and code C reorganized. (WRB) C 900330 Prologue converted to Version 4.0 format. (BAB) C 900727 Added EXTERNAL statement. (WRB) C***END PROLOGUE DFNCK INTEGER I,LUN,KPRINT,IPASS DOUBLE PRECISION D1MACH, + Y(105),V(105),ERRMAX,ERRTOL,ABSERR,RELERR, + D9ATN1,D9LN2R,DACOSH,DAI,DAIE,DASINH,DATANH, + DBESI0,DBESI1,DBESJ0,DBESJ1,DBESK0,DBESK1, + DBESY0,DBESY1,DBETA,DBETAI,DBI,DBIE,DBINOM, + DBSI0E,DBSI1E,DBSK0E,DBSK1E,DCBRT,DCHU,DCOSDG, + DCOT,DDAWS,DE1,DEI,DERF,DEXPRL,DFAC,DGAMI,DGAMIC, + DGAMIT,DGAMMA,DGAMR,DLI,DLNREL,DPOCH,DPOCH1,DPSI, + DSINDG,DSPENC EXTERNAL DCOT, DERF, DGAMMA C C Correct values through different calculations are stored in V(*) C DATA V( 1) / .8344518000 0000000000 0000000000 D+09/ DATA V( 2) / .2250829575 1200000000 0000000000 D+13/ DATA V( 3) / .1307674368 0000000000 0000000000 D+13/ DATA V( 4) / .8222838654 1779228177 2556288000 D+34/ DATA V( 5) /-.2000000000 0000000000 0000000000 D+01/ DATA V( 6) / .9983407900 0000000000 0000000000 D+02/ DATA V( 7) / .8660254037 8443864676 3723170753 D+00/ DATA V( 8) /-.7071067811 8654752440 0844362105 D+00/ DATA V( 9) / .6420926159 3433070300 6419986594 D+00/ DATA V( 10) /-.1830487721 7124519192 6801943897 D+01/ DATA V( 11) /-.2908191279 9355107028 5950148310 D+00/ DATA V( 12) /-.1116064102 7573868712 2866817478 D+00/ DATA V( 13) / .5000000000 0000000000 0000000000 D+00/ DATA V( 14) / .7071067811 8654752440 0844362105 D+00/ DATA V( 15) / .1371498381 4723363824 3285631505 D+00/ DATA V( 16) /-.1000000500 0003333335 8333416027 D-05/ DATA V( 17) / .1001251042 3180339898 4880296644 D+01/ DATA V( 18) / .9950166250 8319464260 9402280122 D+00/ DATA V( 19) / .2437208648 6531505582 4104923715 D+00/ DATA V( 20) / .1931471805 5994530941 7232121458 D+00/ DATA V( 21) / .1111122222 3333344444 0000000000 D+00/ DATA V( 22) / .3141592653 5900000000 0000000000 D+01/ DATA V( 23) / .9983407900 0000000000 0000000000 D-01/ DATA V( 24) /-.1194763217 0000000000 0000000000 D+01/ DATA V( 25) /-.1111122222 3333344444 0000000000 D+00/ DATA V( 26) / .2646652412 0000000000 0000000000 D+01/ DATA V( 27) /-.3786710430 6108797672 7207184637 D+00/ DATA V( 28) / .1045163780 1174927848 4458888919 D+01/ DATA V( 29) / .5597735947 7616081174 6795939295 D+00/ DATA V( 30) / .1000195824 0663265190 1909339800 D+00/ DATA V( 31) / .4542199048 6317357992 0523812663 D+00/ DATA V( 32) / .1895117816 3559367554 6652093433 D+01/ DATA V( 33) / .5822405264 6501250590 2656320160 D+00/ DATA V( 34) / .1644934066 8482264364 7241516665 D+01/ DATA V( 35) / .8862269254 5275801364 9083741687 D+00/ DATA V( 36) /-.3141592653 5897932384 6264338328 D+01/ DATA V( 37) / .3183098861 8379067153 7767526733 D+00/ DATA V( 38) / .8823957200 2038009055 0940262394 D-06/ DATA V( 39) /-.2820947917 7387814347 4039725759 D+00/ DATA V( 40) / .1875000000 0000000000 0000000000 D+01/ DATA V( 41) / .5135166683 8205029558 4635612122 D-01/ DATA V( 42) / .5987500000 0000000000 0000000000 D+02/ DATA V( 43) / .1570796326 7948966192 3132169164 D+01/ DATA V( 44) / .7550061690 3746404275 1871235437 D-03/ DATA V( 45) / .4227843350 9846713939 3487909918 D+00/ DATA V( 46) / .2303001034 2976863752 7259355045 D+01/ DATA V( 47) / .9998566182 6372370688 5830759463 D+00/ DATA V( 48) / .8882907071 8395673587 8281870759 D+00/ DATA V( 49) / .1353352832 3661269189 3999494971 D+00/ DATA V( 50) / .3469303062 9580145617 0933128256 D-03/ DATA V( 51) / .7869386805 7473315279 2400930048 D+00/ DATA V( 52) / .6316733917 7525812329 1222663623 D-01/ DATA V( 53) / .3812815664 6177091614 9261183171 D+00/ DATA V( 54) / .2656250000 0000000000 0000000000 D+00/ DATA V( 55) / .5204998778 1304653768 2746653770 D+00/ DATA V( 56) / .8883882317 0170776406 9578446749 D+00/ DATA V( 57) / .4244363835 0202229593 4042352455 D+00/ DATA V( 58) / .3370006597 4209342338 3019719632 D+00/ DATA V( 59) /-.1775967713 1433830434 7397013056 D+00/ DATA V( 60) / .2238907791 4123566805 1827454628 D+00/ DATA V( 61) /-.3275791375 9146522203 7734321812 D+00/ DATA V( 62) / .5767248077 5687338720 2448242187 D+00/ DATA V( 63) / .5103756726 4974511959 6606592612 D+00/ DATA V( 64) /-.3085176252 4903378007 3648984210 D+00/ DATA V( 65) / .1478631433 9122684480 1050675510 D+00/ DATA V( 66) /-.1070324315 4093754688 8370772230 D+00/ DATA V( 67) / .2279585302 3360672674 3720444020 D+01/ DATA V( 68) / .2723987182 3604446894 5442320700 D+02/ DATA V( 69) / .1590636854 6373290633 8225442450 D+01/ DATA V( 70) / .2433564214 2450527199 1430504400 D+02/ DATA V( 71) / .1138938727 4953343565 2719574910 D+00/ DATA V( 72) / .3691098334 0425942747 3526100740 D-02/ DATA V( 73) / .1398658818 1652242728 4598806997 D+00/ DATA V( 74) / .4044613445 4521642083 6502183700 D-02/ DATA V( 75) / .3085083225 5367103953 3384319255 D+00/ DATA V( 76) / .1835408126 0932835307 3650751820 D+00/ DATA V( 77) / .1639722669 4454235692 6122903850 D+00/ DATA V( 78) / .2152692892 4893765915 8505143243 D+00/ DATA V( 79) / .8415682150 7077141791 9124867127 D+00/ DATA V( 80) / .5478075643 1351898686 8201568700 D+00/ DATA V( 81) / .6002738587 8831258293 6045656600 D+00/ DATA V( 82) / .1033476847 0686885731 7535710603 D+01/ DATA V( 83) / .8862269254 5275801364 9083741000 D+00/ DATA V( 84) / .1329340388 1791370204 7362561200 D+01/ DATA V( 85) / .2880237507 7214635443 5952215970 D+01/ DATA V( 86) / .5604991216 3979286993 1128243359 D+00/ DATA V( 87) / .6725989459 6775144391 7353892000 D+00/ DATA V( 88) / .9640584892 2044373628 1540578570 D+00/ DATA V( 89) / .4610685044 4789455843 9575873876 D+00/ DATA V( 90) / .9221370088 9578911687 9151747751 D+00/ DATA V( 91) / .2316936064 8083348976 9125254500 D+00/ DATA V( 92) / .1572592338 0470489995 2660465400 D-01/ DATA V( 93) / .2932771591 2994736245 0897433147 D+00/ DATA V( 94) / .2193222051 2871206086 2850888400 D+00/ DATA V( 95) / .8542770431 0315549330 0048798776 D+00/ DATA V( 96) / .1878941503 7478950009 0933504950 D+01/ DATA V( 97) / .6748924111 1563021286 5414309867 D+00/ DATA V( 98) / .4647504801 9609251501 9775411670 D+00/ DATA V( 99) / .2499999999 9999999999 9999999880 D+00/ DATA V(100) / .7350086093 0037774536 9706799000 D+00/ DATA V(101) / .4069617876 5067297974 2685260000 D+00/ DATA V(102) / .4482566692 9158295391 6931735480 D+00/ DATA V(103) / .5963473623 2319407434 1078499290 D+00/ DATA V(104) / .7573420861 2217595345 4414369190 D+00/ DATA V(105) / .7578721561 4131210604 3351240000 D+00/ C***FIRST EXECUTABLE STATEMENT DFNCK C C Compute functional values C C Exercise routines in Category C1. C Y( 1) = DBINOM(35,12) Y( 2) = DBINOM(50,15) Y( 3) = DFAC(15) Y( 4) = DFAC(31) C C Exercise routines in Category C2 C Y( 5) = DCBRT(-8.D0) Y( 6) = DCBRT(.9950306243 6570396447 5039000000 D6) C C Exercise routines in Category C4A. C Y( 7) = DCOSDG(30.D0) Y( 8) = DCOSDG(135.D0) Y( 9) = DCOT(1.D0) Y( 10) = DCOT(-.5D0) Y( 11) = D9ATN1(.5D0) Y( 12) = D9ATN1(2.D0) Y( 13) = DSINDG(30.D0) Y( 14) = DSINDG(135.D0) C C Exercise routines in Category C4B. C Y( 15) = DLNREL(.147D0) Y( 16) = DLNREL(-.1D-5) Y( 17) = DEXPRL(.25D-2) Y( 18) = DEXPRL(-.1D-1) Y( 19) = D9LN2R(.5D0) Y( 20) = D9LN2R(1.D0) C C Exercise routines in Category C4C. C Y( 21) = DACOSH(.1006179316 4909482374 7218929626 D1) Y( 22) = DACOSH(.1159195327 5523908462 8557897777 D2) Y( 23) = DASINH(.1000000001 0129514521 1538706587 D0) Y( 24) = DASINH(-.1499999999 4824063412 4264852207 D1) Y( 25) = DATANH(-.1106572080 4138399806 6515207788 D0) Y( 26) = DATANH(.9899999999 9279130066 3084082410 D0) C C Exercise routines in Category C5. C Y( 27) = DLI(.5D0) Y( 28) = DLI(2.D0) Y( 29) = DE1(.5D0) Y( 30) = DE1(1.5D0) Y( 31) = DEI(.5D0) Y( 32) = DEI(1.D0) Y( 33) = DSPENC(.5D0) Y( 34) = DSPENC(1.D0) Y( 35) = DGAMMA(1.5D0) Y( 36) = DGAMMA(-.5D0)*DGAMMA(1.5D0) Y( 37) = DGAMR(-1.5D0)*DGAMR(2.5D0) Y( 38) = DGAMR(10.5D0) C C Exercise routines in Category C7A. C Y( 39) = DPOCH(-.5D0,1.5D0) Y( 40) = DPOCH(.5D0,3.D0) Y( 41) = DPOCH1(.5D0,2.5D0) Y( 42) = DPOCH1(10.5D0,2.D0) C C Exercise routines in Category C7B. C Y( 43) = DBETA(.5D0,1.5D0) Y( 44) = DBETA(5.5D0,5.5D0) C C Exercise routines in Category C7C. C Y( 45) = DPSI(2.D0) Y( 46) = DPSI(10.5D0) C C Exercise routines in Category C7E. C Y( 47) = DGAMI(1.D0,8.85D0) Y( 48) = DGAMI(2.D0,3.75D0) Y( 49) = DGAMIC(1.D0,2.D0) Y( 50) = DGAMIC(2.D0,10.4D0) Y( 51) = DGAMIT(1.D0,.5D0) Y( 52) = DGAMIT(2.D0,3.75D0) C C Exercise routines in Category C7F. C Y( 53) = DBETAI(.5D0,2.D0,1.5D0) Y( 54) = DBETAI(.25D0,1.5D0,2.D0) C C Exercise routines in Category C8A. C Y( 55) = DERF(.5D0) Y( 56) = DERF(1.125D0) C C Exercise routines in Category C8C. C Y( 57) = DDAWS(.5D0) Y( 58) = DDAWS(1.84D0) C C Exercise routines in Category C10A1. C Y( 59) = DBESJ0(5.D0) Y( 60) = DBESJ0(2.D0) Y( 61) = DBESJ1(5.D0) Y( 62) = DBESJ1(2.D0) Y( 63) = DBESY0(2.D0) Y( 64) = DBESY0(5.D0) Y( 65) = DBESY1(5.D0) Y( 66) = DBESY1(2.D0) C C Exercise routines in Category C10B1. C Y( 67) = DBESI0(2.D0) Y( 68) = DBESI0(5.D0) Y( 69) = DBESI1(2.D0) Y( 70) = DBESI1(5.D0) Y( 71) = DBESK0(2.D0) Y( 72) = DBESK0(5.D0) Y( 73) = DBESK1(2.D0) Y( 74) = DBESK1(5.D0) Y( 75) = DBSI0E(2.D0) Y( 76) = DBSI0E(5.D0) Y( 77) = DBSI1E(5.D0) Y( 78) = DBSI1E(2.D0) Y( 79) = DBSK0E(2.D0) Y( 80) = DBSK0E(5.D0) Y( 81) = DBSK1E(5.D0) Y( 82) = DBSK1E(2.D0) C C Exercise routines in Category C10B3. C CALL DBSKES(.5D0,2.D0,3,Y(83)) CALL DBSKES(.5D0,5.D0,3,Y(86)) CALL DBESKS(.5D0,1.D0,2,Y(89)) C C Exercise routines in Category C10D. C Y( 91) = DAI(.5D0) Y( 92) = DAI(2.5D0) Y( 93) = DAIE(.5D0) Y( 94) = DAIE(2.5D0) Y( 95) = DBI(.5D0) Y( 96) = DBI(1.5D0) Y( 97) = DBIE(.5D0) Y( 98) = DBIE(2.5D0) C C Exercise routines in Category C11. C Y( 99) = DCHU(1.D0,2.D0,4.D0) Y(100) = DCHU(5.D0/6.D0,5.D0/3.D0,4.D0/3.D0) Y(101) = DCHU(.75D0,.75D0,2.5D0) Y(102) = DCHU(1.D0,1.D0,1.5D0) Y(103) = DCHU(1.D0,1.D0,1.D0) Y(104) = DCHU(1.D0,1.D0,-LOG(.5D0)) Y(105) = DCHU(.5D0,.5D0,1.D0) C C Check for possible errors C ERRMAX = D1MACH(4) ERRTOL = SQRT(ERRMAX) DO 10 I = 1,105 ABSERR = ABS(V(I)-Y(I)) RELERR = ABSERR/ABS(V(I)) ERRMAX = MAX(RELERR,ERRMAX) IF (RELERR.GT.ERRTOL .AND. KPRINT.GE.2) + WRITE (LUN,620) I,RELERR,ABSERR 10 CONTINUE IPASS = 0 IF (ERRMAX.LE.ERRTOL) IPASS = 1 IF (IPASS.NE.0 .AND. KPRINT.GE.2) WRITE (LUN,610) RETURN 610 FORMAT (' Double precision Fullerton special function ', + ' routines o.k.') 620 FORMAT (' For I = ', I3, ' test fails with RELERR = ', + D38.30, ' and ABSERR = ', D38.30) END *DECK DFQD1 DOUBLE PRECISION FUNCTION DFQD1 (X) C***BEGIN PROLOGUE DFQD1 C***SUBSIDIARY C***PURPOSE Function evaluator for DQNC79 and DGAUS8 quick checks. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (FQD1-S, DFQD1-D) C***AUTHOR Boland, W. Robert, (LANL) C***SEE ALSO DQG8TS, DQN79Q C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 920229 DATE WRITTEN C***END PROLOGUE DFQD1 C .. Scalar Arguments .. DOUBLE PRECISION X C .. Intrinsic Functions .. INTRINSIC SQRT C***FIRST EXECUTABLE STATEMENT DFQD1 DFQD1 = 0.0D0 IF (X .GT. 0.0D0) THEN DFQD1 = 1.0D0/SQRT(X) ENDIF RETURN END *DECK DFQD2 DOUBLE PRECISION FUNCTION DFQD2 (X) C***BEGIN PROLOGUE DFQD2 C***SUBSIDIARY C***PURPOSE Function evaluator for DQNC79 and DGAUS8 quick checks. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (FQD2-S, DFQD2-D) C***AUTHOR Boland, W. Robert, (LANL) C***SEE ALSO DQG8TS, DQN79Q C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 920229 DATE WRITTEN C***END PROLOGUE DFQD2 C .. Scalar Arguments .. DOUBLE PRECISION X C .. Intrinsic Functions .. INTRINSIC COS,EXP C***FIRST EXECUTABLE STATEMENT DFQD2 DFQD2 = EXP(X)*COS(10.0D0*X) RETURN END *DECK DFZTST SUBROUTINE DFZTST (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DFZTST C***PURPOSE Quick check for DFZERO. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (FZTEST-S, DFZTST-D) C***AUTHOR Boland, W. Robert, (LANL) C***ROUTINES CALLED D1MACH, DFZERO, XERCLR, XGETF, XSETF C***REVISION HISTORY (YYMMDD) C 920212 DATE WRITTEN C***END PROLOGUE DFZTST C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. INTEGER IFLAG, KONTRL DOUBLE PRECISION AE, B, C, PI, R, RE, TOL LOGICAL FATAL C .. External Functions .. DOUBLE PRECISION D1MACH EXTERNAL D1MACH C .. External Subroutines .. EXTERNAL DFZERO, XERCLR, XGETF, XSETF C .. Intrinsic Functions .. DOUBLE PRECISION DSIN, DTAN INTRINSIC ABS, ATAN, DSIN, DTAN, MAX, SQRT C***FIRST EXECUTABLE STATEMENT DFZTST IF (KPRINT .GE. 2) WRITE (LUN,9000) IPASS = 1 PI = 4.0D0 *ATAN(1.0D0) RE = 1.0D-10 AE = 1.0D-10 TOL = MAX(1.0D-9,SQRT(D1MACH(4))) C C Set up and solve example problem C B = 0.1D0 C = 4.0D0 R = C - B CALL DFZERO (DSIN, B, C, R, RE, AE, IFLAG) C C See if test was passed. C IF (ABS(B-PI).LE.TOL .AND. ABS(C-PI).LE.TOL) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9010) 'PASSED', B, C, IFLAG ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9010) 'FAILED', B, C, IFLAG ENDIF C C Trigger 2 error conditions C CALL XGETF (KONTRL) IF (KPRINT .LE. 2) THEN CALL XSETF (0) ELSE CALL XSETF (1) ENDIF FATAL = .FALSE. CALL XERCLR C IF (KPRINT .GE. 3) WRITE (LUN,9020) B = 1.0D0 C C IFLAG=3 (Singular point) C C = 2.0D0 R = 0.5D0*(B+C) CALL DFZERO (DTAN, B, C, B, RE, AE, IFLAG) IF (IFLAG .NE. 3) THEN IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 2) WRITE (LUN,9030) IFLAG, 2 ENDIF C C IFLAG=4 (No sign change) C B = -3.0D0 C = -0.1D0 R = 0.5D0*(B+C) CALL DFZERO (DSIN, B, C, R, RE, AE, IFLAG) IF (IFLAG .NE. 4) THEN IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 2) WRITE (LUN,9030) IFLAG, 4 ENDIF C CALL XERCLR C CALL XSETF (KONTRL) IF (FATAL) THEN IF (KPRINT .GE. 2) THEN WRITE (LUN, 9040) ENDIF ELSE IF (KPRINT .GE. 3) THEN WRITE (LUN, 9050) ENDIF ENDIF C IF (IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN,9060) IF (IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN,9070) RETURN 9000 FORMAT ('1' / ' DFZERO QUICK CHECK') 9010 FORMAT (' Accuracy test ', A / + ' Example problem results: (answer = PI), B =', F20.14, + ' C =', F20.14 / ' IFLAG =', I2) 9020 FORMAT (/ ' IFLAG 3 and 4 tests') 9030 FORMAT (/' IFLAG test FAILED. IFLAG =', I2, ', but should ', + 'have been', I2) 9040 FORMAT (/ ' At least IFLAG test failed') 9050 FORMAT (/ ' All IFLAG tests passed') 9060 FORMAT (/' ***************DFZERO PASSED ALL TESTS**************') 9070 FORMAT (/' ***************DFZERO FAILED SOME TESTS*************') END *DECK DGEQC SUBROUTINE DGEQC (LUN, KPRINT, NERR) C***BEGIN PROLOGUE DGEQC C***PURPOSE Quick check for DGEFS. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (SGEQC-S, DGEQC-D, CGEQC-C) C***KEYWORDS QUICK CHECK C***AUTHOR Jacobsen, Nancy, (LANL) C***DESCRIPTION C C Let A*X=B be a DOUBLE PRECISION linear system where the C matrix is of the proper type for the Linpack subroutines C being called. The values of A and B and the pre-computed C values of BXEX (the solution vector) are given in DATA C statements. The computed test results for X are compared to C the stored pre-computed values. Failure of the test occurs C when there is less than 80% agreement between the absolute C values. There are 2 tests - one for the normal case and one C for the singular case. A message is printed indicating C whether each subroutine has passed or failed for each case. C C On return, NERR (INTEGER type) contains the total count of C all failures detected. C C***ROUTINES CALLED D1MACH, DGEFS C***REVISION HISTORY (YYMMDD) C 801022 DATE WRITTEN C 891009 Removed unreferenced statement label. (WRB) C 891009 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920601 Code reworked and TYPE section added. (RWC, WRB) C***END PROLOGUE DGEQC C .. Scalar Arguments .. INTEGER KPRINT, LUN, NERR C .. Local Scalars .. DOUBLE PRECISION ERRCMP, ERRMAX INTEGER I, IND, ITASK, J, KPROG, LDA, N C .. Local Arrays .. DOUBLE PRECISION A(5,4), ATEMP(5,4), B(4), BTEMP(4), BXEX(4), + WORK(20) INTEGER IWORK(4) CHARACTER LIST(2)*4 C .. External Functions .. DOUBLE PRECISION D1MACH EXTERNAL D1MACH C .. External Subroutines .. EXTERNAL DGEFS C .. Intrinsic Functions .. INTRINSIC ABS, MAX C .. Data statements .. DATA A /5.0D0, 1.0D0, 0.3D0, 2.1D0, 0.0D0, + -1.0D0, -0.5D0, 1.0D0, 1.0D0, 0.0D0, + 4.5D0, -1.0D0, -1.7D0, 2.0D0, 0.0D0, + 0.5D0, 2.0D0, 0.6D0, 1.3D0, 0.0D0/ DATA B /0.0D0, 3.5D0, 3.6D0, 2.4D0/ DATA BXEX /0.10D+01, 0.10D+01, -0.10D+01, 0.10D+01/ DATA LIST /'GEFS', 'GEIR'/ C***FIRST EXECUTABLE STATEMENT DGEQC N = 4 LDA = 5 NERR = 0 ERRCMP = D1MACH(4)**0.8D0 IF (KPRINT .GE. 2) WRITE (LUN,9000) C KPROG = 1 C C First test case - normal C ITASK = 1 DO 100 I=1,N BTEMP(I) = B(I) 100 CONTINUE DO 120 J=1,N DO 110 I=1,N ATEMP(I,J) = A(I,J) 110 CONTINUE 120 CONTINUE CALL DGEFS (ATEMP, LDA, N, BTEMP, ITASK, IND, WORK, IWORK) IF (IND .LT. 0) THEN IF (KPRINT .GE. 2) WRITE (LUN, FMT=9020) LIST(KPROG), IND NERR = NERR + 1 ENDIF C C Calculate error for first test C ERRMAX = 0.0D0 C DO 130 I=1,N ERRMAX = MAX(ERRMAX,ABS(BTEMP(I)-BXEX(I))) 130 CONTINUE IF (ERRCMP .GT. ERRMAX) THEN IF (KPRINT .GE. 3) WRITE (LUN, FMT=9010) LIST(KPROG) ELSE IF (KPRINT .GE. 2) WRITE (LUN, FMT=9020) LIST(KPROG), ERRMAX NERR = NERR + 1 ENDIF C C Second test case - singular matrix C ITASK = 1 DO 140 I=1,N BTEMP(I) = B(I) 140 CONTINUE DO 160 J=1,N DO 150 I=1,N ATEMP(I,J) = A(I,J) 150 CONTINUE 160 CONTINUE DO 170 J=1,N ATEMP(1,J) = 0.0D0 170 CONTINUE CALL DGEFS (ATEMP, LDA, N, BTEMP, ITASK, IND, WORK, IWORK) IF (IND .EQ. -4) THEN IF (KPRINT .GE. 3) WRITE (LUN, FMT=9030) LIST(KPROG) ELSE IF (KPRINT .GE. 2) WRITE (LUN, FMT=9040) LIST(KPROG), IND NERR = NERR + 1 ENDIF C IF (KPRINT.GE.3 .AND. NERR.EQ.0) WRITE (LUN,9050) IF (KPRINT.GE.2 .AND. NERR.NE.0) WRITE (LUN,9060) RETURN C 9000 FORMAT (//, 2X, 'DGEFS Quick Check' /) 9010 FORMAT (/, 5X, 'D', A, ' Normal test PASSED') 9020 FORMAT (/, 5X, 'D', A, ' Test FAILED, MAX ABS(ERROR) is', E13.5) 9030 FORMAT (/, 5X, 'D', A, ' Singular test PASSED') 9040 FORMAT (/, 5X, 'D', A, ' Singular test FAILED, IND=', I3) 9050 FORMAT (/, 2X, 'DGEFS Quick Check PASSED' /) 9060 FORMAT (/, 2X, 'SGEFS and SGEIR Quick Check FAILED' /) END *DECK DGVEC SUBROUTINE DGVEC (X, G) C***BEGIN PROLOGUE DGVEC C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DGVEC DOUBLE PRECISION X,G DIMENSION G(*) C***FIRST EXECUTABLE STATEMENT DGVEC G(1) = 0.0D0 G(2) = 1.0D0+COS(X) RETURN END *DECK DJAC SUBROUTINE DJAC (T, U, PD, NROWPD, RPAR, IPAR) C***BEGIN PROLOGUE DJAC C***SUBSIDIARY C***PURPOSE Evaluate Jacobian for DDEBDF quick check. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (JAC-S, DJAC-D) C***AUTHOR Chow, Jeff (LANL) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 810801 DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 900415 Minor clean-up of prologue and code and name changed from C DDJAC to DJAC. (WRB) C***END PROLOGUE DJAC INTEGER IPAR, NROWPD DOUBLE PRECISION PD, R, R5, RPAR, RSQ, T, U, U1SQ, U2SQ, U1U2 DIMENSION U(*), PD(NROWPD,*), RPAR(*), IPAR(*) C***FIRST EXECUTABLE STATEMENT DJAC U1SQ = U(1)*U(1) U2SQ = U(2)*U(2) U1U2 = U(1)*U(2) RSQ = U1SQ + U2SQ R = SQRT(RSQ) R5 = RSQ*RSQ*R PD(3,1) = (3.D0*U1SQ - RSQ)/R5 PD(4,1) = 3.D0*U1U2/R5 PD(3,2) = PD(4,1) PD(4,2) = (3.D0*U2SQ - RSQ)/R5 PD(1,3) = 1.D0 PD(2,4) = 1.D0 RETURN END *DECK DLSEIT SUBROUTINE DLSEIT (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DLSEIT C***PURPOSE Quick check for DLSEI. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (LSEIQX-S, DLSEIT-D) C***KEYWORDS QUICK CHECK C***AUTHOR Hanson, R. J., (SNLA) C Haskell, Karen, (SNLA) C***DESCRIPTION C C THE SAMPLE PROBLEM SOLVED IS FROM A PAPER BY J. STOER, IN C SIAM JOURNAL OF NUM. ANAL., JUNE 1971. C C***ROUTINES CALLED D1MACH, DAXPY, DCOPY, DDOT, DLSEI, DNRM2, DVOUT C***REVISION HISTORY (YYMMDD) C 790216 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF, modified tolerances C to use R1MACH(4) rather than R1MACH(3) and cleaned up C FORMATs. (RWC) C***END PROLOGUE DLSEIT IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION D(11,6), IP(17), WORK(105), F(6), PRGOPT(4) DIMENSION X(5), H(5), SOL(5), A(6,5), G(5,5), ERR(5) C C DEFINE THE DATA ARRAYS FOR THE EXAMPLE. THE ARRAY A( ) C CONTAINS THE LEAST SQUARES EQUATIONS. (THERE ARE NO EQUALITY C CONSTRAINTS IN THIS EXAMPLE). C DATA A(1,1),A(1,2),A(1,3),A(1,4),A(1,5) * /-74.0D0,80.0D0,18.0D0,-11.0D0,-4.0D0/ DATA A(2,1),A(2,2),A(2,3),A(2,4),A(2,5) * /14.0D0,-69.0D0,21.0D0,28.0D0,0.0D0/ DATA A(3,1),A(3,2),A(3,3),A(3,4),A(3,5) * /66.0D0,-72.0D0,-5.0D0,7.0D0,1.0D0/ DATA A(4,1),A(4,2),A(4,3),A(4,4),A(4,5) * /-12.0D0,66.0D0,-30.0D0,-23.0D0,3.0D0/ DATA A(5,1),A(5,2),A(5,3),A(5,4),A(5,5) * /3.0D0,8.0D0,-7.0D0,-4.0D0,1.0D0/ DATA A(6,1),A(6,2),A(6,3),A(6,4),A(6,5) * /4.0D0,-12.0D0,4.0D0,4.0D0,0.0D0/ C C THE ARRAY G( ) CONTAINS THE INEQUALITY CONSTRAINT EQUATIONS, C WRITTEN IN THE SENSE C (ROW VECTOR)*(SOLUTION VECTOR) .GE. (GIVEN VALUE). C DATA G(1,1),G(1,2),G(1,3),G(1,4),G(1,5) * /-1.0D0,-1.0D0,-1.0D0,-1.0D0,-1.0D0/ DATA G(2,1),G(2,2),G(2,3),G(2,4),G(2,5) * /10.0D0,10.0D0,-3.0D0,5.0D0,4.0D0/ DATA G(3,1),G(3,2),G(3,3),G(3,4),G(3,5) * /-8.0D0,1.0D0,-2.0D0,-5.0D0,3.0D0/ DATA G(4,1),G(4,2),G(4,3),G(4,4),G(4,5) * /8.0D0,-1.0D0,2.0D0,5.0D0,-3.0D0/ DATA G(5,1),G(5,2),G(5,3),G(5,4),G(5,5) * /-4.0D0,-2.0D0,3.0D0,-5.0D0,1.0D0/ C C DEFINE THE LEAST SQUARES RIGHT-SIDE VECTOR. C DATA F(1),F(2),F(3),F(4),F(5),F(6) * /-5.0D0,-9.0D0,708.0D0,4165.0D0,-13266.0D0,8409.0D0/ C C DEFINE THE INEQUALITY CONSTRAINT RIGHT-SIDE VECTOR. C DATA H(1),H(2),H(3),H(4),H(5) * /-5.0D0,20.0D0,-40.0D0,11.0D0,-30.0D0/ C C DEFINE THE VECTOR THAT IS THE KNOWN SOLUTION. C DATA SOL(1),SOL(2),SOL(3),SOL(4),SOL(5) * /1.0D0,2.0D0,-1.0D0,3.0D0,-4.0D0/ C***FIRST EXECUTABLE STATEMENT DLSEIT C C DEFINE THE MATRIX DIMENSIONS, NUMBER OF LEAST SQUARES EQUATIONS, C NUMBER OF EQUALITY CONSTRAINTS, TOTAL NUMBER OF C EQUATIONS, AND NUMBER OF VARIABLES. SET ME=0 TO INDICATE C THERE ARE NO EQUALITY CONSTRAINTS. C MDD = 11 MDA = 6 MDG = 5 MA = 6 MG = 5 M = MA + MG N = 5 ME = 0 C NP1 = N + 1 MEP1 = ME + 1 MEAP1 = ME + MA + 1 C C COPY THE PROBLEM MATRICES C DO 10 I = 1, N C C COPY THE I-TH COL OF THE INEQUALITY CONSTRAINT MATRIX INTO C THE WORK ARRAY. C CALL DCOPY(MG, G(1,I), 1, D(MEAP1,I), 1) C C COPY THE I-TH COL OF THE LEAST SQUARES MATRIX INTO THE WORK C ARRAY. C CALL DCOPY(MA, A(1,I), 1, D(MEP1,I), 1) 10 CONTINUE C C COPY THE RIGHT-SIDE VECTORS INTO THE WORK ARRAY IN COMPATIBLE C ORDER. C CALL DCOPY(MG, H, 1, D(MEAP1,NP1), 1) CALL DCOPY(MA, F, 1, D(MEP1,NP1), 1) C IF (KPRINT.GE.2) WRITE (LUN,99999) C C USE DEFAULT PROGRAM OPTIONS IN DLSEI, AND SET MATRIX-VECTOR C PRINTING ACCURACY PARAMETERS. C PRGOPT(1) = 1 IDIGIT = -4 JDIGIT = -11 C C COMPUTE RESIDUAL NORM OF KNOWN LEAST SQUARES SOLN. C (TO BE USED TO CHECK COMPUTED RESIDUAL NORM = RNORML.) C DO 20 I = 1, MA WORK(I) = DDOT(N,D(I,1),MDD,SOL,1) - F(I) 20 CONTINUE RESNRM = DNRM2(MA,WORK,1) C C CALL DLSEI TO GET SOLN IN X(*), LEAST SQUARES RESIDUAL IN RNORML. C CALL DLSEI(D, MDD, ME, MA, MG, N, PRGOPT, X, RNORME, RNORML, MODE, * WORK, IP) C C COMPUTE REL. ERROR IN PROBLEM VARIABLE SOLN. AND RESIDUAL C NORM COMPUTATION. C TNORM = DNRM2(N,SOL,1) CALL DCOPY(N, SOL, 1, ERR, 1) CALL DAXPY(N, -1.0D0, X, 1, ERR, 1) CNORM = DNRM2(N, ERR, 1) RELERR = CNORM/TNORM RELNRM = (RESNRM-RNORML)/RESNRM C IF (RELERR .LE. 70.0D0*SQRT(D1MACH(4)) .AND. * RELNRM .LT. 5.0D0*D1MACH(4)) THEN IPASS = 1 IF (KPRINT.GE.3) WRITE (LUN,99998) ELSE IPASS = 0 IF (KPRINT.GE.2) WRITE (LUN,99997) RELERR, RELNRM ENDIF C C PRINT OUT KNOWN SOLUTION AND COMPUTED SOLUTION C IF (KPRINT.GE.3) THEN CALL DVOUT(N, ERR, * '('' RESIDUALS FROM KNOWN LEAST SQUARES SOLN'')', IDIGIT) CALL DVOUT(N, X, '(/'' SOLN COMPUTED BY DLSEI.'')', JDIGIT) ENDIF C IF (KPRINT.GE.2) THEN IF (.NOT.(KPRINT.EQ.2 .AND. IPASS.NE.0)) THEN C C PRINT OUT THE KNOWN AND COMPUTED RESIDUAL NORMS C CALL DVOUT(1, RESNRM, * '(/'' RESIDUAL NORM OF KNOWN LEAST SQUARES SOLN'')', * JDIGIT) CALL DVOUT(1, RNORML, '(/'' RES NORM COMPUTED BY DLSEI.'')', * JDIGIT) C C PRINT OUT THE COMPUTED SOLUTION RELATIVE ERROR C CALL DVOUT(1, RELERR, '(/'' COMPUTED SOLN REL. ERROR'')', * IDIGIT) C C PRINT OUT THE COMPUTED RELATIVE ERROR IN RESIDUAL NORM C CALL DVOUT(1, RELNRM, * '(/'' COMPUTED REL. ERROR IN RESIDUAL NORM'')', IDIGIT) ENDIF ENDIF C C CHECK CALLS TO ERROR PROCESSOR C IF (KPRINT.GE.2) THEN WRITE (LUN,99996) CALL DLSEI(D, 0, ME, MA, MG, N, PRGOPT, X, RNORME, RNORML, * MODE, WORK, IP) PRGOPT(1) = -1 CALL DLSEI(D, MDD, ME, MA, MG, N, PRGOPT, X, RNORME, RNORML, * MODE, WORK, IP) ENDIF C IF (IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN,99995) IF (IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN,99994) RETURN C 99994 FORMAT (/' ****************DLSEI FAILED SOME TESTS**************') 99995 FORMAT (/' ****************DLSEI PASSED ALL TESTS***************') 99996 FORMAT (/ ' 2 ERROR MESSAGES EXPECTED') 99997 FORMAT (/' DLSEI FAILED TEST'/' RELERR = ',1P,D20.6/' RELNRM = ', * D20.6) 99998 FORMAT (/' DLSEI PASSED TEST') 99999 FORMAT ('1TEST OF SUBROUTINE DLSEI') END *DECK DNLS1Q SUBROUTINE DNLS1Q (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DNLS1Q C***PURPOSE Quick check for DNLS1E, DNLS1, and DCOV. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C THIS SUBROUTINE PERFORMS A QUICK CHECK ON THE SUBROUTINES DNLS1E C (AND DNLS1) AND DCOV. C C***ROUTINES CALLED D1MACH, DCOV, DENORM, DFCN1, DFCN2, DFCN3, DFDJC3, C DNLS1E, PASS C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DNLS1Q IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER ICNT, ITEST(8) DIMENSION X(2),FVEC(10),FJAC(10,2),FJROW(2),WA(40),IW(2),FJTJ(3) EXTERNAL DFCN1,DFCN2,DFCN3 C***FIRST EXECUTABLE STATEMENT DNLS1Q INFOS=1 FNORMS=0.11151779D+02 M=10 N=2 LWA=40 LDFJAC=10 NPRINT=-1 IFLAG=1 ZERO=0.D0 ONE=1.D0 TOL=MAX(SQRT(40.D0*D1MACH(4)),1.D-12) TOL2=SQRT(TOL) IF (KPRINT.GE.2) WRITE(LUN,1000) C C OPTION=2, THE FULL JACOBIAN IS STORED AND THE USER PROVIDES THE C JACOBIAN. IOPT=2 X(1)=3.D-1 X(2)=4.D-1 CALL DNLS1E(DFCN2,IOPT,M,N,X,FVEC,TOL,NPRINT,INFO, * IW,WA,LWA) ICNT=1 FNORM=DENORM(M,FVEC) ITEST(ICNT)=0 IF ((INFO.EQ.INFOS) .AND. (ABS(FNORM-FNORMS)/FNORMS.LE.TOL2)) * ITEST(ICNT)=1 IF (KPRINT.EQ.0) GO TO 15 IF ((KPRINT.GE.2.AND.ITEST(ICNT).NE.1).OR.KPRINT.GE.3) * WRITE(LUN,1010) INFOS,FNORMS,INFO,FNORM IF((KPRINT.GE.2).OR.(KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) * CALL PASS (LUN, ICNT, ITEST(ICNT)) 15 CONTINUE C C FORM JAC-TRANSPOSE*JAC SIGMA=FNORM*FNORM/(M-N) IFLAG = 2 CALL DFCN2(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) DO 10 I=1,3 10 FJTJ(I)=ZERO DO 11 I=1,M FJTJ(1)=FJTJ(1)+FJAC(I,1)**2 FJTJ(2)=FJTJ(2)+FJAC(I,1)*FJAC(I,2) FJTJ(3)=FJTJ(3)+FJAC(I,2)**2 11 CONTINUE C C CALCULATE COVARIANCE MATRIX CALL DCOV(DFCN2,IOPT,M,N,X,FVEC,FJAC,LDFJAC,INFO, *WA(1),WA(N+1),WA(2*N+1),WA(3*N+1)) C C FORM JAC-TRANSPOSE*JAC * COVARIANCE MATRIX C (SHOULD = SIGMA*I) TEMP1=(FJTJ(1)*FJAC(1,1)+FJTJ(2)*FJAC(1,2))/SIGMA TEMP2=(FJTJ(1)*FJAC(1,2)+FJTJ(2)*FJAC(2,2))/SIGMA TEMP3=(FJTJ(2)*FJAC(1,2)+FJTJ(3)*FJAC(2,2))/SIGMA ICNT=5 ITEST(ICNT)=0 IF (INFO.EQ.INFOS .AND. ABS(TEMP1-ONE).LT.TOL2 .AND. * ABS(TEMP2).LT.TOL2 .AND. ABS(TEMP3-ONE).LT.TOL2) *ITEST(ICNT)=1 IF (KPRINT.EQ.0) GO TO 20 IF ((KPRINT.GE.2.AND.ITEST(ICNT).NE.1).OR.KPRINT.GE.3) * WRITE(LUN,1020) INFOS,INFO,TEMP1,TEMP2,TEMP3 IF((KPRINT.GE.2).OR.(KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) * CALL PASS (LUN, ICNT, ITEST(ICNT)) C C OPTION=1, THE FULL JACOBIAN IS STORED AND THE CODE APPROXIMATES C THE JACOBIAN. 20 IOPT=1 X(1)=3.D-1 X(2)=4.D-1 CALL DNLS1E(DFCN1,IOPT,M,N,X,FVEC,TOL,NPRINT,INFO, * IW,WA,LWA) ICNT=2 FNORM=DENORM(M,FVEC) ITEST(ICNT)=0 IF ((INFO.EQ.INFOS).AND.(ABS(FNORM-FNORMS)/FNORMS.LE.TOL2)) * ITEST(ICNT)=1 IF (KPRINT.EQ.0) GO TO 25 IF ((KPRINT.GE.2.AND.ITEST(ICNT).NE.1).OR.KPRINT.GE.3) * WRITE(LUN,1010) INFOS,FNORMS,INFO,FNORM IF((KPRINT.GE.2).OR.(KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) * CALL PASS (LUN, ICNT, ITEST(ICNT)) 25 CONTINUE C C FORM JAC-TRANSPOSE*JAC SIGMA=FNORM*FNORM/(M-N) IFLAG = 1 CALL DFDJC3(DFCN1,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,ZERO,WA) DO 26 I=1,3 26 FJTJ(I)=ZERO DO 27 I=1,M FJTJ(1)=FJTJ(1)+FJAC(I,1)**2 FJTJ(2)=FJTJ(2)+FJAC(I,1)*FJAC(I,2) FJTJ(3)=FJTJ(3)+FJAC(I,2)**2 27 CONTINUE C C CALCULATE COVARIANCE MATRIX CALL DCOV(DFCN1,IOPT,M,N,X,FVEC,FJAC,LDFJAC,INFO, *WA(1),WA(N+1),WA(2*N+1),WA(3*N+1)) C C FORM JAC-TRANSPOSE*JAC * COVARIANCE MATRIX C (SHOULD = SIGMA*I) TEMP1=(FJTJ(1)*FJAC(1,1)+FJTJ(2)*FJAC(1,2))/SIGMA TEMP2=(FJTJ(1)*FJAC(1,2)+FJTJ(2)*FJAC(2,2))/SIGMA TEMP3=(FJTJ(2)*FJAC(1,2)+FJTJ(3)*FJAC(2,2))/SIGMA ICNT=6 ITEST(ICNT)=0 IF (INFO.EQ.INFOS .AND. ABS(TEMP1-ONE).LT.TOL2 .AND. * ABS(TEMP2).LT.TOL2 .AND. ABS(TEMP3-ONE).LT.TOL2) *ITEST(ICNT)=1 IF (KPRINT.EQ.0) GO TO 30 IF ((KPRINT.GE.2.AND.ITEST(ICNT).NE.1).OR.KPRINT.GE.3) * WRITE(LUN,1020) INFOS,INFO,TEMP1,TEMP2,TEMP3 IF((KPRINT.GE.2).OR.(KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) * CALL PASS (LUN, ICNT, ITEST(ICNT)) C C OPTION=3, THE FULL JACOBIAN IS NOT STORED ONLY THE PRODUCT OF THE C JACOBIAN TRANSPOSE AND JACOBIAN IS STORED. THE USER PROVIDES THE C THE JACOBIAN ONE ROW AT A TIME. 30 IOPT=3 X(1)=3.D-1 X(2)=4.D-1 CALL DNLS1E(DFCN3,IOPT,M,N,X,FVEC,TOL,NPRINT,INFO, * IW,WA,LWA) ICNT=3 FNORM=DENORM(M,FVEC) ITEST(ICNT)=0 IF ((INFO.EQ.INFOS).AND.(ABS(FNORM-FNORMS)/FNORMS.LE.TOL2)) * ITEST(ICNT)=1 IF (KPRINT.EQ.0) GO TO 35 IF ((KPRINT.GE.2.AND.ITEST(ICNT).NE.1).OR.KPRINT.GE.3) * WRITE(LUN,1010) INFOS,FNORMS,INFO,FNORM IF((KPRINT.GE.2).OR.(KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) * CALL PASS (LUN, ICNT, ITEST(ICNT)) 35 CONTINUE C C FORM JAC-TRANSPOSE*JAC SIGMA=FNORM*FNORM/(M-N) DO 36 I=1,3 36 FJTJ(I)=ZERO IFLAG=3 DO 37 I=1,M CALL DFCN3(IFLAG,M,N,X,FVEC,FJROW,I) FJTJ(1)=FJTJ(1)+FJROW(1)**2 FJTJ(2)=FJTJ(2)+FJROW(1)*FJROW(2) FJTJ(3)=FJTJ(3)+FJROW(2)**2 37 CONTINUE C C CALCULATE COVARIANCE MATRIX CALL DCOV(DFCN3,IOPT,M,N,X,FVEC,FJAC,LDFJAC,INFO, *WA(1),WA(N+1),WA(2*N+1),WA(3*N+1)) C C FORM JAC-TRANSPOSE*JAC * COVARIANCE MATRIX C (SHOULD = SIGMA*I) TEMP1=(FJTJ(1)*FJAC(1,1)+FJTJ(2)*FJAC(1,2))/SIGMA TEMP2=(FJTJ(1)*FJAC(1,2)+FJTJ(2)*FJAC(2,2))/SIGMA TEMP3=(FJTJ(2)*FJAC(1,2)+FJTJ(3)*FJAC(2,2))/SIGMA ICNT=7 ITEST(ICNT)=0 IF (INFO.EQ.INFOS .AND. ABS(TEMP1-ONE).LT.TOL2 .AND. * ABS(TEMP2).LT.TOL2 .AND. ABS(TEMP3-ONE).LT.TOL2) *ITEST(ICNT)=1 IF (KPRINT.EQ.0) GO TO 40 IF ((KPRINT.GE.2.AND.ITEST(ICNT).NE.1).OR.KPRINT.GE.3) * WRITE(LUN,1020) INFOS,INFO,TEMP1,TEMP2,TEMP3 IF((KPRINT.GE.2).OR.(KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) * CALL PASS (LUN, ICNT, ITEST(ICNT)) C C TEST IMPROPER INPUT PARAMETERS 40 LWA=35 IOPT=2 X(1)=3.D-1 X(2)=4.D-1 CALL DNLS1E(DFCN2,IOPT,M,N,X,FVEC,TOL,NPRINT,INFO, * IW,WA,LWA) ICNT=4 ITEST(ICNT)=0 IF (INFO.EQ.0) ITEST(ICNT)=1 IF((KPRINT.GE.2).OR.(KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) * CALL PASS (LUN, ICNT, ITEST(ICNT)) ITEST(8)=1 IF(KPRINT.LT.3) GO TO 999 M=0 CALL DCOV(DFCN2,IOPT,M,N,X,FVEC,FJAC,LDFJAC,INFO, *WA(1),WA(N+1),WA(2*N+1),WA(3*N+1)) ICNT=8 ITEST(ICNT)=0 IF (INFO.EQ.0) ITEST(ICNT)=1 IF((KPRINT.GE.2).OR.(KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) * CALL PASS (LUN, ICNT, ITEST(ICNT)) C C SET IPASS 999 IPASS=ITEST(1)*ITEST(2)*ITEST(3)*ITEST(4) IPASS=IPASS*ITEST(5)*ITEST(6)*ITEST(7)*ITEST(8) RETURN 1000 FORMAT(1H1,19H DNLS1E QUICK CHECK/) 1010 FORMAT(41H EXPECTED VALUE OF INFO AND RESIDUAL NORM,I5,D20.9/ * 41H RETURNED VALUE OF INFO AND RESIDUAL NORM,I5,D20.9/) 1020 FORMAT(36H EXPECTED AND RETURNED VALUE OF INFO,I5,10X,I5/ *56H RETURNED PRODUCT OF (J-TRANS*J)*COVARIANCE MATRIX/SIGMA/ *41H (SHOULD = THE IDENTITY -- 1.0, 0.0, 1.0)/3D20.9/) END *DECK DNSQQK SUBROUTINE DNSQQK (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DNSQQK C***PURPOSE Quick check for DNSQE and DNSQ. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (SNSQQK-S, DNSQQK-D) C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C This subroutine performs a quick check on the subroutine DNSQE C (and DNSQ). C C***ROUTINES CALLED D1MACH, DENORM, DNSQE, DQFCN2, DQJAC2, PASS C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920310 Code cleaned up and TYPE section added. (RWC, WRB) C***END PROLOGUE DNSQQK C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. DOUBLE PRECISION FNORM, FNORMS, TOL INTEGER ICNT, INFO, INFOS, IOPT, LWA, N, NPRINT C .. Local Arrays .. DOUBLE PRECISION FVEC(2), WA(19), X(2) INTEGER ITEST(3) C .. External Functions .. DOUBLE PRECISION D1MACH, DENORM EXTERNAL D1MACH, DENORM C .. External Subroutines .. EXTERNAL DNSQE, DQFCN2, DQJAC2, PASS C .. Intrinsic Functions .. INTRINSIC SQRT C***FIRST EXECUTABLE STATEMENT DNSQQK INFOS = 1 FNORMS = 0.0D0 N = 2 LWA = 19 NPRINT = -1 TOL = SQRT(D1MACH(4)) IF (KPRINT .GE. 2) WRITE (LUN,9000) C C Option 1, the user provides the Jacobian. C IOPT = 1 X(1) = -1.2D0 X(2) = 1.0D0 CALL DNSQE (DQFCN2,DQJAC2,IOPT,N,X,FVEC,TOL,NPRINT,INFO,WA,LWA) ICNT = 1 FNORM = DENORM(N,FVEC) ITEST(ICNT) = 0 IF ((INFO.EQ.INFOS) .AND. (FNORM-FNORMS.LE.TOL)) ITEST(ICNT) = 1 C IF (KPRINT .NE. 0) THEN IF ((KPRINT.GE.2 .AND. ITEST(ICNT).NE.1) .OR. KPRINT.GE.3) + WRITE (LUN,9010) INFOS,FNORMS,INFO,FNORM IF ((KPRINT.GE.2) .OR. (KPRINT.EQ.1 .AND. ITEST(ICNT).NE.1)) + CALL PASS (LUN, ICNT, ITEST(ICNT)) ENDIF C C Option 2, the code approximates the Jacobian. C IOPT = 2 X(1) = -1.2D0 X(2) = 1.0D0 CALL DNSQE (DQFCN2,DQJAC2,IOPT,N,X,FVEC,TOL,NPRINT,INFO,WA,LWA) ICNT = 2 FNORM = DENORM(N,FVEC) ITEST(ICNT) = 0 IF ((INFO.EQ.INFOS) .AND. (FNORM-FNORMS.LE.TOL)) ITEST(ICNT) = 1 C IF (KPRINT .NE. 0) THEN IF (KPRINT.GE.3 .OR. (KPRINT.GE.2.AND.ITEST(ICNT).NE.1)) + WRITE (LUN,9010) INFOS, FNORMS, INFO, FNORM IF (KPRINT.GE.2 .OR. (KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) + CALL PASS (LUN, ICNT, ITEST(ICNT)) ENDIF C C Test improper input parameters. C LWA = 15 IOPT = 1 X(1) = -1.2D0 X(2) = 1.0D0 CALL DNSQE (DQFCN2,DQJAC2,IOPT,N,X,FVEC,TOL,NPRINT,INFO,WA,LWA) ICNT = 3 ITEST(ICNT) = 0 IF (INFO .EQ. 0) ITEST(ICNT) = 1 IF (KPRINT.GE.2 .OR. (KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) + CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Set IPASS. C IPASS = ITEST(1)*ITEST(2)*ITEST(3) IF (KPRINT.GE.1 .AND. IPASS.NE.1) WRITE (LUN,9020) IF (KPRINT.GE.2 .AND. IPASS.EQ.1) WRITE (LUN,9030) RETURN 9000 FORMAT ('1' / ' DNSQE QUICK CHECK'/) 9010 FORMAT (' EXPECTED VALUE OF INFO AND RESIDUAL NORM', I5, D20.5 / + ' RETURNED VALUE OF INFO AND RESIDUAL NORM', I5, D20.5 /) 9020 FORMAT (/' **********WARNING -- DNSQE/DNSQ FAILED SOME TESTS****', + '******') 9030 FORMAT (/' ----------DNSQE/DNSQ PASSED ALL TESTS----------') END *DECK DPCHQ1 SUBROUTINE DPCHQ1 (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DPCHQ1 C***PURPOSE Test the PCHIP evaluators DCHFDV, DCHFEV, DPCHFD, DPCHFE. C***LIBRARY SLATEC (PCHIP) C***TYPE DOUBLE PRECISION (PCHQK1-S, DPCHQ1-D) C***KEYWORDS PCHIP EVALUATOR QUICK CHECK C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C DPCHIP QUICK CHECK NUMBER 1 C C TESTS THE EVALUATORS: DCHFDV, DCHFEV, DPCHFD, DPCHFE. C *Usage: C C INTEGER LUN, KPRINT, IPASS C C CALL DPCHQ1 (LUN, KPRINT, IPASS) C C *Arguments: C C LUN :IN is the unit number to which output is to be written. C C KPRINT:IN controls the amount of output, as specified in the C SLATEC Guidelines. C C IPASS:OUT will contain a pass/fail flag. IPASS=1 is good. C IPASS=0 indicates one or more tests failed. C C *Description: C C This routine carries out three tests of the PCH evaluators: C DEVCHK tests the single-cubic evaluators. C DEVPCK tests the full PCH evaluators. C DEVERK exercises the error returns in all evaluators. C C***ROUTINES CALLED DEVCHK, DEVERK, DEVPCK C***REVISION HISTORY (YYMMDD) C 820601 DATE WRITTEN C 890306 Changed IPASS to the more accurate name IFAIL. (FNF) C 890307 Removed conditional on call to DEVERK. C 890706 Cosmetic changes to prologue. (WRB) C 891004 Correction in prologue. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900309 Added DEVERK to list of routines called. (FNF) C 900314 Improved some output formats. C 900315 Revised prologue and improved some output formats. (FNF) C 900316 Additional minor cosmetic changes. (FNF) C 900321 Removed IFAIL from call sequence for SLATEC standards and C made miscellaneous cosmetic changes. (FNF) C***END PROLOGUE DPCHQ1 C C Declare arguments. C INTEGER LUN, KPRINT, IPASS C C DECLARE LOCAL VARIABLES. C INTEGER I1, I2, I3, I4, I5, I6, I7, I8, I9, IFAIL, NPTS DOUBLE PRECISION WORK (4000) LOGICAL FAIL C C***FIRST EXECUTABLE STATEMENT DPCHQ1 IF (KPRINT .GE. 2) WRITE (LUN, 1000) C C TEST DCHFDV AND DCHFEV. C IFAIL = 0 NPTS = 1000 I1 = 1 + NPTS I2 = I1 + NPTS I3 = I2 + NPTS CALL DEVCHK (LUN, KPRINT, NPTS, WORK(1), WORK(I1), WORK(I2), * WORK(I3), FAIL) IF (FAIL) IFAIL = IFAIL + 1 C C TEST DPCHFD AND DPCHFE. C I1 = 1 + 10 I2 = I1 + 10 I3 = I2 + 100 I4 = I3 + 100 I5 = I4 + 100 I6 = I5 + 51 I7 = I6 + 51 I8 = I7 + 51 I9 = I8 + 51 CALL DEVPCK (LUN, KPRINT, WORK(1), WORK(I1), WORK(I2), WORK(I3), * WORK(I4), WORK(I5), WORK(I6), WORK(I7), WORK(I8), * WORK(I9), FAIL) IF (FAIL) IFAIL = IFAIL + 2 C C TEST ERROR RETURNS. C CALL DEVERK (LUN, KPRINT, FAIL) IF (FAIL) IFAIL = IFAIL + 4 C C PRINT SUMMARY AND TERMINATE. C At this point, IFAIL has the following value: C IFAIL = 0 IF ALL TESTS PASSED. C IFAIL BETWEEN 1 AND 7 IS THE SUM OF: C IFAIL=1 IF SINGLE CUBIC TEST FAILED. (SEE DEVCHK OUTPUT.) C IFAIL=2 IF DPCHFD/DPCHFE TEST FAILED. (SEE DEVPCK OUTPUT.) C IFAIL=4 IF ERROR RETURN TEST FAILED. (SEE DEVERK OUTPUT.) C IF ((KPRINT.GE.2).AND.(IFAIL.NE.0)) WRITE (LUN, 3001) IFAIL C IF (IFAIL.EQ.0) THEN IPASS = 1 IF (KPRINT.GE.2) WRITE(LUN,99998) ELSE IPASS = 0 IF (KPRINT.GE.1) WRITE(LUN,99999) ENDIF C RETURN C C FORMATS. C 1000 FORMAT ('1'/' ------------ DPCHIP QUICK CHECK OUTPUT', . ' ------------') 3001 FORMAT (/' *** TROUBLE ***',I5,' EVALUATION TESTS FAILED.') 99998 FORMAT (/' ------------ DPCHIP PASSED ALL EVALUATION TESTS', . ' ------------') 99999 FORMAT (/' ************ DPCHIP FAILED SOME EVALUATION TESTS', . ' ************') C------------- LAST LINE OF DPCHQ1 FOLLOWS ----------------------------- END *DECK DPCHQ2 SUBROUTINE DPCHQ2 (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DPCHQ2 C***PURPOSE Test the PCHIP integrators DPCHIA and DPCHID. C***LIBRARY SLATEC (PCHIP) C***TYPE DOUBLE PRECISION (PCHQK2-S, DPCHQ2-D) C***KEYWORDS PCHIP INTEGRATOR QUICK CHECK C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C DPCHIP QUICK CHECK NUMBER 2 C C TESTS THE INTEGRATORS: DPCHIA, DPCHID. C *Usage: C C INTEGER LUN, KPRINT, IPASS C C CALL DPCHQ2 (LUN, KPRINT, IPASS) C C *Arguments: C C LUN :IN is the unit number to which output is to be written. C C KPRINT:IN controls the amount of output, as specified in the C SLATEC Guidelines. C C IPASS:OUT will contain a pass/fail flag. IPASS=1 is good. C IPASS=0 indicates one or more tests failed. C C *Description: C C This routine constructs data from a cubic, integrates it with DPCHIA C and compares the results with the correct answer. C Since DPCHIA calls DPCHID, this tests both integrators. C C***ROUTINES CALLED D1MACH, DPCHIA C***REVISION HISTORY (YYMMDD) C 820601 DATE WRITTEN C 890306 Changed IPASS to the more accurate name IFAIL. (FNF) C 890316 1. Removed IMPLICIT statement. (FNF) C 2. Eliminated unnecessary variable N1. (FNF) C 3. Miscellaneous cosmetic changes. (FNF) C 891004 Cosmetic changes to prologue. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900314 Improved some output formats. (FNF) C 900315 Revised prologue and improved some output formats. (FNF) C 900316 Additional minor cosmetic changes. (FNF) C 900321 Removed IFAIL from call sequence for SLATEC standards and C made miscellaneous cosmetic changes. (FNF) C 900323 Corrected list of routines called. (FNF) C 901130 Added 1P's to formats; changed to allow KPRINT.gt.3. (FNF) C 910708 Minor modifications in use of KPRINT. (WRB) C***END PROLOGUE DPCHQ2 C C Declare arguments. C INTEGER LUN, KPRINT, IPASS C C DECLARE VARIABLES. C INTEGER I, IEREXP(17), IERR, IFAIL, N, NPAIRS DOUBLE PRECISION * A(17), B(17), CALC, D(7), ERRMAX, ERROR, F(7), MACHEP, * ONE, THREE, THRQTR, TOL, TRUE, TWO, X(7) LOGICAL FAIL, SKIP C C DECLARE EXTERNALS. C DOUBLE PRECISION DPCHIA, D1MACH C C DEFINE TEST FUNCTIONS. C DOUBLE PRECISION AX, FCN, DERIV, ANTDER FCN(AX) = THREE*AX*AX*(AX-TWO) DERIV(AX) = THREE*AX*(TWO*(AX-TWO) + AX) ANTDER(AX) = AX**3 * (THRQTR*AX - TWO) C C INITIALIZE. C DATA THRQTR /0.75D0/, ONE /1.D0/, TWO /2.D0/, THREE /3.D0/ DATA N /7/ DATA X /-4.D0, -2.D0, -0.9D0, 0.D0, 0.9D0, 2.D0, 4.D0/ DATA NPAIRS /17/ DATA A /-3.0D0, 3.0D0,-0.5D0,-0.5D0,-0.5D0,-4.0D0,-4.0D0, 3.0D0, * -5.0D0,-5.0D0,-6.0D0, 6.0D0,-1.5D0,-1.5D0,-3.0D0, 3.0D0, 0.5D0/ DATA B / 3.0D0,-3.0D0, 1.0D0, 2.0D0, 5.0D0,-0.5D0, 4.0D0, 5.0D0, * -3.0D0, 5.0D0,-5.0D0, 5.0D0,-0.5D0,-1.0D0,-2.5D0, 3.5D0, 0.5D0/ DATA IEREXP /0,0,0,0,2,0,0,2,1,3,3,3,0,0,0,0,0/ C C SET PASS/FAIL TOLERANCE. C C***FIRST EXECUTABLE STATEMENT DPCHQ2 MACHEP = D1MACH(4) TOL = 100.D0*MACHEP C C SET UP PCH FUNCTION DEFINITION. C DO 10 I = 1, N F(I) = FCN(X(I)) D(I) = DERIV(X(I)) 10 CONTINUE C IF (KPRINT .GE. 3) WRITE (LUN, 1000) (X(I), F(I), D(I), I=1,N) IF (KPRINT .GE. 2) WRITE (LUN, 1001) C C LOOP OVER (A,B)-PAIRS. C IF (KPRINT .GE. 3) WRITE (LUN, 2000) C IFAIL = 0 C SKIP = .FALSE. DO 20 I = 1, NPAIRS C --------------------------------------------- CALC = DPCHIA (N, X, F, D, 1, SKIP, A(I), B(I), IERR) C --------------------------------------------- IF (IERR .GE. 0) THEN FAIL = IERR .NE. IEREXP(I) TRUE = ANTDER(B(I)) - ANTDER(A(I)) ERROR = CALC - TRUE IF (KPRINT .GE. 3) THEN IF (FAIL) THEN WRITE (LUN, 2001) A(I), B(I), IERR, TRUE, CALC, ERROR, * IEREXP(I) ELSE WRITE (LUN, 2002) A(I), B(I), IERR, TRUE, CALC, ERROR ENDIF ENDIF C ERROR = ABS(ERROR) / MAX(ONE, ABS(TRUE)) IF (FAIL .OR. (ERROR.GT.TOL)) IFAIL = IFAIL + 1 IF (I .EQ. 1) THEN ERRMAX = ERROR ELSE ERRMAX = MAX(ERRMAX, ERROR) ENDIF ELSE IF (KPRINT .GE. 3) WRITE (LUN, 2002) A(I), B(I), IERR IFAIL = IFAIL + 1 ENDIF 20 CONTINUE C C PRINT SUMMARY. C IF (KPRINT .GE. 2) THEN WRITE (LUN, 2003) ERRMAX, TOL IF (IFAIL .NE. 0) WRITE (LUN, 3001) IFAIL ENDIF C C TERMINATE. C IF (IFAIL.EQ.0) THEN IPASS = 1 IF (KPRINT.GE.2) WRITE(LUN,99998) ELSE IPASS = 0 IF (KPRINT.GE.1) WRITE(LUN,99999) ENDIF C RETURN C C FORMATS. C 1000 FORMAT ('1'//10X,'TEST DPCHIP INTEGRATORS' * // 5X,'DATA:' //11X,'X',9X,'F',9X,'D' * /(5X,3F10.3) ) 1001 FORMAT (//10X,'DPCHQ2 RESULTS'/10X,'--------------') 2000 FORMAT (// 5X,'TEST RESULTS:' * //' A B ERR TRUE',16X,'CALC',15X,'ERROR') 2001 FORMAT (2F6.1,I5,1P,2D20.10,D15.5,' (',I1,') *****' ) 2002 FORMAT (2F6.1,I5,1P,2D20.10,D15.5) 2003 FORMAT (/' MAXIMUM RELATIVE ERROR IS:',1P,D15.5, * ', TOLERANCE:',1P,D15.5) 3001 FORMAT (/' *** TROUBLE ***',I5,' INTEGRATION TESTS FAILED.') 99998 FORMAT (/' ------------ DPCHIP PASSED ALL INTEGRATION TESTS', . ' ------------') 99999 FORMAT (/' ************ DPCHIP FAILED SOME INTEGRATION TESTS', . ' ************') C------------- LAST LINE OF DPCHQ2 FOLLOWS ----------------------------- END *DECK DPCHQ3 SUBROUTINE DPCHQ3 (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DPCHQ3 C***PURPOSE Test the PCHIP interpolators DPCHIC, DPCHIM, DPCHSP. C***LIBRARY SLATEC (PCHIP) C***TYPE DOUBLE PRECISION (PCHQK3-S, DPCHQ3-D) C***KEYWORDS PCHIP INTERPOLATOR QUICK CHECK C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C DPCHIP QUICK CHECK NUMBER 3 C C TESTS THE INTERPOLATORS: DPCHIC, DPCHIM, DPCHSP. C *Usage: C C INTEGER LUN, KPRINT, IPASS C C CALL DPCHQ3 (LUN, KPRINT, IPASS) C C *Arguments: C C LUN :IN is the unit number to which output is to be written. C C KPRINT:IN controls the amount of output, as specified in the C SLATEC Guidelines. C C IPASS:OUT will contain a pass/fail flag. IPASS=1 is good. C IPASS=0 indicates one or more tests failed. C C *Description: C C This routine interpolates a constructed data set with all three C DPCHIP interpolators and compares the results with those obtained C on a Cray X/MP. Two different values of the DPCHIC parameter SWITCH C are used. C C *Remarks: C 1. The Cray results are given only to nine significant figures, C so don't expect them to match to more. C 2. The results will depend to some extent on the accuracy of C the EXP function. C C***ROUTINES CALLED COMP, D1MACH, DPCHIC, DPCHIM, DPCHSP C***REVISION HISTORY (YYMMDD) C 900309 DATE WRITTEN C 900314 Converted to a subroutine and added a SLATEC 4.0 prologue. C 900315 Revised prologue and improved some output formats. (FNF) C 900316 Made TOLD machine-dependent and added extra output when C KPRINT=3. (FNF) C 900320 Added E0's to DATA statement for X to reduce single/double C differences, and other minor cosmetic changes. C 900320 Converted to double precision. C 900321 Removed IFAIL from call sequence for SLATEC standards and C made miscellaneous cosmetic changes. (FNF) C 900322 Minor changes to reduce single/double differences. (FNF) C 900530 Tolerance (TOLD) and argument to DPCHIC changed. (WRB) C 900802 Modified TOLD formula and constants in DPCHIC calls to C correct DPCHQ3 failures. (FNF) C 901130 Several significant changes: (FNF) C 1. Changed comparison between DPCHIM and DPCHIC to only C require agreement to machine precision. C 2. Revised to print more output when KPRINT=3. C 3. Added 1P's to formats. C 910708 Minor modifications in use of KPRINT. (WRB) C***END PROLOGUE DPCHQ3 C C*Internal Notes: C C TOLD is used to compare with stored Cray results. Its value C should be consistent with significance of stored values. C TOLZ is used for cases in which exact equality is expected. C TOL is used for cases in which agreement to machine precision C is expected. C**End C C Declare arguments. C INTEGER LUN, KPRINT, IPASS LOGICAL COMP DOUBLE PRECISION D1MACH C C Declare variables. C INTEGER I, IC(2), IERR, IFAIL, N, NBAD, NBADZ, NWK PARAMETER (N = 9, NWK = 2*N) DOUBLE PRECISION D(N), DC(N), DC5, DC6, DM(N), DS(N), ERR, F(N), . MONE, TOL, TOLD, TOLZ, VC(2), X(N), WK(NWK), ZERO PARAMETER (ZERO = 0.0D0, MONE = -1.0D0) CHARACTER*6 RESULT C C Initialize. C C Data. DATA IC /0, 0/ DATA X /-2.2D0,-1.2D0,-1.0D0,-0.5D0,-0.01D0, 0.5D0, 1.0D0, . 2.0D0, 2.2D0/ C C Results generated on Cray X/MP (9 sign. figs.) DATA DM / 0. , 3.80027352D-01, 7.17253009D-01, . 5.82014161D-01, 0. ,-5.68208031D-01, . -5.13501618D-01,-7.77910977D-02,-2.45611117D-03/ DATA DC5,DC6 / 1.76950158D-02,-5.69579814D-01/ DATA DS /-5.16830792D-02, 5.71455855D-01, 7.40530225D-01, . 7.63864934D-01, 1.92614386D-02,-7.65324380D-01, . -7.28209035D-01,-7.98445427D-02,-2.85983446D-02/ C C***FIRST EXECUTABLE STATEMENT DPCHQ3 IFAIL = 0 C C Set tolerances. TOL = 10*D1MACH(4) TOLD = MAX( 1.0D-7, 10*TOL ) TOLZ = ZERO C IF (KPRINT .GE. 3) WRITE (LUN, 1000) IF (KPRINT .GE. 2) WRITE (LUN, 1002) C C Set up data. C DO 10 I = 1, N F(I) = EXP(-X(I)**2) 10 CONTINUE C IF (KPRINT .GE. 3) THEN DO 12 I = 1, 4 WRITE (LUN, 1010) X(I), F(I), DM(I), DS(I) 12 CONTINUE WRITE (LUN, 1011) X(5), F(5), DM(5), DC5, DS(5) WRITE (LUN, 1011) X(6), F(6), DM(6), DC6, DS(6) DO 15 I = 7, N WRITE (LUN, 1010) X(I), F(I), DM(I), DS(I) 15 CONTINUE ENDIF C C Test DPCHIM. C IF (KPRINT.GE.3) WRITE (LUN, 2000) 'IM' C -------------------------------- CALL DPCHIM (N, X, F, D, 1, IERR) C -------------------------------- C Expect IERR=1 (one monotonicity switch). IF ( KPRINT.GE.3 ) WRITE (LUN, 2001) 1 IF ( .NOT.COMP (IERR, 1, LUN, KPRINT) ) THEN IFAIL = IFAIL + 1 ELSE IF ( KPRINT.GE.3 ) WRITE (LUN, 2002) NBAD = 0 NBADZ = 0 DO 20 I = 1, N RESULT = ' OK' C D-values should agree with stored values. C (Zero values should agree exactly.) IF ( DM(I).EQ.ZERO ) THEN ERR = ABS( D(I) ) IF ( ERR.GT.TOLZ ) THEN NBADZ = NBADZ + 1 RESULT = '**BADZ' ENDIF ELSE ERR = ABS( (D(I)-DM(I))/DM(I) ) IF ( ERR.GT.TOLD ) THEN NBAD = NBAD + 1 RESULT = '**BAD' ENDIF ENDIF IF (KPRINT.GE.3) * WRITE (LUN, 2003) I, X(I), D(I), ERR, RESULT 20 CONTINUE IF ( (NBADZ.NE.0).OR.(NBAD.NE.0) ) THEN IFAIL = IFAIL + 1 IF ((NBADZ.NE.0).AND.(KPRINT.GE.2)) * WRITE (LUN, 2004) NBAD IF ((NBAD.NE.0).AND.(KPRINT.GE.2)) * WRITE (LUN, 2005) NBAD, 'IM', TOLD ELSE IF (KPRINT.GE.3) WRITE (LUN, 2006) 'IM' ENDIF ENDIF C C Test DPCHIC -- options set to reproduce DPCHIM. C IF (KPRINT.GE.3) WRITE (LUN, 2000) 'IC' C -------------------------------------------------------- CALL DPCHIC (IC, VC, ZERO, N, X, F, DC, 1, WK, NWK, IERR) C -------------------------------------------------------- C Expect IERR=0 . IF ( KPRINT.GE.3 ) WRITE (LUN, 2001) 0 IF ( .NOT.COMP (IERR, 0, LUN, KPRINT) ) THEN IFAIL = IFAIL + 1 ELSE IF ( KPRINT.GE.3 ) WRITE (LUN, 2002) NBAD = 0 DO 30 I = 1, N RESULT = ' OK' C D-values should agree exactly with those computed by DPCHIM. C (To be generous, will only test to machine precision.) ERR = ABS( D(I)-DC(I) ) IF ( ERR.GT.TOL ) THEN NBAD = NBAD + 1 RESULT = '**BAD' ENDIF IF (KPRINT.GE.3) * WRITE (LUN, 2003) I, X(I), DC(I), ERR, RESULT 30 CONTINUE IF ( NBAD.NE.0 ) THEN IFAIL = IFAIL + 1 IF (KPRINT.GE.2) WRITE (LUN, 2005) NBAD, 'IC', TOL ELSE IF (KPRINT.GE.3) WRITE (LUN, 2006) 'IC' ENDIF ENDIF C C Test DPCHIC -- default nonzero switch derivatives. C IF (KPRINT.GE.3) WRITE (LUN, 2000) 'IC' C ------------------------------------------------------- CALL DPCHIC (IC, VC, MONE, N, X, F, D, 1, WK, NWK, IERR) C ------------------------------------------------------- C Expect IERR=0 . IF ( KPRINT.GE.3 ) WRITE (LUN, 2001) 0 IF ( .NOT.COMP (IERR, 0, LUN, KPRINT) ) THEN IFAIL = IFAIL + 1 ELSE IF ( KPRINT.GE.3 ) WRITE (LUN, 2002) NBAD = 0 NBADZ = 0 DO 40 I = 1, N RESULT = ' OK' C D-values should agree exactly with those computed in C previous call, except at points 5 and 6. IF ( (I.LT.5).OR.(I.GT.6) ) THEN ERR = ABS( D(I)-DC(I) ) IF ( ERR.GT.TOLZ ) THEN NBADZ = NBADZ + 1 RESULT = '**BADA' ENDIF ELSE IF ( I.EQ.5 ) THEN ERR = ABS( (D(I)-DC5)/DC5 ) ELSE ERR = ABS( (D(I)-DC6)/DC6 ) ENDIF IF ( ERR.GT.TOLD ) THEN NBAD = NBAD + 1 RESULT = '**BAD' ENDIF ENDIF IF (KPRINT.GE.3) * WRITE (LUN, 2003) I, X(I), D(I), ERR, RESULT 40 CONTINUE IF ( (NBADZ.NE.0).OR.(NBAD.NE.0) ) THEN IFAIL = IFAIL + 1 IF ((NBADZ.NE.0).AND.(KPRINT.GE.2)) * WRITE (LUN, 2007) NBAD IF ((NBAD.NE.0).AND.(KPRINT.GE.2)) * WRITE (LUN, 2005) NBAD, 'IC', TOLD ELSE IF (KPRINT.GE.3) WRITE (LUN, 2006) 'IC' ENDIF ENDIF C C Test DPCHSP. C IF (KPRINT.GE.3) WRITE (LUN, 2000) 'SP' C ------------------------------------------------- CALL DPCHSP (IC, VC, N, X, F, D, 1, WK, NWK, IERR) C ------------------------------------------------- C Expect IERR=0 . IF ( KPRINT.GE.3 ) WRITE (LUN, 2001) 0 IF ( .NOT.COMP (IERR, 0, LUN, KPRINT) ) THEN IFAIL = IFAIL + 1 ELSE IF ( KPRINT.GE.3 ) WRITE (LUN, 2002) NBAD = 0 DO 50 I = 1, N RESULT = ' OK' C D-values should agree with stored values. ERR = ABS( (D(I)-DS(I))/DS(I) ) IF ( ERR.GT.TOLD ) THEN NBAD = NBAD + 1 RESULT = '**BAD' ENDIF IF (KPRINT.GE.3) * WRITE (LUN, 2003) I, X(I), D(I), ERR, RESULT 50 CONTINUE IF ( NBAD.NE.0 ) THEN IFAIL = IFAIL + 1 IF (KPRINT.GE.2) WRITE (LUN, 2005) NBAD, 'SP', TOLD ELSE IF (KPRINT.GE.3) WRITE (LUN, 2006) 'SP' ENDIF ENDIF C C PRINT SUMMARY AND TERMINATE. C IF ((KPRINT.GE.2).AND.(IFAIL.NE.0)) WRITE (LUN, 3001) IFAIL C IF (IFAIL.EQ.0) THEN IPASS = 1 IF (KPRINT.GE.2) WRITE(LUN,99998) ELSE IPASS = 0 IF (KPRINT.GE.1) WRITE(LUN,99999) ENDIF C RETURN C C FORMATS. C 1000 FORMAT ('1'//10X,'TEST DPCHIP INTERPOLATORS' . // 5X,'DATA:' . /39X,'---------- EXPECTED D-VALUES ----------' . /12X,'X',9X,'F',18X,'DM',13X,'DC',13X,'DS') 1002 FORMAT (//10X,'DPCHQ3 RESULTS'/10X,'--------------') 1010 FORMAT (5X,F10.2,1P,D15.5,4X,D15.5,15X,D15.5) 1011 FORMAT (5X,F10.2,1P,D15.5,4X,3D15.5) 2000 FORMAT (/5X,'DPCH',A2,' TEST:') 2001 FORMAT (15X,'EXPECT IERR =',I5) 2002 FORMAT (/9X,'I',7X,'X',9X,'D',13X,'ERR') 2003 FORMAT (5X,I5,F10.2,1P,2D15.5,2X,A) 2004 FORMAT (/' **',I5,' DPCHIM RESULTS FAILED TO BE EXACTLY ZERO.') 2005 FORMAT (/' **',I5,' DPCH',A2,' RESULTS FAILED TOLERANCE TEST.', * ' TOL =',1P,D10.3) 2006 FORMAT (/5X,' ALL DPCH',A2,' RESULTS OK.') 2007 FORMAT (/' **',I5,' DPCHIC RESULTS FAILED TO AGREE WITH', * ' PREVIOUS CALL.') 3001 FORMAT (/' *** TROUBLE ***',I5,' INTERPOLATION TESTS FAILED.') 99998 FORMAT (/' ------------ DPCHIP PASSED ALL INTERPOLATION TESTS', . ' ------------') 99999 FORMAT (/' ************ DPCHIP FAILED SOME INTERPOLATION TESTS', . ' ************') C------------- LAST LINE OF DPCHQ3 FOLLOWS ----------------------------- END *DECK DPCHQ4 SUBROUTINE DPCHQ4 (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DPCHQ4 C***PURPOSE Test the PCHIP monotonicity checker DPCHCM. C***LIBRARY SLATEC (PCHIP) C***TYPE DOUBLE PRECISION (PCHQK4-S, DPCHQ4-D) C***KEYWORDS PCHIP MONOTONICITY CHECKER QUICK CHECK C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C DPCHIP QUICK CHECK NUMBER 4 C C TESTS THE MONOTONICITY CHECKER: DPCHCM. C *Usage: C C INTEGER LUN, KPRINT, IPASS C C CALL DPCHQ4 (LUN, KPRINT, IPASS) C C *Arguments: C C LUN :IN is the unit number to which output is to be written. C C KPRINT:IN controls the amount of output, as specified in the C SLATEC Guidelines. C C IPASS:OUT will contain a pass/fail flag. IPASS=1 is good. C IPASS=0 indicates one or more tests failed. C C *Description: C C This routine tests a constructed data set with three different C INCFD settings and compares with the expected results. It then C runs a special test to check for bug in overall monotonicity found C in DPCHMC. Finally, it reverses the data and repeats all tests. C C***ROUTINES CALLED DPCHCM C***REVISION HISTORY (YYMMDD) C 890208 DATE WRITTEN C 890306 Changed LOUT to LUN and added it to call list. (FNF) C 890316 Removed DATA statements to suit new quick check standards. C 890410 Changed PCHMC to PCHCM. C 890410 Added a SLATEC 4.0 format prologue. C 900314 Changed name from PCHQK3 to PCHQK4 and improved some output C formats. C 900315 Revised prologue and improved some output formats. (FNF) C 900320 Converted to double precision. C 900321 Removed IFAIL from call sequence for SLATEC standards and C made miscellaneous cosmetic changes. (FNF) C 900322 Added declarations so all variables are declared. (FNF) C 910708 Minor modifications in use of KPRINT. (WRB) C***END PROLOGUE DPCHQ4 C C*Internal Notes: C C Data set-up is done via assignment statements to avoid modifying C DATA-loaded arrays, as required by the 1989 SLATEC Guidelines. C Run with KPRINT=3 to display the data. C**End C C Declare arguments. C INTEGER LUN, KPRINT, IPASS C C DECLARE VARIABLES. C INTEGER MAXN, MAXN2, MAXN3, NB PARAMETER (MAXN = 16, MAXN2 = 8, MAXN3 = 6, NB = 7) INTEGER I, IERR, IFAIL, INCFD, ISMEX1(MAXN), ISMEX2(MAXN2), . ISMEX3(MAXN3), ISMEXB(NB), ISMON(MAXN), K, N, NS(3) DOUBLE PRECISION D(MAXN), DB(NB), F(MAXN), FB(NB), X(MAXN) LOGICAL SKIP C C DEFINE EXPECTED RESULTS. C DATA ISMEX1 / 1, 1,-1, 1, 1,-1, 1, 1,-1, 1, 1,-1, 1, 1,-1, 2/ DATA ISMEX2 / 1, 2, 2, 1, 2, 2, 1, 2/ DATA ISMEX3 / 1, 1, 1, 1, 1, 1/ DATA ISMEXB / 1, 3, 1, -1, -3, -1, 2/ C C DEFINE TEST DATA. C DATA NS /16, 8, 6/ C C Define X, F, D. C***FIRST EXECUTABLE STATEMENT DPCHQ4 DO 1 I = 1, MAXN X(I) = I D(I) = 0.D0 1 CONTINUE DO 2 I = 2, MAXN, 3 D(I) = 2.D0 2 CONTINUE DO 3 I = 1, 3 F(I) = X(I) F(I+ 3) = F(I ) + 1.D0 F(I+ 6) = F(I+3) + 1.D0 F(I+ 9) = F(I+6) + 1.D0 F(I+12) = F(I+9) + 1.D0 3 CONTINUE F(16) = 6.D0 C Define FB, DB. FB(1) = 0.D0 FB(2) = 2.D0 FB(3) = 3.D0 FB(4) = 5.D0 DB(1) = 1.D0 DB(2) = 3.D0 DB(3) = 3.D0 DB(4) = 0.D0 DO 4 I = 1, 3 FB(NB-I+1) = FB(I) DB(NB-I+1) = -DB(I) 4 CONTINUE C C INITIALIZE. C IFAIL = 0 C IF (KPRINT .GE. 3) THEN WRITE (LUN, 1000) DO 10 I = 1, NB WRITE (LUN, 1001) I, X(I), F(I), D(I), FB(I), DB(I) 10 CONTINUE DO 20 I = NB+1, MAXN WRITE (LUN, 1001) I, X(I), F(I), D(I) 20 CONTINUE ENDIF IF (KPRINT .GE. 2) WRITE (LUN, 1002) C C TRANSFER POINT FOR SECOND SET OF TESTS. C 25 CONTINUE C C Loop over a series of values of INCFD. C DO 30 INCFD = 1, 3 N = NS(INCFD) SKIP = .FALSE. C ------------------------------------------------- CALL DPCHCM (N, X, F, D, INCFD, SKIP, ISMON, IERR) C ------------------------------------------------- IF (KPRINT.GE.3) . WRITE (LUN, 2000) INCFD, IERR, (ISMON(I), I=1,N) IF ( IERR.NE.0 ) THEN IFAIL = IFAIL + 1 IF (KPRINT.GE.3) WRITE (LUN,2001) ELSE DO 29 I = 1, N IF (INCFD.EQ.1) THEN IF ( ISMON(I).NE.ISMEX1(I) ) THEN IFAIL = IFAIL + 1 IF (KPRINT.GE.3) . WRITE (LUN, 2002) (ISMEX1(K),K=1,N) GO TO 30 ENDIF ELSE IF (INCFD.EQ.2) THEN IF ( ISMON(I).NE.ISMEX2(I) ) THEN IFAIL = IFAIL + 1 IF (KPRINT.GE.3) . WRITE (LUN, 2002) (ISMEX2(K),K=1,N) GO TO 30 ENDIF ELSE IF ( ISMON(I).NE.ISMEX3(I) ) THEN IFAIL = IFAIL + 1 IF (KPRINT.GE.3) . WRITE (LUN, 2002) (ISMEX3(K),K=1,N) GO TO 30 ENDIF ENDIF 29 CONTINUE ENDIF 30 CONTINUE C C Test for -1,3,1 bug. C SKIP = .FALSE. C ------------------------------------------------ CALL DPCHCM (NB, X, FB, DB, 1, SKIP, ISMON, IERR) C ------------------------------------------------ IF (KPRINT.GE.3) . WRITE (LUN, 2030) IERR, (ISMON(I), I=1,NB) IF ( IERR.NE.0 ) THEN IFAIL = IFAIL + 1 IF (KPRINT.GE.3) WRITE (LUN,2001) ELSE DO 34 I = 1, NB IF ( ISMON(I).NE.ISMEXB(I) ) THEN IFAIL = IFAIL + 1 IF (KPRINT.GE.3) . WRITE (LUN, 2002) (ISMEXB(K),K=1,NB) GO TO 35 ENDIF 34 CONTINUE ENDIF 35 CONTINUE C IF (F(1).LT.0.) GO TO 90 C C Change sign and do again. C DO 40 I = 1, MAXN F(I) = -F(I) D(I) = -D(I) IF ( ISMEX1(I).NE.2 ) ISMEX1(I) = -ISMEX1(I) 40 CONTINUE DO 42 I = 1, MAXN2 IF ( ISMEX2(I).NE.2 ) ISMEX2(I) = -ISMEX2(I) 42 CONTINUE DO 43 I = 1, MAXN3 IF ( ISMEX3(I).NE.2 ) ISMEX3(I) = -ISMEX3(I) 43 CONTINUE DO 50 I = 1, NB FB(I) = -FB(I) DB(I) = -DB(I) IF ( ISMEXB(I).NE.2 ) ISMEXB(I) = -ISMEXB(I) 50 CONTINUE GO TO 25 C C PRINT SUMMARY AND TERMINATE. C 90 CONTINUE IF ((KPRINT.GE.2).AND.(IFAIL.NE.0)) WRITE (LUN, 3001) IFAIL C IF (IFAIL.EQ.0) THEN IPASS = 1 IF (KPRINT.GE.2) WRITE(LUN,99998) ELSE IPASS = 0 IF (KPRINT.GE.1) WRITE(LUN,99999) ENDIF C RETURN C C FORMATS. C 1000 FORMAT ('1'//10X,'TEST DPCHIP MONOTONICITY CHECKER' * // 5X,'DATA:' . // 9X,'I',4X,'X',5X,'F',5X,'D',5X,'FB',4X,'DB') 1001 FORMAT (5X,I5,5F6.1) 1002 FORMAT (//10X,'DPCHQ4 RESULTS'/10X,'--------------') 2000 FORMAT (/4X,'INCFD =',I2,': IERR =',I3/15X,'ISMON =',16I3) 2001 FORMAT (' *** Failed -- bad IERR value.') 2002 FORMAT (' *** Failed -- expect:',16I3) 2030 FORMAT (/4X,' Bug test: IERR =',I3/15X,'ISMON =',7I3) 3001 FORMAT (/' *** TROUBLE ***',I5,' MONOTONICITY TESTS FAILED.') 99998 FORMAT (/' ------------ DPCHIP PASSED ALL MONOTONICITY TESTS', . ' ------------') 99999 FORMAT (/' ************ DPCHIP FAILED SOME MONOTONICITY TESTS', . ' ************') C------------- LAST LINE OF DPCHQ4 FOLLOWS ----------------------------- END *DECK DPFITT SUBROUTINE DPFITT (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DPFITT C***PURPOSE Quick check for DPOLFT, DPCOEF and DP1VLU. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (PFITQX-S, DPFITT-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED D1MACH, DCMPAR, DP1VLU, DPCOEF, DPOLFT, PASS, C XERCLR, XGETF, XSETF C***COMMON BLOCKS DCHECK C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 890921 Realigned order of variables in the COMMON block. C (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900911 Test problem changed and cosmetic changes to code. (WRB) C 901205 Changed usage of D1MACH(3) to D1MACH(4) and modified the C FORMATs. (RWC) C 910708 Minor modifications in use of KPRINT. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900911 Test problem changed and cosmetic changes to code. (WRB) C 920214 Code restructured to test for all values of KPRINT and to C provide more PASS/FAIL information. (WRB) C***END PROLOGUE DPFITT C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Scalars in Common .. DOUBLE PRECISION EPS, RP, SVEPS, TOL INTEGER IERP, IERR, NORD, NORDP C .. Arrays in Common .. DOUBLE PRECISION R(11) C .. Local Scalars .. DOUBLE PRECISION YFIT INTEGER I, ICNT, M, MAXORD C .. Local Arrays .. DOUBLE PRECISION A(97), TC(5), W(11), X(11), Y(11), YP(5) INTEGER ITEST(9) C .. External Functions .. DOUBLE PRECISION D1MACH EXTERNAL D1MACH C .. External Subroutines .. EXTERNAL DCMPAR, PASS, DPCOEF, DPOLFT, DP1VLU C .. Intrinsic Functions .. INTRINSIC ABS, SQRT C .. Common blocks .. COMMON /DCHECK/ EPS, R, RP, SVEPS, TOL, NORDP, NORD, IERP, IERR C***FIRST EXECUTABLE STATEMENT DPFITT IF (KPRINT .GE. 2) WRITE (LUN,FMT=9000) C C Initialize variables for testing passage or failure of tests C DO 100 I = 1,9 ITEST(I) = 0 100 CONTINUE ICNT = 0 TOL = SQRT(D1MACH(4)) M = 11 DO 110 I = 1,M X(I) = I - 6 Y(I) = X(I)**4 110 CONTINUE C C Test DPOLFT C Input EPS is negative - specified level C W(1) = -1.0D0 EPS = -0.01D0 SVEPS = EPS MAXORD = 8 NORDP = 4 RP = 625.0D0 IERP = 1 CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) C C See if test passed C CALL DCMPAR (ICNT, ITEST) C C Check for suppression of printing. C IF (KPRINT .EQ. 0) GO TO 130 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 130 WRITE (LUN,FMT=9010) WRITE (LUN,FMT=9020) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 120 WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR C C Send message indicating passage or failure of test C 120 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Input EPS is negative - computed level C 130 EPS = -1.0D0 SVEPS = EPS CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) C C See if test passed C CALL DCMPAR (ICNT, ITEST) C C Check for suppression of printing. C IF (KPRINT .EQ. 0) GO TO 150 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 150 WRITE (LUN,FMT=9050) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 140 WRITE (LUN,FMT=9060) MAXORD WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR C C Send message indicating passage or failure of test C 140 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Input EPS is zero C 150 W(1) = -1.0D0 EPS = 0.0D0 SVEPS = EPS NORDP = 5 MAXORD = 5 CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) C C See if test passed C CALL DCMPAR (ICNT, ITEST) C C Check for suppression of printing. C IF (KPRINT .EQ. 0) GO TO 170 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 170 WRITE (LUN,FMT=9070) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 160 WRITE (LUN,FMT=9060) MAXORD WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR C C Send message indicating passage or failure of test C 160 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Input EPS is positive C 170 IERP = 1 NORDP = 4 EPS = 75.0D0*D1MACH(4) SVEPS = EPS CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) C C See if test passed C CALL DCMPAR (ICNT, ITEST) C C Check for suppression of printing. C IF (KPRINT .EQ. 0) GO TO 190 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 190 WRITE (LUN,FMT=9080) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 180 WRITE (LUN,FMT=9060) MAXORD WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR C C Send message indicating passage or failure of test C 180 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Improper input C 190 IERP = 2 M = -2 C C Check for suppression of printing. C CALL XGETF (KONTRL) IF (KPRINT .LE. 2) THEN CALL XSETF (0) ELSE CALL XSETF (1) ENDIF CALL XERCLR C IF (KPRINT .GE. 3) WRITE (LUN,9090) CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) C C See if test passed C ICNT = ICNT + 1 IF (IERR .EQ. 2) THEN ITEST(ICNT) = 1 IF (KPRINT .GE. 3) THEN WRITE (LUN, 9100) 'PASSED', IERR ENDIF ELSE IF (KPRINT .GE. 2) THEN WRITE (LUN, 9100) 'FAILED', IERR ENDIF ENDIF C C Check for suppression of printing. C IF (KPRINT .EQ. 0) GO TO 210 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 210 IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 200 C C Send message indicating passage or failure of test C 200 CALL PASS (LUN, ICNT, ITEST(ICNT)) C CALL XERCLR CALL XSETF (KONTRL) C C MAXORD too small to meet RMS error C 210 M = 11 W(1) = -1.0D0 EPS = 5.0D0*D1MACH(4) SVEPS = EPS RP = 553.0D0 MAXORD = 2 IERP = 3 NORDP = 2 CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) C C See if test passed C CALL DCMPAR (ICNT, ITEST) C C Check for suppression of printing. C IF (KPRINT .EQ. 0) GO TO 230 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 230 WRITE (LUN,FMT=9110) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 220 WRITE (LUN,FMT=9060) MAXORD WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR C C Send message indicating passage or failure of test C 220 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C MAXORD too small to meet statistical test C 230 NORDP = 4 IERP = 4 RP = 625.0D0 EPS = -0.01D0 SVEPS = EPS MAXORD = 5 CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) C C See if test passed C CALL DCMPAR (ICNT, ITEST) C C Check for suppression of printing. C IF (KPRINT .EQ. 0) GO TO 250 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 250 WRITE (LUN,FMT=9120) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 240 WRITE (LUN,FMT=9060) MAXORD WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR C C Send message indicating passage or failure of test C 240 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Test DPCOEF C 250 MAXORD = 6 EPS = 0.0D0 SVEPS = EPS Y(6) = 1.0D0 DO 260 I = 1,M W(I) = 1.0D0/(Y(I)**2) 260 CONTINUE Y(6) = 0.0D0 CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) CALL DPCOEF (4, 5.0D0, TC, A) C C See if test passed C ICNT = ICNT + 1 IF (ABS(R(11)-TC(1)) .LE. TOL) ITEST(ICNT) = 1 C C Check for suppression of printing C IF (KPRINT .EQ. 0) GO TO 280 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 280 WRITE (LUN,FMT=9130) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 270 WRITE (LUN,FMT=9140) R(11),TC(1) C C Send message indicating passage or failure of test C 270 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Test DP1VLU C Normal call C 280 CALL DP1VLU (6, 0, X(8), YFIT, YP, A) C C See if test passed C ICNT = ICNT + 1 IF (ABS(R(8)-YFIT) .LE. TOL) ITEST(ICNT) = 1 C C Check for suppression of printing C IF (KPRINT .EQ. 0) GO TO 300 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 300 WRITE (LUN,FMT=9150) WRITE (LUN,FMT=9160) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 290 WRITE (LUN,FMT=9170) X(8),R(8),YFIT C C Send message indicating passage or failure of test C 290 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Check to see if all tests passed C 300 IPASS = 1 DO 310 I = 1,9 IPASS = IPASS*ITEST(I) 310 CONTINUE C IF (IPASS.EQ.1 .AND. KPRINT.GE.3) WRITE (LUN,FMT=9180) IF (IPASS.EQ.0 .AND. KPRINT.GE.2) WRITE (LUN,FMT=9190) RETURN C 9000 FORMAT ('1' / 'Test DPOLFT, DPCOEF and DP1VLU') 9010 FORMAT (' Exercise DPOLFT') 9020 FORMAT (' Input EPS is negative - specified significance level') 9030 FORMAT (' Input EPS = ', E15.8, ' correct order = ', I3, + ' R(1) = ', E15.8, ' IERR = ', I1) 9040 FORMAT (' Output EPS = ', E15.8, ' computed order = ', I3, + ' R(1) = ', E15.8, ' IERR = ', I1) 9050 FORMAT (/ ' Input EPS is negative - computed significance level') 9060 FORMAT (' Maximum order = ', I2) 9070 FORMAT (/ ' Input EPS is zero') 9080 FORMAT (/ ' Input EPS is positive') 9090 FORMAT (/ ' Invalid input') 9100 FORMAT (' DPOLFT incorrect argument test ', A / + ' IERR should be 2. It is ', I4) 9110 FORMAT (/ ' Cannot meet RMS error requirement') 9120 FORMAT (/ ' Cannot satisfy statistical test') 9130 FORMAT (/ ' Exercise DPCOEF') 9140 FORMAT (/ ' For C=1.0, correct coefficient = ', E15.8, + ' computed = ', E15.8) 9150 FORMAT (/ ' Exercise DP1VLU') 9160 FORMAT (' Normal execution') 9170 FORMAT (' For X = ', F5.2, ' correct P(X) = ', E15.8, + ' P(X) from DP1VLU = ', E15.8) 9180 FORMAT (/' ***************DPOLFT PASSED ALL TESTS***************') 9190 FORMAT (/' ***************DPOLFT FAILED SOME TESTS**************') END *DECK DPLPQX SUBROUTINE DPLPQX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DPLPQX C***PURPOSE Quick check for DSPLP. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (SPLPQX-S, DPLPQX-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED DCOPY, DSPLP, DUSRMT, PASS C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 901013 Added additional printout on failure. (RWC) C***END PROLOGUE DPLPQX IMPLICIT DOUBLE PRECISION (A-H,O-Z) EXTERNAL DUSRMT INTEGER ICNT, IND(60), IBASIS(60), IPASS, IWORK(900), ISOLN(14) DOUBLE PRECISION COSTS(37) DOUBLE PRECISION PRGOPT(50), DATTRV(210), BL(60), BU(60) DOUBLE PRECISION PRIMAL(60), DUALS(60) DOUBLE PRECISION WORK(800) DOUBLE PRECISION D(14,37) DOUBLE PRECISION ZERO INTEGER MRELAS,NVARS,INFO,LW,LIW C***FIRST EXECUTABLE STATEMENT DPLPQX IF(KPRINT.GE.2) WRITE(LUN,999) 999 FORMAT ('1 DSPLP QUICK CHECK') ICNT=1 ZERO = 0.0D0 IPASS=0 C DEFINE WORKING ARRAY LENGTHS LIW = 900 LW = 800 MRELAS = 14 NVARS = 37 C DEFINE THE ARRAY COSTS(*) FOR THE OBJECTIVE FUNCTION COSTS(1) = 1.030D0 COSTS(2) = 0.985D0 COSTS(3) = 0.997D0 COSTS(4) = 1.036D0 COSTS(5) = 1.005D0 COSTS(6) = 0.980D0 COSTS(7) = 1.004D0 COSTS(8) = 0.993D0 COSTS(9) = 1.018D0 COSTS(10) = 0.947D0 COSTS(11) = 0.910D0 COSTS(12) = 1.028D0 COSTS(13) = 0.957D0 COSTS(14) = 1.025D0 COSTS(15) = 1.036D0 COSTS(16) = 1.060D0 COSTS(17) = 0.954D0 COSTS(18) = 0.891D0 COSTS(19) = 0.921D0 COSTS(20) = 1.040D0 COSTS(21) = 0.912D0 COSTS(22) = 0.926D0 COSTS(23) = 1.000D0 COSTS(24) = 0.000D0 COSTS(25) = 0.000D0 COSTS(26) = 0.000D0 COSTS(27) = 0.000D0 COSTS(28) = 0.000D0 COSTS(29) = 0.000D0 COSTS(30) = 0.000D0 COSTS(31) = 0.000D0 COSTS(32) = 0.000D0 COSTS(33) = 0.000D0 COSTS(34) = 0.000D0 COSTS(35) = 0.000D0 COSTS(36) = 0.000D0 COSTS(37) = 0.000D0 C PLACE THE NONZERO INFORMATION ABOUT THE MATRIX IN DATTRV(*) CALL DCOPY(14*37, ZERO, 0, D, 1) D(1,1) = 1.04000D0 D(1,23) = 1.00000D0 D(1,24) = -1.00000D0 D(2,6) = 0.04125D0 D(2,7) = 0.05250D0 D(2,17) = 0.04875D0 D(2,24) = 1.00000D0 D(2,25) = -1.00000D0 D(3,8) = 0.05625D0 D(3,9) = 0.06875D0 D(3,11) = 0.02250D0 D(3,25) = 1.00000D0 D(3,26) = -1.00000D0 D(4,2) = 1.04000D0 D(4,3) = 1.05375D0 D(4,5) = 1.06125D0 D(4,12) = 0.08000D0 D(4,16) = 0.09375D0 D(4,18) = 0.03750D0 D(4,19) = 0.04625D0 D(4,20) = 0.08125D0 D(4,22) = 0.05250D0 D(4,26) = 1.00000D0 D(4,27) = -1.00000D0 D(5,10) = 0.04375D0 D(5,27) = 1.00000D0 D(5,28) = -1.00000D0 D(6,4) = 1.05875D0 D(6,13) = 0.04500D0 D(6,14) = 0.06375D0 D(6,15) = 0.06625D0 D(6,21) = 0.05000D0 D(6,28) = 1.00000D0 D(6,29) = -1.00000D0 D(7,6) = 1.04125D0 D(7,7) = 1.05250D0 D(7,8) = 1.05625D0 D(7,9) = 1.06875D0 D(7,11) = 0.02250D0 D(7,17) = 0.04875D0 D(7,29) = 1.00000D0 D(7,30) = -1.00000D0 D(8,10) = 1.04375D0 D(8,12) = 0.08000D0 D(8,13) = 0.04500D0 D(8,14) = 0.06375D0 D(8,15) = 0.06625D0 D(8,16) = 0.09375D0 D(8,18) = 0.03750D0 D(8,19) = 0.04625D0 D(8,20) = 0.08125D0 D(8,21) = 0.05000D0 D(8,22) = 0.05250D0 D(8,30) = 1.00000D0 D(8,31) = -1.00000D0 D(9,11) = 1.02250D0 D(9,17) = 0.04875D0 D(9,31) = 1.00000D0 D(9,32) = -1.00000D0 D(10,12) = 1.08000D0 D(10,13) = 1.04500D0 D(10,14) = 1.06375D0 D(10,15) = 1.06625D0 D(10,16) = 1.09375D0 D(10,18) = 0.03750D0 D(10,19) = 0.04625D0 D(10,20) = 0.08125D0 D(10,21) = 0.05000D0 D(10,22) = 0.05250D0 D(10,32) = 1.00000D0 D(10,33) = -1.00000D0 D(11,17) = 1.04875D0 D(11,33) = 1.00000D0 D(11,34) = -1.00000D0 D(12,18) = 1.03750D0 D(12,19) = 1.04625D0 D(12,20) = 1.08125D0 D(12,21) = 1.05000D0 D(12,22) = 0.05250D0 D(12,34) = 1.00000D0 D(12,35) = -1.00000D0 D(13,35) = 1.00000D0 D(13,36) = -1.00000D0 D(14,22) = 1.05250D0 D(14,36) = 1.00000D0 D(14,37) = -1.00000D0 KOUNT = 1 DO 20 MM=1,NVARS DATTRV(KOUNT) = -MM DO 10 KK=1,MRELAS IF (D(KK,MM).EQ.ZERO) GO TO 10 KOUNT = KOUNT + 1 DATTRV(KOUNT) = KK KOUNT = KOUNT + 1 DATTRV(KOUNT) = D(KK,MM) 10 CONTINUE KOUNT = KOUNT + 1 20 CONTINUE DATTRV(KOUNT) = ZERO C NON-NEGATIVITY CONSTRAINT DO 30 IC=1,NVARS BL(IC) = ZERO IND(IC) = 3 BU(IC) = 10000000.000D0 30 CONTINUE C LE CONSTRAINTS DO 40 IV=1,MRELAS IVV = IV + NVARS IND(IVV) = 3 BL(IVV) = 100.00000D0 BU(IVV) = 100000000.00000D0 40 CONTINUE PRGOPT(01) = 18 PRGOPT(02) = 59 PRGOPT(03) = 0 PRGOPT(04) = 1 PRGOPT(05) = 3 PRGOPT(06) = 8 PRGOPT(07) = 10 PRGOPT(08) = 11 PRGOPT(09) = 16 PRGOPT(10) = 17 PRGOPT(11) = 21 PRGOPT(12) = 22 PRGOPT(13) = 24 PRGOPT(14) = 25 PRGOPT(15) = 27 PRGOPT(16) = 28 PRGOPT(17) = 35 PRGOPT(18) = 21 PRGOPT(19) = 51 PRGOPT(20) = 0 PRGOPT(21) = 1 CALL DSPLP(DUSRMT, MRELAS, NVARS, COSTS, PRGOPT, DATTRV, BL, * BU, IND, INFO, PRIMAL, DUALS, IBASIS, WORK, LW, IWORK, LIW) C C LOOK FOR THE KNOWN BASIS AT THE SOLN., NOW IS ISOLN(*). C DO 50 I=1,MRELAS ISOLN(I) = PRGOPT(I+3) 50 CONTINUE C IPASS = 1 DO 70 J=1,MRELAS DO 60 I=1,MRELAS IF (ISOLN(I).EQ.IBASIS(J)) GO TO 70 60 CONTINUE IPASS = 0 GO TO 80 70 CONTINUE C 80 IF (KPRINT.GE.2) WRITE (LUN, 99997) (ISOLN(I), IBASIS(I), * I=1,MRELAS) C IF (KPRINT.GE.2 .OR. (KPRINT.EQ.1.AND.IPASS.NE.1)) * CALL PASS (LUN, ICNT, IPASS) C C HERE IPASS=0 IF CODE FAILED QUICK CHECK; C =1 IF CODE PASSED QUICK CHECK. C IF (KPRINT.GE.1 .AND. IPASS.NE.1) WRITE (LUN,99999) IF (KPRINT.GE.2 .AND. IPASS.EQ.1) WRITE (LUN,99998) RETURN C 99997 FORMAT (/' ISOLN IBASIS'/(2I10)) 99998 FORMAT (/' ************ DSPLP PASSED ALL TESTS ****************') 99999 FORMAT (/' ************ DSPLP FAILED SOME TESTS ***************') END *DECK DPNTCK SUBROUTINE DPNTCK (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DPNTCK C***PURPOSE Quick check for DPLINT, DPOLCF and DPOLVL C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (PNTCHK-S, DPNTCK-D) C***KEYWORDS QUICK CHECK C***AUTHOR Boland, W. Robert, (LANL) C***ROUTINES CALLED D1MACH, DPLINT, DPOLCF, DPOLVL, NUMXER, XERCLR, C XGETF, XSETF C***REVISION HISTORY (YYMMDD) C 920212 DATE WRITTEN C***END PROLOGUE DPNTCK C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. DOUBLE PRECISION TOL, YF INTEGER I, IERR, KONTRL, N, NERR LOGICAL FATAL C .. Local Arrays .. DOUBLE PRECISION C(6), D(6), DCHK(6), W(12), X(6), XCHK(6), Y(6) C .. External Functions .. DOUBLE PRECISION D1MACH INTEGER NUMXER EXTERNAL D1MACH, NUMXER C .. External Subroutines .. EXTERNAL DPOLCF, DPLINT, DPOLVL, XERCLR, XGETF, XSETF C .. Intrinsic Functions .. INTRINSIC ABS, SQRT C .. Data statements .. DATA X / 1.0D0, 2.0D0, 3.0D0, -1.0D0, -2.0D0, -3.0D0 / DATA Y / 0.0D0, 9.0D0, 64.0D0, 0.0D0, 9.0D0, 64.0D0 / DATA XCHK / 1.0D0, 0.0D0, -2.0D0, 0.0D0, 1.0D0, 0.0D0 / DATA DCHK / 1.0D0, 0.0D0, -4.0D0, 0.0D0, 24.0D0, 0.0D0 / C***FIRST EXECUTABLE STATEMENT DPNTCK IF (KPRINT .GE. 2) WRITE (LUN,9000) C C Initialize variables for tests. C TOL = SQRT(D1MACH(4)) IPASS = 1 N = 6 C C Set up polynomial test. C CALL DPLINT (N, X, Y, C) CALL DPOLCF (0.0D0, N, X, C, D, W) C C Check to see if DPOLCF test passed. C FATAL = .FALSE. DO 110 I = 1,N IF (ABS(D(I)-XCHK(I)) .GT. TOL) THEN IPASS = 0 FATAL = .TRUE. ENDIF 110 CONTINUE IF (FATAL) THEN IF (KPRINT .GE. 2) WRITE (LUN, 9010) 'FAILED', (D(I), I = 1,N) ELSE IF (KPRINT .GE. 3) WRITE (LUN, 9010) 'PASSED', (D(I), I = 1,N) ENDIF C C Test DPOLVL. C CALL DPOLVL (5, 0.0D0, YF, D, N, X, C, W, IERR) IF (ABS(DCHK(1)-YF) .LE. TOL) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9020) 'PASSED', YF,(D(I),I=1,5) ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9020) 'FAILED', YF,(D(I),I=1,5) ENDIF C FATAL = .FALSE. DO 120 I = 1,5 IF (ABS(DCHK(I+1)-D(I)) .GT. TOL) THEN IPASS = 0 FATAL = .TRUE. ENDIF 120 CONTINUE C C Trigger 2 error conditions C CALL XGETF (KONTRL) IF (KPRINT .LE. 2) THEN CALL XSETF (0) ELSE CALL XSETF (1) ENDIF FATAL = .FALSE. CALL XERCLR C IF (KPRINT .GE. 3) WRITE (LUN,9030) CALL DPLINT (0, X, Y, C) IF (NUMXER(NERR) .NE. 2) THEN IPASS = 0 FATAL = .TRUE. ENDIF CALL XERCLR C X(1) = -1.0D0 CALL DPLINT (N, X, Y, C) IF (NUMXER(NERR) .NE. 2) THEN IPASS = 0 FATAL = .TRUE. ENDIF CALL XERCLR C CALL XSETF (KONTRL) IF (FATAL) THEN IF (KPRINT .GE. 2) THEN WRITE (LUN, 9040) ENDIF ELSE IF (KPRINT .GE. 3) THEN WRITE (LUN, 9050) ENDIF ENDIF C IF (IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN,9080) IF (IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN,9090) RETURN C 9000 FORMAT ('1' / ' Test DPLINT, DPOLCF and DPOLVL') 9010 FORMAT (/ 'DPOLCF ', A, ' test' / + ' Taylor coefficients for the quintic should be' / + 6X, '1.000', 5X, '0.000', 4X, '-2.000', 5X, '0.000', 5X, + '1.000', 5X, '0.000' / + ' Taylor coefficients from DPOLCF are' / 1X, 6F10.3 /) 9020 FORMAT (' Derivative test ', A / + ' The derivatives of the polynomial at zero as ', + 'computed by DPOLVL are' / 1X, 6F10.3 /) 9030 FORMAT (/' 2 Error messages expected') 9040 FORMAT (/ ' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED') 9050 FORMAT (/ ' ALL INCORRECT ARGUMENT TESTS PASSED') 9080 FORMAT (/' ****************DPLINT PASSED ALL TESTS**************') 9090 FORMAT (/' ***************DPLINT FAILED SOME TESTS**************') END *DECK DPRIN SUBROUTINE DPRIN (LUN, NUM1, KPRINT, IP, EXACT, RESULT, ABSERR, + NEVAL, IERV, LIERV) C***BEGIN PROLOGUE DPRIN C***SUBSIDIARY C***PURPOSE Subsidiary to CDQAG, CDQAG, CDQAGI, CDQAGP, CDQAGS, CDQAWC, C CDQAWF, CDQAWO, CDQAWS, and CDQNG. C***LIBRARY SLATEC C***AUTHOR Piessens, Robert C Applied Mathematics and Programming Division C K. U. Leuven C de Doncker, Elise C Applied Mathematics and Programming Division C K. U. Leuven C***DESCRIPTION C C This program is called by the (double precision) Quadpack quick C check routines for printing out their messages. C C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 811027 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 910627 Code completely rewritten. (WRB) C***END PROLOGUE DPRIN C .. Scalar Arguments .. DOUBLE PRECISION ABSERR, EXACT, RESULT INTEGER IP, KPRINT, LIERV, LUN, NEVAL, NUM1 C .. Array Arguments .. INTEGER IERV(*) C .. Local Scalars .. DOUBLE PRECISION ERROR INTEGER IER, K C .. Intrinsic Functions .. INTRINSIC ABS C***FIRST EXECUTABLE STATEMENT DPRIN IER = IERV(1) ERROR = ABS(EXACT-RESULT) C IF (KPRINT .GE. 2) THEN IF (IP.EQ.1) THEN IF (KPRINT .GE. 3) THEN C C Write PASS message. C WRITE (UNIT=LUN, FMT=9000) NUM1 ENDIF ELSE C C Write failure messages. C WRITE (UNIT=LUN, FMT=9010) NUM1 IF (NUM1 .EQ. 0) WRITE (UNIT=LUN, FMT=9020) IF (NUM1 .GT. 0) WRITE (UNIT=LUN, FMT=9030) NUM1 IF (LIERV .GT. 1) WRITE (UNIT=LUN, FMT=9040) (IERV(K), + K=2,LIERV) IF (NUM1 .EQ. 6) WRITE (UNIT=LUN, FMT=9050) WRITE (UNIT=LUN, FMT=9060) WRITE (UNIT=LUN, FMT=9070) IF (NUM1 .NE. 5) THEN WRITE (UNIT=LUN, FMT=9080) EXACT,RESULT,ERROR,ABSERR,IER, + NEVAL ELSE WRITE (LUN,FMT=9090) RESULT,ABSERR,IER,NEVAL ENDIF ENDIF ENDIF C RETURN C 9000 FORMAT (' TEST ON IER = ', I2, ' PASSED') 9010 FORMAT (' TEST ON IER = ', I1, ' FAILED.') 9020 FORMAT (' WE MUST HAVE IER = 0, ERROR.LE.ABSERR AND ABSERR.LE', + '.MAX(EPSABS,EPSREL*ABS(EXACT))') 9030 FORMAT (' WE MUST HAVE IER = ', I1) 9040 FORMAT (' OR IER = ', 8(I1,2X)) 9050 FORMAT (' RESULT, ABSERR, NEVAL AND EVENTUALLY LAST SHOULD BE', + ' ZERO') 9060 FORMAT (' WE HAVE ') 9070 FORMAT (7X, 'EXACT', 11X, 'RESULT', 6X, 'ERROR', 4X, 'ABSERR', + 4X, 'IER NEVAL', /, ' ', 42X, + '(EST.ERR.)(FLAG)(NO F-EVAL)') 9080 FORMAT (' ', 2(D15.7,1X), 2(D9.2,1X), I4, 4X, I6) 9090 FORMAT (5X, 'INFINITY', 4X, D15.7, 11X, D9.2, I5, 4X, I6) END *DECK DQCGLS SUBROUTINE DQCGLS (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DQCGLS C***PURPOSE Quick check for DGLSS. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (QCGLSS-S, DQCGLS-D) C***AUTHOR Voorhees, E. A., (LANL) C***DESCRIPTION C C QUICK CHECK SUBROUTINE DQCGLS TESTS THE EXECUTION C OF THE GENERAL LINEAR SYSTEM SOLVER, DGLSS . THE C DGLSS SUBROUTINE PACKAGE WAS WRITTEN BY T. MANTEUFFEL C (LANL). C C A TITLE LINE AND A SUMMARY LINE ARE ALWAYS OUTPUTTED C BY DQCGLS. THE SUMMARY LINE GIVES A COUNT OF THE C NUMBER OF PROBLEMS DETECTED DURING THE TEST. C C THE REAL QUANTITIES FOR THE COMPUTED SOLUTION VECTOR C X AND THE CORRESPONDING RNORM ARE COMPARED AGAINST C STORED VALUES. DISAGREEMENT OCCURS IF A DIFFERENCE C IS SQRT(D1MACH(4) OR MORE. THE RETURNED VALUE (INTEGER) C OF INFO IS ALSO CHECKED. FOUR CASES ARE RUN, TWO C INVOLVING LLSIA AND TWO INVOLVING ULSIA . C C DQCGLS REQUIRES NO INPUT ARGUMENTS. ON RETURN, NERR C (INTEGER TYPE) CONTAINS THE COUNT OF THE NUMBER OF C PROBLEMS DETECTED BY QCGLSS . C C***ROUTINES CALLED D1MACH, DGLSS C***REVISION HISTORY (YYMMDD) C 811026 DATE WRITTEN C 850601 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF, cleaned up FORMATs, C including removing an illegal character from column 1, and C editorial changes. (RWC) C***END PROLOGUE DQCGLS C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION AA(4,4,2),A(4,4),BB(4,2),B(4),XX(4,4) DIMENSION WORK(50) CHARACTER*1 LIST(2) INTEGER INF(4),NERR,KPROG,KCASE INTEGER IWORK(20),INFO,LUN DATA AA/1.D0,.5D0,1.D0,.25D0,0.D0,2.D0,0.D0,1.D0,2.D0,-1.D0, 11.D0,0.D0,0.D0,0.D0,0.D0,0.D0,1.D0,2.D0,-1.D0,0.D0,0.D0,1.D0, 22.D0,0.D0,-1.D0,0.D0,1.D0,0.D0,1.D0,0.D0,1.D0,0.D0/ DATA BB/3.D0,1.5D0,2.D0,1.25D0,1.D0,3.D0,3.D0,0.D0/ DATA XX/.9999999999999787D0,1.000000000000007D0, 1 1.000000000000007D0,0.D0,.8095238095238102D0, 2 1.047619047619044D0,1.095238095238081D0,0.D0, 3 .7777777777777857D0,1.444444444444429D0,.3333333333333393D0, 4 .5555555555555500D0, 5 .3333333333333321D0,0.0D0,-.3333333333333286D0, 6 .3333333333333286D0/ DATA INF/0,1,0,2/ DATA LIST/'L', 'U'/ C***FIRST EXECUTABLE STATEMENT DQCGLS INFO = 0 NERR = 0 R = MAX(SQRT(D1MACH(4)),1.D-12) IF (KPRINT.GE.2) WRITE(LUN,800) DO 60 KPROG=1,2 DO 50 KCASE=1,2 C C FORM BASIC MATRIX A AND VECTOR B . (CASE 1) C DO 10 I=1,4 DO 5 J=1,4 A(I,J) = AA(I,J,KPROG) 5 CONTINUE B(I) = BB(I,KPROG) 10 CONTINUE C C MAKE 3 ROWS IDENTICAL FOR CASE 2. C IF (KCASE .NE. 1) THEN DO 20 I=2,3 DO 15 J=1,4 A(I,J) = A(1,J) 15 CONTINUE B(I) = B(1) 20 CONTINUE ENDIF C C SOLVE FOR VECTOR X . C INFO = 0 IF (KPROG .EQ. 1) CALL DGLSS(A,4,4,3,B,4,1,RNORM,WORK,50, 1 IWORK,20,INFO) IF (KPROG .EQ. 2) CALL DGLSS(A,4,3,4,B,4,1,RNORM,WORK,50, 1 IWORK,20,INFO) C C TEST COMPUTED X , RNORM , AND INFO . C KK = 2*(KPROG - 1) + KCASE DELMAX = 0.0D0 DO 30 I=1,4 DELX = ABS(B(I)-XX(I,KK)) DELMAX = MAX(DELMAX,DELX) 30 CONTINUE C IF (KPRINT.GE.3) WRITE (LUN,701) LIST(KPROG),KCASE,DELMAX IF (DELMAX .GE. R) THEN NERR = NERR + 1 IF(KPRINT.GE.2) WRITE(LUN,801) LIST(KPROG),KCASE,DELMAX ENDIF C IF (KPRINT.GE.3) WRITE (LUN,702) LIST(KPROG),KCASE,RNORM IF (RNORM .GE. R) THEN NERR = NERR + 1 IF (KPRINT.GE.2) WRITE (LUN,802) LIST(KPROG),KCASE,RNORM ENDIF IF (KPRINT.GE.3) WRITE (LUN,703) LIST(KPROG),KCASE,INFO, * INF(KK) IF (INFO .NE. INF(KK)) THEN NERR = NERR + 1 IF (KPRINT.GE.2) WRITE (LUN,803) LIST(KPROG),KCASE,INFO, * INF(KK) ENDIF 50 CONTINUE 60 CONTINUE C C SUMMARY PRINT C IPASS=0 IF (NERR.EQ.0) IPASS=1 IF (NERR.NE.0 .AND. KPRINT.NE.0) WRITE (LUN,804) NERR IF (NERR.EQ.0 .AND. KPRINT.GT.1) WRITE (LUN,805) RETURN C 703 FORMAT (3X, A, 'LSIA, CASE ', I1, '. INFO=', I1, ' (SHOULD = ', 1 I1, ')'/) 804 FORMAT (/' **** DQCGLS DETECTED A TOTAL OF ', I2, 1 ' PROBLEMS WITH DGLSS. ****'/) 805 FORMAT (' DQCGLS DETECTED NO PROBLEMS WITH DGLSS.'/) 801 FORMAT (' PROBLEM WITH ', A, 'LSIA, CASE ', I1, 1 '. MAX ABS ERROR OF', D11.4/) 800 FORMAT(/' * DQCGLS - QUICK CHECK FOR DGLSS (DLLSIA AND DULSIA)'/) 701 FORMAT (3X, A, 'LSIA, CASE ', I1, '. MAX ABS ERROR OF', D11.4/) 702 FORMAT (3X, A, 'LSIA, CASE ', I1, '. RNORM IS ', D11.4/) 802 FORMAT (' PROBLEM WITH ', A, 'LSIA, CASE ', I1, 1 '. RNORM (TOO LARGE) IS', D11.4/) 803 FORMAT (' PROBLEM WITH ', A, 'LSIA, CASE ', I1, '. INFO=', I1, 1 ' (SHOULD = ', I1, ')'/) END *DECK DQCK SUBROUTINE DQCK (LUN, KPRINT, NERR) C***BEGIN PROLOGUE DQCK C***PURPOSE Quick check for DPOFS AND DNBFS. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Voorhees, E. A., (LANL) C***DESCRIPTION C C QUICK CHECK SUBROUTINE DQCK TESTS THE EXECUTION OF THE C SLATEC SUBROUTINES DPOFS AND DNBFS. C A TITLE LINE AND A SUMMARY LINE ARE ALWAYS OUTPUTTED. C C THE SUMMARY LINE GIVES A COUNT OF THE NUMBER OF C PROBLEMS ENCOUNTERED IN THE TEST IF ANY EXIST. DQCK C CHECKS COMPUTED VS. EXACT SOLUTIONS TO AGREE TO C WITHIN 0.8 TIMES THE WORD LENGTH OF THE COMPUTER C (1.6 IF DOUBLE PRECISION) FOR CASE 1. DQCK ALSO C TESTS ERROR HANDLING BY THE SUBROUTINE (CALLS TO C XERMSG (DQCK SETS IFLAG/KONTRL TO 0)) C USING A SINGULAR MATRIX FOR CASE 2. EACH EXECUTION C PROBLEM DETECTED BY DQCK RESULTS IN AN ADDITIONAL C EXPLANATORY LINE OF OUTPUT. C C DQCK REQUIRES NO INPUT ARGUMENTS. C ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT C OF ALL PROBLEMS DETECTED BY DQCK. C C***ROUTINES CALLED D1MACH, DNBFS, DPOFS C***REVISION HISTORY (YYMMDD) C 801002 DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901009 Restructured using IF-THEN-ELSE-ENDIF, cleaned up FORMATs, C including removing an illegal character from column 1, and C editorial changes. (RWC) C***END PROLOGUE DQCK DOUBLE PRECISION A(4,4),AT(5,4),ABE(5,7),ABET(5,7),B(4),BT(4), 1 C(4),WORK(35),SIGN,D1MACH REAL R,DELX,DELMAX CHARACTER*4 LIST(2) INTEGER LDA,N,ML,MU,IND,IWORK(4),NERR,I,J,J1,J2,JD,MLP,K,KCASE, 1 KPROG DATA A/5.0D0,4.0D0,1.0D0,1.0D0,4.0D0,5.0D0,1.0D0,1.0D0, 1 1.0D0,1.0D0,4.0D0,2.0D0,1.0D0,1.0D0,2.0D0,4.0D0/ DATA LIST/'POFS', 'NBFS'/ C***FIRST EXECUTABLE STATEMENT DQCK IF (KPRINT.GE.3) WRITE (LUN,800) LDA = 5 N = 4 ML = 2 MU = 1 JD = 2*ML+MU+1 NERR = 0 R = D1MACH(4)**0.8E0 C C COMPUTE C VECTOR. C SIGN = 1.0D0 DO 10 I=1,N C(I) = SIGN/I SIGN = -SIGN 10 CONTINUE C C CASE 1 FOR WELL-CONDITIONED MATRIX, CASE 2 FOR SINGULAR MATRIX. C DO 170 KCASE=1,2 DO 140 KPROG=1,2 C SET VECTOR B TO ZERO. DO 11 I=1,N B(I) = 0.0D0 11 CONTINUE C C FORM VECTOR B FOR NON-BANDED. C IF (KPROG.EQ.1) THEN DO 13 I=1,N DO 12 J=1,N B(I) = B(I)+A(I,J)*C(J) 12 CONTINUE 13 CONTINUE ELSE C C FORM ABE(NB ARRAY) FROM MATRIX A C AND FORM VECTOR B FOR BANDED. C DO 30 J=1,JD DO 20 I=1,N ABE(I,J) = 0.0D0 20 CONTINUE 30 CONTINUE C MLP = ML+1 DO 50 I=1,N J1 = MAX(1,I-ML) J2 = MIN(N,I+MU) DO 40 J=J1,J2 K = J-I+MLP ABE(I,K) = A(I,J) B(I) = B(I)+(A(I,J)*C(J)) 40 CONTINUE 50 CONTINUE ENDIF C C FORM BT FROM B, AT FROM A, AND ABET FROM ABE. C DO 60 I=1,N BT(I) = B(I) DO 58 J=1,N AT(I,J) = A(I,J) 58 CONTINUE 60 CONTINUE C DO 80 J=1,JD DO 70 I=1,N ABET(I,J) = ABE(I,J) 70 CONTINUE 80 CONTINUE C C MAKE AT AND ABET SINGULAR FOR CASE = 2 C IF (KCASE.EQ.2) THEN DO 88 J=1,N AT(1,J) = 0.0D0 88 CONTINUE C DO 90 J=1,JD ABET(1,J) = 0.0D0 90 CONTINUE ENDIF C C SOLVE FOR X C IF (KPROG.EQ.1) CALL DPOFS (AT,LDA,N,BT,1,IND,WORK) IF (KPROG.EQ.2) CALL DNBFS (ABET,LDA,N,ML,MU,BT,1,IND,WORK, * IWORK) C C COMPARE EXACT AND COMPUTED SOLUTIONS FOR CASE 1 C IF (KCASE.EQ.1) THEN DELMAX = 0.0E0 DO 110 I=1,N DELX = ABS(BT(I)-C(I)) DELMAX = MAX(DELMAX,DELX) 110 CONTINUE C IF (R.LE.DELMAX) THEN NERR = NERR+1 WRITE (LUN,801) LIST(KPROG),KCASE,DELMAX ENDIF ELSE C C CHECK CONTROL FOR SINGULAR MATRIX FOR CASE 2 C IF (IND.NE.-4) THEN NERR = NERR+1 WRITE (LUN,802) LIST(KPROG),KCASE,IND ENDIF ENDIF 140 CONTINUE 170 CONTINUE C C SUMMARY PRINT C IF (NERR.NE.0) WRITE (LUN,803) NERR IF (KPRINT.GE.2 .AND. NERR.EQ.0) WRITE (LUN,804) RETURN C 800 FORMAT (/' * DQCK - QUICK CHECK FOR DPOFS AND DNBFS'/) 801 FORMAT (' PROBLEM WITH D', A, ', CASE ', I1, 1 '. MAX ABS ERROR OF', E11.4/) 802 FORMAT (' PROBLEM WITH D', A, ', CASE ', I1, '. IND = ', I2, 1 ' INSTEAD OF -4'/) 803 FORMAT (/' **** DQCK DETECTED A TOTAL OF ', I2,' PROBLEMS. ****'/) 804 FORMAT (' DQCK DETECTED NO PROBLEMS.'/) END *DECK DQCKIN SUBROUTINE DQCKIN (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DQCKIN C***PURPOSE Quick check for DBSKIN. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Amos, D. E., (SNLA) C***DESCRIPTION C C ABSTRACT * A DOUBLE PRECISION ROUTINE * C DQCKIN IS A QUICK CHECK ROUTINE WHICH EXERCISES THE MAJOR C LOOPS IN SUBROUTINE DBSKIN (X,N,KODE,M,Y,NZ,IERR) FOR BICKLEY C FUNCTIONS KI(J,X). MORE PRECISELY, DQCKIN DOES CONSISTENCY CHECKS C ON THE OUTPUT FROM DBSKIN BY COMPARING SINGLE EVALUATIONS (M=1) C AGAINST SELECTED MEMBERS OF SEQUENCES WHICH ARE GENERATED BY C RECURSION. IF THE RELATIVE ERROR IS LESS THAN 1000 TIMES UNIT C ROUND OFF, THEN THE TEST IS PASSED - IF NOT, THEN X, THE VALUES C TO BE COMPARED, THE RELATIVE ERROR AND PARAMETERS KODE, N, M AND K C ARE WRITTEN ON LOGICAL UNIT 6 WHERE K IS THE MEMBER OF THE C SEQUENCE OF LENGTH M WHICH FAILED THE TEST. THAT IS, THE INDEX C OF THE FUNCTION WHICH FAILED THE TEST IS J=N+K-1. UNDERFLOW C TESTS ARE MADE AND ERROR CONDITIONS ARE TRIGGERED. C C FUNCTIONS I1MACH AND D1MACH MUST BE INITIALIZED ACCORDING TO THE C PROLOGUE IN EACH FUNCTION FOR THE MACHINE ENVIRONMENT BEFORE C DQCKIN OR DBSKIN CAN BE EXECUTED. FIFTEEN MACHINE ENVIRONMENTS C CAN BE DEFINED IN I1MACH AND D1MACH. C C***ROUTINES CALLED D1MACH, DBSKIN, I1MACH C***REVISION HISTORY (YYMMDD) C 820601 DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DQCKIN INTEGER I, IERR, IFLG, IX, I1M12, J, K, KODE, LUN, M, MDEL, MM, * N, NDEL, NN INTEGER I1MACH DOUBLE PRECISION AIX, ER, TOL, V, X, XINC, Y DOUBLE PRECISION D1MACH DIMENSION V(1), Y(10) C***FIRST EXECUTABLE STATEMENT DQCKIN TOL = 1000.0D0*MAX(D1MACH(4),1.0D-18) IFLG = 0 IF(KPRINT.GE.3)WRITE (LUN,99999) 99999 FORMAT (1H1//35H QUICK CHECK DIAGNOSTICS FOR DBSKIN//) DO 70 KODE=1,2 N = 0 DO 60 NN=1,7 M = 1 DO 50 MM=1,4 X = 0.0D0 DO 40 IX=1,6 IF (N.EQ.0 .AND. IX.EQ.1) GO TO 30 CALL DBSKIN(X, N, KODE, M, Y, NZ, IERR) DO 20 K=1,M,2 J = N + K - 1 CALL DBSKIN(X, J, KODE, 1, V, NZ, IERR) ER = ABS((V(1)-Y(K))/V(1)) IF (ER.LE.TOL) GO TO 20 IF (IFLG.NE.0) GO TO 10 IF(KPRINT.GE.2)WRITE (LUN,99998) 99998 FORMAT (8X, 1HX, 13X, 4HV(1), 11X, 4HY(K), 9X, 6HREL ER, * 1HR, 5X, 4HKODE, 3X, 1HN, 4X, 1HM, 4X, 1HK) 10 CONTINUE IFLG = IFLG + 1 IF(KPRINT.GE.2) * WRITE (LUN,99997) X, V(1), Y(K), ER, KODE, N, M, K 99997 FORMAT (4E15.6, 4I5) IF (IFLG.GT.200) GO TO 130 20 CONTINUE 30 CONTINUE AIX = 2*IX - 3 XINC = MAX(1.0D0,AIX) X = X + XINC 40 CONTINUE MDEL = MAX(1,MM-1) M = M + MDEL 50 CONTINUE NDEL = MAX(1,2*N-2) N = N + NDEL 60 CONTINUE 70 CONTINUE C----------------------------------------------------------------------- C TEST UNDERFLOW C----------------------------------------------------------------------- KODE = 1 M = 10 N = 10 I1M12 = I1MACH(15) X = -2.302D0*D1MACH(5)*I1M12 CALL DBSKIN(X, N, KODE, M, Y, NZ, IERR) IF (NZ.EQ.M) GO TO 80 IF(KPRINT.GE.2)WRITE (LUN,99996) 99996 FORMAT (//30H NZ IN UNDERFLOW TEST IS NOT 1//) IFLG = IFLG + 1 GO TO 110 80 CONTINUE DO 90 I=1,M IF (Y(I).NE.0.0D0) GO TO 100 90 CONTINUE GO TO 110 100 CONTINUE IFLG = IFLG + 1 IF(KPRINT.GE.2)WRITE (LUN,99995) 99995 FORMAT (//43H SOME Y VALUE IN UNDERFLOW TEST IS NOT ZERO//) 110 CONTINUE IF (IFLG.NE.0.OR.KPRINT.LT.3) GO TO 120 WRITE (LUN,99994) 99994 FORMAT (//16H QUICK CHECKS OK//) 120 CONTINUE IPASS=0 IF(IFLG.EQ.0)IPASS=1 RETURN 130 CONTINUE IF(KPRINT.GE.2)WRITE (LUN,99992) 99992 FORMAT (//52H PROCESSING OF MAIN LOOPS TERMINATED BECAUSE THE NUM, * 36HBER OF DIAGNOSTIC PRINTS EXCEEDS 200//) IPASS=0 IF(IFLG.EQ.0)IPASS=1 RETURN END *DECK DQCPSI SUBROUTINE DQCPSI (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DQCPSI C***PURPOSE Quick check for DPSIFN. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Amos, D. E., (SNLA) C***DESCRIPTION C C ABSTRACT * A DOUBLE PRECISION ROUTINE * C DQCPSI IS A QUICK CHECK ROUTINE WHICH EXERCISES THE MAJOR C LOOPS IN SUBROUTINE DPSIFN(X,N,KODE,M,ANS,NZ,IERR) FOR DERIVATIVES C OF THE PSI FUNCTION. FOR N=0, THE PSI FUNCTIONS ARE CALCULATED C EXPLICITLY AND CHECKED AGAINST EVALUATIONS FROM DPSIFN. FOR C N.GT.0, CONSISTENCY CHECKS ARE MADE BY COMPARING A SEQUENCE C AGAINST SINGLE EVALUATIONS OF DPSIFN, ONE AT A TIME. C IF THE RELATIVE ERROR IS LESS THAN 1000 TIMES THE MAXIMUM OF C UNIT ROUNDOFF AND 1.0D-18, THEN THE TEST IS PASSED--IF NOT, C THEN X, THE VALUES TO BE COMPARED, THE RELATIVE ERROR AND C PARAMETERS KODE AND N ARE WRITTEN ON LOGICAL UNIT 6 WHERE N IS C THE ORDER OF THE DERIVATIVE AND KODE IS A SELECTION PARAMETER C DEFINED IN THE PROLOGUE TO DPSIFN. C C FUNCTIONS I1MACH AND D1MACH MUST BE INITIALIZED ACCORDING TO THE C PROLOGUE IN EACH FUNCTION FOR THE MACHINE ENVIRONMENT BEFORE C DQCPSI OR DPSIFN CAN BE EXECUTED. C C***ROUTINES CALLED D1MACH, DPSIFN C***REVISION HISTORY (YYMMDD) C 820601 DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DQCPSI INTEGER I, IERR, IFLG, IX, KODE, LUN, M, N, NM, NN, NZ DOUBLE PRECISION ER, EULER, PSI1, PSI2, R1M4, S, TOL, X DOUBLE PRECISION D1MACH DIMENSION PSI1(3), PSI2(20) DATA EULER /0.5772156649015328606D0/ C***FIRST EXECUTABLE STATEMENT DQCPSI R1M4 = D1MACH(4) TOL = 1000.0D0*MAX(R1M4,1.0D-18) IF(KPRINT.GE.3)WRITE (LUN,99999) 99999 FORMAT (1H1//35H QUICK CHECK DIAGNOSTICS FOR DPSIFN//) C----------------------------------------------------------------------- C CHECK PSI(I) AND PSI(I-0.5), I=1,2,... C----------------------------------------------------------------------- IFLG = 0 N = 0 DO 50 KODE=1,2 DO 40 M=1,2 S = -EULER + (M-1)*(-2.0D0*LOG(2.0D0)) X = 1.0D0 - (M-1)*0.5D0 DO 30 I=1,20 CALL DPSIFN(X, N, KODE, 1, PSI2, NZ, IERR) PSI1(1) = -S + (KODE-1)*LOG(X) ER = ABS((PSI1(1)-PSI2(1))/PSI1(1)) IF (ER.LE.TOL) GO TO 20 IF (IFLG.NE.0) GO TO 10 IF(KPRINT.GE.2)WRITE (LUN,99998) 99998 FORMAT (8X, 1HX, 13X, 4HPSI1, 11X, 4HPSI2, 9X, 7HREL ERR, * 5X, 4HKODE, 3X, 1HN) 10 CONTINUE IFLG = IFLG + 1 IF(KPRINT.GE.2) * WRITE (LUN,99997) X, PSI1(1), PSI2(I), ER, KODE, N 99997 FORMAT (4E15.6, 2I5) IF (IFLG.GT.200) GO TO 150 20 CONTINUE S = S + 1.0D0/X X = X + 1.0D0 30 CONTINUE 40 CONTINUE 50 CONTINUE C----------------------------------------------------------------------- C CHECK SMALL X.LT.UNIT ROUNDOFF C----------------------------------------------------------------------- KODE = 1 X = TOL/10000.0D0 N = 1 CALL DPSIFN(X, N, KODE, 1, PSI2, NZ, IERR) PSI1(1) = X**(-N-1) ER = ABS((PSI1(1)-PSI2(1))/PSI1(1)) IF (ER.LE.TOL) GO TO 70 IF (IFLG.NE.0) GO TO 60 IF(KPRINT.GE.2)WRITE (LUN,99998) 60 CONTINUE IFLG = IFLG + 1 IF(KPRINT.GE.2) * WRITE (LUN,99997) X, PSI1(1), PSI2(1), ER, KODE, N 70 CONTINUE C----------------------------------------------------------------------- C CONSISTENCY TESTS FOR N.GE.0 C----------------------------------------------------------------------- DO 130 KODE=1,2 DO 120 M=1,5 DO 110 N=1,16,5 NN = N - 1 X = 0.1D0 DO 100 IX=1,25,2 X = X + 1.0D0 CALL DPSIFN(X, NN, KODE, M, PSI2, NZ, IERR) DO 90 I=1,M NM = NN + I - 1 CALL DPSIFN(X, NM, KODE, 1, PSI1, NZ, IERR) ER = ABS((PSI2(I)-PSI1(1))/PSI1(1)) IF (ER.LT.TOL) GO TO 90 IF (IFLG.NE.0) GO TO 80 IF(KPRINT.GE.2)WRITE (LUN,99998) 80 CONTINUE IFLG = IFLG + 1 IF(KPRINT.GE.2) * WRITE (LUN,99997) X, PSI1(1), PSI2(I), ER, KODE, NM 90 CONTINUE 100 CONTINUE 110 CONTINUE 120 CONTINUE 130 CONTINUE IF (IFLG.NE.0.OR.KPRINT.LT.3) GO TO 140 WRITE (LUN,99996) 99996 FORMAT (//16H QUICK CHECKS OK//) 140 CONTINUE IPASS=0 IF(IFLG.EQ.0)IPASS=1 RETURN 150 CONTINUE IF(KPRINT.GE.2)WRITE (LUN,99994) 99994 FORMAT (//52H PROCESSING OF MAIN LOOPS TERMINATED BECAUSE THE NUM, * 36HBER OF DIAGNOSTIC PRINTS EXCEEDS 200//) IPASS=0 IF(IFLG.EQ.0)IPASS=1 RETURN END *DECK DQFCN2 SUBROUTINE DQFCN2 (N, X, FVEC, IFLAG) C***BEGIN PROLOGUE DQFCN2 C***PURPOSE C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C SUBROUTINE WHICH EVALUATES THE FUNCTION FOR TEST C PROGRAM USED IN QUICK CHECK OF DNSQE. C C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DQFCN2 INTEGER IFLAG, N DOUBLE PRECISION FVEC(*), X(*) C***FIRST EXECUTABLE STATEMENT DQFCN2 FVEC(1) = 1.0D0 - X(1) FVEC(2) = 1.0D1*(X(2) - X(1)**2) RETURN END *DECK DQG8TS SUBROUTINE DQG8TS (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DQG8TS C***PURPOSE Quick check for DGAUS8. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (QG8TST-S, DQG8TS-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED D1MACH, DFQD1, DFQD2, DGAUS8, XGETF, XSETF C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Changed usage of D1MACH(3) to D1MACH(4). (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C 910708 Minor modifications in use of KPRINT. (WRB) C 920213 Code restructured to test DGAUS8 for all values of KPRINT, C second accuracy test added and testing of error returns C revised. (WRB) C***END PROLOGUE DQG8TS C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. INTEGER IERR DOUBLE PRECISION A, ANS, B, COR, ERR, REQ, TOL LOGICAL FATAL C .. External Functions .. DOUBLE PRECISION D1MACH, DFQD1, DFQD2 EXTERNAL D1MACH, DFQD1, DFQD2 C .. External Subroutines .. EXTERNAL DGAUS8, XGETF, XSETF C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT C***FIRST EXECUTABLE STATEMENT DQG8TS IF (KPRINT .GE. 2) WRITE (LUN,FMT=9000) C C Initialize variables for testing. C TOL = SQRT(D1MACH(4)) IPASS = 1 C C First accuracy test. C A = 1.0D0 B = 4.0D0 ERR = TOL/100.0D0 CALL DGAUS8 (DFQD1, A, B, ERR, ANS, IERR) COR = 2.0D0 IF (ABS(ANS-COR).LE.TOL .AND. IERR.EQ.1) THEN IF (KPRINT .GE. 3) + WRITE (LUN, 9010) 'PASSED', A, B, ANS, COR, ERR, IERR ELSE IPASS = 0 IF (KPRINT .GE. 2) + WRITE (LUN, 9010) 'FAILED', A, B, ANS, COR, ERR, IERR ENDIF C C Second accuracy test. C A = 0.0D0 B = 4.0D0*ATAN(1.0D0) ERR = TOL/100.0D0 CALL DGAUS8 (DFQD2, A, B, ERR, ANS, IERR) COR = (EXP(B)-1.0D0)/101.0D0 IF (ABS(ANS-COR).LE.TOL .AND. IERR.EQ.1) THEN IF (KPRINT .GE. 3) + WRITE (LUN, 9010) 'PASSED', A, B, ANS, COR, ERR, IERR ELSE IPASS = 0 IF (KPRINT .GE. 2) + WRITE (LUN, 9010) 'FAILED', A, B, ANS, COR, ERR, IERR ENDIF C C Test error returns. C CALL XGETF (KONTRL) IF (KPRINT .LE. 2) THEN CALL XSETF (0) ELSE CALL XSETF (1) ENDIF FATAL = .FALSE. C IF (KPRINT .GE. 3) WRITE (LUN,FMT=9030) C C Test with a discontinuous integrand and a tight error tolerance. C A = 0.0D0 B = 1.0D0 COR = 2.0D0 ERR = 100.0D0*D1MACH(4) REQ = ERR CALL DGAUS8 (DFQD1, A, B, ERR, ANS, IERR) C C See if test passed. C IF (IERR .EQ. 2) THEN IF (KPRINT .GE. 3) + WRITE (LUN,FMT=9040) 'PASSED', REQ, ANS, IERR, ERR, COR ELSE IF (KPRINT .GE. 2) + WRITE (LUN,FMT=9040) 'FAILED', REQ, ANS, IERR, ERR, COR IPASS = 0 FATAL = .TRUE. ENDIF C C Test DGAUS8 with A and B nearly equal. C A = 2.0D0 B = A*(1.0D0+D1MACH(4)) COR = 0.0D0 ERR = TOL C CALL DGAUS8 (DFQD1, A, B, ERR, ANS, IERR) C C Check to see if test passed. C IF (IERR.EQ.-1 .AND. ANS.EQ.0.0D0) THEN IF (KPRINT .GE. 3) WRITE (LUN,9050) 'PASSED' ELSE IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 2) WRITE (LUN,9050) 'FAILED' ENDIF C CALL XSETF (KONTRL) IF (FATAL) THEN IF (KPRINT .GE. 2) THEN WRITE (LUN, 9060) ENDIF ELSE IF (KPRINT .GE. 3) THEN WRITE (LUN, 9070) ENDIF ENDIF C IF (IPASS.EQ.1 .AND. KPRINT.GE.3) WRITE (LUN,FMT=9080) IF (IPASS.EQ.0 .AND. KPRINT.GE.2) WRITE (LUN,FMT=9090) RETURN C 9000 FORMAT ('1' / ' DGAUS8 Quick Check') 9010 FORMAT (/ ' Accuracy test of DGAUS8 ', A / + ' A = ', F10.5, ' B = ', F10.5 / + ' Computed result = ', D14.7, ' Exact result = ', + D14.7 / + ' Tolerance = ', D14.7, ' IERR = ', I2 /) 9030 FORMAT (/ ' Test error returns' / + ' 2 error messages expected' /) 9040 FORMAT (' Test of DGAUS8 ', A / + ' REQ =', D10.2, 5X, 'ANS =', D20.13, 5X, 'IERR =', I2, + 5X, 'should be 2' / + ' ERR =', D10.2, ' CORRECT =' ,D20.13 /) 9050 FORMAT (' Test of A and B nearly equal ', A) 9060 FORMAT (/ ' At least one incorrect argument test FAILED') 9070 FORMAT (/ ' All incorrect argument tests PASSED') 9080 FORMAT (/,' ***************DGAUS8 PASSED ALL TESTS**************') 9090 FORMAT (/,' ***************DGAUS8 FAILED SOME TESTS*************') END *DECK DQJAC2 SUBROUTINE DQJAC2 (N, X, FVEC, FJAC, LDFJAC, IFLAG) C***BEGIN PROLOGUE DQJAC2 C***PURPOSE C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C SUBROUTINE TO EVALUATE THE FULL JACOBIAN FOR TEST PROBLEM USED C IN QUICK CHECK OF DNSQE. C C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DQJAC2 INTEGER IFLAG, LDFJAC, N DOUBLE PRECISION FJAC(LDFJAC,*), FVEC(*), X(*) C***FIRST EXECUTABLE STATEMENT DQJAC2 FJAC(1,1) = -1.0D0 FJAC(1,2) = 0.0D0 FJAC(2,1) = -2.0D1*X(1) FJAC(2,2) = 1.0D1 RETURN END *DECK DQN79Q SUBROUTINE DQN79Q (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DQN79Q C***PURPOSE Quick check for DQNC79. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (QN79QX-S, DQN79Q-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED D1MACH, DFQD1, DFQD2, DQNC79, XGETF, XSETF C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Changed usage of D1MACH(3) to D1MACH(4). (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C 910708 Minor modifications in use of KPRINT. (WRB) C 920213 Code restructured to test DQNC79 for all values of KPRINT, C second accuracy test added and testing of error returns C revised. (WRB) C***END PROLOGUE DQN79Q C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. INTEGER IERR, KONTRL, NFCT DOUBLE PRECISION A, ANS, B, COR, ERR, REQ, TOL LOGICAL FATAL C .. External Functions .. DOUBLE PRECISION D1MACH, DFQD1, DFQD2 EXTERNAL D1MACH, DFQD1, DFQD2 C .. External Subroutines .. EXTERNAL DQNC79, XGETF, XSETF C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT C***FIRST EXECUTABLE STATEMENT DQN79Q IF (KPRINT .GE. 2) WRITE (LUN,FMT=9000) C C Initialize variables for testing. C TOL = SQRT(D1MACH(4)) IPASS = 1 C C First accuracy test. C A = 1.0D0 B = 4.0D0 ERR = TOL/100.0D0 CALL DQNC79 (DFQD1, A, B, ERR, ANS, IERR, NFCT) COR = 2.0D0 IF (ABS(ANS-COR).LE.TOL .AND. IERR.EQ.1) THEN IF (KPRINT .GE. 3) + WRITE (LUN, 9010) 'PASSED', A, B, ANS, COR, ERR, IERR, NFCT ELSE IPASS = 0 IF (KPRINT .GE. 2) + WRITE (LUN, 9010) 'FAILED', A, B, ANS, COR, ERR, IERR, NFCT ENDIF C C Second accuracy test. C A = 0.0D0 B = 4.0D0*ATAN(1.0D0) ERR = TOL/10.0D0 CALL DQNC79 (DFQD2, A, B, ERR, ANS, IERR, NFCT) COR = (EXP(B)-1.0D0)/101.0D0 IF (ABS(ANS-COR).LE.TOL .AND. IERR.EQ.1) THEN IF (KPRINT .GE. 3) + WRITE (LUN, 9010) 'PASSED', A, B, ANS, COR, ERR, IERR, NFCT ELSE IPASS = 0 IF (KPRINT .GE. 2) + WRITE (LUN, 9010) 'FAILED', A, B, ANS, COR, ERR, IERR, NFCT ENDIF C C Test error returns. C CALL XGETF (KONTRL) IF (KPRINT .LE. 2) THEN CALL XSETF (0) ELSE CALL XSETF (1) ENDIF FATAL = .FALSE. C IF (KPRINT .GE. 3) WRITE (LUN,FMT=9030) C C Test with a discontinuous integrand and a tight error tolerance. C A = 0.0D0 B = 1.0D0 COR = 2.0D0 ERR = 100.0D0*D1MACH(4) REQ = ERR CALL DQNC79 (DFQD1, A, B, ERR, ANS, IERR, NFCT) C C See if test passed. C IF (IERR .EQ. 2) THEN IF (KPRINT .GE. 3) + WRITE (LUN,FMT=9040) 'PASSED', REQ, ANS, IERR, ERR, COR ELSE IF (KPRINT .GE. 2) + WRITE (LUN,FMT=9040) 'FAILED', REQ, ANS, IERR, ERR, COR IPASS = 0 FATAL = .TRUE. ENDIF C C Test DQNC79 with A and B nearly equal. C A = 2.0D0 B = A*(1.0D0+D1MACH(4)) COR = 0.0D0 ERR = TOL C CALL DQNC79 (DFQD1, A, B, ERR, ANS, IERR, NFCT) C C Check to see if test passed. C IF (IERR.EQ.-1 .AND. ANS.EQ.0.0D0) THEN IF (KPRINT .GE. 3) WRITE (LUN,9050) 'PASSED' ELSE IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 2) WRITE (LUN,9050) 'FAILED' ENDIF C CALL XSETF (KONTRL) IF (FATAL) THEN IF (KPRINT .GE. 2) THEN WRITE (LUN, 9060) ENDIF ELSE IF (KPRINT .GE. 3) THEN WRITE (LUN, 9070) ENDIF ENDIF C IF (IPASS.EQ.1 .AND. KPRINT.GE.3) WRITE (LUN,FMT=9080) IF (IPASS.EQ.0 .AND. KPRINT.GE.2) WRITE (LUN,FMT=9090) RETURN C 9000 FORMAT ('1' / ' DQNC79 Quick Check') 9010 FORMAT (/ ' Accuracy test of DQNC79 ', A / + ' A = ', F10.5, ' B = ', F10.5 / + ' Computed result = ', D14.7, ' Exact result = ', + D14.7 / + ' Tolerance = ', D14.7, ' IERR = ', I2, + ' Number of function evals = ', I5 /) 9030 FORMAT (/ ' Test error returns' / + ' 2 error messages expected' /) 9040 FORMAT (' Test of DQNC79 ', A / + ' REQ =', D10.2, 5X, 'ANS =', D20.13, 5X, 'IERR =', I2, + 5X, 'should be 2' / + ' ERR =', D10.2, ' CORRECT =' ,D20.13 /) 9050 FORMAT (' Test of A and B nearly equal ', A) 9060 FORMAT (/ ' At least one incorrect argument test FAILED') 9070 FORMAT (/ ' All incorrect argument tests PASSED') 9080 FORMAT (/' ***************DQNC79 PASSED ALL TESTS***************') 9090 FORMAT (/' ***************DQNC79 FAILED SOME TESTS**************') END *DECK DSOSFN DOUBLE PRECISION FUNCTION DSOSFN (X, K) C***BEGIN PROLOGUE DSOSFN C***PURPOSE Function evaluator for DSOS quick check. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Watts, H. A., (SNLA) C***DESCRIPTION C C FUNCTION WHICH EVALUATES THE FUNCTIONS, ONE AT A TIME, C FOR TEST PROGRAM USED IN QUICK CHECK OF DSOS. C C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 801001 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DSOSFN INTEGER K DOUBLE PRECISION X(2) C***FIRST EXECUTABLE STATEMENT DSOSFN IF (K .EQ. 1) DSOSFN = 1.0D0 - X(1) IF (K .EQ. 2) DSOSFN = 1.0D1*(X(2) - X(1)**2) RETURN END *DECK DSOSQX SUBROUTINE DSOSQX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DSOSQX C***PURPOSE Quick check for DSOS. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (SOSNQX-S, DSOSQX-D) C***KEYWORDS QUICK CHECK C***AUTHOR Watts, H. A., (SNLA) C***DESCRIPTION C C This subroutine performs a quick check on the subroutine DSOS. C C***ROUTINES CALLED D1MACH, DNRM2, DSOS, DSOSFN, PASS C***REVISION HISTORY (YYMMDD) C 801001 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920310 Code cleaned up and TYPE section added. (RWC, WRB) C***END PROLOGUE DSOSQX C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. DOUBLE PRECISION AER, FNORM, FNORMS, RER, TOLF INTEGER ICNT, IFLAG, IFLAGS, LIW, LWA, N C .. Local Arrays .. DOUBLE PRECISION FVEC(2), WA(17), X(2) INTEGER ITEST(2), IW(6) C .. External Functions .. DOUBLE PRECISION D1MACH, DNRM2, DSOSFN EXTERNAL D1MACH, DNRM2, DSOSFN C .. External Subroutines .. EXTERNAL DSOS, PASS C .. Intrinsic Functions .. INTRINSIC SQRT C***FIRST EXECUTABLE STATEMENT DSOSQX IFLAGS = 3 FNORMS = 0.0D0 N = 2 LWA = 17 LIW = 6 TOLF = SQRT(D1MACH(4)) RER = SQRT(D1MACH(4)) AER = 0.0D0 IF (KPRINT .GE. 2) WRITE (LUN,9000) C C Test the code with proper input values. C IFLAG = 0 X(1) = -1.2D0 X(2) = 1.0D0 CALL DSOS (DSOSFN,N,X,RER,AER,TOLF,IFLAG,WA,LWA,IW,LIW) ICNT = 1 FVEC(1) = DSOSFN(X,1) FVEC(2) = DSOSFN(X,2) FNORM = DNRM2(N,FVEC,1) ITEST(ICNT) = 0 IF (IFLAG.LE.IFLAGS .AND. FNORM-FNORMS.LE.RER) ITEST(ICNT) = 1 C IF (KPRINT .NE. 0) THEN IF (KPRINT.GE.3 .OR. (KPRINT.GE.2.AND.ITEST(ICNT).NE.1)) + WRITE (LUN,9010) IFLAGS,FNORMS,IFLAG,FNORM IF (KPRINT.GE.2 .OR. (KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) + CALL PASS (LUN,ICNT,ITEST(ICNT)) ENDIF C C Test improper input parameters. C LWA = 15 IFLAG = 0 X(1) = -1.2D0 X(2) = 1.0D0 CALL DSOS (DSOSFN,N,X,RER,AER,TOLF,IFLAG,WA,LWA,IW,LIW) ICNT = 2 ITEST(ICNT) = 0 IF (IFLAG .EQ. 9) ITEST(ICNT) = 1 IF (KPRINT.GE.2 .OR. (KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) + CALL PASS (LUN,ICNT,ITEST(ICNT)) C C Set IPASS. C IPASS = ITEST(1)*ITEST(2) IF (KPRINT.GE.1 .AND. IPASS.NE.1) WRITE (LUN,9020) IF (KPRINT.GE.2 .AND. IPASS.EQ.1) WRITE (LUN,9030) RETURN 9000 FORMAT ('1' / ' DSOS QUICK CHECK' /) 9010 FORMAT (' EXPECTED VALUE OF IFLAG AND RESIDUAL NORM', I5, D20.5 / + ' RETURNED VALUE OF IFLAG AND RESIDUAL NORM', I5, D20.5 /) 9020 FORMAT (/' **********WARNING -- DSOS FAILED SOME TESTS**********') 9030 FORMAT (/' ----------DSOS PASSED ALL TESTS----------') END *DECK DT0 DOUBLE PRECISION FUNCTION DT0 (X) C***BEGIN PROLOGUE DT0 C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED DF0S C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DT0 DOUBLE PRECISION A,B,DF0S,X,X1,Y C***FIRST EXECUTABLE STATEMENT DT0 A = 0.0D+00 B = 0.1D+01 X1 = X+0.1D+01 Y = (B-A)/X1+A DT0 = (B-A)*DF0S(Y)/X1/X1 RETURN END *DECK DT1 DOUBLE PRECISION FUNCTION DT1 (X) C***BEGIN PROLOGUE DT1 C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED DF1S C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DT1 DOUBLE PRECISION A,B,DF1S,X,X1,Y C***FIRST EXECUTABLE STATEMENT DT1 A = 0.0D+00 B = 0.1D+01 X1 = X+0.1D+01 Y = (B-A)/X1+A DT1 = (B-A)*DF1S(Y)/X1/X1 RETURN END *DECK DT2 DOUBLE PRECISION FUNCTION DT2 (X) C***BEGIN PROLOGUE DT2 C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED DF2S C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DT2 DOUBLE PRECISION A,B,DF2S,X,X1,Y C***FIRST EXECUTABLE STATEMENT DT2 A = 0.1D+00 B = 0.1D+01 X1 = X+0.1D+01 Y = (B-A)/X1+A DT2 = (B-A)*DF2S(Y)/X1/X1 RETURN END *DECK DT3 DOUBLE PRECISION FUNCTION DT3 (X) C***BEGIN PROLOGUE DT3 C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED DF3S C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DT3 DOUBLE PRECISION A,B,DF3S,X,X1,Y C***FIRST EXECUTABLE STATEMENT DT3 A = 0.0D+00 B = 0.5D+01 X1 = X+0.1D+01 Y = (B-A)/X1+A DT3 = (B-A)*DF3S(Y)/X1/X1 RETURN END *DECK DT4 DOUBLE PRECISION FUNCTION DT4 (X) C***BEGIN PROLOGUE DT4 C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED DF4S C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DT4 DOUBLE PRECISION A,B,DF4S,X,X1,Y C***FIRST EXECUTABLE STATEMENT DT4 A = 0.0D+00 B = 0.1D+01 X1 = X+0.1D+01 Y = (B-A)/X1+A DT4 = (B-A)*DF4S(Y)/X1/X1 RETURN END *DECK DT5 DOUBLE PRECISION FUNCTION DT5 (X) C***BEGIN PROLOGUE DT5 C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED DF5S C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DT5 DOUBLE PRECISION A,B,DF5S,X,X1,Y C***FIRST EXECUTABLE STATEMENT DT5 A = 0.0D+00 B = 0.1D+01 X1 = X+0.1D+01 Y = (B-A)/X1+A DT5 = (B-A)*DF5S(Y)/X1/X1 RETURN END *DECK DTEST SUBROUTINE DTEST (LEN, DCOMP, DTRUE, DSIZE, DFAC, KPRINT) C***BEGIN PROLOGUE DTEST C***PURPOSE Compare arrays DCOMP and DTRUE. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (STEST-S, DTEST-D) C***KEYWORDS QUICK CHECK C***AUTHOR Lawson, C. L., (JPL) C***DESCRIPTION C C This subroutine compares arrays DCOMP and DTRUE of length LEN to C see if the term by term differences, multiplied by DFAC, are C negligible. In the case of a significant difference, appropriate C messages are written. C C***ROUTINES CALLED D1MACH C***COMMON BLOCKS COMBLA C***REVISION HISTORY (YYMMDD) C 741210 DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 900820 Modified IF test to use function DDIFF and made cosmetic C changes to routine. (WRB) C 901005 Removed usage of DDIFF in favour of D1MACH. (RWC) C 910501 Added TYPE record. (WRB) C 920211 Code restructured and information added to the DESCRIPTION C section. (WRB) C***END PROLOGUE DTEST DOUBLE PRECISION DCOMP(*), DTRUE(*), DSIZE(*), DFAC, DD, + RELEPS, D1MACH LOGICAL PASS COMMON /COMBLA/ NPRINT, ICASE, N, INCX, INCY, MODE, PASS SAVE RELEPS DATA RELEPS /0.0D0/ C***FIRST EXECUTABLE STATEMENT DTEST IF (RELEPS .EQ. 0.0D0) RELEPS = D1MACH(4) DO 100 I = 1,LEN DD = ABS(DCOMP(I)-DTRUE(I)) IF (DFAC*DD .GT. ABS(DSIZE(I))*RELEPS) THEN C C Here DCOMP(I) is not close to DTRUE(I). C IF (PASS) THEN C C Print FAIL message and header. C PASS = .FALSE. IF (KPRINT .GE. 3) THEN WRITE (NPRINT,9000) WRITE (NPRINT,9010) ENDIF ENDIF IF (KPRINT .GE. 3) WRITE (NPRINT,9020) ICASE, N, INCX, INCY, + MODE, I, DCOMP(I), DTRUE(I), DD, DSIZE(I) ENDIF 100 CONTINUE RETURN 9000 FORMAT ('+', 39X, 'FAIL') 9010 FORMAT ('0CASE N INCX INCY MODE I', 29X, 'COMP(I)', 29X, + 'TRUE(I)', 2X, 'DIFFERENCE', 5X, 'SIZE(I)' / 1X) 9020 FORMAT (1X, I4, I3, 3I5, I3, 2D36.18, 2D12.4) END *DECK DUIVP SUBROUTINE DUIVP (X, Y, YP) C***BEGIN PROLOGUE DUIVP C***PURPOSE Dummy routine for DBVSUP quick check. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (UIVP-S, DUIVP-D) C***KEYWORDS QUICK CHECK C***AUTHOR Watts, H. A., (SNLA) C***DESCRIPTION C C This routine is never called; it is here to prevent loaders from C complaining about undefined externals while testing DBVSUP. C C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 750601 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920401 Variables declaration and TYPE sections added. (WRB) C***END PROLOGUE DUIVP C .. Scalar Arguments .. DOUBLE PRECISION X C .. Array Arguments .. DOUBLE PRECISION Y(*), YP(*) C***FIRST EXECUTABLE STATEMENT DUIVP STOP END *DECK DUVEC SUBROUTINE DUVEC (X, Y, YP) C***BEGIN PROLOGUE DUVEC C***PURPOSE Dummy routine for DBVSUP quick check. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (UVEC-S, DUVEC-D) C***KEYWORDS QUICK CHECK C***AUTHOR Watts, H. A., (SNLA) C***DESCRIPTION C C This routine is never called; it is here to prevent loaders from C complaining about undefined externals while testing DBVSUP. C C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 750601 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920401 Variables declaration and TYPE sections added. (WRB) C***END PROLOGUE DUVEC C .. Scalar Arguments .. DOUBLE PRECISION X C .. Array Arguments .. DOUBLE PRECISION Y(*), YP(*) C***FIRST EXECUTABLE STATEMENT DUVEC STOP END *DECK EG8CK SUBROUTINE EG8CK (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE EG8CK C***PURPOSE Quick check for EXINT and GAUS8. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (EG8CK-S, DEG8CK-D) C***KEYWORDS QUICK CHECK C***AUTHOR Amos, D. E., (SNLA) C***DESCRIPTION C C EG8CK is a quick check routine for EXINT and GAUS8. Exponential C integrals from EXINT are checked against quadratures from GAUS8. C C***ROUTINES CALLED EXINT, FEIN, GAUS8, R1MACH C***COMMON BLOCKS FEINX C***REVISION HISTORY (YYMMDD) C 800501 DATE WRITTEN C 890718 Added check when testing error conditions. (WRB) C 890718 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 910708 Code revised to test error returns for all values of C KPRINT. (WRB) C 920206 Corrected argument list in CALL to EXINT. (WRB) C***END PROLOGUE EG8CK COMMON /FEINX/ X, A, FKM INTEGER I, ICASE, IE, IERR, II, IK, IPASS, IX, IY, K, KE, KK, * KODE, KX, LUN, M, N, NM, NZ REAL A, ANS, ATOL, BB, EN, ER, EX, FKM, SIG, SUM, TOL, T1, T2, X, * XX, Y REAL R1MACH, FEIN DIMENSION EN(4), Y(4), XX(5) LOGICAL FATAL EXTERNAL FEIN C***FIRST EXECUTABLE STATEMENT EG8CK IF (KPRINT .GE. 2) WRITE (LUN,90000) IPASS=1 TOL = SQRT(MAX(R1MACH(4),1.0E-18)) DO 150 KODE=1,2 IK = KODE - 1 FKM = IK DO 140 N=1,25,8 DO 130 M=1,4 NM = N + M - 1 DO 120 IX=1,25,8 X = IX- 0.20E0 CALL EXINT(X, N, KODE, M, TOL, EN, NZ, IERR) KX = X+0.5E0 IF (KX.EQ.0) KX = 1 ICASE = 1 A = N IF (KX.LE.N) GO TO 10 ICASE = 2 A = NM IF (KX.GE.NM) GO TO 10 ICASE = 3 A = KX 10 CONTINUE SIG = 3.0E0/X T2 = 1.0E0 SUM = 0.0E0 20 CONTINUE T1 = T2 T2 = T2 + SIG ATOL = TOL CALL GAUS8(FEIN, T1, T2, ATOL, ANS, IERR) SUM = SUM + ANS IF (ABS(ANS).LT.ABS(SUM)*TOL) GO TO 30 GO TO 20 30 CONTINUE EX = 1.0E0 IF (KODE.EQ.1) EX = EXP(-X) BB = A IF (ICASE.NE.3) GO TO 40 IY = KX - N + 1 Y(IY) = SUM KE = M - IY IE = IY - 1 KK = IY II = IY GO TO 60 40 CONTINUE IF (ICASE.NE.2) GO TO 50 Y(M) = SUM IF (M.EQ.1) GO TO 100 IE = M - 1 II = M GO TO 80 50 CONTINUE Y(1) = SUM IF (M.EQ.1) GO TO 100 KE = M - 1 KK = 1 60 CONTINUE C C Forward recur C DO 70 K=1,KE Y(KK+1) = (EX-X*Y(KK))/BB BB = BB + 1.0E0 KK = KK + 1 70 CONTINUE IF (ICASE.NE.3) GO TO 100 80 BB = A - 1.0E0 C C Backward recur C DO 90 I=1,IE Y(II-1) = (EX-BB*Y(II))/X BB = BB - 1.0E0 II = II - 1 90 CONTINUE 100 CONTINUE DO 110 I=1,M ER = ABS((Y(I)-EN(I))/Y(I)) IF (ER .GT. TOL) THEN WRITE (LUN,90010) IPASS = 0 GO TO 160 ENDIF 110 CONTINUE 120 CONTINUE 130 CONTINUE 140 CONTINUE 150 CONTINUE C C Trigger 6 error conditions. C 160 FATAL = .FALSE. C IF (KPRINT .GE. 3) WRITE (LUN, 90020) XX(1) = 1.0E0 XX(2) = 1.0E0 XX(3) = 1.0E0 XX(4) = 1.0E0 XX(5) = 0.01E0 DO 170 I=1,5 XX(I) = -XX(I) K = XX(2) N = XX(3) M = XX(4) CALL EXINT (XX(I), N, K, M, XX(5), EN, NZ, IERR) IF (IERR .NE. 1) THEN IPASS = 0 FATAL = .TRUE. WRITE (LUN, 90030) I ENDIF XX(I) = -XX(I) 170 CONTINUE X = 0.0E0 TOL = 1.0E-2 CALL EXINT (X, 1, 1, 1, TOL, EN, NZ, IERR) IF (IERR .NE. 1) THEN IPASS = 0 FATAL = .TRUE. WRITE (LUN, 90040) ENDIF IF (FATAL) THEN IF (KPRINT .GE. 2) THEN WRITE (LUN, 90070) ENDIF ELSE IF (KPRINT .GE. 3) THEN WRITE (LUN, 90080) ENDIF ENDIF C IF(IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN, 90100) IF(IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN, 90110) RETURN C 90000 FORMAT ('1' / ' QUICK CHECK FOR EXINT AND GAUS8' /) 90010 FORMAT (// ' ERROR IN EG8CK COMPARISON TEST' /) 90020 FORMAT (/ ' TRIGGER 6 ERROR CONDITIONS') 90030 FORMAT (' Error occurred with DO index I =', I2) 90040 FORMAT (' Error occurred with X = 0.0') 90070 FORMAT (/' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED') 90080 FORMAT (/' ALL INCORRECT ARGUMENT TESTS PASSED') 90100 FORMAT (/ ' **********EXINT AND GAUS8 PASSED ALL TESTS**********') 90110 FORMAT (/ ' **********EXINT OR GAUS8 FAILED SOME TESTS**********') END *DECK EISQX1 SUBROUTINE EISQX1 (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE EISQX1 C***PURPOSE Quick check for SGEEV and CGEEV. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C THIS QUICK CHECK ROUTINE IS WRITTEN FOR EISPACK DRIVERS C SGEEV AND CGEEV. THE EIGENVALUES OF INPUT MATRIX A(.,.) C ARE STORED IN EK(.). RELERR IS THE RELATIVE ACCURACY C REQUIRED FOR THEM TO PASS. C C***ROUTINES CALLED CGEEV, R1MACH, SGEEV C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900405 CALL to XERROR replaced by message to LUN. (WRB) C***END PROLOGUE EISQX1 INTEGER KPRINT,IPASS,LUN INTEGER LDA,N,LDV,JOB,I,J,ID REAL A(3,3),EK(3),W(9) REAL ERR,ERRI,RELERR,RECJ COMPLEX AC(3,3),EC(3),VC(3,3) DATA LDA,N,LDV / 3*3 / DATA A / 1., -2., 6., -1., 0., -3., 2., 5., 6. / DATA EK / -1., 3., 5. / C***FIRST EXECUTABLE STATEMENT EISQX1 IPASS = 1 RELERR = SQRT(R1MACH(4)) DO 20 J=1,N DO 10 I=1,N AC(I,J) = CMPLX(A(I,J),0.) 10 CONTINUE 20 CONTINUE JOB = 1 CALL CGEEV(AC,LDA,N,EC,VC,LDV,W,JOB,INFO) IF (INFO .NE. 0) THEN IF (KPRINT .GE. 2) WRITE (LUN, 688) 'CGEEV', INFO IPASS = 0 ENDIF DO 40 J=1,N ERR = ABS(AIMAG(EC(J))) IF (ERR .GE. RELERR) IPASS = 0 RECJ = REAL(EC(J)) ERR = ABS(RECJ - EK(1)) ID = 1 DO 30 I=2,N ERRI = ABS(RECJ - EK(I)) IF (ERRI .LT. ERR) ID = I ERR = MIN(ERRI,ERR) 30 CONTINUE IF (ABS(RECJ-EK(ID))/ABS(EK(ID)) .GE. RELERR) IPASS = 0 40 CONTINUE JOB = 0 CALL SGEEV(A,LDA,N,EC,VC,LDV,W,JOB,INFO) IF (INFO .NE. 0) THEN IF (KPRINT .GE. 2) WRITE (LUN, 688) 'SGEEV', INFO IPASS = 0 ENDIF DO 60 J=1,N ERR = ABS(AIMAG(EC(J))) IF (ERR .GE. RELERR) IPASS = 0 RECJ = REAL(EC(J)) ERR = ABS(RECJ - EK(1)) ID = 1 DO 50 I=2,N ERRI = ABS(RECJ - EK(I)) IF (ERRI .LT. ERR) ID = I ERR = MIN(ERRI,ERR) 50 CONTINUE IF (ABS(RECJ-EK(ID))/ABS(EK(ID)) .GE. RELERR) IPASS = 0 60 CONTINUE IF (KPRINT.GE.2 .AND. IPASS.NE.0) WRITE (LUN,670) 670 FORMAT(25H EISQX1 PASSES ALL TESTS.) IF (KPRINT.GE.1 .AND. IPASS.EQ.0) WRITE (LUN,680) 680 FORMAT(25H EISQX1 FAILS SOME TESTS.) 688 FORMAT (1X, 'Eigenvalue iteration failed to converge in ', A5, + ', INFO = ', I4) RETURN END *DECK EISQX2 SUBROUTINE EISQX2 (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE EISQX2 C***PURPOSE Quick check for SSIEV, CHIEV and SSPEV. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Kahaner, D. K., (NBS) C***DESCRIPTION C C THIS QUICK CHECK ROUTINE IS WRITTEN FOR EISPACK DRIVERS C SSIEV, CHIEV AND SSPEV. THE EIGENVALUES OF INPUT MATRIX C A(.,.) ARE STORED IN EK(.). RELERR IS THE RELATIVE C ACCURACY REQUIRED FOR THEM TO PASS. C C***ROUTINES CALLED CHIEV, R1MACH, SSIEV, SSPEV C***REVISION HISTORY (YYMMDD) C 800808 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900405 CALL to XERROR replaced by message to LUN. (WRB) C***END PROLOGUE EISQX2 INTEGER KPRINT,IPASS,LUN INTEGER LDA,N,LDV,JOB,I,J,ID REAL A1(4,4),A2(10),AP(10),E(4),V(4,4),EK(4),W(16) REAL ERR,ERRI,RELERR COMPLEX AC(4,4),VC(4,4) EQUIVALENCE (V,VC) DATA LDA,N,LDV / 3*4 / DATA AP / 5., 4., 5., 1., 1., 4., 1., 1., 2., 4. / DATA EK / 1., 2., 5., 10. / C***FIRST EXECUTABLE STATEMENT EISQX2 IPASS = 1 RELERR = SQRT(R1MACH(4)) ID = 0 DO 20 J=1,N DO 10 I=1,J ID = ID + 1 A1(I,J) = AP(ID) A2(ID) = AP(ID) AC(I,J) = CMPLX(AP(ID),0.) 10 CONTINUE 20 CONTINUE JOB = 1 CALL CHIEV(AC,LDA,N,E,VC,LDV,W,JOB,INFO) IF (INFO .NE. 0) THEN IF (KPRINT .GE. 2) WRITE (LUN, 688) 'CHIEV', INFO IPASS = 0 ENDIF DO 40 J=1,N ERR = ABS(E(J) - EK(1)) ID = 1 DO 30 I=2,N ERRI = ABS(E(J) - EK(I)) IF (ERRI .LT. ERR) ID = I ERR = MIN(ERRI,ERR) 30 CONTINUE IF (ABS(E(J)-EK(ID))/ABS(EK(ID)) .GE. RELERR) IPASS = 0 40 CONTINUE CALL SSIEV(A1,LDA,N,E,W,JOB,INFO) IF (INFO .NE. 0) THEN IF (KPRINT .GE. 2) WRITE (LUN, 688) 'SSIEV', INFO IPASS = 0 ENDIF DO 60 J=1,N ERR = ABS(E(J) - EK(1)) ID = 1 DO 50 I=2,N ERRI = ABS(E(J) - EK(I)) IF (ERRI .LT. ERR) ID = I ERR = MIN(ERRI,ERR) 50 CONTINUE IF (ABS(E(J)-EK(ID))/ABS(EK(ID)) .GE. RELERR) IPASS = 0 60 CONTINUE JOB = 0 CALL SSPEV(A2,N,E,V,LDV,W,JOB,INFO) IF (INFO .NE. 0) THEN IF (KPRINT .GE. 2) WRITE (LUN, 688) 'SSPEV', INFO IPASS = 0 ENDIF DO 80 J=1,N ERR = ABS(E(J) - EK(1)) ID = 1 DO 70 I=2,N ERRI = ABS(E(J) - EK(I)) IF (ERRI .LT. ERR) ID = I ERR = MIN(ERRI,ERR) 70 CONTINUE IF (ABS(E(J)-EK(ID))/ABS(EK(ID)) .GE. RELERR) IPASS = 0 80 CONTINUE IF (KPRINT.GE.2 .AND. IPASS.NE.0) WRITE (LUN,684) 684 FORMAT(25H EISQX2 PASSES ALL TESTS.) IF (KPRINT.GE.1 .AND. IPASS.EQ.0) WRITE (LUN,686) 686 FORMAT(25H EISQX2 FAILS SOME TESTS.) 688 FORMAT (1X, 'Eigenvalue iteration failed to converge in ', A5, + ', INFO = ', I4) RETURN END *DECK EVCHCK SUBROUTINE EVCHCK (LOUT, KPRINT, NPTS, XEV, FEV, DEV, FEV2, FAIL) C***BEGIN PROLOGUE EVCHCK C***SUBSIDIARY C***PURPOSE Test evaluation accuracy of CHFDV and CHFEV for PCHQK1. C***LIBRARY SLATEC (PCHIP) C***TYPE SINGLE PRECISION (EVCHCK-S, DEVCHK-D) C***KEYWORDS PCHIP EVALUATOR QUICK CHECK C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C -------- CODE TO TEST EVALUATION ACCURACY OF CHFDV AND CHFEV -------- C C USING FUNCTION AND DERIVATIVE VALUES FROM A CUBIC (COMPUTED IN C DOUBLE PRECISION) AT NINT DIFFERENT (X1,X2) PAIRS: C 1. CHECKS THAT CHFDV AND CHFEV BOTH REPRODUCE ENDPOINT VALUES. C 2. EVALUATES AT NPTS POINTS, 10 OF WHICH ARE OUTSIDE THE INTERVAL C AND: C A. CHECKS ACCURACY OF CHFDV FUNCTION AND DERIVATIVE VALUES C AGAINST EXACT VALUES. C B. CHECKS THAT RETURNED VALUES OF NEXT SUM TO 10. C C. CHECKS THAT FUNCTION VALUES FROM CHFEV AGREE WITH THOSE C FROM CHFDV. C C C FORTRAN INTRINSICS USED: ABS, MAX, MIN. C FORTRAN LIBRARY ROUTINES USED: SQRT, (READ), (WRITE). C SLATEC LIBRARY ROUTINES USED: CHFDV, CHFEV, R1MACH, RAND. C OTHER ROUTINES USED: FDTRUE. C C***ROUTINES CALLED CHFDV, CHFEV, FDTRUE, R1MACH, RAND C***REVISION HISTORY (YYMMDD) C 820601 DATE WRITTEN C 820624 CONVERTED TO QUICK CHECK FOR SLATEC LIBRARY. C 820630 1. MODIFIED DEFINITIONS OF RELATIVE ERROR AND TEST C TOLERANCES. C 2. VARIOUS IMPROVEMENTS TO OUTPUT FORMATS. C 820716 1. SET MACHEP VIA A CALL TO R1MACH. C 2. CHANGED FROM FORTLIB'S RANF TO SLATEC'S RAND. C 890629 1. Appended E0 to real constants to reduce S.P./D.P. C differences. C 2. Other minor cosmetic changes. C 890831 Modified array declarations. (WRB) C 890911 Removed unnecessary intrinsics. (WRB) C 891004 Cosmetic changes to prologue. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 Revised prologue and improved some output formats. (FNF) C Also moved formats to end to be consistent with other PCHIP C quick checks. C 900316 Additional minor cosmetic changes. (FNF) C 900321 Made miscellaneous cosmetic changes. (FNF) C 901130 Added 1P's to formats and revised some to reduce maximum C line length. (FNF) C 910708 Minor modifications in use of KPRINT. (WRB) C 910801 Added EXTERNAL statement for RAND due to problem on IBM C RS 6000. (WRB) C***END PROLOGUE EVCHCK C C Declare arguments. C INTEGER LOUT, KPRINT, NPTS REAL XEV(*), FEV(*), DEV(*), FEV2(*) LOGICAL FAIL C C DECLARATIONS. C INTEGER I, IERR, IINT, NEXT(2), NEXT2(2), NINT REAL AED, AED2, AEDMAX, AEDMIN, AEF, AEF2, AEFMAX, AEFMIN, * CHECK(2), CHECKF(2), CHECKD(2), D1, D2, DERMAX, DTRUE, DX, * EPS1, EPS2, F1, F2, FACT, FERMAX, FLOORD, FLOORF, FOUR, * FTRUE, LEFT(3), MACHEP, * ONE, RED, RED2, REDMAX, REDMIN, REF, REF2, REFMAX, * REFMIN, RIGHT(3), SMALL, TEN, TOL1, TOL2, * X1, X2, XADMAX, XADMIN, XAFMAX, XAFMIN, XRDMAX, * XRDMIN, XRFMAX, XRFMIN, ZERO LOGICAL FAILOC, FAILNX C REAL R1MACH C The following should stay REAL (no D.P. equivalent). REAL RAND EXTERNAL RAND C C DEFINE RELATIVE ERROR WITH FLOOR. C REAL RERR, ERR, VALUE, FLOOR RERR(ERR,VALUE,FLOOR) = ERR / MAX(ABS(VALUE), FLOOR) C C INITIALIZE. C DATA ZERO /0.E0/, ONE /1.E0/, FOUR /4.E0/, TEN /10.E0/ DATA SMALL /1.0E-10/ DATA NINT /3/ DATA LEFT /-1.5E0, 2.0E-10, 1.0E0 / DATA RIGHT / 2.5E0, 3.0E-10, 1.0E+8/ C C***FIRST EXECUTABLE STATEMENT EVCHCK MACHEP = R1MACH(4) EPS1 = FOUR*MACHEP EPS2 = TEN*MACHEP C FAIL = .FALSE. C IF (KPRINT .GE. 2) WRITE (LOUT, 3000) C C CYCLE OVER INTERVALS. C DO 90 IINT = 1, NINT X1 = LEFT(IINT) X2 = RIGHT(IINT) C FACT = MAX(SQRT(X2-X1), ONE) TOL1 = EPS1 * FACT TOL2 = EPS2 * FACT C C COMPUTE AND PRINT ENDPOINT VALUES. C CALL FDTRUE (X1, F1, D1) CALL FDTRUE (X2, F2, D2) C IF (KPRINT .GE. 3) THEN IF (IINT .EQ. 1) WRITE (LOUT, 2000) WRITE (LOUT, '(/)') WRITE (LOUT, 2001) 'X1', X1, 'X2', X2 WRITE (LOUT, 2001) 'F1', F1, 'F2', F2 WRITE (LOUT, 2001) 'D1', D1, 'D2', D2 ENDIF C IF (KPRINT .GE. 2) WRITE (LOUT, 3001) X1, X2 C C COMPUTE FLOORS FOR RELATIVE ERRORS. C FLOORF = MAX( MIN(ABS(F1),ABS(F2)), SMALL) FLOORD = MAX( MIN(ABS(D1),ABS(D2)), SMALL) C C CHECK REPRODUCTION OF ENDPOINT VALUES. C XEV(1) = X1 XEV(2) = X2 C ----------------------------------------------------------- CALL CHFDV (X1, X2, F1, F2, D1, D2, 2, XEV, CHECKF, CHECKD, * NEXT, IERR) C ----------------------------------------------------------- AEF = CHECKF(1)-F1 REF = RERR(AEF , F1, FLOORF) AEF2 = CHECKF(2)-F2 REF2 = RERR(AEF2, F2, FLOORF) AED = CHECKD(1)-D1 RED = RERR(AED , D1, FLOORD) AED2 = CHECKD(2)-D2 RED2 = RERR(AED2, D2, FLOORD) C FAILOC = MAX(ABS(REF),ABS(REF2),ABS(RED),ABS(RED2)) .GT. TOL1 FAIL = FAIL .OR. FAILOC C IF (KPRINT .GE. 3) THEN WRITE (LOUT, 2002) NEXT, AEF, AEF2, AED, AED2 WRITE (LOUT, 2003) REF, REF2, RED, RED2 ENDIF C IF (FAILOC .AND. (KPRINT.GE.2)) WRITE (LOUT, 3002) C C CHFEV SHOULD AGREE EXACTLY WITH CHFDV. C ------- C -------------------------------------------------------------- CALL CHFEV (X1, X2, F1, F2, D1, D2, 2, XEV, CHECK, NEXT, IERR) C -------------------------------------------------------------- FAILOC = (CHECK(1).NE.CHECKF(1)) .OR. (CHECK(2).NE.CHECKF(2)) FAIL = FAIL .OR. FAILOC C IF (FAILOC .AND. (KPRINT.GE.2)) WRITE (LOUT, 3003) C C EVALUATE AT NPTS 'UNIFORMLY RANDOM' POINTS IN (X1,X2). C THIS VERSION EXTENDS EVALUATION DOMAIN BY ADDING 4 SUBINTERVALS C TO LEFT AND 6 TO RIGHT OF [X1,X2]. C DX = (X2-X1)/(NPTS-10) DO 20 I = 1, NPTS XEV(I) = (X1 + (I-5)*DX) + DX*RAND(ZERO) 20 CONTINUE C -------------------------------------------------------- CALL CHFDV (X1, X2, F1, F2, D1, D2, NPTS, XEV, FEV, DEV, * NEXT, IERR) C -------------------------------------------------------- IF (IERR .NE. 0) THEN FAILOC = .TRUE. IF (KPRINT .GE. 2) WRITE (LOUT, 4003) IERR ELSE C C CUMULATE LARGEST AND SMALLEST ERRORS FOR SUMMARY. C DO 30 I = 1, NPTS CALL FDTRUE (XEV(I), FTRUE, DTRUE) AEF = FEV(I) - FTRUE REF = RERR(AEF, FTRUE, FLOORF) AED = DEV(I) - DTRUE RED = RERR(AED, DTRUE, FLOORD) C IF (I .EQ. 1) THEN C INITIALIZE. AEFMIN = AEF AEFMAX = AEF AEDMIN = AED AEDMAX = AED REFMIN = REF REFMAX = REF REDMIN = RED REDMAX = RED XAFMIN = XEV(1) XAFMAX = XEV(1) XADMIN = XEV(1) XADMAX = XEV(1) XRFMIN = XEV(1) XRFMAX = XEV(1) XRDMIN = XEV(1) XRDMAX = XEV(1) ELSE C SELECT. IF (AEF .LT. AEFMIN) THEN AEFMIN = AEF XAFMIN = XEV(I) ELSE IF (AEF .GT. AEFMAX) THEN AEFMAX = AEF XAFMAX = XEV(I) ENDIF IF (AED .LT. AEDMIN) THEN AEDMIN = AED XADMIN = XEV(I) ELSE IF (AED .GT. AEDMAX) THEN AEDMAX = AED XADMAX = XEV(I) ENDIF IF (REF .LT. REFMIN) THEN REFMIN = REF XRFMIN = XEV(I) ELSE IF (REF .GT. REFMAX) THEN REFMAX = REF XRFMAX = XEV(I) ENDIF IF (RED .LT. REDMIN) THEN REDMIN = RED XRDMIN = XEV(I) ELSE IF (RED .GT. REDMAX) THEN REDMAX = RED XRDMAX = XEV(I) ENDIF ENDIF 30 CONTINUE C FERMAX = MAX (ABS(REFMAX), ABS(REFMIN)) DERMAX = MAX (ABS(REDMAX), ABS(REDMIN)) C FAILNX = (NEXT(1) + NEXT(2)) .NE. 10 FAILOC = FAILNX .OR. (MAX(FERMAX, DERMAX) .GT. TOL2) ENDIF FAIL = FAIL .OR. FAILOC C C PRINT SUMMARY. C IF (KPRINT .GE. 3) THEN WRITE (LOUT, 2004) NPTS-10, NEXT C WRITE (LOUT, 2005) 'MIN', AEFMIN, REFMIN, AEDMIN, REDMIN WRITE (LOUT, 2006) XAFMIN, XRFMIN, XADMIN, XRDMIN WRITE (LOUT, 2005) 'MAX', AEFMAX, REFMAX, AEDMAX, REDMAX WRITE (LOUT, 2006) XAFMAX, XRFMAX, XADMAX, XRDMAX ENDIF C IF (KPRINT .GE. 2) THEN IF (FAILOC) THEN IF (FERMAX .GT. TOL2) WRITE (LOUT, 3006) 'F', FERMAX, TOL2 IF (DERMAX .GT. TOL2) WRITE (LOUT, 3006) 'D', DERMAX, TOL2 IF (FAILNX) WRITE (LOUT, 4006) NEXT ELSE WRITE (LOUT, 5006) ENDIF ENDIF C C CHECK THAT CHFEV AGREES WITH CHFDV. C C ----------------------------------------------------------------- CALL CHFEV (X1, X2, F1, F2, D1, D2, NPTS, XEV, FEV2, NEXT2, IERR) C ----------------------------------------------------------------- IF (IERR .NE. 0) THEN FAILOC = .TRUE. IF (KPRINT .GE. 2) WRITE (LOUT, 3007) IERR ELSE AEFMAX = ABS(FEV2(1) - FEV(1)) XAFMAX = XEV(1) DO 40 I = 2, NPTS AEF = ABS(FEV2(I) - FEV(I)) IF (AEF .GT. AEFMAX) THEN AEFMAX = AEF XAFMAX = XEV(I) ENDIF 40 CONTINUE FAILNX = (NEXT2(1).NE.NEXT(1)) .OR. (NEXT2(2).NE.NEXT(2)) FAILOC = FAILNX .OR. (AEFMAX.NE.ZERO) IF (KPRINT .GE. 2) THEN IF (FAILOC) THEN WRITE (LOUT, 3008) IF (AEFMAX.NE.ZERO) WRITE (LOUT, 3009) AEFMAX, XAFMAX IF (FAILNX) WRITE (LOUT, 4009) NEXT2, NEXT ELSE WRITE (LOUT, 5009) ENDIF ENDIF ENDIF C FAIL = FAIL .OR. FAILOC C C GO BACK FOR ANOTHER INTERVAL. C 90 CONTINUE C RETURN C C FORMATS. C 2000 FORMAT (/10X,'CHFDV ACCURACY TEST') 2001 FORMAT (10X,A2,' =',1P,E18.10,5X,A2,' =',E18.10) 2002 FORMAT (/' ERRORS AT ENDPOINTS:',40X,'(NEXT =',2I3,')' * // 1P,4X,'F1:',E13.5,4X,'F2:',E13.5, * 4X,'D1:',E13.5,4X,'D2:',E13.5) 2003 FORMAT (1P,4(7X,E13.5)) 2004 FORMAT (/' ERRORS AT ',I5,' INTERIOR POINTS + 10 OUTSIDE:', * 15X,'(NEXT =',2I3,')' * //30X,'FUNCTION',17X,'DERIVATIVE' * /15X,2(11X,'ABS',9X,'REL') ) 2005 FORMAT (/5X,A3,'IMUM ERROR: ',1P,2E12.4,2X,2E12.4) 2006 FORMAT ( 5X,'LOCATED AT X = ',1P,2E12.4,2X,2E12.4) 3000 FORMAT (//10X,'EVCHCK RESULTS'/10X,'--------------') 3001 FORMAT (/10X,'INTERVAL = (',1P,E12.5,',',E12.5,' ):' ) 3002 FORMAT (/' ***** CHFDV FAILED TO REPRODUCE ENDPOINT VALUES.') 3003 FORMAT (/' ***** CHFEV DOES NOT AGREE WITH CHFDV AT ENDPOINTS.') 3006 FORMAT (/' ***** MAXIMUM RELATIVE ERROR IN ',A1,' =',1P,E12.5,',' * / 17X,'EXCEEDS TOLERANCE =',E12.5) 3007 FORMAT (/' ***** ERROR ***** CHFEV RETURNED IERR =',I5) 3008 FORMAT (/' ***** CHFEV DID NOT AGREE WITH CHFDV:') 3009 FORMAT (7X,'MAXIMUM DIFFERENCE ',1P,E12.5, * '; OCCURRED AT X =',E12.5) 4003 FORMAT (/' ***** ERROR ***** CHFDV RETURNED IERR =',I5) 4006 FORMAT (/' ***** REPORTED NEXT =',2I5,' RATHER THAN 4 6') 4009 FORMAT (7X,'REPORTED NEXT =',2I3,' RATHER THAN ',2I3) 5006 FORMAT (/' CHFDV RESULTS OK.') 5009 FORMAT (/' CHFEV AGREES WITH CHFDV.') C------------- LAST LINE OF EVCHCK FOLLOWS ----------------------------- END *DECK EVERCK SUBROUTINE EVERCK (LOUT, KPRINT, FAIL) C***BEGIN PROLOGUE EVERCK C***SUBSIDIARY C***PURPOSE Test error returns from PCHIP evaluators for PCHQK1. C***LIBRARY SLATEC (PCHIP) C***TYPE SINGLE PRECISION (EVERCK-S, DEVERK-D) C***KEYWORDS PCHIP EVALUATOR QUICK CHECK C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C --------- CODE TO TEST ERROR RETURNS FROM PCHIP EVALUATORS. --------- C C C FORTRAN LIBRARY ROUTINES USED: (WRITE). C SLATEC LIBRARY ROUTINES USED: CHFDV, CHFEV, PCHFD, PCHFE, C XERDMP, XGETF, XSETF. C OTHER ROUTINES USED: COMP. C C***ROUTINES CALLED CHFDV, CHFEV, COMP, PCHFD, PCHFE, XERDMP, XGETF, C XSETF C***REVISION HISTORY (YYMMDD) C 820601 DATE WRITTEN C 820715 CONVERTED TO QUICK CHECK FOR SLATEC LIBRARY. C 890207 ADDED CALLS TO ERROR HANDLER. C 890316 Added call to XERDMP if KPRINT.GT.2 (FNF). C 890629 Appended E0 to real constants to reduce S.P./D.P. C differences. C 890706 Cosmetic changes to prologue. (WRB) C 891009 Removed unreferenced statement label. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900309 Added COMP to list of routines called. (FNF) C 900315 Revised prologue and improved some output formats. (FNF) C 900316 Deleted INCFD tests because some compilers object to them, C and made additional minor cosmetic changes. (FNF) C 900322 Made miscellaneous cosmetic changes. (FNF) C 910708 Minor modifications in use of KPRINT. (WRB) C***END PROLOGUE EVERCK C C Declare arguments. C INTEGER LOUT, KPRINT LOGICAL FAIL C C DECLARATIONS. C INTEGER I, IERR, KONTRL, N, NERR, NEXT(2) REAL D(10), DUM, F(10), TEMP, X(10) LOGICAL COMP, SKIP C C INITIALIZE. C PARAMETER (N = 10) C***FIRST EXECUTABLE STATEMENT EVERCK NERR = 0 C CALL XGETF (KONTRL) IF (KPRINT .LE. 2) THEN CALL XSETF (0) ELSE CALL XSETF (1) ENDIF C IF (KPRINT .GE. 3) WRITE (LOUT, 2000) IF (KPRINT .GE. 2) WRITE (LOUT, 5000) C C FIRST, TEST CHFEV AND CHFDV. C IF (KPRINT .GE. 3) WRITE (LOUT, 5001) (-1) CALL CHFEV (0.E0, 1.E0, 3.E0, 7.E0, 3.E0, 6.E0, 0, DUM, DUM, * NEXT, IERR) IF (.NOT. COMP (IERR, -1, LOUT, KPRINT) ) NERR = NERR + 1 C IF (KPRINT .GE. 3) WRITE (LOUT, 5001) (-2) CALL CHFEV (1.E0, 1.E0, 3.E0, 7.E0, 3.E0, 6.E0, 1, DUM, DUM, * NEXT, IERR) IF (.NOT. COMP (IERR, -2, LOUT, KPRINT) ) NERR = NERR + 1 C IF (KPRINT .GE. 3) WRITE (LOUT, 5001) (-1) CALL CHFDV (0.E0, 1.E0, 3.E0, 7.E0, 3.E0, 6.E0, 0, DUM, DUM, DUM, * NEXT, IERR) IF (.NOT. COMP (IERR, -1, LOUT, KPRINT) ) NERR = NERR + 1 C IF (KPRINT .GE. 3) WRITE (LOUT, 5001) (-2) CALL CHFDV (1.E0, 1.E0, 3.E0, 7.E0, 3.E0, 6.E0, 1, DUM, DUM, DUM, * NEXT, IERR) IF (.NOT. COMP (IERR, -2, LOUT, KPRINT) ) NERR = NERR + 1 C C SET UP PCH DEFINITION. C DO 10 I = 1, N X(I) = I F(I) = I + 2 D(I) = 1.E0 10 CONTINUE C C SWAP POINTS 4 AND 7, SO X-ARRAY IS OUT OF ORDER. C TEMP = X(4) X(4) = X(7) X(7) = TEMP C C NOW, TEST PCHFE AND PCHFD. C IF (KPRINT .GE. 3) WRITE (LOUT, 5001) (-1) SKIP = .FALSE. CALL PCHFE (1, X, F, D, 1, SKIP, 0, DUM, DUM, IERR) IF (.NOT. COMP (IERR, -1, LOUT, KPRINT) ) NERR = NERR + 1 C IF (KPRINT .GE. 3) WRITE (LOUT, 5001) (-3) SKIP = .FALSE. CALL PCHFE (N, X, F, D, 1, SKIP, 0, DUM, DUM, IERR) IF (.NOT. COMP (IERR, -3, LOUT, KPRINT) ) NERR = NERR + 1 C IF (KPRINT .GE. 3) WRITE (LOUT, 5001) (-4) SKIP = .TRUE. CALL PCHFE (N, X, F, D, 1, SKIP, 0, DUM, DUM, IERR) IF (.NOT. COMP (IERR, -4, LOUT, KPRINT) ) NERR = NERR + 1 C IF (KPRINT .GE. 3) WRITE (LOUT, 5001) (-1) SKIP = .FALSE. CALL PCHFD (1, X, F, D, 1, SKIP, 0, DUM, DUM, DUM, IERR) IF (.NOT. COMP (IERR, -1, LOUT, KPRINT) ) NERR = NERR + 1 C IF (KPRINT .GE. 3) WRITE (LOUT, 5001) (-3) SKIP = .FALSE. CALL PCHFD (N, X, F, D, 1, SKIP, 0, DUM, DUM, DUM, IERR) IF (.NOT. COMP (IERR, -3, LOUT, KPRINT) ) NERR = NERR + 1 C IF (KPRINT .GE. 3) WRITE (LOUT, 5001) (-4) SKIP = .TRUE. CALL PCHFD (N, X, F, D, 1, SKIP, 0, DUM, DUM, DUM, IERR) IF (.NOT. COMP (IERR, -4, LOUT, KPRINT) ) NERR = NERR + 1 C C SUMMARIZE RESULTS. C IF (KPRINT .GT. 2) CALL XERDMP IF (NERR .EQ. 0) THEN FAIL = .FALSE. IF (KPRINT .GE. 2) WRITE (LOUT, 5002) ELSE FAIL = .TRUE. IF (KPRINT .GE. 2) WRITE (LOUT, 5003) NERR ENDIF C C TERMINATE. C CALL XSETF (KONTRL) RETURN C C FORMATS. C 2000 FORMAT ('1'//10X,'TEST ERROR RETURNS') 5000 FORMAT (//10X,'EVERCK RESULTS'/10X,'--------------') 5001 FORMAT (/' THIS CALL SHOULD RETURN IERR =',I3) 5002 FORMAT (/' ALL ERROR RETURNS OK.') 5003 FORMAT (//' ***** TROUBLE IN EVERCK *****' * //5X,I5,' TESTS FAILED TO GIVE EXPECTED RESULTS.') C------------- LAST LINE OF EVERCK FOLLOWS ----------------------------- END *DECK EVPCCK SUBROUTINE EVPCCK (LOUT, KPRINT, X, Y, F, FX, FY, XE, YE, FE, DE, + FE2, FAIL) C***BEGIN PROLOGUE EVPCCK C***SUBSIDIARY C***PURPOSE Test usage of increment argument in PCHFD and PCHFE for C PCHQK1. C***LIBRARY SLATEC (PCHIP) C***TYPE SINGLE PRECISION (EVPCCK-S, DEVPCK-D) C***KEYWORDS PCHIP EVALUATOR QUICK CHECK C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C ---- CODE TO TEST USAGE OF INCREMENT ARGUMENT IN PCHFD AND PCHFE ---- C C EVALUATES A BICUBIC FUNCTION AND ITS FIRST PARTIAL DERIVATIVES C ON A 4X6 MESH CONTAINED IN A 10X10 ARRAY. C C INTERPOLATION OF THESE DATA ALONG MESH LINES IN EITHER DIMENSION C SHOULD AGREE WITH CORRECT FUNCTION WITHIN ROUNDOFF ERROR. C C ARRAYS ARE ARGUMENTS ONLY TO ALLOW SHARING STORAGE WITH OTHER C TEST ROUTINES. C C NOTE: RUN WITH KPRINT=4 FOR FULL GORY DETAILS (10 PAGES WORTH). C C C FORTRAN INTRINSICS USED: ABS. C FORTRAN LIBRARY ROUTINES USED: (WRITE). C SLATEC LIBRARY ROUTINES USED: PCHFD, PCHFE, R1MACH. C C***ROUTINES CALLED PCHFD, PCHFE, R1MACH C***REVISION HISTORY (YYMMDD) C 820601 DATE WRITTEN C 820714 CONVERTED TO QUICK CHECK FOR SLATEC LIBRARY. C 820715 1. CORRECTED SOME FORMATS. C 2. ADDED CALL TO R1MACH TO SET MACHEP. C 890406 1. Modified to make sure final elements of X and XE C agree, to avoid possible failure due to roundoff C error. C 2. Added printout of TOL in case of failure. C 3. Minor cosmetic changes. C 890407 Appended E0 to real constants to reduce S.P./D.P. C differences. C 890706 Cosmetic changes to prologue. (WRB) C 890911 Removed unnecessary intrinsics. (WRB) C 891004 Cosmetic changes to prologue. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 Revised prologue and improved some output formats. (FNF) C 900316 Additional minor cosmetic changes. (FNF) C 900321 Made miscellaneous cosmetic changes. (FNF) C 901130 Made many changes to output: (FNF) C 1. Reduced amount of output for KPRINT=3. (Now need to C use KPRINT=4 for full output.) C 2. Added 1P's to formats and revised some to reduce maximum C line length. C 910708 Minor modifications in use of KPRINT. (WRB) C***END PROLOGUE EVPCCK C C Declare arguments. C INTEGER LOUT, KPRINT LOGICAL FAIL REAL X(10), Y(10), F(10,10), FX(10,10), FY(10,10), * XE(51), YE(51), FE(51), DE(51), FE2(51) C C DECLARATIONS. C INTEGER I, IER2, IERR, INC, J, K, NE, NERR, NMAX, NX, NY LOGICAL FAILD, FAILE, FAILOC, SKIP REAL DERMAX, DERR, DTRUE, DX, FDIFF, FDIFMX, FERMAX, FERR, * FTRUE, MACHEP, TOL, PDERMX, PDIFMX, PFERMX, ZERO REAL R1MACH C C DEFINE TEST FUNCTION AND DERIVATIVES. C REAL AX, AY, FCN, DFDX, DFDY FCN(AX,AY) = AX*(AY*AY)*(AX*AX + 1.E0) DFDX(AX,AY) = (AY*AY)*(3.E0*AX*AX + 1.E0) DFDY(AX,AY) = 2.E0*AX*AY*(AX*AX + 1.E0) C DATA NMAX /10/, NX /4/, NY /6/ DATA NE /51/ DATA ZERO /0.E0/ C C INITIALIZE. C C***FIRST EXECUTABLE STATEMENT EVPCCK MACHEP = R1MACH(4) TOL = 10.E0*MACHEP C FAIL = .FALSE. C C SET UP 4-BY-6 MESH IN A 10-BY-10 ARRAY: C X = 0.25(0.25)1. ; C Y = -0.75(0.5 )1.75 . C DO 1 I = 1, NX-1 X(I) = 0.25E0*I 1 CONTINUE X(NX) = 1.E0 DO 5 J = 1, NY Y(J) = 0.5E0*J - 1.25E0 DO 4 I = 1, NX F(I,J) = FCN (X(I), Y(J)) FX(I,J) = DFDX(X(I), Y(J)) FY(I,J) = DFDY(X(I), Y(J)) 4 CONTINUE 5 CONTINUE C C SET UP EVALUATION POINTS: C XE = 0.(0.02)1. ; C YE = -2.(0.08)2. . C DX = 1.E0/(NE-1) DO 8 K = 1, NE-1 XE(K) = DX*(K-1) YE(K) = 4.E0*XE(K) - 2.E0 8 CONTINUE XE(NE) = 1.E0 YE(NE) = 2.E0 C IF (KPRINT .GE. 2) WRITE (LOUT, 1000) IF (KPRINT .GE. 3) WRITE (LOUT, 1001) C C EVALUATE ON HORIZONTAL MESH LINES (Y FIXED, X RUNNING) .............. C NERR = 0 INC = 1 SKIP = .FALSE. DO 20 J = 1, NY C -------------------------------------------------------------- CALL PCHFD (NX, X, F(1,J), FX(1,J), INC, SKIP, NE, XE, FE, DE, * IERR) C -------------------------------------------------------------- IF (KPRINT .GE. 3) * WRITE (LOUT, 2000) INC, 'J', J, 'Y', Y(J), IERR IF (IERR .LT. 0) GO TO 15 IF (KPRINT .GT. 3) WRITE (LOUT, 2001) 'X' C C PCHFE SHOULD AGREE EXACTLY WITH PCHFD. C C ----------------------------------------------------------- CALL PCHFE (NX, X, F(1,J), FX(1,J), INC, SKIP, NE, XE, FE2, * IER2) C ----------------------------------------------------------- C DO 10 K = 1, NE FTRUE = FCN(XE(K), Y(J)) FERR = FE(K) - FTRUE DTRUE = DFDX(XE(K), Y(J)) DERR = DE(K) - DTRUE IF (KPRINT .GT. 3) * WRITE (LOUT, 2002) XE(K), FTRUE, FE(K), FERR, * DTRUE, DE(K), DERR IF (K .EQ. 1) THEN C INITIALIZE. FERMAX = ABS(FERR) PFERMX = XE(1) DERMAX = ABS(DERR) PDERMX = XE(1) FDIFMX = ABS(FE2(1) - FE(1)) PDIFMX = XE(1) ELSE C SELECT. FERR = ABS(FERR) IF (FERR .GT. FERMAX) THEN FERMAX = FERR PFERMX = XE(K) ENDIF DERR = ABS(DERR) IF (DERR .GT. DERMAX) THEN DERMAX = DERR PDERMX = XE(K) ENDIF FDIFF = ABS(FE2(K) - FE(K)) IF (FDIFF .GT. FDIFMX) THEN FDIFMX = FDIFF PDIFMX = XE(K) ENDIF ENDIF 10 CONTINUE C FAILD = (FERMAX.GT.TOL) .OR. (DERMAX.GT.TOL) FAILE = FDIFMX .NE. ZERO FAILOC = FAILD .OR. FAILE .OR. (IERR.NE.13) .OR. (IER2.NE.IERR) C IF (FAILOC .AND. (KPRINT.GE.2)) * WRITE (LOUT, 2003) 'J', J, 'Y', Y(J) C IF ((KPRINT.GE.3) .OR. (FAILD.AND.(KPRINT.EQ.2)) ) * WRITE (LOUT, 2004) FERMAX, PFERMX, DERMAX, PDERMX IF (FAILD .AND. (KPRINT.GE.2)) WRITE (LOUT, 2014) TOL C IF ((KPRINT.GE.3) .OR. (FAILE.AND.(KPRINT.EQ.2)) ) * WRITE (LOUT, 2005) FDIFMX, PDIFMX C IF ((IERR.NE.13) .AND. (KPRINT.GE.2)) * WRITE (LOUT, 2006) 'D', IERR, 13 C IF ((IER2.NE.IERR) .AND. (KPRINT.GE.2)) * WRITE (LOUT, 2006) 'E', IER2, IERR GO TO 19 C 15 CONTINUE FAILOC = .TRUE. IF (KPRINT .GE. 2) WRITE (LOUT, 3000) IERR C 19 CONTINUE IF (FAILOC) NERR = NERR + 1 FAIL = FAIL .OR. FAILOC 20 CONTINUE C IF (KPRINT .GE. 2) THEN IF (NERR .GT. 0) THEN WRITE (LOUT, 3001) NERR, 'J' ELSE WRITE (LOUT, 4000) 'J' ENDIF ENDIF C C EVALUATE ON VERTICAL MESH LINES (X FIXED, Y RUNNING) ................ C NERR = 0 INC = NMAX SKIP = .FALSE. DO 40 I = 1, NX C -------------------------------------------------------------- CALL PCHFD (NY, Y, F(I,1), FY(I,1), INC, SKIP, NE, YE, FE, DE, * IERR) C -------------------------------------------------------------- IF (KPRINT .GE. 3) * WRITE (LOUT, 2000) INC, 'I', I, 'X', X(I), IERR IF (IERR .LT. 0) GO TO 35 IF (KPRINT .GT. 3) WRITE (LOUT, 2001) 'Y' C C PCHFE SHOULD AGREE EXACTLY WITH PCHFD. C C ----------------------------------------------------------- CALL PCHFE (NY, Y, F(I,1), FY(I,1), INC, SKIP, NE, YE, FE2, * IER2) C ----------------------------------------------------------- C DO 30 K = 1, NE FTRUE = FCN(X(I), YE(K)) FERR = FE(K) - FTRUE DTRUE = DFDY(X(I), YE(K)) DERR = DE(K) - DTRUE IF (KPRINT .GT. 3) * WRITE (LOUT, 2002) YE(K), FTRUE, FE(K), FERR, * DTRUE, DE(K), DERR IF (K .EQ. 1) THEN C INITIALIZE. FERMAX = ABS(FERR) PFERMX = YE(1) DERMAX = ABS(DERR) PDERMX = YE(1) FDIFMX = ABS(FE2(1) - FE(1)) PDIFMX = YE(1) ELSE C SELECT. FERR = ABS(FERR) IF (FERR .GT. FERMAX) THEN FERMAX = FERR PFERMX = YE(K) ENDIF DERR = ABS(DERR) IF (DERR .GT. DERMAX) THEN DERMAX = DERR PDERMX = YE(K) ENDIF FDIFF = ABS(FE2(K) - FE(K)) IF (FDIFF .GT. FDIFMX) THEN FDIFMX = FDIFF PDIFMX = YE(K) ENDIF ENDIF 30 CONTINUE C FAILD = (FERMAX.GT.TOL) .OR. (DERMAX.GT.TOL) FAILE = FDIFMX .NE. ZERO FAILOC = FAILD .OR. FAILE .OR. (IERR.NE.20) .OR. (IER2.NE.IERR) C IF (FAILOC .AND. (KPRINT.GE.2)) * WRITE (LOUT, 2003) 'I', I, 'X', X(I) C IF ((KPRINT.GE.3) .OR. (FAILD.AND.(KPRINT.EQ.2)) ) * WRITE (LOUT, 2004) FERMAX, PFERMX, DERMAX, PDERMX IF (FAILD .AND. (KPRINT.GE.2)) WRITE (LOUT, 2014) TOL C IF ((KPRINT.GE.3) .OR. (FAILE.AND.(KPRINT.EQ.2)) ) * WRITE (LOUT, 2005) FDIFMX, PDIFMX C IF ((IERR.NE.20) .AND. (KPRINT.GE.2)) * WRITE (LOUT, 2006) 'D', IERR, 20 C IF ((IER2.NE.IERR) .AND. (KPRINT.GE.2)) * WRITE (LOUT, 2006) 'E', IER2, IERR GO TO 39 C 35 CONTINUE FAILOC = .TRUE. IF (KPRINT .GE. 2) WRITE (LOUT, 3000) IERR C 39 CONTINUE IF (FAILOC) NERR = NERR + 1 FAIL = FAIL .OR. FAILOC 40 CONTINUE C IF (KPRINT .GE. 2) THEN IF (NERR .GT. 0) THEN WRITE (LOUT, 3001) NERR, 'I' ELSE WRITE (LOUT, 4000) 'I' ENDIF ENDIF C C TERMINATE. C RETURN C C FORMATS. C 1000 FORMAT (//10X,'EVPCCK RESULTS'/10X,'--------------') 1001 FORMAT ('1'//10X,'TEST PCHFE AND PCHFD') 2000 FORMAT (//20X,'PCHFD INCREMENT TEST -- INCFD = ',I2 * /15X,'ON ',A1,'-LINE ',I2,', ',A1,' =',F8.4, * ' -- IERR =',I3) 2001 FORMAT ( /3X,A1,'E',10X,'F',8X,'FE',9X,'DIFF', * 13X,'D',8X,'DE',9X,'DIFF') 2002 FORMAT (F7.2,2(2X,2F10.5,1P,E15.5,0P)) 2003 FORMAT (/' ***** PCHFD AND/OR PCHFE FAILED ON ',A1,'-LINE ',I1, * ', ',A1,' =',F8.4) 2004 FORMAT (/17X,' MAXIMUM ERROR IN FUNCTION =',1P, * 1P,E13.5,0P,' (AT',F6.2,'),' * /31X, 'IN DERIVATIVE =',1P,E13.5,0P,' (AT',F6.2,').' ) 2005 FORMAT ( ' MAXIMUM DIFFERENCE BETWEEN PCHFE AND PCHFD =', * 1P,E13.5,0P,' (AT',F6.2,').' ) 2006 FORMAT (/' PCHF',A1,' RETURNED IERR = ',I2,' INSTEAD OF ',I2) 2014 FORMAT (' *** BOTH SHOULD BE .LE. TOL =',1P,E12.5,' ***') 3000 FORMAT (//' ***** ERROR ***** PCHFD RETURNED IERR =',I5//) 3001 FORMAT (//' ***** ERROR ***** PCHFD AND/OR PCHFE FAILED ON',I2, * 1X,A1,'-LINES.'//) 4000 FORMAT (/' PCHFD AND PCHFE OK ON ',A1,'-LINES.') C------------- LAST LINE OF EVPCCK FOLLOWS ----------------------------- END *DECK F0C REAL FUNCTION F0C (X) C***BEGIN PROLOGUE F0C C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F0C REAL X C***FIRST EXECUTABLE STATEMENT F0C F0C = 1.E0/(X*X+1.E-4) RETURN END *DECK F0F REAL FUNCTION F0F (X) C***BEGIN PROLOGUE F0F C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F0F REAL X C***FIRST EXECUTABLE STATEMENT F0F F0F = 0.0 IF(X.NE.0.0) F0F = SIN(0.5E+02*X)/(X*SQRT(X)) RETURN END *DECK F0O REAL FUNCTION F0O (X) C***BEGIN PROLOGUE F0O C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F0O REAL X C***FIRST EXECUTABLE STATEMENT F0O F0O = (2.0E0*SIN(X))**14 RETURN END *DECK F0S REAL FUNCTION F0S (X) C***BEGIN PROLOGUE F0S C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F0S REAL X C***FIRST EXECUTABLE STATEMENT F0S F0S = 0.0 IF(X.NE.0.0) F0S = 1.0/SQRT(X) RETURN END *DECK F0WS REAL FUNCTION F0WS (X) C***BEGIN PROLOGUE F0WS C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F0WS REAL X C***FIRST EXECUTABLE STATEMENT F0WS F0WS = SIN(10.0*X) RETURN END *DECK F1C REAL FUNCTION F1C (X) C***BEGIN PROLOGUE F1C C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F1C REAL X C***FIRST EXECUTABLE STATEMENT F1C F1C = 0.0 IF(X.NE.0.33) F1C = (X-0.5)*ABS(X-0.33)**(-0.9) RETURN END *DECK F1F REAL FUNCTION F1F (X) C***BEGIN PROLOGUE F1F C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F1F REAL X,X1,Y C***FIRST EXECUTABLE STATEMENT F1F X1 = X+1.0 F1F = 5.0/X1/X1 Y = 5.0/X1 IF(Y.GT.3.1415926535897932) F1F = 0.0 RETURN END *DECK F1G REAL FUNCTION F1G (X) C***BEGIN PROLOGUE F1G C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F1G REAL PI,X DATA PI/3.1415926535897932/ C***FIRST EXECUTABLE STATEMENT F1G F1G = 2.0/(2.0+SIN(10.0*PI*X)) RETURN END *DECK F1N REAL FUNCTION F1N (X) C***BEGIN PROLOGUE F1N C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F1N REAL X C***FIRST EXECUTABLE STATEMENT F1N F1N=1.0E0/(X**4+X**2+1.0E0) RETURN END *DECK F1O REAL FUNCTION F1O (X) C***BEGIN PROLOGUE F1O C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F1O REAL X C***FIRST EXECUTABLE STATEMENT F1O F1O = 1.0 IF(X.GT.3.1415926535897932) F1O = 0.0 RETURN END *DECK F1P REAL FUNCTION F1P (X) C***BEGIN PROLOGUE F1P C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F1P REAL ALFA1,ALFA2,P1,P2,X,D1,D2 C P1 = 1/7, P2 = 2/3 DATA P1/0.1428571428571428E+00/ DATA P2/0.6666666666666667E+00/ C***FIRST EXECUTABLE STATEMENT F1P ALFA1 = -0.25E0 ALFA2 = -0.5E0 D1=ABS(X-P1) D2=ABS(X-P2) F1P = 0.0E+00 IF(D1.NE.0.0E+00.AND.D2.NE.0.0E+00) F1P = D1**ALFA1+D2**ALFA2 RETURN END *DECK F1S REAL FUNCTION F1S (X) C***BEGIN PROLOGUE F1S C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F1S REAL X C***FIRST EXECUTABLE STATEMENT F1S F1S = 0.2E+01/(0.2E+01+SIN(0.314159E+02*X)) RETURN END *DECK F1WS REAL FUNCTION F1WS (X) C***BEGIN PROLOGUE F1WS C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F1WS REAL X C***FIRST EXECUTABLE STATEMENT F1WS F1WS = ABS(X-0.33E+00)**(-0.999E+00) RETURN END *DECK F2G REAL FUNCTION F2G (X) C***BEGIN PROLOGUE F2G C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F2G REAL X C***FIRST EXECUTABLE STATEMENT F2G F2G = X*SIN(0.3E+02*X)*COS(0.5E+02*X) RETURN END *DECK F2N REAL FUNCTION F2N (X) C***BEGIN PROLOGUE F2N C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F2N REAL X C***FIRST EXECUTABLE STATEMENT F2N F2N=X**(-0.9E+00) RETURN END *DECK F2O REAL FUNCTION F2O (X) C***BEGIN PROLOGUE F2O C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F2O REAL X C***FIRST EXECUTABLE STATEMENT F2O F2O = 0.0E+00 IF(X.NE.0.0E+00) F2O = 1.0/(X*X*SQRT(X)) RETURN END *DECK F2P REAL FUNCTION F2P (X) C***BEGIN PROLOGUE F2P C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F2P REAL X C***FIRST EXECUTABLE STATEMENT F2P F2P = SIN(0.314159E+03*X)/(0.314159E+01*X) RETURN END *DECK F2S REAL FUNCTION F2S (X) C***BEGIN PROLOGUE F2S C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F2S REAL X C***FIRST EXECUTABLE STATEMENT F2S F2S = 100.0 IF(X.NE.0.0) F2S = SIN(0.314159E+03*X)/(0.314159E+01*X) RETURN END *DECK F3G REAL FUNCTION F3G (X) C***BEGIN PROLOGUE F3G C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F3G REAL X C***FIRST EXECUTABLE STATEMENT F3G F3G = ABS(X-0.33E+00)**(-0.9E+00) RETURN END *DECK F3P REAL FUNCTION F3P (X) C***BEGIN PROLOGUE F3P C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F3P REAL X C***FIRST EXECUTABLE STATEMENT F3P F3P = 1.0 IF(X.GT.3.1415926535897932) F3P = 0.0 RETURN END *DECK F3S REAL FUNCTION F3S (X) C***BEGIN PROLOGUE F3S C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F3S REAL X C***FIRST EXECUTABLE STATEMENT F3S F3S = 0.1E+01 IF(X.GT.3.1415926535897932) F3S = 0.0 RETURN END *DECK F4P REAL FUNCTION F4P (X) C***BEGIN PROLOGUE F4P C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F4P REAL X C***FIRST EXECUTABLE STATEMENT F4P F4P = 0.0 IF(X.GT.0.0) F4P = 1.0/(X*SQRT(X)) RETURN END *DECK F4S REAL FUNCTION F4S (X) C***BEGIN PROLOGUE F4S C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F4S REAL X C***FIRST EXECUTABLE STATEMENT F4S IF(X.EQ..33E+00) GO TO 10 F4S = ABS(X-0.33E+00)**(-0.999E+00) RETURN 10 F4S=0.0 RETURN END *DECK F5S REAL FUNCTION F5S (X) C***BEGIN PROLOGUE F5S C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE F5S REAL X C***FIRST EXECUTABLE STATEMENT F5S F5S = 0.0 IF(X.NE.0.0) F5S = 1.0/(X*SQRT(X)) RETURN END *DECK FB REAL FUNCTION FB (X) C***BEGIN PROLOGUE FB C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE FB REAL X C***FIRST EXECUTABLE STATEMENT FB FB = 1.0E0 RETURN END *DECK FCN1 SUBROUTINE FCN1 (IFLAG, M, N, X, FVEC, FJAC, LDFJAC) C***BEGIN PROLOGUE FCN1 C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE FCN1 C C SUBROUTINE WHICH EVALUATES THE FUNCTION FOR TEST C PROGRAM USED IN QUICK CHECK OF SNLS1E. C NUMERICAL APPROXIMATION OF JACOBIAN IS USED. C DIMENSION X(*),FVEC(*) DATA TWO/2.E0/ C***FIRST EXECUTABLE STATEMENT FCN1 IF(IFLAG.NE.1) RETURN DO 100 I=1,M TEMP=I FVEC(I)=TWO+TWO*TEMP-EXP(TEMP*X(1))-EXP(TEMP*X(2)) 100 CONTINUE RETURN END *DECK FCN2 SUBROUTINE FCN2 (IFLAG, M, N, X, FVEC, FJAC, LDFJAC) C***BEGIN PROLOGUE FCN2 C***PURPOSE C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C SUBROUTINE TO EVALUATE FUNCTION AND FULL JACOBIAN C FOR TEST PROBLEM IN QUICK CHECK OF SNLS1E. C C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE FCN2 DIMENSION X(*),FVEC(*),FJAC(LDFJAC,*) DATA TWO/2.E0/ C***FIRST EXECUTABLE STATEMENT FCN2 IF(IFLAG.EQ.0) RETURN C C SHOULD WE EVALUATE FUNCTION OR JACOBIAN C IF(IFLAG.NE.1) GO TO 150 C C EVALUATE FUNCTIONS C DO 100 I=1,M TEMP=I FVEC(I)=TWO+TWO*TEMP-EXP(TEMP*X(1))-EXP(TEMP*X(2)) 100 CONTINUE RETURN C C EVALUATE JACOBIAN C 150 CONTINUE IF(IFLAG.NE.2) RETURN DO 200 I=1,M TEMP=I FJAC(I,1)=-TEMP*EXP(TEMP*X(1)) FJAC(I,2)=-TEMP*EXP(TEMP*X(2)) 200 CONTINUE RETURN END *DECK FCN3 SUBROUTINE FCN3 (IFLAG, M, N, X, FVEC, FJROW, NROW) C***BEGIN PROLOGUE FCN3 C***PURPOSE C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C SUBROUTINE TO EVALUATE THE JACOBIAN, ONE ROW AT A TIME, FOR C TEST PROBLEM USED IN QUICK CHECK OF SNLS1E. C C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE FCN3 DIMENSION X(*),FVEC(*),FJROW(*) DATA TWO/2.E0/ C***FIRST EXECUTABLE STATEMENT FCN3 IF(IFLAG.EQ.0) RETURN C C SHOULD WE EVALUATE FUNCTIONS OR JACOBIAN. C IF(IFLAG.NE.1) GO TO 150 C C EVALUATE FUNCTIONS. C DO 100 I=1,M TEMP=I FVEC(I)=TWO+TWO*TEMP-EXP(TEMP*X(1))-EXP(TEMP*X(2)) 100 CONTINUE RETURN C C EVALUATE ONE ROW OF JACOBIAN. C 150 CONTINUE IF(IFLAG.NE.3) RETURN TEMP=NROW FJROW(1)=-TEMP*EXP(TEMP*X(1)) FJROW(2)=-TEMP*EXP(TEMP*X(2)) RETURN END *DECK FCQX SUBROUTINE FCQX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE FCQX C***PURPOSE Quick check for FC. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (FCQX-S, DFCQX-D) C***KEYWORDS QUICK CHECK C***AUTHOR Hanson, R. J., (SNLA) C***DESCRIPTION C C QUICK CHECK SUBPROGRAM FOR THE SUBROUTINE FC. C C FIT DISCRETE DATA BY AN S-SHAPED CURVE. EVALUATE THE FITTED CURVE, C ITS FIRST TWO DERIVATIVES, AND PROBABLE ERROR CURVE. C C USE SUBPROGRAM FC TO OBTAIN THE CONSTRAINED CUBIC B-SPLINE C REPRESENTATION OF THE CURVE. C C THE VALUES OF THE COEFFICIENTS OF THE B-SPLINE AS COMPUTED C BY FC AND THE VALUES OF THE FITTED CURVE AS COMPUTED BY BVALU C IN THE DE BOOR PACKAGE ARE TESTED FOR ACCURACY WITH THE EXPECTED C VALUES. SEE EXAMPLE PROGRAM SAND78-1291, PP. 22-27. C C THE DIMENSIONS IN THE FOLLOWING ARRAYS ARE AS SMALL C AS POSSIBLE FOR THE PROBLEM BEING SOLVED. C C***ROUTINES CALLED BVALU, CV, FC, IVOUT, R1MACH, SCOPY, SMOUT, SVOUT C***REVISION HISTORY (YYMMDD) C 780801 DATE WRITTEN C 890718 Changed references from BVALUE to BVALU. (WRB) C 890911 Removed unnecessary intrinsics. (WRB) C 891004 Changed computation of XVAL. (WRB) C 891004 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF, modified tolerances C to use R1MACH(4) rather than R1MACH(3) and cleaned up C FORMATs. (RWC) C***END PROLOGUE FCQX DIMENSION XDATA(9), YDATA(9), SDDATA(9), BKPT(13), XCONST(11), * YCONST(11), COEFF(9), V(51,5), W(529), WORK(12), CHECK(51), * COEFCK(9) INTEGER ICNT, IPASS, ITEST(38), NDERIV(11), IW(30) C DATA XDATA(1),XDATA(2),XDATA(3),XDATA(4),XDATA(5), 1 XDATA(6),XDATA(7),XDATA(8),XDATA(9) 2 /0.15,0.27,0.33,0.40,0.43,0.47,0.53,0.58,0.63/ DATA YDATA(1),YDATA(2),YDATA(3),YDATA(4),YDATA(5), 1 YDATA(6),YDATA(7),YDATA(8),YDATA(9) 2 /0.025,0.05,0.13,0.27,0.37,0.47,0.64,0.77,0.87/ DATA SDDATA(1) /0.015 /,NDATA/09/,NORD/04/,NBKPT/13/,LAST/10/ DATA BKPT(1),BKPT(2),BKPT(3),BKPT(4),BKPT(5), 1 BKPT(6),BKPT(7),BKPT(8),BKPT(9),BKPT(10), 2 BKPT(11),BKPT(12),BKPT(13) 3 /-0.6,-0.4,-0.2,0.,0.2,0.4,0.6,0.8,0.9,1.0,1.1,1.2,1.3/ C C STORE THE DATA TO BE USED TO CHECK THE ACCURACY OF THE C COMPUTED RESULTS. SEE SAND78-1291, P.26. C DATA COEFCK(1),COEFCK(2),COEFCK(3),COEFCK(4),COEFCK(5), 1 COEFCK(6),COEFCK(7),COEFCK(8),COEFCK(9)/ 1.186380846E-13, 2 -2.826166426E-14, -4.333929094E-15, 1.722113311E-01, 3 9.421965984E-01, 9.684708719E-01, 9.894902905E-01, 4 1.005254855E+00, 9.894902905E-01/ DATA CHECK(1), CHECK(2), CHECK(3), CHECK(4), CHECK(5), 1 CHECK(6), CHECK(7), CHECK(8), CHECK(9)/ 2 2.095830752E-16, 2.870188850E-05, 2.296151081E-04, 3 7.749509897E-04, 1.836920865E-03, 3.587736064E-03, 4 6.199607918E-03, 9.844747759E-03, 1.469536692E-02/ DATA CHECK(10), CHECK(11), CHECK(12), CHECK(13), CHECK(14), 1 CHECK(15), CHECK(16), CHECK(17), CHECK(18)/ 2 2.092367672E-02, 2.870188851E-02, 3.824443882E-02, 3 4.993466504E-02, 6.419812979E-02, 8.146039566E-02, 4 1.021470253E-01, 1.266835812E-01, 1.554956261E-01/ DATA CHECK(19), CHECK(20), CHECK(21), CHECK(22), CHECK(23), 1 CHECK(24), CHECK(25), CHECK(26), CHECK(27)/ 2 1.890087225E-01, 2.276484331E-01, 2.718403204E-01, 3 3.217163150E-01, 3.762338189E-01, 4.340566020E-01, 4 4.938484342E-01, 5.542730855E-01, 6.139943258E-01/ DATA CHECK(28), CHECK(29), CHECK(30), CHECK(31), CHECK(32), 1 CHECK(33), CHECK(34), CHECK(35), CHECK(36)/ 2 6.716759250E-01, 7.259816530E-01, 7.755752797E-01, 3 8.191205752E-01, 8.556270903E-01, 8.854875002E-01, 4 9.094402609E-01, 9.282238286E-01, 9.425766596E-01/ DATA CHECK(37), CHECK(38), CHECK(39), CHECK(40), CHECK(41), 1 CHECK(42), CHECK(43), CHECK(44), CHECK(45)/ 2 9.532372098E-01, 9.609439355E-01, 9.664352927E-01, 3 9.704497377E-01, 9.737257265E-01, 9.768786393E-01, 4 9.800315521E-01, 9.831844649E-01, 9.863373777E-01/ DATA CHECK(46), CHECK(47), CHECK(48), CHECK(49), CHECK(50), 1 CHECK(51)/ 9.894902905E-01, 9.926011645E-01, 2 9.954598055E-01, 9.978139804E-01, 9.994114563E-01, 3 1.000000000E+00/ C***FIRST EXECUTABLE STATEMENT FCQX C C BROADCAST SDDATA(1) VALUE TO ALL OF SDDATA(*). C CALL SCOPY(NDATA,SDDATA,0,SDDATA,1) ZERO = 0. ONE = 1. NDEG = NORD-1 C C WRITE THE VARIOUS CONSTRAINTS FOR C THE FITTED CURVE. C NCONST = 0 T = BKPT(NORD) C C CONSTRAIN FUNCTION TO BE ZERO AT LEFT-MOST BREAKPOINT. C NCONST = NCONST+1 XCONST(NCONST) = T YCONST(NCONST) = ZERO NDERIV(NCONST) = 2+4*0 C C CONSTRAIN FIRST DERIVATIVE TO BE C NONNEGATIVE AT LEFT-MOST BREAKPOINT. C NCONST = NCONST+1 XCONST(NCONST) = T YCONST(NCONST) = ZERO NDERIV(NCONST) = 1+4*1 C C CONSTRAIN SECOND DERIVATIVES TO BE C NONNEGATIVE AT LEFT SET OF BREAKPOINTS. C DO 10 I = 1, 3 L = NDEG+I T = BKPT(L) NCONST=NCONST+1 XCONST(NCONST) = T YCONST(NCONST) = ZERO NDERIV(NCONST) = 1+4*2 10 CONTINUE C C CONSTRAIN FUNCTION VALUE AT RIGHT-MOST C BREAKPOINT TO BE ONE. C NCONST = NCONST+1 T = BKPT(LAST) XCONST(NCONST) = T YCONST(NCONST) = ONE NDERIV(NCONST) = 2+4*0 C C CONSTRAIN SLOPE TO AGREE AT LEFT AND C RIGHT-MOST BREAKPOINTS. C NCONST = NCONST+1 XCONST(NCONST) = BKPT(NORD) YCONST(NCONST) = BKPT(LAST) NDERIV(NCONST) = 3+4*1 C C CONSTRAIN SECOND DERIVATIVES TO BE C NONPOSITIVE AT RIGHT SET OF BREAKPOINTS. C DO 20 I = 1, 4 NCONST = NCONST+1 L = LAST-4+I XCONST(NCONST) = BKPT(L) YCONST(NCONST) = ZERO NDERIV(NCONST) = 0+4*2 20 CONTINUE C IF (KPRINT.GE.2) WRITE (LUN,1000) 1000 FORMAT ('1TEST OF SUBROUTINE FC'/) ICNT = 1 IDIGIT = -4 C IF (KPRINT.GE.3) THEN CALL SVOUT (NBKPT, BKPT, '('' ARRAY OF KNOTS.'')', IDIGIT) CALL SVOUT (NDATA, XDATA, '('' INDEP. VAR. VALUES'')', * IDIGIT) CALL SVOUT (NDATA, YDATA, '('' DEPEND. VAR. VALUES'')', IDIGIT) CALL SVOUT (NDATA, SDDATA, '('' DEPEND. VAR. UNCERTAINTY'')', * IDIGIT) C CALL SVOUT (NCONST, XCONST, '('' INDEP. VAR. CONST. VALS.'')', * IDIGIT) CALL SVOUT (NCONST, YCONST, '('' CONST. VALUES'')', IDIGIT) CALL IVOUT (NCONST, NDERIV, '('' CONST. INDICATOR'')', IDIGIT) ENDIF C C DECLARE AMOUNT OF WORKING STORAGE ALLOCATED TO FC. C IW(1) = 529 IW(2) = 30 C C SET MODE TO INDICATE A NEW PROBLEM C AND REQUEST THE VARIANCE FUNCTION. C MODE = 2 C C OBTAIN THE COEFFICIENTS OF THE B-SPLINE. C CALL FC(NDATA,XDATA,YDATA,SDDATA, 1 NORD,NBKPT,BKPT, 2 NCONST,XCONST,YCONST,NDERIV, 3 MODE, 4 COEFF, 5 W,IW) C C CHECK COEFFICIENTS C TOL = 7.E0*SQRT(R1MACH(4)) DO 40 I = 1, NDATA DIFF = ABS(COEFF(I)-COEFCK(I)) IF (DIFF .GT. TOL) GO TO 50 40 CONTINUE C ITEST(ICNT) = 1 IF (KPRINT.GE.3) WRITE (LUN,1001) 1001 FORMAT (/' FC PASSED TEST 1') GO TO 60 C 50 ITEST(ICNT) = 0 IF (KPRINT.GE.2) WRITE (LUN,1002) 1002 FORMAT (/' FC FAILED TEST 1') C 60 K = ITEST(ICNT) IF (KPRINT.NE.2 .OR. K.EQ.0) THEN IF (KPRINT.GE.2) THEN CALL SVOUT (NDATA, COEFCK, * '(/'' PREDICTED COEFFICIENTS OF THE B-SPLINE FROM SAMPLE'')', * IDIGIT) CALL SVOUT (NDATA, COEFF, * '(/'' COEFFICIENTS OF THE B-SPLINE COMPUTED BY FC'')', * IDIGIT) ENDIF ENDIF C ICNT=ICNT+1 C C COMPUTE VALUE, FIRST TWO DERIVS., AND PROBABLE UNCERTAINTY. C N = NBKPT-NORD NVAL = 51 DO 90 I = 1, NVAL C C THE FUNCTION BVALU IS IN THE DE BOOR B-SPLINE PACKAGE. C XVAL = REAL(I-1)/(NVAL-1) II = 1 DO 80 J = 1, 3 V(I,J+1) = BVALU(BKPT,COEFF,N,NORD,J-1,XVAL,II,WORK) 80 CONTINUE V(I,1) = XVAL C C THE VARIANCE FUNCTION CV IS A COMPANION SUBPROGRAM TO FC. C V(I,5) = SQRT(CV(XVAL,NDATA,NCONST,NORD,NBKPT,BKPT,W)) 90 CONTINUE C DO 100 I = 1, NVAL DIFF = ABS(V(I,2)-CHECK(I)) IF (DIFF .GT. TOL) GO TO 110 100 CONTINUE C ITEST(ICNT) = 1 IF (KPRINT.GE.3) WRITE (LUN,1003) 1003 FORMAT (/' FC (AND BVALU) PASSED TEST 2') GO TO 120 C 110 ITEST(ICNT) = 0 IF (KPRINT.GE.2) WRITE (LUN,1004) 1004 FORMAT (/' FC (AND BVALU) FAILED TEST 2') C 120 K = ITEST(ICNT) IF (KPRINT.NE.2 .OR. K.EQ.0) THEN IF (KPRINT.GE.2) THEN C C PRINT THESE VALUES. C CALL SMOUT (NVAL, 5, NVAL, V, 1 '(''1'',15X,''X'',10X,''FNCN'',8X,''1ST D'',7X,''2ND D'', 2 7X, ''ERROR'')', IDIGIT) WRITE (LUN,1005) 1005 FORMAT (/' VALUES SHOULD CORRESPOND TO THOSE IN ', * 'SAND78-1291, P. 26') ENDIF ENDIF C C CHECK ERROR PROCESSOR C IF (KPRINT.GE.2) THEN WRITE (LUN,1006) 1006 FORMAT (/ ' 6 ERROR MESSAGES EXPECTED') CALL FC(NDATA,XDATA,YDATA,SDDATA,0,NBKPT,BKPT,NCONST,XCONST, 1 YCONST,NDERIV,MODE,COEFF,W,IW) CALL FC(NDATA,XDATA,YDATA,SDDATA,NORD,0,BKPT,NCONST,XCONST, 1 YCONST,NDERIV,MODE,COEFF,W,IW) CALL FC(-1,XDATA,YDATA,SDDATA,NORD,NBKPT,BKPT,NCONST,XCONST, 1 YCONST,NDERIV,MODE,COEFF,W,IW) MODE = 0 CALL FC(NDATA,XDATA,YDATA,SDDATA,NORD,NBKPT,BKPT,NCONST,XCONST, 1 YCONST,NDERIV,MODE,COEFF,W,IW) IW(1) = 10 CALL FC(NDATA,XDATA,YDATA,SDDATA,NORD,NBKPT,BKPT,NCONST,XCONST, 1 YCONST,NDERIV,MODE,COEFF,W,IW) IW(1) = 529 IW(2) = 2 CALL FC(NDATA,XDATA,YDATA,SDDATA,NORD,NBKPT,BKPT,NCONST,XCONST, 1 YCONST,NDERIV,MODE,COEFF,W,IW) ENDIF C IP = 1 DO 150 I = 1, ICNT IP = IP*ITEST(I) 150 CONTINUE C IPASS = IP IF (IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN,1007) IF (IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN,1008) RETURN C 1007 FORMAT (/' *****************FC PASSED ALL TESTS*****************') 1008 FORMAT (/' ****************FC FAILED SOME TESTS*****************') END *DECK FDEQC SUBROUTINE FDEQC (T, U, UPRIME, RPAR, IPAR) C***BEGIN PROLOGUE FDEQC C***SUBSIDIARY C***PURPOSE Derivative evaluator for DEPAC quick checks. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (FDEQC-S, DFDEQC-D) C***AUTHOR Chow, Jeff, (LANL) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 810801 DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 900415 Name changed from F to FDEQC. (WRB) C***END PROLOGUE FDEQC C C Declare arguments. C INTEGER IPAR(*) REAL RPAR(*), T, U(*), UPRIME(*) C C Declare local variables. C REAL R, RSQ, R3 C***FIRST EXECUTABLE STATEMENT FDEQC RSQ = U(1)*U(1) + U(2)*U(2) R = SQRT(RSQ) R3 = RSQ*R UPRIME(1) = U(3) UPRIME(2) = U(4) UPRIME(3) = -(U(1)/R3) UPRIME(4) = -(U(2)/R3) RETURN END *DECK FDTRUE SUBROUTINE FDTRUE (X, F, D) C***BEGIN PROLOGUE FDTRUE C***SUBSIDIARY C***PURPOSE Compute exact function values for EVCHCK. C***LIBRARY SLATEC (PCHIP) C***TYPE SINGLE PRECISION (FDTRUE-S, DFDTRU-D) C***KEYWORDS PCHIP EVALUATOR QUICK CHECK C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C COMPUTE EXACT FUNCTION VALUES IN DOUBLE PRECISION. C C F(X) = X*(X+1)*(X-2) C C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 820601 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 890706 Cosmetic changes to prologue. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 Revised prologue. (FNF) C 900316 Deleted variables ONE and TWO. (FNF) C 900321 Changed name of d.p. version from DFTRUE to DFDTRU. C***END PROLOGUE FDTRUE REAL X, F, D DOUBLE PRECISION FACT1, FACT2, XX C C***FIRST EXECUTABLE STATEMENT FDTRUE XX = X FACT1 = XX + 1 FACT2 = XX - 2 F = XX * FACT1 * FACT2 D = FACT1*FACT2 + XX*(FACT1 + FACT2) C RETURN C------------- LAST LINE OF FDTRUE FOLLOWS ----------------------------- END *DECK FEIN REAL FUNCTION FEIN (T) C***BEGIN PROLOGUE FEIN C***PURPOSE Subsidiary to EG8CK. C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***COMMON BLOCKS FEINX C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE FEIN COMMON /FEINX/ X, A, FKM REAL X, A, FKM, T, ALN C***FIRST EXECUTABLE STATEMENT FEIN ALN = (FKM-T)*X - A*LOG(T) FEIN = EXP(ALN) RETURN END *DECK FFTQX SUBROUTINE FFTQX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE FFTQX C***PURPOSE Quick check for the NCAR FFT routines. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Swarztrauber, P. N., (NCAR) C***DESCRIPTION C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C VERSION 4 APRIL 1985 C C A TEST DRIVER FOR C A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE FAST FOURIER C TRANSFORM OF PERIODIC AND OTHER SYMMETRIC SEQUENCES C C BY C C PAUL N SWARZTRAUBER C C NATIONAL CENTER FOR ATMOSPHERIC RESEARCH BOULDER,COLORADO 80307 C C WHICH IS SPONSORED BY THE NATIONAL SCIENCE FOUNDATION C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C C THIS PROGRAM TESTS THE PACKAGE OF FAST FOURIER C TRANSFORMS FOR BOTH COMPLEX AND REAL PERIODIC SEQUENCES AND C CERTAIN OTHER SYMMETRIC SEQUENCES THAT ARE LISTED BELOW. C C 1. RFFTI INITIALIZE RFFTF AND RFFTB C 2. RFFTF FORWARD TRANSFORM OF A REAL PERIODIC SEQUENCE C 3. RFFTB BACKWARD TRANSFORM OF A REAL COEFFICIENT ARRAY C C 4. EZFFTI INITIALIZE EZFFTF AND EZFFTB C 5. EZFFTF A SIMPLIFIED REAL PERIODIC FORWARD TRANSFORM C 6. EZFFTB A SIMPLIFIED REAL PERIODIC BACKWARD TRANSFORM C C 7. SINTI INITIALIZE SINT C 8. SINT SINE TRANSFORM OF A REAL ODD SEQUENCE C C 9. COSTI INITIALIZE COST C 10. COST COSINE TRANSFORM OF A REAL EVEN SEQUENCE C C 11. SINQI INITIALIZE SINQF AND SINQB C 12. SINQF FORWARD SINE TRANSFORM WITH ODD WAVE NUMBERS C 13. SINQB UNNORMALIZED INVERSE OF SINQF C C 14. COSQI INITIALIZE COSQF AND COSQB C 15. COSQF FORWARD COSINE TRANSFORM WITH ODD WAVE NUMBERS C 16. COSQB UNNORMALIZED INVERSE OF COSQF C C 17. CFFTI INITIALIZE CFFTF AND CFFTB C 18. CFFTF FORWARD TRANSFORM OF A COMPLEX PERIODIC SEQUENCE C 19. CFFTB UNNORMALIZED INVERSE OF CFFTF C C***ROUTINES CALLED CFFTB, CFFTF, CFFTI, COSQB, COSQF, COSQI, COST, C COSTI, EZFFTB, EZFFTF, EZFFTI, PIMACH, R1MACH, C RFFTB, RFFTF, RFFTI, SINQB, SINQF, SINQI, SINT, C SINTI C***REVISION HISTORY (YYMMDD) C 790601 DATE WRITTEN C 890718 Changed computation of PI to use PIMACH. (WRB) C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Changed usage of R1MACH(3) to R1MACH(4). (RWC) C 910708 Minor modifications in use of KPRINT. (WRB) C 920211 Code cleaned up, an error in printing an error message fixed C and comments on PASS/FAIL of individual tests added. (WRB) C 920618 Code upgraded to "Version 4". (BKS, WRB) C***END PROLOGUE FFTQX C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. REAL ARG, ARG1, ARG2, AZERO, AZEROH, CF, COSQBT, COSQFB, COSQFT, + COSTFB, COSTT, DCFB, DCFFTB, DCFFTF, DEZB1, DEZF1, DEZFB, DT, + DUM, ERRMAX, FN, PI, RFTB, RFTF, RFTFB, SIGN, SINQBT, SINQFB, + SINQFT, SINTFB, SINTT, SQRT2, SUM, SUM1, SUM2, TFN, TPI INTEGER I, J, K, MODN, N, NM1, NNS, NP1, NS2, NS2M, NZ C .. Local Arrays .. COMPLEX CX(200), CY(200) REAL A(100), AH(100), B(100), BH(100), W(2000), X(200), XH(200), + Y(200) INTEGER ND(10) C .. External Functions .. REAL PIMACH, R1MACH EXTERNAL PIMACH, R1MACH C .. External Subroutines .. EXTERNAL CFFTB, CFFTF, CFFTI, COSQB, COSQF, COSQI, COST, COSTI, + EZFFTB, EZFFTF, EZFFTI, RFFTB, RFFTF, RFFTI, SINQB, + SINQF, SINQI, SINT, SINTI C .. Intrinsic Functions .. INTRINSIC ABS, CABS, CMPLX, COS, MAX, MOD, SIN, SQRT C .. Data statements .. DATA ND(1), ND(2), ND(3), ND(4), ND(5), ND(6), ND(7)/120, 54, 49, + 32, 4, 3, 2/ C***FIRST EXECUTABLE STATEMENT FFTQX SQRT2 = SQRT(2.0) ERRMAX = 2.0*SQRT(R1MACH(4)) NNS = 7 PI = PIMACH(DUM) IF (KPRINT .GE. 2) WRITE (LUN, 9000) IPASS = 1 DO 660 NZ=1,NNS N = ND(NZ) IF (KPRINT .GE. 2) WRITE (LUN, 9010) N MODN = MOD(N, 2) FN = N TFN = FN + FN NP1 = N + 1 NM1 = N - 1 DO 100 J=1,NP1 X(J) = SIN(J*SQRT2) Y(J) = X(J) XH(J) = X(J) 100 CONTINUE C C Test Subroutines RFFTI, RFFTF and RFFTB C CALL RFFTI(N, W) DT = (PI+PI)/FN NS2 = (N+1)/2 IF (NS2 .LT. 2) GO TO 130 DO 120 K=2,NS2 SUM1 = 0.0 SUM2 = 0.0 ARG = (K-1)*DT DO 110 I=1,N ARG1 = (I-1)*ARG SUM1 = SUM1 + X(I)*COS(ARG1) SUM2 = SUM2 + X(I)*SIN(ARG1) 110 CONTINUE Y(2*K-2) = SUM1 Y(2*K-1) = -SUM2 120 CONTINUE 130 SUM1 = 0.0 SUM2 = 0.0 DO 140 I=1,NM1,2 SUM1 = SUM1 + X(I) SUM2 = SUM2 + X(I+1) 140 CONTINUE IF (MODN .EQ. 1) SUM1 = SUM1 + X(N) Y(1) = SUM1 + SUM2 IF (MODN .EQ. 0) Y(N) = SUM1 - SUM2 CALL RFFTF(N, X, W) RFTF = 0.0 DO 150 I=1,N RFTF = MAX(RFTF, ABS(X(I)-Y(I))) X(I) = XH(I) 150 CONTINUE RFTF = RFTF/FN IF (RFTF .LE. ERRMAX) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9020) ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9030) END IF SIGN = 1.0 DO 180 I=1,N SUM = 0.5*X(1) ARG = (I-1)*DT IF (NS2 .LT. 2) GO TO 170 DO 160 K=2,NS2 ARG1 = (K-1)*ARG SUM = SUM + X(2*K-2)*COS(ARG1) - X(2*K-1)*SIN(ARG1) 160 CONTINUE 170 IF (MODN .EQ. 0) SUM = SUM + 0.5*SIGN*X(N) Y(I) = SUM + SUM SIGN = -SIGN 180 CONTINUE CALL RFFTB(N, X, W) RFTB = 0.0 DO 190 I=1,N RFTB = MAX(RFTB, ABS(X(I)-Y(I))) X(I) = XH(I) Y(I) = XH(I) 190 CONTINUE IF (RFTB .LE. ERRMAX) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9040) ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9050) END IF C CALL RFFTB(N, Y, W) CALL RFFTF(N, Y, W) CF = 1.0/FN RFTFB = 0.0 DO 200 I=1,N RFTFB = MAX(RFTFB, ABS(CF*Y(I)-X(I))) 200 CONTINUE IF (RFTFB .LE. ERRMAX) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9060) ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9070) END IF C C Test Subroutines SINTI and SINT C DT = PI/FN DO 210 I=1,NM1 X(I) = XH(I) 210 CONTINUE DO 230 I=1,NM1 Y(I) = 0.0 ARG1 = (I)*DT DO 220 K=1,NM1 Y(I) = Y(I) + X(K)*SIN((K)*ARG1) 220 CONTINUE Y(I) = Y(I) + Y(I) 230 CONTINUE CALL SINTI(NM1, W) CALL SINT(NM1, X, W) CF = 0.5/FN SINTT = 0.0 DO 240 I=1,NM1 SINTT = MAX(SINTT, ABS(X(I)-Y(I))) X(I) = XH(I) Y(I) = X(I) 240 CONTINUE SINTT = CF*SINTT IF (SINTT .LE. ERRMAX) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9080) ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9090) END IF CALL SINT(NM1, X, W) CALL SINT(NM1, X, W) SINTFB = 0.0 DO 250 I=1,NM1 SINTFB = MAX(SINTFB, ABS(CF*X(I)-Y(I))) 250 CONTINUE IF (SINTFB .LE. ERRMAX) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9100) ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9110) END IF C C Test Subroutines COSTI and COST C DO 260 I=1,NP1 X(I) = XH(I) 260 CONTINUE SIGN = 1.0 DO 280 I=1,NP1 Y(I) = 0.5*(X(1)+SIGN*X(N+1)) ARG = (I-1)*DT DO 270 K=2,N Y(I) = Y(I) + X(K)*COS((K-1)*ARG) 270 CONTINUE Y(I) = Y(I) + Y(I) SIGN = -SIGN 280 CONTINUE CALL COSTI(NP1, W) CALL COST(NP1, X, W) COSTT = 0.0 DO 290 I=1,NP1 COSTT = MAX(COSTT, ABS(X(I)-Y(I))) X(I) = XH(I) Y(I) = XH(I) 290 CONTINUE COSTT = CF*COSTT IF (COSTT .LE. ERRMAX) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9120) ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9130) END IF C CALL COST(NP1, X, W) CALL COST(NP1, X, W) COSTFB = 0.0 DO 300 I=1,NP1 COSTFB = MAX(COSTFB, ABS(CF*X(I)-Y(I))) 300 CONTINUE IF (COSTFB .LE. ERRMAX) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9140) ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9150) END IF C C Test Subroutines SINQI, SINQF and SINQB C CF = 0.25/FN DO 310 I=1,N Y(I) = XH(I) 310 CONTINUE DT = PI/(FN+FN) DO 330 I=1,N X(I) = 0.0 ARG = DT*(I) DO 320 K=1,N X(I) = X(I) + Y(K)*SIN((K+K-1)*ARG) 320 CONTINUE X(I) = 4.0*X(I) 330 CONTINUE CALL SINQI(N, W) CALL SINQB(N, Y, W) SINQBT = 0.0 DO 340 I=1,N SINQBT = MAX(SINQBT, ABS(Y(I)-X(I))) X(I) = XH(I) 340 CONTINUE SINQBT = CF*SINQBT IF (SINQBT .LE. ERRMAX) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9160) ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9170) END IF C SIGN = 1.0 DO 360 I=1,N ARG = (I+I-1)*DT Y(I) = 0.5*SIGN*X(N) DO 350 K=1,NM1 Y(I) = Y(I) + X(K)*SIN((K)*ARG) 350 CONTINUE Y(I) = Y(I) + Y(I) SIGN = -SIGN 360 CONTINUE CALL SINQF(N, X, W) SINQFT = 0.0 DO 370 I=1,N SINQFT = MAX(SINQFT, ABS(X(I)-Y(I))) Y(I) = XH(I) X(I) = XH(I) 370 CONTINUE IF (SINQFT .LE. ERRMAX) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9180) ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9190) END IF C CALL SINQF(N, Y, W) CALL SINQB(N, Y, W) SINQFB = 0.0 DO 380 I=1,N SINQFB = MAX(SINQFB, ABS(CF*Y(I)-X(I))) 380 CONTINUE IF (SINQFB .LE. ERRMAX) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9200) ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9210) END IF C C Test Subroutines COSQI, COSQF and COSQB C DO 390 I=1,N Y(I) = XH(I) 390 CONTINUE DO 410 I=1,N X(I) = 0.0 ARG = (I-1)*DT DO 400 K=1,N X(I) = X(I) + Y(K)*COS((K+K-1)*ARG) 400 CONTINUE X(I) = 4.0*X(I) 410 CONTINUE CALL COSQI(N, W) CALL COSQB(N, Y, W) COSQBT = 0.0 DO 420 I=1,N COSQBT = MAX(COSQBT, ABS(X(I)-Y(I))) X(I) = XH(I) 420 CONTINUE COSQBT = CF*COSQBT IF (COSQBT .LE. ERRMAX) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9220) ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9230) END IF C DO 440 I=1,N Y(I) = 0.5*X(1) ARG = (I+I-1)*DT DO 430 K=2,N Y(I) = Y(I) + X(K)*COS((K-1)*ARG) 430 CONTINUE Y(I) = Y(I) + Y(I) 440 CONTINUE CALL COSQF(N, X, W) COSQFT = 0.0 DO 450 I=1,N COSQFT = MAX(COSQFT, ABS(Y(I)-X(I))) X(I) = XH(I) Y(I) = XH(I) 450 CONTINUE COSQFT = CF*COSQFT IF (COSQFT .LE. ERRMAX) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9240) ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9250) END IF C CALL COSQB(N, X, W) CALL COSQF(N, X, W) COSQFB = 0.0 DO 460 I=1,N COSQFB = MAX(COSQFB, ABS(CF*X(I)-Y(I))) 460 CONTINUE IF (COSQFB .LE. ERRMAX) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9260) ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9270) END IF C C Test Subroutines EZFFTI, EZFFTF and EZFFTB C CALL EZFFTI(N, W) DO 470 I=1,N X(I) = XH(I) 470 CONTINUE TPI = 2.0*PI DT = TPI/N NS2 = (N+1)/2 CF = 2.0/N NS2M = NS2 - 1 IF (NS2M .LE. 0) GO TO 500 DO 490 K=1,NS2M SUM1 = 0.0 SUM2 = 0.0 ARG = K*DT DO 480 I=1,N ARG1 = (I-1)*ARG SUM1 = SUM1 + X(I)*COS(ARG1) SUM2 = SUM2 + X(I)*SIN(ARG1) 480 CONTINUE A(K) = CF*SUM1 B(K) = CF*SUM2 490 CONTINUE 500 NM1 = N - 1 SUM1 = 0.0 SUM2 = 0.0 DO 510 I=1,NM1,2 SUM1 = SUM1 + X(I) SUM2 = SUM2 + X(I+1) 510 CONTINUE IF (MODN .EQ. 1) SUM1 = SUM1 + X(N) AZERO = 0.5*CF*(SUM1+SUM2) IF (MODN .EQ. 0) A(NS2) = 0.5*CF*(SUM1-SUM2) CALL EZFFTF(N, X, AZEROH, AH, BH, W) DEZF1 = ABS(AZEROH-AZERO) IF (MODN .EQ. 0) DEZF1 = MAX(DEZF1, ABS(A(NS2)-AH(NS2))) IF (NS2M .LE. 0) GO TO 530 DO 520 I=1,NS2M DEZF1 = MAX(DEZF1, ABS(AH(I)-A(I)), ABS(BH(I)-B(I))) 520 CONTINUE IF (DEZF1 .LE. ERRMAX) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9280) ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9290) END IF C 530 NS2 = N/2 IF (MODN .EQ. 0) B(NS2) = 0.0 DO 550 I=1,N SUM = AZERO ARG1 = (I-1)*DT DO 540 K=1,NS2 ARG2 = (K)*ARG1 SUM = SUM + A(K)*COS(ARG2) + B(K)*SIN(ARG2) 540 CONTINUE X(I) = SUM 550 CONTINUE CALL EZFFTB(N, Y, AZERO, A, B, W) DEZB1 = 0.0 DO 560 I=1,N DEZB1 = MAX(DEZB1, ABS(X(I)-Y(I))) X(I) = XH(I) 560 CONTINUE IF (DEZB1 .LE. ERRMAX) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9300) ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9310) END IF C CALL EZFFTF(N, X, AZERO, A, B, W) CALL EZFFTB(N, Y, AZERO, A, B, W) DEZFB = 0.0 DO 570 I=1,N DEZFB = MAX(DEZFB, ABS(X(I)-Y(I))) 570 CONTINUE IF (DEZFB .LE. ERRMAX) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9320) ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9330) END IF C C Test Subroutines CFFTI, CFFTF and CFFTB C DO 580 I=1,N CX(I) = CMPLX(COS(SQRT2*I), SIN(SQRT2*(I*I))) 580 CONTINUE DT = (PI+PI)/FN DO 600 I=1,N ARG1 = -(I-1)*DT CY(I) = (0.0, 0.0) DO 590 K=1,N ARG2 = (K-1)*ARG1 CY(I) = CY(I) + CMPLX(COS(ARG2), SIN(ARG2))*CX(K) 590 CONTINUE 600 CONTINUE CALL CFFTI(N, W) CALL CFFTF(N, CX, W) DCFFTF = 0.0 DO 610 I=1,N DCFFTF = MAX(DCFFTF, CABS(CX(I)-CY(I))) CX(I) = CX(I)/FN 610 CONTINUE DCFFTF = DCFFTF/FN IF (DCFFTF .LE. ERRMAX) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9340) ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9350) END IF C DO 630 I=1,N ARG1 = (I-1)*DT CY(I) = (0.0, 0.0) DO 620 K=1,N ARG2 = (K-1)*ARG1 CY(I) = CY(I) + CMPLX(COS(ARG2), SIN(ARG2))*CX(K) 620 CONTINUE 630 CONTINUE CALL CFFTB(N, CX, W) DCFFTB = 0.0 DO 640 I=1,N DCFFTB = MAX(DCFFTB, CABS(CX(I)-CY(I))) CX(I) = CY(I) 640 CONTINUE IF (DCFFTB .LE. ERRMAX) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9360) ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9370) END IF C CF = 1.0/FN CALL CFFTF(N, CX, W) CALL CFFTB(N, CX, W) DCFB = 0.0 DO 650 I=1,N DCFB = MAX(DCFB, CABS(CF*CX(I)-CY(I))) 650 CONTINUE IF (DCFB .LE. ERRMAX) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9380) ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9390) END IF IF (KPRINT .GE. 3) THEN WRITE (LUN, 9400) N, RFTF, RFTB, RFTFB, SINTT, SINTFB, + COSTT, COSTFB, SINQFT, SINQBT, SINQFB, COSQFT, COSQBT, + COSQFB, DEZF1, DEZB1, DEZFB, DCFFTF, DCFFTB, DCFB END IF 660 CONTINUE IF (KPRINT.GE.2 .AND. IPASS.EQ.1) WRITE (LUN, 9410) IF (KPRINT.GE.1 .AND. IPASS.EQ.0) WRITE (LUN, 9420) RETURN C 9000 FORMAT ('1' / ' FFT QUICK CHECK') 9010 FORMAT (/ ' Test FFT routines with a sequence of length ', I3) 9020 FORMAT (' Test of RFFTF PASSED') 9030 FORMAT (' Test of RFFTF FAILED') 9040 FORMAT (' Test of RFFTB PASSED') 9050 FORMAT (' Test of RFFTB FAILED') 9060 FORMAT (' Test of RFFTF and RFFTB PASSED') 9070 FORMAT (' Test of RFFTF and RFFTB FAILED') 9080 FORMAT (' First test of SINT PASSED') 9090 FORMAT (' First test of SINT FAILED') 9100 FORMAT (' Second test of SINT PASSED') 9110 FORMAT (' Second test of SINT FAILED') 9120 FORMAT (' First test of COST PASSED') 9130 FORMAT (' First test of COST FAILED') 9140 FORMAT (' Second test of COST PASSED') 9150 FORMAT (' Second test of COST FAILED') 9160 FORMAT (' Test of SINQB PASSED') 9170 FORMAT (' Test of SINQB FAILED') 9180 FORMAT (' Test of SINQF PASSED') 9190 FORMAT (' Test of SINQF FAILED') 9200 FORMAT (' Test of SINQF and SINQB PASSED') 9210 FORMAT (' Test of SINQF and SINQB FAILED') 9220 FORMAT (' Test of COSQB PASSED') 9230 FORMAT (' Test of COSQB FAILED') 9240 FORMAT (' Test of COSQF PASSED') 9250 FORMAT (' Test of COSQF FAILED') 9260 FORMAT (' Test of COSQF and COSQB PASSED') 9270 FORMAT (' Test of COSQF and COSQB FAILED') 9280 FORMAT (' Test of EZFFTF PASSED') 9290 FORMAT (' Test of EZFFTF FAILED') 9300 FORMAT (' Test of EZFFTB PASSED') 9310 FORMAT (' Test of EZFFTB FAILED') 9320 FORMAT (' Test of EZFFTF and EZFFTB PASSED') 9330 FORMAT (' Test of EZFFTF and EZFFTB FAILED') 9340 FORMAT (' Test of CFFTF PASSED') 9350 FORMAT (' Test of CFFTF FAILED') 9360 FORMAT (' Test of CFFTB PASSED') 9370 FORMAT (' Test of CFFTB FAILED') 9380 FORMAT (' Test of CFFTF and CFFTB PASSED') 9390 FORMAT (' Test of CFFTF and CFFTB FAILED') 9400 FORMAT ('0N', I5, ' RFFTF ', E9.3, ' RFFTB ', E9.3, + ' RFFTFB ',E9.3 / + 7X, ' SINT ', E9.3, ' SINTFB ', E9.3 / + 7X, ' COST ', E9.3 , ' COSTFB ' , E9.3 / + 7X, ' SINQF ', E9.3, ' SINQB ', E9.3, ' SINQFB ', + E9.3 / + 7X, ' COSQF ', E9.3, ' COSQB ', E9.3, ' COSQFB ', + E9.3 / + 7X, ' DEZF1 ', E9.3, ' DEZB1 ', E9.3, ' DEZFB ', + E9.3 / + 7X, ' CFFTF ', E9.3, ' CFFTB ', E9.3, ' CFFTFB ', + E9.3) 9410 FORMAT (/ ' ***********FFT ROUTINES PASSED ALL TESTS************') 9420 FORMAT (/ ' ***********FFT ROUTINES FAILED SOME TESTS***********') END *DECK FMAT SUBROUTINE FMAT (X, Y, YP) C***BEGIN PROLOGUE FMAT C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***COMMON BLOCKS SAVEX C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE FMAT DIMENSION Y(*),YP(*) COMMON /SAVEX/ XSAVE, TERM C***FIRST EXECUTABLE STATEMENT FMAT YP(1) = Y(2) IF (X .EQ. XSAVE) GO TO 10 XSAVE=X TANX=TAN(X/57.2957795130823) TERM=3.0/TANX+2.0*TANX 10 YP(2) = -TERM*Y(2)-0.7*Y(1) RETURN END *DECK FQD1 REAL FUNCTION FQD1 (X) C***BEGIN PROLOGUE FQD1 C***SUBSIDIARY C***PURPOSE Function evaluator for QNC79 and GAUS8 quick checks. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (FQD1-S, DFQD1-D) C***AUTHOR Boland, W. Robert, (LANL) C***SEE ALSO QG8TST, QN79QX C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 920229 DATE WRITTEN C***END PROLOGUE FQD1 C .. Scalar Arguments .. REAL X C .. Intrinsic Functions .. INTRINSIC SQRT C***FIRST EXECUTABLE STATEMENT FQD1 FQD1 = 0.0E0 IF (X .GT. 0.0E0) THEN FQD1 = 1.0E0/SQRT(X) ENDIF RETURN END *DECK FQD2 REAL FUNCTION FQD2 (X) C***BEGIN PROLOGUE FQD2 C***SUBSIDIARY C***PURPOSE Function evaluator for QNC79 and GAUS8 quick checks. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (FQD2-S, DFQD2-D) C***AUTHOR Boland, W. Robert, (LANL) C***SEE ALSO QG8TST, QN79QX C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 920229 DATE WRITTEN C***END PROLOGUE FQD2 C .. Scalar Arguments .. REAL X C .. Intrinsic Functions .. INTRINSIC COS, EXP C***FIRST EXECUTABLE STATEMENT FQD2 FQD2 = EXP(X)*COS(10.0E0*X) RETURN END *DECK FZTEST SUBROUTINE FZTEST (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE FZTEST C***PURPOSE Quick check for FZERO. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (FZTEST-S, DFZTST-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED FZERO, R1MACH, XERCLR, XGETF, XSETF C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Changed usage of R1MACH(3) to R1MACH(4). (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C 910708 Minor modifications in use of KPRINT. (WRB) C 920212 Code completely restructured to test IFLAG for all values C of KPRINT. (WRB) C***END PROLOGUE FZTEST C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. INTEGER IFLAG, KONTRL REAL AE, B, C, PI, R, RE, TOL LOGICAL FATAL C .. External Functions .. REAL R1MACH EXTERNAL R1MACH C .. External Subroutines .. EXTERNAL FZERO, XERCLR, XGETF, XSETF C .. Intrinsic Functions .. REAL SIN, TAN INTRINSIC ABS, ATAN, MAX, SIN, SQRT, TAN C***FIRST EXECUTABLE STATEMENT FZTEST IF (KPRINT .GE. 2) WRITE (LUN,9000) IPASS = 1 PI = 4.0E0 *ATAN(1.0E0) RE = 1.0E-6 AE = 1.0E-6 TOL = MAX(1.0E-5,SQRT(R1MACH(4))) C C Set up and solve example problem C B = 0.1E0 C = 4.0E0 R = C - B CALL FZERO (SIN, B, C, R, RE, AE, IFLAG) C C See if test was passed. C IF (ABS(B-PI).LE.TOL .AND. ABS(C-PI).LE.TOL) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9010) 'PASSED', B, C, IFLAG ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9010) 'FAILED', B, C, IFLAG ENDIF C C Trigger 2 error conditions C CALL XGETF (KONTRL) IF (KPRINT .LE. 2) THEN CALL XSETF (0) ELSE CALL XSETF (1) ENDIF FATAL = .FALSE. CALL XERCLR C IF (KPRINT .GE. 3) WRITE (LUN,9020) B = 1.0E0 C C IFLAG=3 (Singular point) C C = 2.0E0 R = 0.5E0*(B+C) CALL FZERO (TAN, B, C, B, RE, AE, IFLAG) IF (IFLAG .NE. 3) THEN IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 2) WRITE (LUN,9030) IFLAG, 2 ENDIF C C IFLAG=4 (No sign change) C B = -3.0E0 C = -0.1E0 R = 0.5E0*(B+C) CALL FZERO (SIN, B, C, R, RE, AE, IFLAG) IF (IFLAG .NE. 4) THEN IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 2) WRITE (LUN,9030) IFLAG, 4 ENDIF C CALL XERCLR C CALL XSETF (KONTRL) IF (FATAL) THEN IF (KPRINT .GE. 2) THEN WRITE (LUN, 9040) ENDIF ELSE IF (KPRINT .GE. 3) THEN WRITE (LUN, 9050) ENDIF ENDIF C IF (IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN,9060) IF (IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN,9070) RETURN 9000 FORMAT ('1' / ' FZERO QUICK CHECK') 9010 FORMAT (' Accuracy test ', A / + ' Example problem results: (answer = PI), B =', F20.14, + ' C =', F20.14 / ' IFLAG =', I2) 9020 FORMAT (/ ' IFLAG 3 and 4 tests') 9030 FORMAT (/' IFLAG test FAILED. IFLAG =', I2, ', but should ', + 'have been', I2) 9040 FORMAT (/ ' At least IFLAG test failed') 9050 FORMAT (/ ' All IFLAG tests passed') 9060 FORMAT (/' ***************FZERO PASSED ALL TESTS**************') 9070 FORMAT (/' ***************FZERO FAILED SOME TESTS*************') END *DECK GVEC SUBROUTINE GVEC (X, G) C***BEGIN PROLOGUE GVEC C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE GVEC DIMENSION G(*) C***FIRST EXECUTABLE STATEMENT GVEC G(1) = 0.0 G(2) = 1.0+COS(X) RETURN END *DECK HEADER SUBROUTINE HEADER (KPRINT) C***BEGIN PROLOGUE HEADER C***PURPOSE Print header for BLAS quick checks. C***LIBRARY SLATEC C***AUTHOR Lawson, C. L., (JPL) C***ROUTINES CALLED (NONE) C***COMMON BLOCKS COMBLA C***REVISION HISTORY (YYMMDD) C 741212 DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 920210 Minor modifications to prologue and code. (WRB) C***END PROLOGUE HEADER COMMON /COMBLA/ NPRINT, ICASE, N, INCX, INCY, MODE, PASS LOGICAL PASS CHARACTER*6 L(38) C DATA L(1) /' SDOT'/ DATA L(2) /' DSDOT'/ DATA L(3) /'SDSDOT'/ DATA L(4) /' DDOT'/ DATA L(5) /'DQDOTI'/ DATA L(6) /'DQDOTA'/ DATA L(7) /' CDOTC'/ DATA L(8) /' CDOTU'/ DATA L(9) /' SAXPY'/ DATA L(10) /' DAXPY'/ DATA L(11) /' CAXPY'/ DATA L(12) /' SROTG'/ DATA L(13) /' DROTG'/ DATA L(14) /' SROT'/ DATA L(15) /' DROT'/ DATA L(16) /'SROTMG'/ DATA L(17) /'DROTMG'/ DATA L(18) /' SROTM'/ DATA L(19) /' DROTM'/ DATA L(20) /' SCOPY'/ DATA L(21) /' DCOPY'/ DATA L(22) /' CCOPY'/ DATA L(23) /' SSWAP'/ DATA L(24) /' DSWAP'/ DATA L(25) /' CSWAP'/ DATA L(26) /' SNRM2'/ DATA L(27) /' DNRM2'/ DATA L(28) /'SCNRM2'/ DATA L(29) /' SASUM'/ DATA L(30) /' DASUM'/ DATA L(31) /'SCASUM'/ DATA L(32) /' SSCAL'/ DATA L(33) /' DSCAL'/ DATA L(34) /' CSCAL'/ DATA L(35) /'CSSCAL'/ DATA L(36) /'ISAMAX'/ DATA L(37) /'IDAMAX'/ DATA L(38) /'ICAMAX'/ C***FIRST EXECUTABLE STATEMENT HEADER IF (KPRINT .GE. 2) WRITE (NPRINT,9000) ICASE,L(ICASE) RETURN C 9000 FORMAT (' Test of subprogram number', I3, 2X, A) END *DECK ITEST SUBROUTINE ITEST (LEN, ICOMP, ITRUE, KPRINT) C***BEGIN PROLOGUE ITEST C***PURPOSE Compare arrays ICOMP and ITRUE. C***LIBRARY SLATEC C***TYPE INTEGER (ITEST-I) C***KEYWORDS QUICK CHECK C***AUTHOR Lawson, C. L., (JPL) C***DESCRIPTION C C This subroutine compares the arrays ICOMP and ITRUE of length LEN C for equality. In the case of an unequal compare, appropriate C messages are written. C C***ROUTINES CALLED (NONE) C***COMMON BLOCKS COMBLA C***REVISION HISTORY (YYMMDD) C 741210 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920211 Code restructured and information added to the DESCRIPTION C section. (WRB) C***END PROLOGUE ITEST INTEGER ICOMP(*), ITRUE(*) LOGICAL PASS COMMON /COMBLA/ NPRINT, ICASE, N, INCX, INCY, MODE, PASS C***FIRST EXECUTABLE STATEMENT ITEST DO 100 I = 1,LEN IF (ICOMP(I) .NE. ITRUE(I)) THEN C C Here ICOMP(I) is not equal to ITRUE(I). C IF (PASS) THEN C C Print FAIL message and header. C PASS = .FALSE. IF (KPRINT .GE. 3) THEN WRITE (NPRINT,9000) WRITE (NPRINT,9010) ENDIF ENDIF IF (KPRINT .GE. 3) THEN ID = ICOMP(I) - ITRUE(I) WRITE (NPRINT,9020) ICASE, N, INCX, INCY, MODE, I, ICOMP(I), + ITRUE(I), ID ENDIF ENDIF 100 CONTINUE RETURN 9000 FORMAT ('+', 39X, 'FAIL') 9010 FORMAT ('0CASE N INCX INCY MODE I', 29X, 'COMP(I)', 29X, + 'TRUE(I)', 2X, 'DIFFERENCE' / 1X) 9020 FORMAT (1X, I4, I3, 3I5, I3, 2I36, I12) END *DECK JAC SUBROUTINE JAC (T, U, PD, NROWPD, RPAR, IPAR) C***BEGIN PROLOGUE JAC C***SUBSIDIARY C***PURPOSE Evaluate Jacobian for DEBDF quick check. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (JAC-S, DJAC-D) C***AUTHOR Chow, Jeff (LANL) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 810801 DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 900415 Minor clean-up of prologue and code. (WRB) C***END PROLOGUE JAC INTEGER IPAR, NROWPD REAL PD, R, R5, RPAR, RSQ, T, U, U1SQ, U2SQ, U1U2 DIMENSION U(*),PD(NROWPD,*),RPAR(*),IPAR(*) C***FIRST EXECUTABLE STATEMENT JAC U1SQ = U(1)*U(1) U2SQ = U(2)*U(2) U1U2 = U(1)*U(2) RSQ = U1SQ + U2SQ R = SQRT(RSQ) R5 = RSQ*RSQ*R PD(3,1) = (3.E0*U1SQ - RSQ)/R5 PD(4,1) = 3.E0*U1U2/R5 PD(3,2) = PD(4,1) PD(4,2) = (3.E0*U2SQ - RSQ)/R5 PD(1,3) = 1.E0 PD(2,4) = 1.E0 RETURN END *DECK LSEIQX SUBROUTINE LSEIQX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE LSEIQX C***PURPOSE Quick check for LSEI. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (LSEIQX-S, DLSEIT-D) C***KEYWORDS QUICK CHECK C***AUTHOR Hanson, R. J, (SNLA) C Haskell, Karen, (SNLA) C***DESCRIPTION C C THE SAMPLE PROBLEM SOLVED IS FROM A PAPER BY J. STOER, IN C SIAM JOURNAL OF NUM. ANAL., JUNE 1971. C C***ROUTINES CALLED LSEI, R1MACH, SAXPY, SCOPY, SDOT, SNRM2, SVOUT C***REVISION HISTORY (YYMMDD) C 790216 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF, modified tolerances C to use R1MACH(4) rather than R1MACH(3) and cleaned up C FORMATs. (RWC) C 920722 Initialized IP(1) and IP(2) for CALL to LSEI. (BKS, WRB) C***END PROLOGUE LSEIQX DIMENSION D(11,6), IP(17), WORK(105), F(6), PRGOPT(4) DIMENSION X(5), H(5), SOL(5), A(6,5), G(5,5), ERR(5) C C DEFINE THE DATA ARRAYS FOR THE EXAMPLE. THE ARRAY A( ) C CONTAINS THE LEAST SQUARES EQUATIONS. (THERE ARE NO EQUALITY C CONSTRAINTS IN THIS EXAMPLE). C DATA A(1,1),A(1,2),A(1,3),A(1,4),A(1,5) * /-74.,80.,18.,-11.,-4./ DATA A(2,1),A(2,2),A(2,3),A(2,4),A(2,5) * /14.,-69.,21.,28.,0./ DATA A(3,1),A(3,2),A(3,3),A(3,4),A(3,5) * /66.,-72.,-5.,7.,1./ DATA A(4,1),A(4,2),A(4,3),A(4,4),A(4,5) * /-12.,66.,-30.,-23.,3./ DATA A(5,1),A(5,2),A(5,3),A(5,4),A(5,5) * /3.,8.,-7.,-4.,1./ DATA A(6,1),A(6,2),A(6,3),A(6,4),A(6,5) * /4.,-12.,4.,4.,0./ C C THE ARRAY G( ) CONTAINS THE INEQUALITY CONSTRAINT EQUATIONS, C WRITTEN IN THE SENSE C (ROW VECTOR)*(SOLUTION VECTOR) .GE. (GIVEN VALUE). C DATA G(1,1),G(1,2),G(1,3),G(1,4),G(1,5) * /-1.,-1.,-1.,-1.,-1./ DATA G(2,1),G(2,2),G(2,3),G(2,4),G(2,5) * /10.,10.,-3.,5.,4./ DATA G(3,1),G(3,2),G(3,3),G(3,4),G(3,5) * /-8.,1.,-2.,-5.,3./ DATA G(4,1),G(4,2),G(4,3),G(4,4),G(4,5) * /8.,-1.,2.,5.,-3./ DATA G(5,1),G(5,2),G(5,3),G(5,4),G(5,5) * /-4.,-2.,3.,-5.,1./ C C DEFINE THE LEAST SQUARES RIGHT-SIDE VECTOR. C DATA F(1),F(2),F(3),F(4),F(5),F(6) * /-5.,-9.,708.,4165.,-13266.,8409./ C C DEFINE THE INEQUALITY CONSTRAINT RIGHT-SIDE VECTOR. C DATA H(1),H(2),H(3),H(4),H(5) * /-5.,20.,-40.,11.,-30./ C C DEFINE THE VECTOR THAT IS THE KNOWN SOLUTION. C DATA SOL(1),SOL(2),SOL(3),SOL(4),SOL(5) * /1.,2.,-1.,3.,-4./ C***FIRST EXECUTABLE STATEMENT LSEIQX C C DEFINE THE MATRIX DIMENSIONS, NUMBER OF LEAST SQUARES EQUATIONS, C NUMBER OF EQUALITY CONSTRAINTS, TOTAL NUMBER OF C EQUATIONS, AND NUMBER OF VARIABLES. SET ME=0 TO INDICATE C THERE ARE NO EQUALITY CONSTRAINTS. C MDD = 11 MDA = 6 MDG = 5 MA = 6 MG = 5 M = MA + MG N = 5 ME = 0 C IP(1) = 105 IP(2) = 17 C NP1 = N + 1 MEP1 = ME + 1 MEAP1 = ME + MA + 1 C C COPY THE PROBLEM MATRICES C DO 10 I = 1, N C C COPY THE I-TH COL OF THE INEQUALITY CONSTRAINT MATRIX INTO C THE WORK ARRAY. C CALL SCOPY(MG, G(1,I), 1, D(MEAP1,I), 1) C C COPY THE I-TH COL OF THE LEAST SQUARES MATRIX INTO THE WORK C ARRAY. C CALL SCOPY(MA, A(1,I), 1, D(MEP1,I), 1) 10 CONTINUE C C COPY THE RIGHT-SIDE VECTORS INTO THE WORK ARRAY IN COMPATIBLE C ORDER. C CALL SCOPY(MG, H, 1, D(MEAP1,NP1), 1) CALL SCOPY(MA, F, 1, D(MEP1,NP1), 1) C IF (KPRINT.GE.2) WRITE (LUN,99999) C C USE DEFAULT PROGRAM OPTIONS IN LSEI, AND SET MATRIX-VECTOR C PRINTING ACCURACY PARAMETERS. C PRGOPT(1) = 1 IDIGIT = -4 JDIGIT = -11 C C COMPUTE RESIDUAL NORM OF KNOWN LEAST SQUARES SOLN. C (TO BE USED TO CHECK COMPUTED RESIDUAL NORM = RNORML.) C DO 20 I = 1, MA WORK(I) = SDOT(N,D(I,1),MDD,SOL,1) - F(I) 20 CONTINUE RESNRM = SNRM2(MA,WORK,1) C C CALL LSEI TO GET SOLN IN X(*), LEAST SQUARES RESIDUAL IN RNORML. C CALL LSEI(D, MDD, ME, MA, MG, N, PRGOPT, X, RNORME, RNORML, MODE, * WORK, IP) C C COMPUTE REL. ERROR IN PROBLEM VARIABLE SOLN. AND RESIDUAL C NORM COMPUTATION. C TNORM = SNRM2(N,SOL,1) CALL SCOPY(N, SOL, 1, ERR, 1) CALL SAXPY(N, -1.0, X, 1, ERR, 1) CNORM = SNRM2(N, ERR, 1) RELERR = CNORM/TNORM RELNRM = (RESNRM-RNORML)/RESNRM C IF (RELERR .LE. 70.*SQRT(R1MACH(4)) .AND. * RELNRM .LE. 5.*R1MACH(4)) THEN IPASS = 1 IF (KPRINT.GE.3) WRITE (LUN,99998) ELSE IPASS = 0 IF (KPRINT.GE.2) WRITE (LUN,99997) RELERR, RELNRM ENDIF C C PRINT OUT KNOWN SOLUTION AND COMPUTED SOLUTION C IF (KPRINT.GE.3) THEN CALL SVOUT(N, ERR, * '('' RESIDUALS FROM KNOWN LEAST SQUARES SOLN'')', IDIGIT) CALL SVOUT(N, X, '(/'' SOLN COMPUTED BY LSEI.'')', JDIGIT) ENDIF C IF (KPRINT.GE.2) THEN IF (.NOT.(KPRINT.EQ.2 .AND. IPASS.NE.0)) THEN C C PRINT OUT THE KNOWN AND COMPUTED RESIDUAL NORMS C CALL SVOUT(1, RESNRM, * '(/'' RESIDUAL NORM OF KNOWN LEAST SQUARES SOLN'')', * JDIGIT) CALL SVOUT(1, RNORML, '(/'' RES NORM COMPUTED BY LSEI.'')', * JDIGIT) C C PRINT OUT THE COMPUTED SOLUTION RELATIVE ERROR C CALL SVOUT(1, RELERR, '(/'' COMPUTED SOLN REL. ERROR'')', * IDIGIT) C C PRINT OUT THE COMPUTED RELATIVE ERROR IN RESIDUAL NORM C CALL SVOUT(1, RELNRM, * '(/'' COMPUTED REL. ERROR IN RESIDUAL NORM'')', IDIGIT) ENDIF ENDIF C C CHECK CALLS TO ERROR PROCESSOR C IF (KPRINT.GE.2) THEN WRITE (LUN,99996) CALL LSEI(D, 0, ME, MA, MG, N, PRGOPT, X, RNORME, RNORML, * MODE, WORK, IP) PRGOPT(1) = -1 CALL LSEI(D, MDD, ME, MA, MG, N, PRGOPT, X, RNORME, RNORML, * MODE, WORK, IP) ENDIF C IF (IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN,99995) IF (IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN,99994) RETURN C 99994 FORMAT (/' ****************LSEI FAILED SOME TESTS**************') 99995 FORMAT (/' ****************LSEI PASSED ALL TESTS***************') 99996 FORMAT (/ ' 2 ERROR MESSAGES EXPECTED') 99997 FORMAT (/' LSEI FAILED TEST'/' RELERR = ',1P,E20.6/' RELNRM = ', * E20.6) 99998 FORMAT (/' LSEI PASSED TEST') 99999 FORMAT ('1TEST OF SUBROUTINE LSEI') END *DECK PASS SUBROUTINE PASS (LUN, ICNT, ITEST) C***BEGIN PROLOGUE PASS C***PURPOSE Print a PASS/FAIL message for a particular quick check C test. C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 920210 PURPOSE added and code restructured. (WRB) C***END PROLOGUE PASS INTEGER ICNT, ITEST, LUN C***FIRST EXECUTABLE STATEMENT PASS IF (ITEST .NE. 0) THEN WRITE (LUN,9000) ICNT ELSE WRITE (LUN,9100) ICNT ENDIF RETURN 9000 FORMAT(/ ' TEST NUMBER', I5, ' PASSED') 9100 FORMAT(/ ' *****TEST NUMBER' ,I5, ' FAILED**********') END *DECK PCHQK1 SUBROUTINE PCHQK1 (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE PCHQK1 C***PURPOSE Test the PCHIP evaluators CHFDV, CHFEV, PCHFD and PCHFE. C***LIBRARY SLATEC (PCHIP) C***TYPE SINGLE PRECISION (PCHQK1-S, DPCHQ1-D) C***KEYWORDS PCHIP EVALUATOR QUICK CHECK C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C PCHIP QUICK CHECK NUMBER 1 C C TESTS THE EVALUATORS: CHFDV, CHFEV, PCHFD, PCHFE. C *Usage: C C INTEGER LUN, KPRINT, IPASS C C CALL PCHQK1 (LUN, KPRINT, IPASS) C C *Arguments: C C LUN :IN is the unit number to which output is to be written. C C KPRINT:IN controls the amount of output, as specified in the C SLATEC Guidelines. C C IPASS:OUT will contain a pass/fail flag. IPASS=1 is good. C IPASS=0 indicates one or more tests failed. C C *Description: C C This routine carries out three tests of the PCH evaluators: C EVCHCK tests the single-cubic evaluators. C EVPCCK tests the full PCH evaluators. C EVERCK exercises the error returns in all evaluators. C C***ROUTINES CALLED EVCHCK, EVERCK, EVPCCK C***REVISION HISTORY (YYMMDD) C 820601 DATE WRITTEN C 890306 Changed IPASS to the more accurate name IFAIL. (FNF) C 890618 REVISION DATE from Version 3.2 C 890706 Cosmetic changes to prologue. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900309 Added EVERCK to list of routines called. (FNF) C 900314 Improved some output formats. C 900315 Revised prologue and improved some output formats. (FNF) C 900316 Additional minor cosmetic changes. (FNF) C 900321 Removed IFAIL from call sequence for SLATEC standards and C made miscellaneous cosmetic changes. (FNF) C***END PROLOGUE PCHQK1 C C Declare arguments. C INTEGER LUN, KPRINT, IPASS C C DECLARE LOCAL VARIABLES. C INTEGER I1, I2, I3, I4, I5, I6, I7, I8, I9, IFAIL, NPTS REAL WORK (4000) LOGICAL FAIL C C***FIRST EXECUTABLE STATEMENT PCHQK1 IF (KPRINT .GE. 2) WRITE (LUN, 1000) C C TEST CHFDV AND CHFEV. C IFAIL = 0 NPTS = 1000 I1 = 1 + NPTS I2 = I1 + NPTS I3 = I2 + NPTS CALL EVCHCK (LUN, KPRINT, NPTS, WORK(1), WORK(I1), WORK(I2), * WORK(I3), FAIL) IF (FAIL) IFAIL = IFAIL + 1 C C TEST PCHFD AND PCHFE. C I1 = 1 + 10 I2 = I1 + 10 I3 = I2 + 100 I4 = I3 + 100 I5 = I4 + 100 I6 = I5 + 51 I7 = I6 + 51 I8 = I7 + 51 I9 = I8 + 51 CALL EVPCCK (LUN, KPRINT, WORK(1), WORK(I1), WORK(I2), WORK(I3), * WORK(I4), WORK(I5), WORK(I6), WORK(I7), WORK(I8), * WORK(I9), FAIL) IF (FAIL) IFAIL = IFAIL + 2 C C TEST ERROR RETURNS. C CALL EVERCK (LUN, KPRINT, FAIL) IF (FAIL) IFAIL = IFAIL + 4 C C PRINT SUMMARY AND TERMINATE. C At this point, IFAIL has the following value: C IFAIL = 0 IF ALL TESTS PASSED. C IFAIL BETWEEN 1 AND 7 IS THE SUM OF: C IFAIL=1 IF SINGLE CUBIC TEST FAILED. (SEE EVCHCK OUTPUT.) C IFAIL=2 IF PCHFD/PCHFE TEST FAILED. (SEE EVPCCK OUTPUT.) C IFAIL=4 IF ERROR RETURN TEST FAILED. (SEE EVERCK OUTPUT.) C IF ((KPRINT.GE.2).AND.(IFAIL.NE.0)) WRITE (LUN, 3001) IFAIL C IF (IFAIL.EQ.0) THEN IPASS = 1 IF (KPRINT.GE.2) WRITE(LUN,99998) ELSE IPASS = 0 IF (KPRINT.GE.1) WRITE(LUN,99999) ENDIF C RETURN C C FORMATS. C 1000 FORMAT ('1'/' ------------ PCHIP QUICK CHECK OUTPUT', . ' ------------') 3001 FORMAT (/' *** TROUBLE ***',I5,' EVALUATION TESTS FAILED.') 99998 FORMAT (/' ------------ PCHIP PASSED ALL EVALUATION TESTS', . ' ------------') 99999 FORMAT (/' ************ PCHIP FAILED SOME EVALUATION TESTS', . ' ************') C------------- LAST LINE OF PCHQK1 FOLLOWS ----------------------------- END *DECK PCHQK2 SUBROUTINE PCHQK2 (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE PCHQK2 C***PURPOSE Test the PCHIP integrators PCHIA and PCHID. C***LIBRARY SLATEC (PCHIP) C***TYPE SINGLE PRECISION (PCHQK2-S, DPCHQ2-D) C***KEYWORDS PCHIP INTEGRATOR QUICK CHECK C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C PCHIP QUICK CHECK NUMBER 2 C C TESTS THE INTEGRATORS: PCHIA, PCHID. C *Usage: C C INTEGER LUN, KPRINT, IPASS C C CALL PCHQK2 (LUN, KPRINT, IPASS) C C *Arguments: C C LUN :IN is the unit number to which output is to be written. C C KPRINT:IN controls the amount of output, as specified in the C SLATEC Guidelines. C C IPASS:OUT will contain a pass/fail flag. IPASS=1 is good. C IPASS=0 indicates one or more tests failed. C C *Description: C C This routine constructs data from a cubic, integrates it with PCHIA C and compares the results with the correct answer. C Since PCHIA calls PCHID, this tests both integrators. C C***ROUTINES CALLED PCHIA, R1MACH C***REVISION HISTORY (YYMMDD) C 820601 DATE WRITTEN C 890306 Changed IPASS to the more accurate name IFAIL. (FNF) C 890316 Added declarations as in DPCHQ2. (FNF) C 890629 Appended E0 to real constants to reduce S.P./D.P. C differences. C 890706 Cosmetic changes to prologue. (WRB) C 891004 Cosmetic changes to prologue. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900314 Improved some output formats. (FNF) C 900315 Revised prologue and improved some output formats. (FNF) C 900316 Additional minor cosmetic changes. (FNF) C 900321 Removed IFAIL from call sequence for SLATEC standards and C made miscellaneous cosmetic changes. (FNF) C 901130 Added 1P's to formats; changed to allow KPRINT.gt.3. (FNF) C 910708 Minor modifications in use of KPRINT. (WRB) C***END PROLOGUE PCHQK2 C C Declare arguments. C INTEGER LUN, KPRINT, IPASS C C DECLARE VARIABLES. C INTEGER I, IEREXP(17), IERR, IFAIL, N, NPAIRS REAL A(17), B(17), CALC, D(7), ERRMAX, ERROR, F(7), MACHEP, * ONE, THREE, THRQTR, TOL, TRUE, TWO, X(7) LOGICAL FAIL, SKIP C C DECLARE EXTERNALS. C REAL PCHIA, R1MACH C C DEFINE TEST FUNCTIONS. C REAL AX, FCN, DERIV, ANTDER FCN(AX) = THREE*AX*AX*(AX-TWO) DERIV(AX) = THREE*AX*(TWO*(AX-TWO) + AX) ANTDER(AX) = AX**3 * (THRQTR*AX - TWO) C C INITIALIZE. C DATA THRQTR /0.75E0/, ONE /1.E0/, TWO /2.E0/, THREE /3.E0/ DATA N /7/ DATA X /-4.E0, -2.E0, -0.9E0, 0.E0, 0.9E0, 2.E0, 4.E0/ DATA NPAIRS /17/ DATA A /-3.0E0, 3.0E0,-0.5E0,-0.5E0,-0.5E0,-4.0E0,-4.0E0, 3.0E0, * -5.0E0,-5.0E0,-6.0E0, 6.0E0,-1.5E0,-1.5E0,-3.0E0, 3.0E0, 0.5E0/ DATA B / 3.0E0,-3.0E0, 1.0E0, 2.0E0, 5.0E0,-0.5E0, 4.0E0, 5.0E0, * -3.0E0, 5.0E0,-5.0E0, 5.0E0,-0.5E0,-1.0E0,-2.5E0, 3.5E0, 0.5E0/ DATA IEREXP /0,0,0,0,2,0,0,2,1,3,3,3,0,0,0,0,0/ C C SET PASS/FAIL TOLERANCE. C C***FIRST EXECUTABLE STATEMENT PCHQK2 MACHEP = R1MACH(4) TOL = 100.E0*MACHEP C C SET UP PCH FUNCTION DEFINITION. C DO 10 I = 1, N F(I) = FCN(X(I)) D(I) = DERIV(X(I)) 10 CONTINUE C IF (KPRINT .GE. 3) WRITE (LUN, 1000) (X(I), F(I), D(I), I=1,N) IF (KPRINT .GE. 2) WRITE (LUN, 1001) C C LOOP OVER (A,B)-PAIRS. C IF (KPRINT .GE. 3) WRITE (LUN, 2000) C IFAIL = 0 C SKIP = .FALSE. DO 20 I = 1, NPAIRS C --------------------------------------------- CALC = PCHIA (N, X, F, D, 1, SKIP, A(I), B(I), IERR) C --------------------------------------------- IF (IERR .GE. 0) THEN FAIL = IERR .NE. IEREXP(I) TRUE = ANTDER(B(I)) - ANTDER(A(I)) ERROR = CALC - TRUE IF (KPRINT .GE. 3) THEN IF (FAIL) THEN WRITE (LUN, 2001) A(I), B(I), IERR, TRUE, CALC, ERROR, * IEREXP(I) ELSE WRITE (LUN, 2002) A(I), B(I), IERR, TRUE, CALC, ERROR ENDIF ENDIF C ERROR = ABS(ERROR) / MAX(ONE, ABS(TRUE)) IF (FAIL .OR. (ERROR.GT.TOL)) IFAIL = IFAIL + 1 IF (I .EQ. 1) THEN ERRMAX = ERROR ELSE ERRMAX = MAX(ERRMAX, ERROR) ENDIF ELSE IF (KPRINT .GE. 3) WRITE (LUN, 2002) A(I), B(I), IERR IFAIL = IFAIL + 1 ENDIF 20 CONTINUE C C PRINT SUMMARY. C IF (KPRINT .GE. 2) THEN WRITE (LUN, 2003) ERRMAX, TOL IF (IFAIL .NE. 0) WRITE (LUN, 3001) IFAIL ENDIF C C TERMINATE. C IF (IFAIL.EQ.0) THEN IPASS = 1 IF (KPRINT.GE.2) WRITE(LUN,99998) ELSE IPASS = 0 IF (KPRINT.GE.1) WRITE(LUN,99999) ENDIF C RETURN C C FORMATS. C 1000 FORMAT ('1'//10X,'TEST PCHIP INTEGRATORS' * // 5X,'DATA:' //11X,'X',9X,'F',9X,'D' * /(5X,3F10.3) ) 1001 FORMAT (//10X,'PCHQK2 RESULTS'/10X,'--------------') 2000 FORMAT (// 5X,'TEST RESULTS:' * //' A B ERR TRUE',16X,'CALC',15X,'ERROR') 2001 FORMAT (2F6.1,I5,1P,2E20.10,E15.5,' (',I1,') *****' ) 2002 FORMAT (2F6.1,I5,1P,2E20.10,E15.5) 2003 FORMAT (/' MAXIMUM RELATIVE ERROR IS:',1P,E15.5, * ', TOLERANCE:',1P,E15.5) 3001 FORMAT (/' *** TROUBLE ***',I5,' INTEGRATION TESTS FAILED.') 99998 FORMAT (/' ------------ PCHIP PASSED ALL INTEGRATION TESTS', . ' ------------') 99999 FORMAT (/' ************ PCHIP FAILED SOME INTEGRATION TESTS', . ' ************') C------------- LAST LINE OF PCHQK2 FOLLOWS ----------------------------- END *DECK PCHQK3 SUBROUTINE PCHQK3 (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE PCHQK3 C***PURPOSE Test the PCHIP interpolators PCHIC, PCHIM, PCHSP. C***LIBRARY SLATEC (PCHIP) C***TYPE SINGLE PRECISION (PCHQK3-S, DPCHQ3-D) C***KEYWORDS PCHIP INTERPOLATOR QUICK CHECK C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C PCHIP QUICK CHECK NUMBER 3 C C TESTS THE INTERPOLATORS: PCHIC, PCHIM, PCHSP. C *Usage: C C INTEGER LUN, KPRINT, IPASS C C CALL PCHQK3 (LUN, KPRINT, IPASS) C C *Arguments: C C LUN :IN is the unit number to which output is to be written. C C KPRINT:IN controls the amount of output, as specified in the C SLATEC Guidelines. C C IPASS:OUT will contain a pass/fail flag. IPASS=1 is good. C IPASS=0 indicates one or more tests failed. C C *Description: C C This routine interpolates a constructed data set with all three C PCHIP interpolators and compares the results with those obtained C on a Cray X/MP. Two different values of the PCHIC parameter SWITCH C are used. C C *Remarks: C 1. The Cray results are given only to nine significant figures, C so don't expect them to match to more. C 2. The results will depend to some extent on the accuracy of C the EXP function. C C***ROUTINES CALLED COMP, PCHIC, PCHIM, PCHSP, R1MACH C***REVISION HISTORY (YYMMDD) C 900309 DATE WRITTEN C 900314 Converted to a subroutine and added a SLATEC 4.0 prologue. C 900315 Revised prologue and improved some output formats. (FNF) C 900316 Made TOLD machine-dependent and added extra output when C KPRINT=3. (FNF) C 900320 Added E0's to DATA statement for X to reduce single/double C differences, and other minor cosmetic changes. C 900321 Removed IFAIL from call sequence for SLATEC standards and C made miscellaneous cosmetic changes. (FNF) C 900322 Minor changes to reduce single/double differences. (FNF) C 900530 Tolerance (TOLD) changed. (WRB) C 900802 Modified TOLD formula and constants in PCHIC calls to be C compatible with DPCHQ3. (FNF) C 901130 Several significant changes: (FNF) C 1. Changed comparison between PCHIM and PCHIC to only C require agreement to machine precision. C 2. Revised to print more output when KPRINT=3. C 3. Added 1P's to formats. C 910708 Minor modifications in use of KPRINT. (WRB) C***END PROLOGUE PCHQK3 C C*Internal Notes: C C TOLD is used to compare with stored Cray results. Its value C should be consistent with significance of stored values. C TOLZ is used for cases in which exact equality is expected. C TOL is used for cases in which agreement to machine precision C is expected. C**End C C Declare arguments. C INTEGER LUN, KPRINT, IPASS LOGICAL COMP REAL R1MACH C C Declare variables. C INTEGER I, IC(2), IERR, IFAIL, N, NBAD, NBADZ, NWK PARAMETER (N = 9, NWK = 2*N) REAL D(N), DC(N), DC5, DC6, DM(N), DS(N), ERR, F(N), MONE, TOL, . TOLD, TOLZ, VC(2), X(N), WK(NWK), ZERO PARAMETER (ZERO = 0.0E0, MONE = -1.0E0) CHARACTER*6 RESULT C C Initialize. C C Data. DATA IC /0, 0/ DATA X /-2.2E0,-1.2E0,-1.0E0,-0.5E0,-0.01E0, 0.5E0, 1.0E0, . 2.0E0, 2.2E0/ C C Results generated on Cray X/MP (9 sign. figs.) DATA DM / 0. , 3.80027352E-01, 7.17253009E-01, . 5.82014161E-01, 0. ,-5.68208031E-01, . -5.13501618E-01,-7.77910977E-02,-2.45611117E-03/ DATA DC5,DC6 / 1.76950158E-02,-5.69579814E-01/ DATA DS /-5.16830792E-02, 5.71455855E-01, 7.40530225E-01, . 7.63864934E-01, 1.92614386E-02,-7.65324380E-01, . -7.28209035E-01,-7.98445427E-02,-2.85983446E-02/ C C***FIRST EXECUTABLE STATEMENT PCHQK3 IFAIL = 0 C C Set tolerances. TOL = 10*R1MACH(4) TOLD = MAX( 1.0E-7, 10*TOL ) TOLZ = ZERO C IF (KPRINT .GE. 3) WRITE (LUN, 1000) IF (KPRINT .GE. 2) WRITE (LUN, 1002) C C Set up data. C DO 10 I = 1, N F(I) = EXP(-X(I)**2) 10 CONTINUE C IF (KPRINT .GE. 3) THEN DO 12 I = 1, 4 WRITE (LUN, 1010) X(I), F(I), DM(I), DS(I) 12 CONTINUE WRITE (LUN, 1011) X(5), F(5), DM(5), DC5, DS(5) WRITE (LUN, 1011) X(6), F(6), DM(6), DC6, DS(6) DO 15 I = 7, N WRITE (LUN, 1010) X(I), F(I), DM(I), DS(I) 15 CONTINUE ENDIF C C Test PCHIM. C IF (KPRINT.GE.3) WRITE (LUN, 2000) 'IM' C -------------------------------- CALL PCHIM (N, X, F, D, 1, IERR) C -------------------------------- C Expect IERR=1 (one monotonicity switch). IF ( KPRINT.GE.3 ) WRITE (LUN, 2001) 1 IF ( .NOT.COMP (IERR, 1, LUN, KPRINT) ) THEN IFAIL = IFAIL + 1 ELSE IF ( KPRINT.GE.3 ) WRITE (LUN, 2002) NBAD = 0 NBADZ = 0 DO 20 I = 1, N RESULT = ' OK' C D-values should agree with stored values. C (Zero values should agree exactly.) IF ( DM(I).EQ.ZERO ) THEN ERR = ABS( D(I) ) IF ( ERR.GT.TOLZ ) THEN NBADZ = NBADZ + 1 RESULT = '**BADZ' ENDIF ELSE ERR = ABS( (D(I)-DM(I))/DM(I) ) IF ( ERR.GT.TOLD ) THEN NBAD = NBAD + 1 RESULT = '**BAD' ENDIF ENDIF IF (KPRINT.GE.3) * WRITE (LUN, 2003) I, X(I), D(I), ERR, RESULT 20 CONTINUE IF ( (NBADZ.NE.0).OR.(NBAD.NE.0) ) THEN IFAIL = IFAIL + 1 IF ((NBADZ.NE.0).AND.(KPRINT.GE.2)) * WRITE (LUN, 2004) NBAD IF ((NBAD.NE.0).AND.(KPRINT.GE.2)) * WRITE (LUN, 2005) NBAD, 'IM', TOLD ELSE IF (KPRINT.GE.3) WRITE (LUN, 2006) 'IM' ENDIF ENDIF C C Test PCHIC -- options set to reproduce PCHIM. C IF (KPRINT.GE.3) WRITE (LUN, 2000) 'IC' C -------------------------------------------------------- CALL PCHIC (IC, VC, ZERO, N, X, F, DC, 1, WK, NWK, IERR) C -------------------------------------------------------- C Expect IERR=0 . IF ( KPRINT.GE.3 ) WRITE (LUN, 2001) 0 IF ( .NOT.COMP (IERR, 0, LUN, KPRINT) ) THEN IFAIL = IFAIL + 1 ELSE IF ( KPRINT.GE.3 ) WRITE (LUN, 2002) NBAD = 0 DO 30 I = 1, N RESULT = ' OK' C D-values should agree exactly with those computed by PCHIM. C (To be generous, will only test to machine precision.) ERR = ABS( D(I)-DC(I) ) IF ( ERR.GT.TOL ) THEN NBAD = NBAD + 1 RESULT = '**BAD' ENDIF IF (KPRINT.GE.3) * WRITE (LUN, 2003) I, X(I), DC(I), ERR, RESULT 30 CONTINUE IF ( NBAD.NE.0 ) THEN IFAIL = IFAIL + 1 IF (KPRINT.GE.2) WRITE (LUN, 2005) NBAD, 'IC', TOL ELSE IF (KPRINT.GE.3) WRITE (LUN, 2006) 'IC' ENDIF ENDIF C C Test PCHIC -- default nonzero switch derivatives. C IF (KPRINT.GE.3) WRITE (LUN, 2000) 'IC' C ------------------------------------------------------- CALL PCHIC (IC, VC, MONE, N, X, F, D, 1, WK, NWK, IERR) C ------------------------------------------------------- C Expect IERR=0 . IF ( KPRINT.GE.3 ) WRITE (LUN, 2001) 0 IF ( .NOT.COMP (IERR, 0, LUN, KPRINT) ) THEN IFAIL = IFAIL + 1 ELSE IF ( KPRINT.GE.3 ) WRITE (LUN, 2002) NBAD = 0 NBADZ = 0 DO 40 I = 1, N RESULT = ' OK' C D-values should agree exactly with those computed in C previous call, except at points 5 and 6. IF ( (I.LT.5).OR.(I.GT.6) ) THEN ERR = ABS( D(I)-DC(I) ) IF ( ERR.GT.TOLZ ) THEN NBADZ = NBADZ + 1 RESULT = '**BADA' ENDIF ELSE IF ( I.EQ.5 ) THEN ERR = ABS( (D(I)-DC5)/DC5 ) ELSE ERR = ABS( (D(I)-DC6)/DC6 ) ENDIF IF ( ERR.GT.TOLD ) THEN NBAD = NBAD + 1 RESULT = '**BAD' ENDIF ENDIF IF (KPRINT.GE.3) * WRITE (LUN, 2003) I, X(I), D(I), ERR, RESULT 40 CONTINUE IF ( (NBADZ.NE.0).OR.(NBAD.NE.0) ) THEN IFAIL = IFAIL + 1 IF ((NBADZ.NE.0).AND.(KPRINT.GE.2)) * WRITE (LUN, 2007) NBAD IF ((NBAD.NE.0).AND.(KPRINT.GE.2)) * WRITE (LUN, 2005) NBAD, 'IC', TOLD ELSE IF (KPRINT.GE.3) WRITE (LUN, 2006) 'IC' ENDIF ENDIF C C Test PCHSP. C IF (KPRINT.GE.3) WRITE (LUN, 2000) 'SP' C ------------------------------------------------- CALL PCHSP (IC, VC, N, X, F, D, 1, WK, NWK, IERR) C ------------------------------------------------- C Expect IERR=0 . IF ( KPRINT.GE.3 ) WRITE (LUN, 2001) 0 IF ( .NOT.COMP (IERR, 0, LUN, KPRINT) ) THEN IFAIL = IFAIL + 1 ELSE IF ( KPRINT.GE.3 ) WRITE (LUN, 2002) NBAD = 0 DO 50 I = 1, N RESULT = ' OK' C D-values should agree with stored values. ERR = ABS( (D(I)-DS(I))/DS(I) ) IF ( ERR.GT.TOLD ) THEN NBAD = NBAD + 1 RESULT = '**BAD' ENDIF IF (KPRINT.GE.3) * WRITE (LUN, 2003) I, X(I), D(I), ERR, RESULT 50 CONTINUE IF ( NBAD.NE.0 ) THEN IFAIL = IFAIL + 1 IF (KPRINT.GE.2) WRITE (LUN, 2005) NBAD, 'SP', TOLD ELSE IF (KPRINT.GE.3) WRITE (LUN, 2006) 'SP' ENDIF ENDIF C C PRINT SUMMARY AND TERMINATE. C IF ((KPRINT.GE.2).AND.(IFAIL.NE.0)) WRITE (LUN, 3001) IFAIL C IF (IFAIL.EQ.0) THEN IPASS = 1 IF (KPRINT.GE.2) WRITE(LUN,99998) ELSE IPASS = 0 IF (KPRINT.GE.1) WRITE(LUN,99999) ENDIF C RETURN C C FORMATS. C 1000 FORMAT ('1'//10X,'TEST PCHIP INTERPOLATORS' . // 5X,'DATA:' . /39X,'---------- EXPECTED D-VALUES ----------' . /12X,'X',9X,'F',18X,'DM',13X,'DC',13X,'DS') 1002 FORMAT (//10X,'PCHQK3 RESULTS'/10X,'--------------') 1010 FORMAT (5X,F10.2,1P,E15.5,4X,E15.5,15X,E15.5) 1011 FORMAT (5X,F10.2,1P,E15.5,4X,3E15.5) 2000 FORMAT (/5X,' PCH',A2,' TEST:') 2001 FORMAT (15X,'EXPECT IERR =',I5) 2002 FORMAT (/9X,'I',7X,'X',9X,'D',13X,'ERR') 2003 FORMAT (5X,I5,F10.2,1P,2E15.5,2X,A) 2004 FORMAT (/' **',I5,' PCHIM RESULTS FAILED TO BE EXACTLY ZERO.') 2005 FORMAT (/' **',I5,' PCH',A2,' RESULTS FAILED TOLERANCE TEST.', * ' TOL =',1P,E10.3) 2006 FORMAT (/5X,' ALL PCH',A2,' RESULTS OK.') 2007 FORMAT (/' **',I5,' PCHIC RESULTS FAILED TO AGREE WITH', * ' PREVIOUS CALL.') 3001 FORMAT (/' *** TROUBLE ***',I5,' INTERPOLATION TESTS FAILED.') 99998 FORMAT (/' ------------ PCHIP PASSED ALL INTERPOLATION TESTS', . ' ------------') 99999 FORMAT (/' ************ PCHIP FAILED SOME INTERPOLATION TESTS', . ' ************') C------------- LAST LINE OF PCHQK3 FOLLOWS ----------------------------- END *DECK PCHQK4 SUBROUTINE PCHQK4 (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE PCHQK4 C***PURPOSE Test the PCHIP monotonicity checker PCHCM. C***LIBRARY SLATEC (PCHIP) C***TYPE SINGLE PRECISION (PCHQK4-S, DPCHQ4-D) C***KEYWORDS PCHIP MONOTONICITY CHECKER QUICK CHECK C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C PCHIP QUICK CHECK NUMBER 4 C C TESTS THE MONOTONICITY CHECKER: PCHCM. C *Usage: C C INTEGER LUN, KPRINT, IPASS C C CALL PCHQK4 (LUN, KPRINT, IPASS) C C *Arguments: C C LUN :IN is the unit number to which output is to be written. C C KPRINT:IN controls the amount of output, as specified in the C SLATEC Guidelines. C C IPASS:OUT will contain a pass/fail flag. IPASS=1 is good. C IPASS=0 indicates one or more tests failed. C C *Description: C C This routine tests a constructed data set with three different C INCFD settings and compares with the expected results. It then C runs a special test to check for bug in overall monotonicity found C in PCHMC. Finally, it reverses the data and repeats all tests. C C***ROUTINES CALLED PCHCM C***REVISION HISTORY (YYMMDD) C 890208 DATE WRITTEN C 890306 Changed LOUT to LUN and added it to call list. (FNF) C 890316 Removed DATA statements to suit new quick check standards. C 890410 Changed PCHMC to PCHCM. C 890410 Added a SLATEC 4.0 format prologue. C 900314 Changed name from PCHQK3 to PCHQK4 and improved some output C formats. C 900315 Revised prologue and improved some output formats. (FNF) C 900321 Removed IFAIL from call sequence for SLATEC standards and C made miscellaneous cosmetic changes. (FNF) C 900322 Added declarations so all variables are declared. (FNF) C 910708 Minor modifications in use of KPRINT. (WRB) C***END PROLOGUE PCHQK4 C C*Internal Notes: C C Data set-up is done via assignment statements to avoid modifying C DATA-loaded arrays, as required by the 1989 SLATEC Guidelines. C Run with KPRINT=3 to display the data. C**End C C Declare arguments. C INTEGER LUN, KPRINT, IPASS C C DECLARE VARIABLES. C INTEGER MAXN, MAXN2, MAXN3, NB PARAMETER (MAXN = 16, MAXN2 = 8, MAXN3 = 6, NB = 7) INTEGER I, IERR, IFAIL, INCFD, ISMEX1(MAXN), ISMEX2(MAXN2), . ISMEX3(MAXN3), ISMEXB(NB), ISMON(MAXN), K, N, NS(3) REAL D(MAXN), DB(NB), F(MAXN), FB(NB), X(MAXN) LOGICAL SKIP C C DEFINE EXPECTED RESULTS. C DATA ISMEX1 / 1, 1,-1, 1, 1,-1, 1, 1,-1, 1, 1,-1, 1, 1,-1, 2/ DATA ISMEX2 / 1, 2, 2, 1, 2, 2, 1, 2/ DATA ISMEX3 / 1, 1, 1, 1, 1, 1/ DATA ISMEXB / 1, 3, 1, -1, -3, -1, 2/ C C DEFINE TEST DATA. C DATA NS /16, 8, 6/ C C Define X, F, D. C***FIRST EXECUTABLE STATEMENT PCHQK4 DO 1 I = 1, MAXN X(I) = I D(I) = 0.E0 1 CONTINUE DO 2 I = 2, MAXN, 3 D(I) = 2.E0 2 CONTINUE DO 3 I = 1, 3 F(I) = X(I) F(I+ 3) = F(I ) + 1.E0 F(I+ 6) = F(I+3) + 1.E0 F(I+ 9) = F(I+6) + 1.E0 F(I+12) = F(I+9) + 1.E0 3 CONTINUE F(16) = 6.E0 C Define FB, DB. FB(1) = 0.E0 FB(2) = 2.E0 FB(3) = 3.E0 FB(4) = 5.E0 DB(1) = 1.E0 DB(2) = 3.E0 DB(3) = 3.E0 DB(4) = 0.E0 DO 4 I = 1, 3 FB(NB-I+1) = FB(I) DB(NB-I+1) = -DB(I) 4 CONTINUE C C INITIALIZE. C IFAIL = 0 C IF (KPRINT .GE. 3) THEN WRITE (LUN, 1000) DO 10 I = 1, NB WRITE (LUN, 1001) I, X(I), F(I), D(I), FB(I), DB(I) 10 CONTINUE DO 20 I = NB+1, MAXN WRITE (LUN, 1001) I, X(I), F(I), D(I) 20 CONTINUE ENDIF IF (KPRINT .GE. 2) WRITE (LUN, 1002) C C TRANSFER POINT FOR SECOND SET OF TESTS. C 25 CONTINUE C C Loop over a series of values of INCFD. C DO 30 INCFD = 1, 3 N = NS(INCFD) SKIP = .FALSE. C ------------------------------------------------- CALL PCHCM (N, X, F, D, INCFD, SKIP, ISMON, IERR) C ------------------------------------------------- IF (KPRINT.GE.3) . WRITE (LUN, 2000) INCFD, IERR, (ISMON(I), I=1,N) IF ( IERR.NE.0 ) THEN IFAIL = IFAIL + 1 IF (KPRINT.GE.3) WRITE (LUN,2001) ELSE DO 29 I = 1, N IF (INCFD.EQ.1) THEN IF ( ISMON(I).NE.ISMEX1(I) ) THEN IFAIL = IFAIL + 1 IF (KPRINT.GE.3) . WRITE (LUN, 2002) (ISMEX1(K),K=1,N) GO TO 30 ENDIF ELSE IF (INCFD.EQ.2) THEN IF ( ISMON(I).NE.ISMEX2(I) ) THEN IFAIL = IFAIL + 1 IF (KPRINT.GE.3) . WRITE (LUN, 2002) (ISMEX2(K),K=1,N) GO TO 30 ENDIF ELSE IF ( ISMON(I).NE.ISMEX3(I) ) THEN IFAIL = IFAIL + 1 IF (KPRINT.GE.3) . WRITE (LUN, 2002) (ISMEX3(K),K=1,N) GO TO 30 ENDIF ENDIF 29 CONTINUE ENDIF 30 CONTINUE C C Test for -1,3,1 bug. C SKIP = .FALSE. C ------------------------------------------------ CALL PCHCM (NB, X, FB, DB, 1, SKIP, ISMON, IERR) C ------------------------------------------------ IF (KPRINT.GE.3) . WRITE (LUN, 2030) IERR, (ISMON(I), I=1,NB) IF ( IERR.NE.0 ) THEN IFAIL = IFAIL + 1 IF (KPRINT.GE.3) WRITE (LUN,2001) ELSE DO 34 I = 1, NB IF ( ISMON(I).NE.ISMEXB(I) ) THEN IFAIL = IFAIL + 1 IF (KPRINT.GE.3) . WRITE (LUN, 2002) (ISMEXB(K),K=1,NB) GO TO 35 ENDIF 34 CONTINUE ENDIF 35 CONTINUE C IF (F(1).LT.0.) GO TO 90 C C Change sign and do again. C DO 40 I = 1, MAXN F(I) = -F(I) D(I) = -D(I) IF ( ISMEX1(I).NE.2 ) ISMEX1(I) = -ISMEX1(I) 40 CONTINUE DO 42 I = 1, MAXN2 IF ( ISMEX2(I).NE.2 ) ISMEX2(I) = -ISMEX2(I) 42 CONTINUE DO 43 I = 1, MAXN3 IF ( ISMEX3(I).NE.2 ) ISMEX3(I) = -ISMEX3(I) 43 CONTINUE DO 50 I = 1, NB FB(I) = -FB(I) DB(I) = -DB(I) IF ( ISMEXB(I).NE.2 ) ISMEXB(I) = -ISMEXB(I) 50 CONTINUE GO TO 25 C C PRINT SUMMARY AND TERMINATE. C 90 CONTINUE IF ((KPRINT.GE.2).AND.(IFAIL.NE.0)) WRITE (LUN, 3001) IFAIL C IF (IFAIL.EQ.0) THEN IPASS = 1 IF (KPRINT.GE.2) WRITE(LUN,99998) ELSE IPASS = 0 IF (KPRINT.GE.1) WRITE(LUN,99999) ENDIF C RETURN C C FORMATS. C 1000 FORMAT ('1'//10X,'TEST PCHIP MONOTONICITY CHECKER' * // 5X,'DATA:' . // 9X,'I',4X,'X',5X,'F',5X,'D',5X,'FB',4X,'DB') 1001 FORMAT (5X,I5,5F6.1) 1002 FORMAT (//10X,'PCHQK4 RESULTS'/10X,'--------------') 2000 FORMAT (/4X,'INCFD =',I2,': IERR =',I3/15X,'ISMON =',16I3) 2001 FORMAT (' *** Failed -- bad IERR value.') 2002 FORMAT (' *** Failed -- expect:',16I3) 2030 FORMAT (/4X,' Bug test: IERR =',I3/15X,'ISMON =',7I3) 3001 FORMAT (/' *** TROUBLE ***',I5,' MONOTONICITY TESTS FAILED.') 99998 FORMAT (/' ------------ PCHIP PASSED ALL MONOTONICITY TESTS', . ' ------------') 99999 FORMAT (/' ************ PCHIP FAILED SOME MONOTONICITY TESTS', . ' ************') C------------- LAST LINE OF PCHQK4 FOLLOWS ----------------------------- END *DECK PFITQX SUBROUTINE PFITQX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE PFITQX C***PURPOSE Quick check for POLFIT, PCOEF and PVALUE. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (PFITQX-S, DPFITT-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED CMPARE, PASS, PCOEF, POLFIT, PVALUE, R1MACH, C XERCLR, XGETF, XSETF C***COMMON BLOCKS CHECK C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 890921 Realigned order of variables in the COMMON block. C (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900911 Test problem changed and cosmetic changes to code. (WRB) C 901205 Changed usage of R1MACH(3) to R1MACH(4) and modified the C FORMATs. (RWC) C 910708 Minor modifications in use of KPRINT. (WRB) C 920214 Code restructured to test for all values of KPRINT and to C provide more PASS/FAIL information. (WRB) C***END PROLOGUE PFITQX C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Scalars in Common .. REAL EPS, RP, SVEPS, TOL INTEGER IERP, IERR, NORD, NORDP C .. Arrays in Common .. REAL R(11) C .. Local Scalars .. REAL YFIT INTEGER I, ICNT, M, MAXORD C .. Local Arrays .. REAL A(97), TC(5), W(11), X(11), Y(11), YP(5) INTEGER ITEST(9) C .. External Functions .. REAL R1MACH EXTERNAL R1MACH C .. External Subroutines .. EXTERNAL CMPARE, PASS, PCOEF, POLFIT, PVALUE C .. Intrinsic Functions .. INTRINSIC ABS, SQRT C .. Common blocks .. COMMON /CHECK/ EPS, R, RP, SVEPS, TOL, NORDP, NORD, IERP, IERR C***FIRST EXECUTABLE STATEMENT PFITQX IF (KPRINT .GE. 2) WRITE (LUN,FMT=9000) C C Initialize variables for testing passage or failure of tests C DO 100 I = 1,9 ITEST(I) = 0 100 CONTINUE ICNT = 0 TOL = SQRT(R1MACH(4)) M = 11 DO 110 I = 1,M X(I) = I - 6 Y(I) = X(I)**4 110 CONTINUE C C Test POLFIT C Input EPS is negative - specified level C W(1) = -1.0E0 EPS = -0.01E0 SVEPS = EPS MAXORD = 8 NORDP = 4 RP = 625.0E0 IERP = 1 CALL POLFIT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) C C See if test passed C CALL CMPARE (ICNT, ITEST) C C Check for suppression of printing. C IF (KPRINT .EQ. 0) GO TO 130 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 130 WRITE (LUN,FMT=9010) WRITE (LUN,FMT=9020) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 120 WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR C C Send message indicating passage or failure of test C 120 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Input EPS is negative - computed level C 130 EPS = -1.0E0 SVEPS = EPS CALL POLFIT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) C C See if test passed C CALL CMPARE (ICNT, ITEST) C C Check for suppression of printing. C IF (KPRINT .EQ. 0) GO TO 150 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 150 WRITE (LUN,FMT=9050) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 140 WRITE (LUN,FMT=9060) MAXORD WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR C C Send message indicating passage or failure of test C 140 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Input EPS is zero C 150 W(1) = -1.0E0 EPS = 0.0E0 SVEPS = EPS NORDP = 5 MAXORD = 5 CALL POLFIT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) C C See if test passed C CALL CMPARE (ICNT, ITEST) C C Check for suppression of printing. C IF (KPRINT .EQ. 0) GO TO 170 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 170 WRITE (LUN,FMT=9070) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 160 WRITE (LUN,FMT=9060) MAXORD WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR C C Send message indicating passage or failure of test C 160 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Input EPS is positive C 170 IERP = 1 NORDP = 4 EPS = 75.0E0*R1MACH(4) SVEPS = EPS CALL POLFIT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) C C See if test passed C CALL CMPARE (ICNT, ITEST) C C Check for suppression of printing. C IF (KPRINT .EQ. 0) GO TO 190 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 190 WRITE (LUN,FMT=9080) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 180 WRITE (LUN,FMT=9060) MAXORD WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR C C Send message indicating passage or failure of test C 180 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Improper input C 190 IERP = 2 M = -2 C C Check for suppression of printing. C CALL XGETF (KONTRL) IF (KPRINT .LE. 2) THEN CALL XSETF (0) ELSE CALL XSETF (1) ENDIF CALL XERCLR C IF (KPRINT .GE. 3) WRITE (LUN,9090) CALL POLFIT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) C C See if test passed C ICNT = ICNT + 1 IF (IERR .EQ. 2) THEN ITEST(ICNT) = 1 IF (KPRINT .GE. 3) THEN WRITE (LUN, 9100) 'PASSED', IERR ENDIF ELSE IF (KPRINT .GE. 2) THEN WRITE (LUN, 9100) 'FAILED', IERR ENDIF ENDIF C C Check for suppression of printing. C IF (KPRINT .EQ. 0) GO TO 210 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 210 IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 200 C C Send message indicating passage or failure of test C 200 CALL PASS (LUN, ICNT, ITEST(ICNT)) C CALL XERCLR CALL XSETF (KONTRL) C C MAXORD too small to meet RMS error C 210 M = 11 W(1) = -1.0E0 EPS = 5.0E0*R1MACH(4) SVEPS = EPS RP = 553.0E0 MAXORD = 2 IERP = 3 NORDP = 2 CALL POLFIT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) C C See if test passed C CALL CMPARE (ICNT, ITEST) C C Check for suppression of printing. C IF (KPRINT .EQ. 0) GO TO 230 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 230 WRITE (LUN,FMT=9110) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 220 WRITE (LUN,FMT=9060) MAXORD WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR C C Send message indicating passage or failure of test C 220 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C MAXORD too small to meet statistical test C 230 NORDP = 4 IERP = 4 RP = 625.0E0 EPS = -0.01E0 SVEPS = EPS MAXORD = 5 CALL POLFIT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) C C See if test passed C CALL CMPARE (ICNT, ITEST) C C Check for suppression of printing. C IF (KPRINT .EQ. 0) GO TO 250 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 250 WRITE (LUN,FMT=9120) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 240 WRITE (LUN,FMT=9060) MAXORD WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR C C Send message indicating passage or failure of test C 240 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Test PCOEF C 250 MAXORD = 6 EPS = 0.0E0 SVEPS = EPS Y(6) = 1.0E0 DO 260 I = 1,M W(I) = 1.0E0/(Y(I)**2) 260 CONTINUE Y(6) = 0.0E0 CALL POLFIT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) CALL PCOEF (4, 5.0E0, TC, A) C C See if test passed C ICNT = ICNT + 1 IF (ABS(R(11)-TC(1)) .LE. TOL) ITEST(ICNT) = 1 C C Check for suppression of printing C IF (KPRINT .EQ. 0) GO TO 280 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 280 WRITE (LUN,FMT=9130) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 270 WRITE (LUN,FMT=9140) R(11),TC(1) C C Send message indicating passage or failure of test C 270 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Test PVALUE C Normal call C 280 CALL PVALUE (6, 0, X(8), YFIT, YP, A) C C See if test passed C ICNT = ICNT + 1 IF (ABS(R(8)-YFIT) .LE. TOL) ITEST(ICNT) = 1 C C Check for suppression of printing C IF (KPRINT .EQ. 0) GO TO 300 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 300 WRITE (LUN,FMT=9150) WRITE (LUN,FMT=9160) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 290 WRITE (LUN,FMT=9170) X(8),R(8),YFIT C C Send message indicating passage or failure of test C 290 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Check to see if all tests passed C 300 IPASS = 1 DO 310 I = 1,9 IPASS = IPASS*ITEST(I) 310 CONTINUE C IF (IPASS.EQ.1 .AND. KPRINT.GE.3) WRITE (LUN,FMT=9180) IF (IPASS.EQ.0 .AND. KPRINT.GE.2) WRITE (LUN,FMT=9190) RETURN C 9000 FORMAT ('1' / 'Test POLFIT, PCOEF and PVALUE') 9010 FORMAT (' Exercise POLFIT') 9020 FORMAT (' Input EPS is negative - specified significance level') 9030 FORMAT (' Input EPS = ', E15.8, ' correct order = ', I3, + ' R(1) = ', E15.8, ' IERR = ', I1) 9040 FORMAT (' Output EPS = ', E15.8, ' computed order = ', I3, + ' R(1) = ', E15.8, ' IERR = ', I1) 9050 FORMAT (/ ' Input EPS is negative - computed significance level') 9060 FORMAT (' Maximum order = ', I2) 9070 FORMAT (/ ' Input EPS is zero') 9080 FORMAT (/ ' Input EPS is positive') 9090 FORMAT (/ ' Invalid input') 9100 FORMAT (' POLFIT incorrect argument test ', A / + ' IERR should be 2. It is ', I4) 9110 FORMAT (/ ' Cannot meet RMS error requirement') 9120 FORMAT (/ ' Cannot satisfy statistical test') 9130 FORMAT (/ ' Exercise PCOEF') 9140 FORMAT (/ ' For C=1.0, correct coefficient = ', E15.8, + ' computed = ', E15.8) 9150 FORMAT (/ ' Exercise PVALUE') 9160 FORMAT (' Normal execution') 9170 FORMAT (' For X = ', F5.2, ' correct P(X) = ', E15.8, + ' P(X) from PVALUE = ', E15.8) 9180 FORMAT (/' ***************POLFIT PASSED ALL TESTS***************') 9190 FORMAT (/' ***************POLFIT FAILED SOME TESTS**************') END *DECK PNTCHK SUBROUTINE PNTCHK (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE PNTCHK C***PURPOSE Quick check for POLINT, POLCOF and POLYVL C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (PNTCHK-S, DPNTCK-D) C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***ROUTINES CALLED NUMXER, POLCOF, POLINT, POLYVL, R1MACH, XERCLR, C XGETF, XSETF C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Changed usage of R1MACH(3) to R1MACH(4). (RWC) C 910708 Minor modifications in use of KPRINT. (WRB) C 920212 Code completely restructured to test errors for all values C of KPRINT. (WRB) C***END PROLOGUE PNTCHK C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. REAL TOL, YF INTEGER I, IERR, KONTRL, N, NERR LOGICAL FATAL C .. Local Arrays .. REAL C(6), D(6), DCHK(6), W(12), X(6), XCHK(6), Y(6) C .. External Functions .. REAL R1MACH INTEGER NUMXER EXTERNAL R1MACH, NUMXER C .. External Subroutines .. EXTERNAL POLCOF, POLINT, POLYVL, XERCLR, XGETF, XSETF C .. Intrinsic Functions .. INTRINSIC ABS, SQRT C .. Data statements .. DATA X / 1.0E0, 2.0E0, 3.0E0, -1.0E0, -2.0E0, -3.0E0 / DATA Y / 0.0E0, 9.0E0, 64.0E0, 0.0E0, 9.0E0, 64.0E0 / DATA XCHK / 1.0E0, 0.0E0, -2.0E0, 0.0E0, 1.0E0, 0.0E0 / DATA DCHK / 1.0E0, 0.0E0, -4.0E0, 0.0E0, 24.0E0, 0.0E0 / C***FIRST EXECUTABLE STATEMENT PNTCHK IF (KPRINT .GE. 2) WRITE (LUN,9000) C C Initialize variables for tests. C TOL = SQRT(R1MACH(4)) IPASS = 1 N = 6 C C Set up polynomial test. C CALL POLINT (N, X, Y, C) CALL POLCOF (0.0E0, N, X, C, D, W) C C Check to see if POLCOF test passed. C FATAL = .FALSE. DO 110 I = 1,N IF (ABS(D(I)-XCHK(I)) .GT. TOL) THEN IPASS = 0 FATAL = .TRUE. ENDIF 110 CONTINUE IF (FATAL) THEN IF (KPRINT .GE. 2) WRITE (LUN, 9010) 'FAILED', (D(I), I = 1,N) ELSE IF (KPRINT .GE. 3) WRITE (LUN, 9010) 'PASSED', (D(I), I = 1,N) ENDIF C C Test POLYVL. C CALL POLYVL (5, 0.0E0, YF, D, N, X, C, W, IERR) IF (ABS(DCHK(1)-YF) .LE. TOL) THEN IF (KPRINT .GE. 3) WRITE (LUN, 9020) 'PASSED', YF,(D(I),I=1,5) ELSE IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN, 9020) 'FAILED', YF,(D(I),I=1,5) ENDIF C FATAL = .FALSE. DO 120 I = 1,5 IF (ABS(DCHK(I+1)-D(I)) .GT. TOL) THEN IPASS = 0 FATAL = .TRUE. ENDIF 120 CONTINUE C C Trigger 2 error conditions C CALL XGETF (KONTRL) IF (KPRINT .LE. 2) THEN CALL XSETF (0) ELSE CALL XSETF (1) ENDIF FATAL = .FALSE. CALL XERCLR C IF (KPRINT .GE. 3) WRITE (LUN,9030) CALL POLINT (0, X, Y, C) IF (NUMXER(NERR) .NE. 2) THEN IPASS = 0 FATAL = .TRUE. ENDIF CALL XERCLR C X(1) = -1.0E0 CALL POLINT (N, X, Y, C) IF (NUMXER(NERR) .NE. 2) THEN IPASS = 0 FATAL = .TRUE. ENDIF CALL XERCLR C CALL XSETF (KONTRL) IF (FATAL) THEN IF (KPRINT .GE. 2) THEN WRITE (LUN, 9040) ENDIF ELSE IF (KPRINT .GE. 3) THEN WRITE (LUN, 9050) ENDIF ENDIF C IF (IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN,9080) IF (IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN,9090) RETURN C 9000 FORMAT ('1' / ' Test POLINT, POLCOF and POLYVL') 9010 FORMAT (/ 'POLCOF ', A, ' test' / + ' Taylor coefficients for the quintic should be' / + 6X, '1.000', 5X, '0.000', 4X, '-2.000', 5X, '0.000', 5X, + '1.000', 5X, '0.000' / + ' Taylor coefficients from POLCOF are' / 1X, 6F10.3 /) 9020 FORMAT (' Derivative test ', A / + ' The derivatives of the polynomial at zero as ', + 'computed by POLYVL are' / 1X, 6F10.3 /) 9030 FORMAT (/' 2 Error messages expected') 9040 FORMAT (/ ' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED') 9050 FORMAT (/ ' ALL INCORRECT ARGUMENT TESTS PASSED') 9080 FORMAT (/' ****************POLINT PASSED ALL TESTS**************') 9090 FORMAT (/' ***************POLINT FAILED SOME TESTS**************') END *DECK QC6A SUBROUTINE QC6A (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QC6A C***PURPOSE Test subroutine AAAAAA. C***LIBRARY SLATEC C***TYPE ALL (QC6A-A) C***AUTHOR Boland, W. Robert, (LANL) C***DESCRIPTION C C *Usage: C C INTEGER LUN, KPRINT, IPASS C C CALL QC6A (LUN, KPRINT, IPASS) C C *Arguments: C C LUN :IN is the unit number to which output is to be written. C C KPRINT:IN controls the amount of output, as specified in the C SLATEC Guidelines. C C IPASS:OUT indicates whether the test passed or failed. C A value of one is good, indicating no failures. C C *Description: C C This routine tests the SLATEC routine AAAAAA to see if the version C number in the SLATEC library source is the same as the quick check C version number. C C***ROUTINES CALLED AAAAAA C***REVISION HISTORY (YYMMDD) C 890713 DATE WRITTEN C***END PROLOGUE QC6A C C*Internal Notes: C C Data set-up is done via a PARAMETER statement. C C**End C C Declare arguments. C INTEGER LUN, KPRINT, IPASS C C DECLARE VARIABLES. C CHARACTER * 16 VER, VERSN PARAMETER (VERSN = ' 4.0-') C C***FIRST EXECUTABLE STATEMENT QC6A IF (KPRINT.GE.3) WRITE (LUN, 9000) CALL AAAAAA (VER) IF (VER .EQ. VERSN) THEN IPASS = 1 IF (KPRINT .GE. 3) THEN WRITE (LUN, 9010) WRITE (LUN, 9020) VER ENDIF ELSE IPASS = 0 IF (KPRINT .GE. 3) WRITE (LUN, 9010) IF (KPRINT .GE. 2) WRITE (LUN, 9030) VER, VERSN ENDIF C C Terminate. C IF (KPRINT.GE.2 .AND. IPASS.EQ.1) WRITE (LUN, 90000) IF (KPRINT.GE.1 .AND. IPASS.EQ.0) WRITE (LUN, 90010) RETURN C C Formats. C 9000 FORMAT ('1' // ' CODE TO TEST SLATEC ROUTINE AAAAAA') 9010 FORMAT (/ ' QC6A RESULTS') 9020 FORMAT (' *** Passed -- version number = ', A16) 9030 FORMAT (' *** Failed -- version number from AAAAAA = ', A16, + ' but expected version number = ', A16) 90000 FORMAT(/' ************QC6A PASSED ALL TESTS ****************') 90010 FORMAT(/' ************QC6A FAILED SOME TESTS ****************') C------------- LAST LINE OF QC6A FOLLOWS ----------------------------- END *DECK QCDRC SUBROUTINE QCDRC (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QCDRC C***PURPOSE Quick check for DRC. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Pexton, R. L., (LLNL) C***DESCRIPTION C C QUICK TEST FOR CARLSON INTEGRAL DRC C C***ROUTINES CALLED D1MACH, DRC, NUMXER, XERCLR, XGETF, XSETF C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 910708 Minor modifications in use of KPRINT. (WRB) C***END PROLOGUE QCDRC INTEGER KPRINT, IPASS, CONTRL, KONTRL, LUN, IER INTEGER IPASS1, IPASS2, IPASS3, IPASS4, NUMXER DOUBLE PRECISION PI, TRC, DRC, DIF, D1MACH EXTERNAL D1MACH, DRC, NUMXER, XERCLR, XGETF, XSETF C***FIRST EXECUTABLE STATEMENT QCDRC CALL XERCLR CALL XGETF(CONTRL) IF ( KPRINT .GE. 3 ) THEN KONTRL = +1 ELSE KONTRL = 0 ENDIF CALL XSETF(KONTRL) C C FORCE ERROR 1 C IF ( KPRINT .GE. 3 ) WRITE (LUN,101) 101 FORMAT(' DRC - FORCE ERROR 1 TO OCCUR') TRC = DRC(-1.0D0,-1.0D0,IER) IER = NUMXER(IER) IF ( IER .EQ. 1 ) THEN IPASS1 = 1 ELSE IPASS1 = 0 ENDIF CALL XERCLR C C FORCE ERROR 2 C IF ( KPRINT .GE. 3 ) WRITE (LUN,102) 102 FORMAT(' DRC - FORCE ERROR 2 TO OCCUR') TRC = DRC(D1MACH(1),D1MACH(1),IER) IER = NUMXER(IER) IF ( IER .EQ. 2 ) THEN IPASS2 = 1 ELSE IPASS2 = 0 ENDIF CALL XERCLR C C FORCE ERROR 3 C IF ( KPRINT .GE. 3 ) WRITE (LUN,103) 103 FORMAT(' DRC - FORCE ERROR 3 TO OCCUR') TRC = DRC(D1MACH(2),D1MACH(2),IER) IER = NUMXER(IER) IF ( IER .EQ. 3 ) THEN IPASS3 = 1 ELSE IPASS3 = 0 ENDIF CALL XERCLR C C ARGUMENTS IN RANGE C PI = 3.141592653589793238462643383279D0 TRC = DRC(0.0D0,0.25D0,IER) CALL XERCLR DIF = TRC - PI IF ( (ABS(DIF/PI).LT.1000.0D0*D1MACH(4)) .AND. (IER.EQ.0) ) THEN IPASS4 = 1 ELSE IPASS4 = 0 ENDIF IPASS = MIN(IPASS1,IPASS2,IPASS3,IPASS4) IF ( KPRINT .LE. 0 ) THEN GO TO 999 ELSEIF ( KPRINT .EQ. 1 ) THEN IF ( IPASS .EQ. 1 ) THEN GO TO 999 ELSE WRITE (LUN,104) 104 FORMAT(' DRC - FAILED') GO TO 999 ENDIF ELSE IF ( IPASS .EQ. 1 ) THEN WRITE (LUN,105) 105 FORMAT(' DRC - PASSED') GO TO 999 ELSE WRITE (LUN,104) IF ( IPASS4 .EQ. 0 ) WRITE (LUN,106) PI, TRC, DIF 106 FORMAT(' CORRECT ANSWER =', 1PD20.14 / * 'COMPUTED ANSWER =', D20.14 / * ' DIFFERENCE =', D20.14 ) GO TO 999 ENDIF ENDIF 999 CONTINUE CALL XSETF(CONTRL) RETURN END *DECK QCDRD SUBROUTINE QCDRD (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QCDRD C***PURPOSE Quick check for DRD. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Pexton, R. L., (LLNL) C***DESCRIPTION C C QUICK TEST FOR CARLSON INTEGRAL DRD C C***ROUTINES CALLED D1MACH, DRD, NUMXER, XERCLR, XGETF, XSETF C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 910708 Minor modifications in use of KPRINT. (WRB) C***END PROLOGUE QCDRD INTEGER KPRINT, IPASS, CONTRL, KONTRL, LUN, IER INTEGER IPASS1, IPASS2, IPASS3, IPASS4, NUMXER DOUBLE PRECISION BLEM, TRD, DRD, DIF, D1MACH EXTERNAL D1MACH, DRD, NUMXER, XERCLR, XGETF, XSETF C***FIRST EXECUTABLE STATEMENT QCDRD CALL XERCLR CALL XGETF(CONTRL) IF ( KPRINT .GE. 3 ) THEN KONTRL = +1 ELSE KONTRL = 0 ENDIF CALL XSETF(KONTRL) C C FORCE ERROR 1 C IF ( KPRINT .GE. 3 ) WRITE (LUN,101) 101 FORMAT(' DRD - FORCE ERROR 1 TO OCCUR') TRD = DRD(-1.0D0,-1.0D0,-1.0D0,IER) IER = NUMXER(IER) IF ( IER .EQ. 1 ) THEN IPASS1 = 1 ELSE IPASS1 = 0 ENDIF CALL XERCLR C C FORCE ERROR 2 C IF ( KPRINT .GE. 3 ) WRITE (LUN,102) 102 FORMAT(' DRD - FORCE ERROR 2 TO OCCUR') TRD = DRD(1.0D0,1.0D0,-1.0D0,IER) IER = NUMXER(IER) IF ( IER .EQ. 2 ) THEN IPASS2 = 1 ELSE IPASS2 = 0 ENDIF CALL XERCLR C C FORCE ERROR 3 C IF ( KPRINT .GE. 3 ) WRITE (LUN,103) 103 FORMAT(' DRD - FORCE ERROR 3 TO OCCUR') TRD = DRD(D1MACH(2),D1MACH(2),D1MACH(2),IER) IER = NUMXER(IER) IF ( IER .EQ. 3 ) THEN IPASS3 = 1 ELSE IPASS3 = 0 ENDIF CALL XERCLR C C ARGUMENTS IN RANGE C BLEM=3 * LEMNISCATE CONSTANT B C BLEM = 1.797210352103388311159883738420D0 TRD = DRD(0.0D0,2.0D0,1.0D0,IER) CALL XERCLR DIF = TRD - BLEM IF ( (ABS(DIF/BLEM).LT.1000.0D0*D1MACH(4)).AND.(IER.EQ.0) ) THEN IPASS4 = 1 ELSE IPASS = 0 ENDIF IPASS = MIN(IPASS1,IPASS2,IPASS3,IPASS4) IF ( KPRINT .LE. 0 ) THEN GO TO 999 ELSEIF ( KPRINT .EQ. 1 ) THEN IF ( IPASS .EQ. 1 ) THEN GO TO 999 ELSE WRITE (LUN,104) 104 FORMAT(' DRD - FAILED') GO TO 999 ENDIF ELSE IF ( IPASS .EQ. 1 ) THEN WRITE (LUN,105) 105 FORMAT(' DRD - PASSED') GO TO 999 ELSE WRITE (LUN,104) IF ( IPASS4 .EQ. 0 ) WRITE (LUN,106) BLEM, TRD, DIF 106 FORMAT(' CORRECT ANSWER =', 1PD20.14 / * 'COMPUTED ANSWER =', D20.14 / * ' DIFFERENCE =', D20.14 ) GO TO 999 ENDIF ENDIF 999 CONTINUE CALL XSETF(CONTRL) RETURN END *DECK QCDRF SUBROUTINE QCDRF (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QCDRF C***PURPOSE Quick check for DRF. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Pexton, R. L., (LLNL) C***DESCRIPTION C C QUICK TEST FOR CARLSON INTEGRAL DRF C C***ROUTINES CALLED D1MACH, DRF, NUMXER, XERCLR, XGETF, XSETF C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 910708 Minor modifications in use of KPRINT. (WRB) C***END PROLOGUE QCDRF INTEGER KPRINT, IPASS, CONTRL, KONTRL, LUN, IER INTEGER IPASS1, IPASS2, IPASS3, IPASS4, NUMXER DOUBLE PRECISION ALEM, TRF, DRF, DIF, D1MACH EXTERNAL D1MACH, DRF, NUMXER, XERCLR, XGETF, XSETF C***FIRST EXECUTABLE STATEMENT QCDRF CALL XERCLR CALL XGETF(CONTRL) IF ( KPRINT .GE. 3 ) THEN KONTRL = +1 ELSE KONTRL = 0 ENDIF CALL XSETF(KONTRL) C C FORCE ERROR 1 C IF ( KPRINT .GE. 3 ) WRITE (LUN,101) 101 FORMAT(' DRF - FORCE ERROR 1 TO OCCUR') TRF = DRF(-1.0D0,-1.0D0,-1.0D0,IER) IER = NUMXER(IER) IF ( IER .EQ. 1 ) THEN IPASS1 = 1 ELSE IPASS1 = 0 ENDIF CALL XERCLR C C FORCE ERROR 2 C IF ( KPRINT .GE. 3 ) WRITE (LUN,102) 102 FORMAT(' DRF - FORCE ERROR 2 TO OCCUR') TRF = DRF(D1MACH(1),D1MACH(1),D1MACH(1),IER) IER = NUMXER(IER) IF ( IER .EQ. 2 ) THEN IPASS2 = 1 ELSE IPASS2 = 0 ENDIF CALL XERCLR C C FORCE ERROR 3 C IF ( KPRINT .GE. 3 ) WRITE (LUN,103) 103 FORMAT(' DRF - FORCE ERROR 3 TO OCCUR') TRF = DRF(D1MACH(2),D1MACH(2),D1MACH(2),IER) IER = NUMXER(IER) IF ( IER .EQ. 3 ) THEN IPASS3 = 1 ELSE IPASS3 = 0 ENDIF CALL XERCLR C C ARGUMENTS IN RANGE C ALEM=LEMNISCATE CONSTANT A C ALEM = 1.3110287771460599052324197949D0 TRF = DRF(0.0D0,1.0D0,2.0D0,IER) CALL XERCLR DIF = TRF - ALEM IF ( (ABS(DIF/ALEM).LT.1000.0D0*D1MACH(4)).AND.(IER.EQ.0) ) THEN IPASS4 = 1 ELSE IPASS4 = 0 ENDIF IPASS = MIN(IPASS1,IPASS2,IPASS3,IPASS4) IF ( KPRINT .EQ. 0 ) THEN GO TO 999 ELSEIF ( KPRINT .EQ. 1 ) THEN IF ( IPASS .EQ. 1 ) THEN GO TO 999 ELSE WRITE (LUN,104) 104 FORMAT(' DRF - FAILED') GO TO 999 ENDIF ELSE IF ( IPASS .EQ. 1 ) THEN WRITE (LUN,105) 105 FORMAT(' DRF - PASSED') GO TO 999 ELSE WRITE (LUN,104) IF ( IPASS4 .EQ. 0 ) WRITE (LUN,106) ALEM, TRF, DIF 106 FORMAT(' CORRECT ANSWER =', 1PD20.14 / * 'COMPUTED ANSWER =', D20.14 / * ' DIFFERENCE =', D20.14 ) GO TO 999 ENDIF ENDIF 999 CONTINUE CALL XSETF(CONTRL) RETURN END *DECK QCDRJ SUBROUTINE QCDRJ (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QCDRJ C***PURPOSE Quick check for DRJ. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Pexton, R. L., (LLNL) C***DESCRIPTION C C QUICK TEST FOR CARLSON INTEGRAL DRJ C C***ROUTINES CALLED D1MACH, DRJ, NUMXER, XERCLR, XGETF, XSETF C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 910708 Minor modifications in use of KPRINT. (WRB) C***END PROLOGUE QCDRJ INTEGER KPRINT, IPASS, CONTRL, KONTRL, LUN, IER INTEGER IPASS1, IPASS2, IPASS3, IPASS4, NUMXER DOUBLE PRECISION CONSJ, TRJ, DRJ, DIF, D1MACH EXTERNAL D1MACH, DRJ, NUMXER, XERCLR, XGETF, XSETF C***FIRST EXECUTABLE STATEMENT QCDRJ CALL XERCLR CALL XGETF(CONTRL) IF ( KPRINT .GE. 3 ) THEN KONTRL = +1 ELSE KONTRL = 0 ENDIF CALL XSETF(KONTRL) C C FORCE ERROR 1 C IF ( KPRINT .GE. 3 ) WRITE (LUN,101) 101 FORMAT(' DRJ - FORCE ERROR 1 TO OCCUR') TRJ = DRJ(-1.0D0,-1.0D0,-1.0D0,-1.0D0,IER) IER = NUMXER(IER) IF ( IER .EQ. 1 ) THEN IPASS1 = 1 ELSE IPASS1 = 0 ENDIF CALL XERCLR C C FORCE ERROR 2 C IF ( KPRINT .GE. 3 ) WRITE (LUN,102) 102 FORMAT(' DRJ - FORCE ERROR 2 TO OCCUR') TRJ = DRJ(D1MACH(1),D1MACH(1),D1MACH(1),D1MACH(1),IER) IER = NUMXER(IER) IF ( IER .EQ. 2 ) THEN IPASS2 = 1 ELSE IPASS2 = 0 ENDIF CALL XERCLR C C FORCE ERROR 3 C IF ( KPRINT .GE. 3 ) WRITE (LUN,103) 103 FORMAT(' DRJ - FORCE ERROR 3 TO OCCUR') TRJ = DRJ(D1MACH(2),D1MACH(2),D1MACH(2),D1MACH(2),IER) IER = NUMXER(IER) IF ( IER .EQ. 3 ) THEN IPASS3 = 1 ELSE IPASS3 = 0 ENDIF CALL XERCLR C C ARGUMENTS IN RANGE C CONSJ = 0.14297579667156753833233879421D0 TRJ = DRJ(2.0D0,3.0D0,4.0D0,5.0D0,IER) CALL XERCLR DIF = TRJ - CONSJ IF ( (ABS(DIF/CONSJ).LT.1000.0D0*D1MACH(4)).AND.(IER.EQ.0) ) THEN IPASS4 = 1 ELSE IPASS4 = 0 ENDIF IPASS = MIN(IPASS1,IPASS2,IPASS3,IPASS4) IF (KPRINT .LE. 0 ) THEN GO TO 999 ELSEIF ( KPRINT .EQ. 1 ) THEN IF ( IPASS .EQ. 1 ) THEN GO TO 999 ELSE WRITE (LUN,104) 104 FORMAT(' DRJ - FAILED') GO TO 999 ENDIF ELSE IF ( IPASS .EQ. 1 ) THEN WRITE (LUN,105) 105 FORMAT(' DRJ - PASSED') GO TO 999 ELSE WRITE (LUN,104) IF ( IPASS4 .EQ. 0 ) WRITE (LUN,106) CONSJ, TRJ, DIF 106 FORMAT(' CORRECT ANSWER =', 1PD20.14 / * 'COMPUTED ANSWER =', D20.14 / * ' DIFFERENCE =', D20.14 ) GO TO 999 ENDIF ENDIF 999 CONTINUE CALL XSETF(CONTRL) RETURN END *DECK QCGLSS SUBROUTINE QCGLSS (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QCGLSS C***PURPOSE Quick check for SGLSS. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (QCGLSS-S, DQCGLS-D) C***AUTHOR Voorhees, E. A., (LANL) C***DESCRIPTION C C QUICK CHECK SUBROUTINE QCGLSS TESTS THE EXECUTION C OF THE GENERAL LINEAR SYSTEM SOLVER, SGLSS . THE C SGLSS SUBROUTINE PACKAGE WAS WRITTEN BY T. MANTEUFFEL C (LANL). C C A TITLE LINE AND A SUMMARY LINE ARE ALWAYS OUTPUTTED C BY QCGLSS. THE SUMMARY LINE GIVES A COUNT OF THE C NUMBER OF PROBLEMS DETECTED DURING THE TEST. C C THE REAL QUANTITIES FOR THE COMPUTED SOLUTION VECTOR C X AND THE CORRESPONDING RNORM ARE COMPARED AGAINST C STORED VALUES. DISAGREEMENT OCCURS IF A DIFFERENCE C IS SQRT(R1MACH(4) OR MORE. THE RETURNED VALUE (INTEGER) C OF INFO IS ALSO CHECKED. FOUR CASES ARE RUN, TWO C INVOLVING LLSIA AND TWO INVOLVING ULSIA . C C QCGLSS REQUIRES NO INPUT ARGUMENTS. ON RETURN, NERR C (INTEGER TYPE) CONTAINS THE COUNT OF THE NUMBER OF C PROBLEMS DETECTED BY QCGLSS . C C***ROUTINES CALLED R1MACH, SGLSS C***REVISION HISTORY (YYMMDD) C 811026 DATE WRITTEN C 820801 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF, cleaned up FORMATs, C including removing an illegal character from column 1, and C editorial changes. (RWC) C***END PROLOGUE QCGLSS REAL AA(4,4,2),A(4,4),BB(4,2),B(4),XX(4,4),DELMAX,DELX,R REAL WORK(20) CHARACTER*1 LIST(2) INTEGER INF(4),NERR,KPROG,KCASE INTEGER IWORK(7),INFO,LUN DATA AA/1.,.5,1.,.25,0.,2.,0.,1.,2.,-1.,1.,0.,0.,0.,0.,0., 1 1.,2.,-1.,0.,0.,1.,2.,0.,-1.,0.,1.,0.,1.,0.,1.,0./ DATA BB/3.,1.5,2.,1.25,1.,3.,3.,0./ DATA XX/.9999999999999787,1.000000000000007,1.000000000000007, 1 0.,.8095238095238102,1.047619047619044,1.095238095238081,0., 1 .7777777777777857,1.444444444444429,.3333333333333393, 1 .5555555555555500, 1 .3333333333333321,0.0,-.3333333333333286,.3333333333333286/ DATA INF/0,1,0,2/ DATA LIST/'L','U'/ C***FIRST EXECUTABLE STATEMENT QCGLSS INFO = 0 NERR = 0 R = SQRT(R1MACH(4)) IF (KPRINT.GE.2) WRITE (LUN,800) DO 60 KPROG=1,2 DO 50 KCASE=1,2 C C FORM BASIC MATRIX A AND VECTOR B . (CASE 1) C DO 10 I=1,4 DO 5 J=1,4 A(I,J) = AA(I,J,KPROG) 5 CONTINUE B(I) = BB(I,KPROG) 10 CONTINUE C C MAKE 3 ROWS IDENTICAL FOR CASE 2. C IF (KCASE .NE. 1) THEN DO 20 I=2,3 DO 15 J=1,4 A(I,J) = A(1,J) 15 CONTINUE B(I) = B(1) 20 CONTINUE ENDIF C C SOLVE FOR VECTOR X . C INFO = 0 IF (KPROG .EQ. 1) CALL SGLSS(A,4,4,3,B,4,1,RNORM,WORK,20, 1 IWORK,7,INFO) IF (KPROG .EQ. 2) CALL SGLSS(A,4,3,4,B,4,1,RNORM,WORK,20, 1 IWORK,7,INFO) C C TEST COMPUTED X , RNORM , AND INFO . C KK = 2*(KPROG - 1) + KCASE DELMAX = 0.0E0 DO 30 I=1,4 DELX = ABS(B(I)-XX(I,KK)) DELMAX = MAX(DELMAX,DELX) 30 CONTINUE C IF (KPRINT.GE.3) WRITE (LUN,701) LIST(KPROG),KCASE,DELMAX IF (DELMAX .GE. R) THEN NERR = NERR + 1 IF (KPRINT.GE.2) WRITE (LUN,801) LIST(KPROG),KCASE,DELMAX ENDIF IF (KPRINT.GE.3) WRITE (LUN,702) LIST(KPROG),KCASE,RNORM IF (RNORM .GT. R) THEN NERR = NERR + 1 IF (KPRINT.GE.2) WRITE (LUN,802) LIST(KPROG),KCASE,RNORM ENDIF C IF (KPRINT.GE.3) WRITE (LUN,703) LIST(KPROG),KCASE,INFO, * INF(KK) IF (INFO .NE. INF(KK)) THEN NERR = NERR + 1 IF (KPRINT.GE.2) WRITE (LUN,803) LIST(KPROG),KCASE,INFO, * INF(KK) ENDIF 50 CONTINUE 60 CONTINUE C C SUMMARY PRINT C IPASS=0 IF (NERR.EQ.0) IPASS=1 IF (NERR.NE.0 .AND. KPRINT.NE.0) WRITE (LUN,804) NERR IF (NERR.EQ.0 .AND. KPRINT.GT.1) WRITE (LUN,805) RETURN C 701 FORMAT (3X, A, 'LSIA, CASE ', I1, '. MAX ABS ERROR OF', E11.4/) 702 FORMAT (3X, A, 'LSIA, CASE ', I1, '. RNORM IS ', E11.4/) 703 FORMAT (3X, A, 'LSIA, CASE ', I1, '. INFO=', I1, 1 ' (SHOULD = ', I1, ')'/) 800 FORMAT(/' * QCGLSS - QUICK CHECK FOR SGLSS (LLSIA AND ULSIA)'/) 801 FORMAT (' PROBLEM WITH ', A, 'LSIA, CASE ', I1, 1 '. MAX ABS ERROR OF', E11.4/) 802 FORMAT (' PROBLEM WITH ', A, 'LSIA, CASE ', I1, 1 '. RNORM (TOO LARGE) IS', E11.4/) 803 FORMAT (' PROBLEM WITH ', A, 'LSIA, CASE ', I1, 1 '. INFO=', I1, ' (SHOULD = ', I1, ')'/) 804 FORMAT (/' **** QCGLSS DETECTED A TOTAL OF ', I2, 1 ' PROBLEMS WITH SGLSS. ****'/) 805 FORMAT (' QCGLSS DETECTED NO PROBLEMS WITH SGLSS.'/) END *DECK QCKIN SUBROUTINE QCKIN (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QCKIN C***PURPOSE Quick check for BSKIN. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Amos, D. E., (SNLA) C***DESCRIPTION C C ABSTRACT C QCKIN IS A QUICK CHECK ROUTINE WHICH EXERCISES THE MAJOR C LOOPS IN SUBROUTINE BSKIN (X,N,KODE,M,Y,NZ,IERR) FOR BICKLEY C FUNCTIONS KI(J,X). MORE PRECISELY, QCKIN DOES CONSISTENCY CHECKS C ON THE OUTPUT FROM BSKIN BY COMPARING SINGLE EVALUATIONS (M=1) C AGAINST SELECTED MEMBERS OF SEQUENCES WHICH ARE GENERATED BY C RECURSION. IF THE RELATIVE ERROR IS LESS THAN 1000 TIMES UNIT C ROUND OFF, THEN THE TEST IS PASSED - IF NOT, THEN X, THE VALUES C TO BE COMPARED, THE RELATIVE ERROR AND PARAMETERS KODE, N, M AND K C ARE WRITTEN ON LOGICAL UNIT 6 WHERE K IS THE MEMBER OF THE C SEQUENCE OF LENGTH M WHICH FAILED THE TEST. THAT IS, THE INDEX C OF THE FUNCTION WHICH FAILED THE TEST IS J=N+K-1. UNDERFLOW C TESTS ARE MADE AND ERROR CONDITIONS ARE TRIGGERED. C C FUNCTIONS I1MACH AND R1MACH MUST BE INITIALIZED ACCORDING TO THE C PROLOGUE IN EACH FUNCTION FOR THE MACHINE ENVIRONMENT BEFORE C QCKIN OR BSKIN CAN BE EXECUTED. FIFTEEN MACHINE ENVIRONMENTS C CAN BE DEFINED IN I1MACH AND R1MACH. C C***ROUTINES CALLED BSKIN, I1MACH, R1MACH C***REVISION HISTORY (YYMMDD) C 820601 DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE QCKIN INTEGER I, IERR, IFLG, IX, I1M12, J, K, KODE, LUN, M, MDEL, MM, * N, NDEL, NN, NZ INTEGER I1MACH REAL AIX, ER, TOL, V, X, XINC, Y REAL R1MACH DIMENSION V(1), Y(10) C***FIRST EXECUTABLE STATEMENT QCKIN TOL = 1000.0E0*MAX(R1MACH(4),1.0E-18) IFLG = 0 IF(KPRINT.GE.3)WRITE (LUN,99999) 99999 FORMAT (1H1//34H QUICK CHECK DIAGNOSTICS FOR BSKIN//) DO 70 KODE=1,2 N = 0 DO 60 NN=1,7 M = 1 DO 50 MM=1,4 X = 0.0E0 DO 40 IX=1,6 IF (N.EQ.0 .AND. IX.EQ.1) GO TO 30 CALL BSKIN(X, N, KODE, M, Y, NZ, IERR) DO 20 K=1,M,2 J = N + K - 1 CALL BSKIN(X, J, KODE, 1, V, NZ, IERR) ER = ABS((V(1)-Y(K))/V(1)) IF (ER.LE.TOL) GO TO 20 IF (IFLG.NE.0) GO TO 10 IF(KPRINT.GE.2)WRITE (LUN,99998) 99998 FORMAT (8X, 1HX, 13X, 4HV(1), 11X, 4HY(K), 9X, 6HREL ER, * 1HR, 5X, 4HKODE, 3X, 1HN, 4X, 1HM, 4X, 1HK) 10 CONTINUE IFLG = IFLG + 1 IF(KPRINT.GE.2) * WRITE (LUN,99997) X, V(1), Y(K), ER, KODE, N, M, K 99997 FORMAT (4E15.6, 4I5) IF (IFLG.GT.200) GO TO 130 20 CONTINUE 30 CONTINUE AIX = 2*IX-3 XINC = MAX(1.0E0,AIX) X = X + XINC 40 CONTINUE MDEL = MAX(1,MM-1) M = M + MDEL 50 CONTINUE NDEL = MAX(1,2*N-2) N = N + NDEL 60 CONTINUE 70 CONTINUE C----------------------------------------------------------------------- C TEST UNDERFLOW C----------------------------------------------------------------------- KODE = 1 M = 10 N = 10 I1M12 = I1MACH(12) X = -2.302E0*R1MACH(5)*I1M12 CALL BSKIN(X, N, KODE, M, Y, NZ, IERR) IF (NZ.EQ.M) GO TO 80 IF(KPRINT.GE.2)WRITE (LUN,99996) 99996 FORMAT (//30H NZ IN UNDERFLOW TEST IS NOT 1//) IFLG = IFLG + 1 GO TO 110 80 CONTINUE DO 90 I=1,M IF (Y(I).NE.0.0E0) GO TO 100 90 CONTINUE GO TO 110 100 CONTINUE IFLG = IFLG + 1 IF(KPRINT.GE.2)WRITE (LUN,99995) 99995 FORMAT (//43H SOME Y VALUE IN UNDERFLOW TEST IS NOT ZERO//) 110 CONTINUE IF (IFLG.NE.0.OR.KPRINT.LT.3) GO TO 120 WRITE (LUN,99994) 99994 FORMAT (//16H QUICK CHECKS OK//) 120 CONTINUE IPASS=0 IF(IFLG.EQ.0) IPASS=1 RETURN 130 CONTINUE IF(KPRINT.GE.2)WRITE (LUN,99992) 99992 FORMAT (//52H PROCESSING OF MAIN LOOPS TERMINATED BECAUSE THE NUM, * 36HBER OF DIAGNOSTIC PRINTS EXCEEDS 200//) IPASS=0 IF(IFLG.EQ.0) IPASS=1 RETURN END *DECK QCPSI SUBROUTINE QCPSI (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QCPSI C***PURPOSE Quick check for PSIFN. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Amos, D. E., (SNLA) C***DESCRIPTION C C ABSTRACT C QCPSI IS A QUICK CHECK ROUTINE WHICH EXERCISES THE MAJOR C LOOPS IN SUBROUTINE PSIFN(X,N,KODE,M,ANS,NZ,IERR) FOR DERIVATIVES C OF THE PSI FUNCTION. FOR N=0, THE PSI FUNCTIONS ARE CALCULATED C EXPLICITLY AND CHECKED AGAINST EVALUATIONS FROM PSIFN. FOR C N.GT.0, CONSISTENCY CHECKS ARE MADE BY COMPARING A SEQUENCE C AGAINST SINGLE EVALUATIONS OF PSIFN, ONE AT A TIME. C IF THE RELATIVE ERROR IS LESS THAN 1000 TIMES UNIT ROUNDOFF, C THEN THE TEST IS PASSED--IF NOT, C THEN X, THE VALUES TO BE COMPARED, THE RELATIVE ERROR AND C PARAMETERS KODE AND N ARE WRITTEN ON LOGICAL UNIT 6 WHERE N IS C THE ORDER OF THE DERIVATIVE AND KODE IS A SELECTION PARAMETER C DEFINED IN THE PROLOGUE TO PSIFN. C C FUNCTIONS I1MACH AND R1MACH MUST BE INITIALIZED ACCORDING TO THE C PROLOGUE IN EACH FUNCTION FOR THE MACHINE ENVIRONMENT BEFORE C QCPSI OR PSIFN CAN BE EXECUTED. C C***ROUTINES CALLED PSIFN, R1MACH C***REVISION HISTORY (YYMMDD) C 820601 DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE QCPSI INTEGER I, IERR, IFLG, IX, KODE, LUN, M, N, NM, NN, NZ REAL ER, EULER, PSI1, PSI2, R1M4, S, TOL, X REAL R1MACH DIMENSION PSI1(3), PSI2(20) DATA EULER /0.5772156649015328606E0/ C***FIRST EXECUTABLE STATEMENT QCPSI R1M4 = R1MACH(4) TOL = 1000.0E0*MAX(R1M4,1.0E-18) IF(KPRINT.GE.3)WRITE (LUN,99999) 99999 FORMAT (1H1//34H QUICK CHECK DIAGNOSTICS FOR PSIFN//) C----------------------------------------------------------------------- C CHECK PSI(I) AND PSI(I-0.5), I=1,2,... C----------------------------------------------------------------------- IFLG = 0 N = 0 DO 50 KODE=1,2 DO 40 M=1,2 S = -EULER + (M-1)*(-2.0E0*LOG(2.0E0)) X = 1.0E0 - (M-1)*0.5E0 DO 30 I=1,20 CALL PSIFN(X, N, KODE, 1, PSI2, NZ, IERR) PSI1(1) = -S + (KODE-1)*LOG(X) ER = ABS((PSI1(1)-PSI2(1))/PSI1(1)) IF (ER.LE.TOL) GO TO 20 IF (IFLG.NE.0) GO TO 10 IF(KPRINT.GE.2)WRITE (LUN,99998) 99998 FORMAT (8X, 1HX, 13X, 4HPSI1, 11X, 4HPSI2, 9X, 7HREL ERR, * 5X, 4HKODE, 3X, 1HN) 10 CONTINUE IFLG = IFLG + 1 IF(KPRINT.GE.2) * WRITE (LUN,99997) X, PSI1(1), PSI2(I), ER, KODE, N 99997 FORMAT (4E15.6, 2I5) IF (IFLG.GT.200) GO TO 150 20 CONTINUE S = S + 1.0E0/X X = X + 1.0E0 30 CONTINUE 40 CONTINUE 50 CONTINUE C----------------------------------------------------------------------- C CHECK SMALL X.LT.UNIT ROUNDOFF C----------------------------------------------------------------------- KODE = 1 X = TOL/10000.0E0 N = 1 CALL PSIFN(X, N, KODE, 1, PSI2, NZ, IERR) PSI1(1) = X**(-N-1) ER = ABS((PSI1(1)-PSI2(1))/PSI1(1)) IF (ER.LE.TOL) GO TO 70 IF (IFLG.NE.0) GO TO 60 IF(KPRINT.GE.2)WRITE (LUN,99998) 60 CONTINUE IFLG = IFLG + 1 IF(KPRINT.GE.2) * WRITE (LUN,99997) X, PSI1(1), PSI2(1), ER, KODE, N 70 CONTINUE C----------------------------------------------------------------------- C CONSISTENCY TESTS FOR N.GE.0 C----------------------------------------------------------------------- DO 130 KODE=1,2 DO 120 M=1,5 DO 110 N=1,16,5 NN = N - 1 X = 0.1E0 DO 100 IX=1,25,2 X = X + 1.0E0 CALL PSIFN(X, NN, KODE, M, PSI2, NZ, IERR) DO 90 I=1,M NM = NN + I - 1 CALL PSIFN(X, NM, KODE, 1, PSI1, NZ, IERR) ER = ABS((PSI2(I)-PSI1(1))/PSI1(1)) IF (ER.LT.TOL) GO TO 90 IF (IFLG.NE.0) GO TO 80 IF(KPRINT.GE.2)WRITE (LUN,99998) 80 CONTINUE IFLG = IFLG + 1 IF(KPRINT.GE.2) * WRITE (LUN,99997) X, PSI1(1), PSI2(I), ER, KODE, NM 90 CONTINUE 100 CONTINUE 110 CONTINUE 120 CONTINUE 130 CONTINUE IF (IFLG.NE.0.OR.KPRINT.LT.3) GO TO 140 WRITE (LUN,99996) 99996 FORMAT (//16H QUICK CHECKS OK//) 140 CONTINUE IPASS=0 IF(IFLG.EQ.0)IPASS=1 RETURN 150 CONTINUE IF(KPRINT.GE.2)WRITE (LUN,99994) 99994 FORMAT (//52H PROCESSING OF MAIN LOOPS TERMINATED BECAUSE THE NUM, * 36HBER OF DIAGNOSTIC PRINTS EXCEEDS 200//) IPASS=0 IF(IFLG.EQ.0)IPASS=1 RETURN END *DECK QCRC SUBROUTINE QCRC (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QCRC C***PURPOSE Quick check for RC. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Pexton, R. L., (LLNL) C***DESCRIPTION C C QUICK TEST FOR CARLSON INTEGRAL RC C C***ROUTINES CALLED NUMXER, R1MACH, RC, XERCLR, XGETF, XSETF C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 910708 Minor modifications in use of KPRINT. (WRB) C***END PROLOGUE QCRC INTEGER KPRINT, IPASS, CONTRL, KONTRL, LUN, IER INTEGER IPASS1, IPASS2, IPASS3, IPASS4, NUMXER REAL PI, TRC, RC, DIF, R1MACH EXTERNAL NUMXER, R1MACH, RC, XERCLR, XGETF, XSETF C***FIRST EXECUTABLE STATEMENT QCRC CALL XERCLR CALL XGETF(CONTRL) IF ( KPRINT .GE. 3 ) THEN KONTRL = +1 ELSE KONTRL = 0 ENDIF CALL XSETF(KONTRL) C C FORCE ERROR 1 C IF ( KPRINT .GE. 3 ) WRITE (LUN,101) 101 FORMAT(' RC - FORCE ERROR 1 TO OCCUR') TRC = RC(-1.0E0,-1.0E0,IER) IER = NUMXER(IER) IF ( IER .EQ. 1 ) THEN IPASS1 = 1 ELSE IPASS1 = 0 ENDIF CALL XERCLR C C FORCE ERROR 2 C IF ( KPRINT .GE. 3 ) WRITE (LUN,102) 102 FORMAT(' RC - FORCE ERROR 2 TO OCCUR') TRC = RC(R1MACH(1),R1MACH(1),IER) IER = NUMXER(IER) IF ( IER .EQ. 2 ) THEN IPASS2 = 1 ELSE IPASS2 = 0 ENDIF CALL XERCLR C C FORCE ERROR 3 C IF ( KPRINT .GE. 3 ) WRITE (LUN,103) 103 FORMAT(' RC - FORCE ERROR 3 TO OCCUR') TRC = RC(R1MACH(2),R1MACH(2),IER) IER = NUMXER(IER) IF ( IER .EQ. 3 ) THEN IPASS3 = 1 ELSE IPASS3 = 0 ENDIF CALL XERCLR C C ARGUMENTS IN RANGE C PI = 3.1415926535897932E0 TRC = RC(0.0E0,0.25E0,IER) CALL XERCLR DIF = TRC - PI IF ( (ABS(DIF/PI).LT.1000.0E0*R1MACH(4)) .AND. (IER.EQ.0) ) THEN IPASS4 = 1 ELSE IPASS4 = 0 ENDIF IPASS = MIN(IPASS1,IPASS2,IPASS3,IPASS4) IF ( KPRINT .LE. 0 ) THEN GO TO 999 ELSEIF ( KPRINT .EQ. 1 ) THEN IF ( IPASS .EQ. 1 ) THEN GO TO 999 ELSE WRITE (LUN,104) 104 FORMAT(' RC - FAILED') GO TO 999 ENDIF ELSE IF ( IPASS .EQ. 1 ) THEN WRITE (LUN,105) 105 FORMAT(' RC - PASSED') GO TO 999 ELSE WRITE (LUN,104) IF ( IPASS4 .EQ. 0 ) WRITE (LUN,106) PI, TRC, DIF 106 FORMAT(' CORRECT ANSWER =', 1PE14.6 / * 'COMPUTED ANSWER =', E14.6 / * ' DIFFERENCE =', E14.6 ) GO TO 999 ENDIF ENDIF 999 CONTINUE CALL XSETF(CONTRL) RETURN END *DECK QCRD SUBROUTINE QCRD (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QCRD C***PURPOSE Quick check for RD. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Pexton, R. L., (LLNL) C***DESCRIPTION C C QUICK TEST FOR CARLSON INTEGRAL RD C C***ROUTINES CALLED NUMXER, R1MACH, RD, XERCLR, XGETF, XSETF C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 910708 Minor modifications in use of KPRINT. (WRB) C***END PROLOGUE QCRD INTEGER KPRINT, IPASS, CONTRL, KONTRL, LUN, IER INTEGER IPASS1, IPASS2, IPASS3, IPASS4, NUMXER REAL BLEM, TRD, RD, DIF, R1MACH EXTERNAL NUMXER, R1MACH, RD, XERCLR, XGETF, XSETF C***FIRST EXECUTABLE STATEMENT QCRD CALL XERCLR CALL XGETF(CONTRL) IF ( KPRINT .GE. 3 ) THEN KONTRL = +1 ELSE KONTRL = 0 ENDIF CALL XSETF(KONTRL) C C FORCE ERROR 1 C IF ( KPRINT .GE. 3 ) WRITE (LUN,101) 101 FORMAT(' RD - FORCE ERROR 1 TO OCCUR') TRD = RD(-1.0E0,-1.0E0,-1.0E0,IER) IER = NUMXER(IER) IF ( IER .EQ. 1 ) THEN IPASS1 = 1 ELSE IPASS1 = 0 ENDIF CALL XERCLR C C FORCE ERROR 2 C IF ( KPRINT .GE. 3 ) WRITE (LUN,102) 102 FORMAT(' RD - FORCE ERROR 2 TO OCCUR') TRD = RD(1.0E0,1.0E0,-1.0E0,IER) IER = NUMXER(IER) IF ( IER .EQ. 2 ) THEN IPASS2 = 1 ELSE IPASS2 = 0 ENDIF CALL XERCLR C C FORCE ERROR 3 C IF ( KPRINT .GE. 3 ) WRITE (LUN,103) 103 FORMAT(' RD - FORCE ERROR 3 TO OCCUR') TRD = RD(R1MACH(2),R1MACH(2),R1MACH(2),IER) IER = NUMXER(IER) IF ( IER .EQ. 3 ) THEN IPASS3 = 1 ELSE IPASS3 = 0 ENDIF CALL XERCLR C C ARGUMENTS IN RANGE C BLEM=3 * LEMNISCATE CONSTANT B C BLEM = 1.79721035210338831E0 TRD = RD(0.0E0,2.0E0,1.0E0,IER) CALL XERCLR DIF = TRD - BLEM IF ( (ABS(DIF/BLEM).LT.1000.0E0*R1MACH(4)).AND.(IER.EQ.0) ) THEN IPASS4 = 1 ELSE IPASS = 0 ENDIF IPASS = MIN(IPASS1,IPASS2,IPASS3,IPASS4) IF ( KPRINT .LE. 0 ) THEN GO TO 999 ELSEIF ( KPRINT .EQ. 1 ) THEN IF ( IPASS .EQ. 1 ) THEN GO TO 999 ELSE WRITE (LUN,104) 104 FORMAT(' RD - FAILED') GO TO 999 ENDIF ELSE IF ( IPASS .EQ. 1 ) THEN WRITE (LUN,105) 105 FORMAT(' RD - PASSED') GO TO 999 ELSE WRITE (LUN,104) IF ( IPASS4 .EQ. 0 ) WRITE (LUN,106) BLEM, TRD, DIF 106 FORMAT(' CORRECT ANSWER =', 1PE14.6 / * 'COMPUTED ANSWER =', E14.6 / * ' DIFFERENCE =', E14.6 ) GO TO 999 ENDIF ENDIF 999 CONTINUE CALL XSETF(CONTRL) RETURN END *DECK QCRF SUBROUTINE QCRF (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QCRF C***PURPOSE Quick check for RF. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Pexton, R. L., (LLNL) C***DESCRIPTION C C QUICK TEST FOR CARLSON INTEGRAL RF C C***ROUTINES CALLED NUMXER, R1MACH, RF, XERCLR, XGETF, XSETF C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 910708 Minor modifications in use of KPRINT. (WRB) C***END PROLOGUE QCRF INTEGER KPRINT, IPASS, CONTRL, KONTRL, LUN, IER INTEGER IPASS1, IPASS2, IPASS3, IPASS4, NUMXER REAL ALEM, TRF, RF, DIF, R1MACH EXTERNAL NUMXER, R1MACH, RF, XERCLR, XGETF, XSETF C***FIRST EXECUTABLE STATEMENT QCRF CALL XERCLR CALL XGETF(CONTRL) IF ( KPRINT .GE. 3 ) THEN KONTRL = +1 ELSE KONTRL = 0 ENDIF CALL XSETF(KONTRL) C C FORCE ERROR 1 C IF ( KPRINT .GE. 3 ) WRITE (LUN,101) 101 FORMAT(' RF - FORCE ERROR 1 TO OCCUR') TRF = RF(-1.0E0,-1.0E0,-1.0E0,IER) IER = NUMXER(IER) IF ( IER .EQ. 1 ) THEN IPASS1 = 1 ELSE IPASS1 = 0 ENDIF CALL XERCLR C C FORCE ERROR 2 C IF ( KPRINT .GE. 3 ) WRITE (LUN,102) 102 FORMAT(' RF - FORCE ERROR 2 TO OCCUR') TRF = RF(R1MACH(1),R1MACH(1),R1MACH(1),IER) IER = NUMXER(IER) IF ( IER .EQ. 2 ) THEN IPASS2 = 1 ELSE IPASS2 = 0 ENDIF CALL XERCLR C C FORCE ERROR 3 C IF ( KPRINT .GE. 3 ) WRITE (LUN,103) 103 FORMAT(' RF - FORCE ERROR 3 TO OCCUR') TRF = RF(R1MACH(2),R1MACH(2),R1MACH(2),IER) IER = NUMXER(IER) IF ( IER .EQ. 3 ) THEN IPASS3 = 1 ELSE IPASS3 = 0 ENDIF CALL XERCLR C C ARGUMENTS IN RANGE C ALEM=LEMNISCATE CONSTANT A C ALEM = 1.311028777146059905E0 TRF = RF(0.0E0,1.0E0,2.0E0,IER) CALL XERCLR DIF = TRF - ALEM IF ( (ABS(DIF/ALEM).LT.1000.0E0*R1MACH(4)).AND.(IER.EQ.0) ) THEN IPASS4 = 1 ELSE IPASS4 = 0 ENDIF IPASS = MIN(IPASS1,IPASS2,IPASS3,IPASS4) IF ( KPRINT .EQ. 0 ) THEN GO TO 999 ELSEIF ( KPRINT .EQ. 1 ) THEN IF ( IPASS .EQ. 1 ) THEN GO TO 999 ELSE WRITE (LUN,104) 104 FORMAT(' RF - FAILED') GO TO 999 ENDIF ELSE IF ( IPASS .EQ. 1 ) THEN WRITE (LUN,105) 105 FORMAT(' RF - PASSED') GO TO 999 ELSE WRITE (LUN,104) IF ( IPASS4 .EQ. 0 ) WRITE (LUN,106) ALEM, TRF, DIF 106 FORMAT(' CORRECT ANSWER =', 1PE14.6 / * 'COMPUTED ANSWER =', E14.6 / * ' DIFFERENCE =', E14.6 ) GO TO 999 ENDIF ENDIF 999 CONTINUE CALL XSETF(CONTRL) RETURN END *DECK QCRJ SUBROUTINE QCRJ (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QCRJ C***PURPOSE Quick check for RJ. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Pexton, R. L., (LLNL) C***DESCRIPTION C C QUICK TEST FOR CARLSON INTEGRAL RJ C C***ROUTINES CALLED NUMXER, R1MACH, RJ, XERCLR, XGETF, XSETF C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 910708 Minor modifications in use of KPRINT. (WRB) C***END PROLOGUE QCRJ INTEGER KPRINT, IPASS, CONTRL, KONTRL, LUN, IER INTEGER IPASS1, IPASS2, IPASS3, IPASS4, NUMXER REAL CONSJ, TRJ, RJ, DIF, R1MACH EXTERNAL NUMXER, R1MACH, RJ, XERCLR, XGETF, XSETF C***FIRST EXECUTABLE STATEMENT QCRJ CALL XERCLR CALL XGETF(CONTRL) IF ( KPRINT .GE. 3 ) THEN KONTRL = +1 ELSE KONTRL = 0 ENDIF CALL XSETF(KONTRL) C C FORCE ERROR 1 C IF ( KPRINT .GE. 3 ) WRITE (LUN,101) 101 FORMAT(' RJ - FORCE ERROR 1 TO OCCUR') TRJ = RJ(-1.0E0,-1.0E0,-1.0E0,-1.0E0,IER) IER = NUMXER(IER) IF ( IER .EQ. 1 ) THEN IPASS1 = 1 ELSE IPASS1 = 0 ENDIF CALL XERCLR C C FORCE ERROR 2 C IF ( KPRINT .GE. 3 ) WRITE (LUN,102) 102 FORMAT(' RJ - FORCE ERROR 2 TO OCCUR') TRJ = RJ(R1MACH(1),R1MACH(1),R1MACH(1),R1MACH(1),IER) IER = NUMXER(IER) IF ( IER .EQ. 2 ) THEN IPASS2 = 1 ELSE IPASS2 = 0 ENDIF CALL XERCLR C C FORCE ERROR 3 C IF ( KPRINT .GE. 3 ) WRITE (LUN,103) 103 FORMAT(' RJ - FORCE ERROR 3 TO OCCUR') TRJ = RJ(R1MACH(2),R1MACH(2),R1MACH(2),R1MACH(2),IER) IER = NUMXER(IER) IF ( IER .EQ. 3 ) THEN IPASS3 = 1 ELSE IPASS3 = 0 ENDIF CALL XERCLR C C ARGUMENTS IN RANGE C CONSJ = 0.142975796671567538E0 TRJ = RJ(2.0E0,3.0E0,4.0E0,5.0E0,IER) CALL XERCLR DIF = TRJ - CONSJ IF ( (ABS(DIF/CONSJ).LT.1000.0E0*R1MACH(4)).AND.(IER.EQ.0) ) THEN IPASS4 = 1 ELSE IPASS4 = 0 ENDIF IPASS = MIN(IPASS1,IPASS2,IPASS3,IPASS4) IF (KPRINT .LE. 0 ) THEN GO TO 999 ELSEIF ( KPRINT .EQ. 1 ) THEN IF ( IPASS .EQ. 1 ) THEN GO TO 999 ELSE WRITE (LUN,104) 104 FORMAT(' RJ - FAILED') GO TO 999 ENDIF ELSE IF ( IPASS .EQ. 1 ) THEN WRITE (LUN,105) 105 FORMAT(' RJ - PASSED') GO TO 999 ELSE WRITE (LUN,104) IF ( IPASS4 .EQ. 0 ) WRITE (LUN,106) CONSJ, TRJ, DIF 106 FORMAT(' CORRECT ANSWER =', 1PE14.6 / * 'COMPUTED ANSWER =', E14.6 / * ' DIFFERENCE =', E14.6 ) GO TO 999 ENDIF ENDIF 999 CONTINUE CALL XSETF(CONTRL) RETURN END *DECK QG8TST SUBROUTINE QG8TST (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QG8TST C***PURPOSE Quick check for GAUS8. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (QG8TST-S, DQG8TS-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED FQD1, FQD2, GAUS8, R1MACH, XGETF, XSETF C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Changed usage of R1MACH(3) to R1MACH(4). (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C 910708 Minor modifications in use of KPRINT. (WRB) C 920213 Code restructured to test GAUS8 for all values of KPRINT, C second accuracy test added and testing of error returns C revised. (WRB) C***END PROLOGUE QG8TST C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. INTEGER IERR REAL A, ANS, B, COR, ERR, REQ, TOL LOGICAL FATAL C .. External Functions .. REAL FQD1, FQD2, R1MACH EXTERNAL FQD1, FQD2, R1MACH C .. External Subroutines .. EXTERNAL GAUS8, XGETF, XSETF C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT C***FIRST EXECUTABLE STATEMENT QG8TST IF (KPRINT .GE. 2) WRITE (LUN,FMT=9000) C C Initialize variables for testing. C TOL = SQRT(R1MACH(4)) IPASS = 1 C C First accuracy test. C A = 1.0E0 B = 4.0E0 ERR = TOL/100.0E0 CALL GAUS8 (FQD1, A, B, ERR, ANS, IERR) COR = 2.0E0 IF (ABS(ANS-COR).LE.TOL .AND. IERR.EQ.1) THEN IF (KPRINT .GE. 3) + WRITE (LUN, 9010) 'PASSED', A, B, ANS, COR, ERR, IERR ELSE IPASS = 0 IF (KPRINT .GE. 2) + WRITE (LUN, 9010) 'FAILED', A, B, ANS, COR, ERR, IERR ENDIF C C Second accuracy test. C A = 0.0E0 B = 4.0E0*ATAN(1.0E0) ERR = TOL/100.0E0 CALL GAUS8 (FQD2, A, B, ERR, ANS, IERR) COR = (EXP(B)-1.0E0)/101.0E0 IF (ABS(ANS-COR).LE.TOL .AND. IERR.EQ.1) THEN IF (KPRINT .GE. 3) + WRITE (LUN, 9010) 'PASSED', A, B, ANS, COR, ERR, IERR ELSE IPASS = 0 IF (KPRINT .GE. 2) + WRITE (LUN, 9010) 'FAILED', A, B, ANS, COR, ERR, IERR ENDIF C C Test error returns. C CALL XGETF (KONTRL) IF (KPRINT .LE. 2) THEN CALL XSETF (0) ELSE CALL XSETF (1) ENDIF FATAL = .FALSE. C IF (KPRINT .GE. 3) WRITE (LUN,FMT=9030) C C Test with a discontinuous integrand and a tight error tolerance. C A = 0.0E0 B = 1.0E0 COR = 2.0E0 ERR = 100.0E0*R1MACH(4) REQ = ERR CALL GAUS8 (FQD1, A, B, ERR, ANS, IERR) C C See if test passed. C IF (IERR .EQ. 2) THEN IF (KPRINT .GE. 3) + WRITE (LUN,FMT=9040) 'PASSED', REQ, ANS, IERR, ERR, COR ELSE IF (KPRINT .GE. 2) + WRITE (LUN,FMT=9040) 'PASSED', REQ, ANS, IERR, ERR, COR IPASS = 0 FATAL = .TRUE. ENDIF C C Test GAUS8 with A and B nearly equal. C A = 2.0E0 B = A*(1.0E0+R1MACH(4)) COR = 0.0E0 ERR = TOL C CALL GAUS8 (FQD1, A, B, ERR, ANS, IERR) C C Check to see if test passed. C IF (IERR.EQ.-1 .AND. ANS.EQ.0.0E0) THEN IF (KPRINT .GE. 3) WRITE (LUN,9050) 'PASSED' ELSE IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 2) WRITE (LUN,9050) 'FAILED' ENDIF C CALL XSETF (KONTRL) IF (FATAL) THEN IF (KPRINT .GE. 2) THEN WRITE (LUN, 9060) ENDIF ELSE IF (KPRINT .GE. 3) THEN WRITE (LUN, 9070) ENDIF ENDIF C IF (IPASS.EQ.1 .AND. KPRINT.GE.3) WRITE (LUN,FMT=9080) IF (IPASS.EQ.0 .AND. KPRINT.GE.2) WRITE (LUN,FMT=9090) RETURN C 9000 FORMAT ('1' / ' GAUS8 Quick Check') 9010 FORMAT (/ ' Accuracy test of GAUS8 ', A / + ' A = ', F10.5, ' B = ', F10.5 / + ' Computed result = ', E14.7, ' Exact result = ', + E14.7 / + ' Tolerance = ', E14.7, ' IERR = ', I2 /) 9030 FORMAT (/ ' Test error returns' / + ' 2 error messages expected' /) 9040 FORMAT (' Test of GAUS8 ', A / + ' REQ =', E10.2, 5X, 'ANS =', E20.13, 5X, 'IERR =', I2, + 5X, 'should be 2' / + ' ERR =', E10.2, ' CORRECT =' ,E20.13 /) 9050 FORMAT (' Test of A and B nearly equal ', A) 9060 FORMAT (/ ' At least one incorrect argument test FAILED') 9070 FORMAT (/ ' All incorrect argument tests PASSED') 9080 FORMAT (/,' ***************GAUS8 PASSED ALL TESTS***************') 9090 FORMAT (/,' ***************GAUS8 FAILED SOME TESTS**************') END *DECK QN79QX SUBROUTINE QN79QX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QN79QX C***PURPOSE Quick check for QNC79. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (QN79QX-S, DQN79Q-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED FQD1, FQD2, QNC79, R1MACH, XGETF, XSETF C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Changed usage of R1MACH(3) to R1MACH(4). (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C 910708 Minor modifications in use of KPRINT. (WRB) C 920213 Code restructured to test QNC79 for all values of KPRINT, C second accuracy test added and testing of error returns C revised. (WRB) C***END PROLOGUE QN79QX C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. INTEGER IERR, NFCT REAL A, ANS, B, COR, ERR, REQ, TOL LOGICAL FATAL C .. External Functions .. REAL FQD1, FQD2, R1MACH EXTERNAL FQD1, FQD2, R1MACH C .. External Subroutines .. EXTERNAL QNC79, XGETF, XSETF C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT C***FIRST EXECUTABLE STATEMENT QN79QX IF (KPRINT .GE. 2) WRITE (LUN,FMT=9000) C C Initialize variables for testing. C TOL = SQRT(R1MACH(4)) IPASS = 1 C C First accuracy test. C A = 1.0E0 B = 4.0E0 ERR = TOL/100.0E0 CALL QNC79 (FQD1, A, B, ERR, ANS, IERR, NFCT) COR = 2.0E0 IF (ABS(ANS-COR).LE.TOL .AND. IERR.EQ.1) THEN IF (KPRINT .GE. 3) + WRITE (LUN, 9010) 'PASSED', A, B, ANS, COR, ERR, IERR, NFCT ELSE IPASS = 0 IF (KPRINT .GE. 2) + WRITE (LUN, 9010) 'FAILED', A, B, ANS, COR, ERR, IERR, NFCT ENDIF C C Second accuracy test. C A = 0.0E0 B = 4.0E0*ATAN(1.0E0) ERR = TOL/10.0E0 CALL QNC79 (FQD2, A, B, ERR, ANS, IERR, NFCT) COR = (EXP(B)-1.0E0)/101.0E0 IF (ABS(ANS-COR).LE.TOL .AND. IERR.EQ.1) THEN IF (KPRINT .GE. 3) + WRITE (LUN, 9010) 'PASSED', A, B, ANS, COR, ERR, IERR, NFCT ELSE IPASS = 0 IF (KPRINT .GE. 2) + WRITE (LUN, 9010) 'FAILED', A, B, ANS, COR, ERR, IERR, NFCT ENDIF C C Test error returns. C CALL XGETF (KONTRL) IF (KPRINT .LE. 2) THEN CALL XSETF (0) ELSE CALL XSETF (1) ENDIF FATAL = .FALSE. C IF (KPRINT .GE. 3) WRITE (LUN,FMT=9030) C C Test with a discontinuous integrand and a tight error tolerance. C A = 0.0E0 B = 1.0E0 COR = 2.0E0 ERR = 100.0E0*R1MACH(4) REQ = ERR CALL QNC79 (FQD1, A, B, ERR, ANS, IERR, NFCT) C C See if test passed. C IF (IERR .EQ. 2) THEN IF (KPRINT .GE. 3) + WRITE (LUN,FMT=9040) 'PASSED', REQ, ANS, IERR, ERR, COR ELSE IF (KPRINT .GE. 2) + WRITE (LUN,FMT=9040) 'FAILED', REQ, ANS, IERR, ERR, COR IPASS = 0 FATAL = .TRUE. ENDIF C C Test QNC79 with A and B nearly equal. C A = 2.0E0 B = A*(1.0E0+R1MACH(4)) COR = 0.0E0 ERR = TOL C CALL QNC79 (FQD1, A, B, ERR, ANS, IERR, NFCT) C C Check to see if test passed. C IF (IERR.EQ.-1 .AND. ANS.EQ.0.0E0) THEN IF (KPRINT .GE. 3) WRITE (LUN,9050) 'PASSED' ELSE IPASS = 0 FATAL = .TRUE. IF (KPRINT .GE. 2) WRITE (LUN,9050) 'FAILED' ENDIF C CALL XSETF (KONTRL) IF (FATAL) THEN IF (KPRINT .GE. 2) THEN WRITE (LUN, 9060) ENDIF ELSE IF (KPRINT .GE. 3) THEN WRITE (LUN, 9070) ENDIF ENDIF C IF (IPASS.EQ.1 .AND. KPRINT.GE.3) WRITE (LUN,FMT=9080) IF (IPASS.EQ.0 .AND. KPRINT.GE.2) WRITE (LUN,FMT=9090) RETURN C 9000 FORMAT ('1' / ' QNC79 Quick Check') 9010 FORMAT (/ ' Accuracy test of QNC79 ', A / + ' A = ', F10.5, ' B = ', F10.5 / + ' Computed result = ', E14.7, ' Exact result = ', + E14.7 / + ' Tolerance = ', E14.7, ' IERR = ', I2, + ' Number of function evals = ', I5 /) 9030 FORMAT (/ ' Test error returns' / + ' 2 error messages expected' /) 9040 FORMAT (' Test of QNC79 ', A / + ' REQ =', E10.2, 5X, 'ANS =', E20.13, 5X, 'IERR =', I2, + 5X, 'should be 2' / + ' ERR =', E10.2, ' CORRECT =' ,E20.13 /) 9050 FORMAT (' Test of A and B nearly equal ', A) 9060 FORMAT (/ ' At least one incorrect argument test FAILED') 9070 FORMAT (/ ' All incorrect argument tests PASSED') 9080 FORMAT (/' ***************QNC79 PASSED ALL TESTS****************') 9090 FORMAT (/' ***************QNC79 FAILED SOME TESTS***************') END *DECK QXABM SUBROUTINE QXABM (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QXABM C***SUBSIDIARY C***PURPOSE Test the DEPAC routine DEABM. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (QXABM-S, QXDABM-D) C***KEYWORDS QUICK CHECK C***AUTHOR Chow, Jeff, (LANL) C***DESCRIPTION C C *Usage: C C INTEGER LUN, KPRINT, IPASS C C CALL QXABM (LUN, KPRINT, IPASS) C C *Arguments: C C LUN :IN is the unit number to which output is to be written. C C KPRINT:IN controls the amount of output, as specified in the C SLATEC Guidelines. C C IPASS:OUT will contain a pass/fail flag. IPASS=1 is good. C IPASS=0 indicates one or more tests failed. C C *Description: C C DEABM is tested by solving the equations of motion of a body C moving in a plane about a spherical earth, namely C (D/DT)(D/DT)X = -G*X/R**3 C (D/DT)(D/DT)Y = -G*Y/R**3 C where G = 1, R = SQRT(X**2 + Y**2) and C X(0) = 1 C (D/DT)X(0) = 0 C Y(0) = 0 C (D/DT)Y(0) = 1. C C***ROUTINES CALLED DEABM, FDEQC, R1MACH C***REVISION HISTORY (YYMMDD) C 810801 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900415 Code extensively revised. (WRB) C***END PROLOGUE QXABM C C Declare arguments. C INTEGER LUN, KPRINT, IPASS C C Declare local variables. C INTEGER IDID, INFO(15), IPAR, IWORK(51), N, LIW, LRW REAL ABSERR, R, R1MACH, RELERR, RELTOL, RPAR, RWORK(214), T, TOUT, + U(4) EXTERNAL FDEQC C***FIRST EXECUTABLE STATEMENT QXABM IF (KPRINT .GE. 2) WRITE (LUN, 9000) C C Initialize problem. C N = 4 LRW = 214 LIW = 51 T = 0.0E0 TOUT = 8.0E0*ATAN(1.0E0) U(1) = 1.0E0 U(2) = 0.0E0 U(3) = 0.0E0 U(4) = 1.0E0 IPASS = 1 RELTOL = SQRT(R1MACH(4)) RELERR = 0.1E0*RELTOL ABSERR = RELERR**1.5E0 INFO(1) = 0 INFO(2) = 0 INFO(3) = 1 INFO(4) = 0 IF (KPRINT .GT. 2) WRITE (LUN, 9010) RELERR, ABSERR, T, (1.0E0) C 100 CALL DEABM (FDEQC, N, T, U, TOUT, INFO, RELERR, ABSERR, + IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR) R = SQRT(U(1)*U(1)+U(2)*U(2)) IF (ABS(R-1.0E0) .GT. RELTOL) IPASS = 0 IF (KPRINT .GT. 2) WRITE (LUN, 9020) T, R INFO(1) = 1 IF (IDID .EQ. 1) GO TO 100 C C Finish up. C IF (IDID .LT. 1) IPASS = 0 IF (KPRINT.GT.1 .AND. IDID.LT.1) WRITE (LUN, 9030) IDID IF (KPRINT.GT.1 .AND. IPASS.EQ.1) WRITE (LUN, 9040) IF (KPRINT.GE.1 .AND. IPASS.EQ.0) WRITE (LUN, 9050) RETURN C C FORMATs. C 9000 FORMAT ('1'/' ------------ DEABM QUICK CHECK OUTPUT', + ' ------------') 9010 FORMAT (/ ' RELERR = ', E16.8, ' ABSERR =', E16.8 / + 12X, 'T', 19X, 'R' / 2E20.8) 9020 FORMAT (2E20.8) 9030 FORMAT (1X, 'ERROR RETURN FROM DEABM. IDID = ', I3) 9040 FORMAT (/ ' ------------ DEABM PASSED TESTS ------------') 9050 FORMAT (/ ' ************ DEABM FAILED TESTS ************') END *DECK QXBDF SUBROUTINE QXBDF (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QXBDF C***PURPOSE Test the DEPAC routine DEBDF. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (QXBDF-S, QXDBDF-D) C***KEYWORDS QUICK CHECK C***AUTHOR Chow, Jeff, (LANL) C***DESCRIPTION C C *Usage: C C INTEGER LUN, KPRINT, IPASS C C CALL QXBDF (LUN, KPRINT, IPASS) C C *Arguments: C C LUN :IN is the unit number to which output is to be written. C C KPRINT:IN controls the amount of output, as specified in the C SLATEC Guidelines. C C IPASS:OUT will contain a pass/fail flag. IPASS=1 is good. C IPASS=0 indicates one or more tests failed. C C *Description: C C DEBDF is tested by solving the equations of motion of a body C moving in a plane about a spherical earth, namely C (D/DT)(D/DT)X = -G*X/R**3 C (D/DT)(D/DT)Y = -G*Y/R**3 C where G = 1, R = SQRT(X**2 + Y**2) and C X(0) = 1 C (D/DT)X(0) = 0 C Y(0) = 0 C (D/DT)Y(0) = 1. C C***ROUTINES CALLED DEBDF, FDEQC, JAC, R1MACH C***REVISION HISTORY (YYMMDD) C 810801 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900415 Code extensively revised. (WRB) C***END PROLOGUE QXBDF C C Declare arguments. C INTEGER LUN, KPRINT, IPASS C C Declare local variables. C INTEGER IDID, INFO(15), IPAR, IWORK(60), N, LIW, LRW REAL ABSERR, R, R1MACH, RELERR, RELTOL, RPAR, RWORK(306), T, TOUT, + U(4) EXTERNAL FDEQC, JAC C***FIRST EXECUTABLE STATEMENT QXBDF IF (KPRINT .GE. 2) WRITE (LUN, 9000) C C Initialize problem. C N = 4 LRW = 306 LIW = 60 T = 0.0E0 TOUT = 8.0E0*ATAN(1.0E0) U(1) = 1.0E0 U(2) = 0.0E0 U(3) = 0.0E0 U(4) = 1.0E0 IPASS = 1 RELTOL = SQRT(R1MACH(4)) RELERR = 0.001E0*RELTOL ABSERR = RELERR**1.5E0 INFO(1) = 0 INFO(2) = 0 INFO(3) = 1 INFO(4) = 0 INFO(5) = 1 INFO(6) = 0 IF (KPRINT .GT. 2) WRITE (LUN, 9010) RELERR, ABSERR, T, (1.0E0) C 100 CALL DEBDF (FDEQC, N, T, U, TOUT, INFO, RELERR, ABSERR, + IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) R = SQRT(U(1)*U(1)+U(2)*U(2)) IF (ABS(R-1.0E0) .GT. RELTOL) IPASS = 0 IF (KPRINT .GT. 2) WRITE (LUN, 9020) T, R INFO(1) = 1 IF (IDID .EQ. 1) GO TO 100 C C Finish up. C IF (IDID .LT. 1) IPASS = 0 IF (KPRINT.GT.1 .AND. IDID.LT.1) WRITE (LUN, 9030) IDID IF (KPRINT.GT.1 .AND. IPASS.EQ.1) WRITE (LUN, 9040) IF (KPRINT.GE.1 .AND. IPASS.EQ.0) WRITE (LUN, 9050) RETURN C C FORMATs. C 9000 FORMAT ('1'/' ------------ DEBDF QUICK CHECK OUTPUT', + ' ------------') 9010 FORMAT (/ ' RELERR = ', E16.8, ' ABSERR =', E16.8 / + 12X, 'T', 19X, 'R' / 2E20.8) 9020 FORMAT (2E20.8) 9030 FORMAT (1X, 'ERROR RETURN FROM DEBDF. IDID = ', I3) 9040 FORMAT (/ ' ------------ DEBDF PASSED TESTS ------------') 9050 FORMAT (/ ' ************ DEBDF FAILED TESTS ************') END *DECK QXBLKT SUBROUTINE QXBLKT (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QXBLKT C***PURPOSE C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * * C * F I S H P A K * C * * C * * C * A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF * C * * C * SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS * C * * C * (VERSION 3 , JUNE 1979) * C * * C * BY * C * * C * JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET * C * * C * OF * C * * C * THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH * C * * C * BOULDER, COLORADO (80307) U.S.A. * C * * C * WHICH IS SPONSORED BY * C * * C * THE NATIONAL SCIENCE FOUNDATION * C * * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C C PROGRAM TO ILLUSTRATE THE USE OF BLKTRI C C***ROUTINES CALLED BLKTRI C***REVISION HISTORY (YYMMDD) C 800103 DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Added PASS/FAIL message and cleaned up FORMATs. (RWC) C***END PROLOGUE QXBLKT DIMENSION Y(75,105), AM(75), BM(75), CM(75), AN(105), BN(105), 1 CN(105), W(1952), S(75), T(105) C***FIRST EXECUTABLE STATEMENT QXBLKT ERMAX=1.E-3 IFLG = 0 NP = 1 N = 63 MP = 1 M = 50 IDIMY = 75 C C GENERATE AND STORE GRID POINTS FOR THE PURPOSE OF COMPUTING THE C COEFFICIENTS AND THE ARRAY Y. C DELTAS = 1.0E0/(M+1) DO 101 I=1,M S(I) = I * DELTAS 101 CONTINUE DELTAT = 1.0E0/(N+1) DO 102 J=1,N T(J) = J*DELTAT 102 CONTINUE C C COMPUTE THE COEFFICIENTS AM, BM AND CM CORRESPONDING TO THE S C DIRECTION. C HDS = DELTAS/2. TDS = DELTAS+DELTAS DO 103 I=1,M TEMP1 = 1./(S(I)*TDS) TEMP2 = 1./((S(I)-HDS)*TDS) TEMP3 = 1./((S(I)+HDS)*TDS) AM(I) = TEMP1*TEMP2 CM(I) = TEMP1*TEMP3 BM(I) = -(AM(I)+CM(I)) 103 CONTINUE C C COMPUTE THE COEFFICIENTS AN, BN AND CN CORRESPONDING TO THE T C DIRECTION. C HDT = DELTAT/2. TDT = DELTAT+DELTAT DO 104 J=1,N TEMP1 = 1./(T(J)*TDT) TEMP2 = 1./((T(J)-HDT)*TDT) TEMP3 = 1./((T(J)+HDT)*TDT) AN(J) = TEMP1*TEMP2 CN(J) = TEMP1*TEMP3 BN(J) = -(AN(J)+CN(J)) 104 CONTINUE C C COMPUTE RIGHT SIDE OF EQUATION C DO 106 J=1,N DO 105 I=1,M Y(I,J) = 3.75*S(I)*T(J)*(S(I)**4.+T(J)**4.) 105 CONTINUE 106 CONTINUE C C INCLUDE NONHOMOGENEOUS BOUNDARY INTO RIGHT SIDE. NOTE THAT THE C CORNER AT J=N,I=M INCLUDES CONTRIBUTIONS FROM BOTH BOUNDARIES. C DO 107 J=1,N Y(M,J) = Y(M,J)-CM(M)*T(J)**5. 107 CONTINUE DO 108 I=1,M Y(I,N) = Y(I,N)-CN(N)*S(I)**5. 108 CONTINUE C 109 CALL BLKTRI (IFLG,NP,N,AN,BN,CN,MP,M,AM,BM,CM,IDIMY,Y,IERROR,W) IFLG = IFLG+1 IF (IFLG-1) 109,109,110 C C COMPUTE DISCRETIZATION ERROR C 110 ERR = 0. DO 112 J=1,N DO 111 I=1,M Z = ABS(Y(I,J)-(S(I)*T(J))**5.) IF (Z .GT. ERR) ERR = Z 111 CONTINUE 112 CONTINUE C IPASS = 1 IF (ERR.GT.ERMAX) IPASS = 0 IF (KPRINT.EQ.0) RETURN IF (KPRINT.GE.2 .OR. IPASS.EQ.0) THEN WRITE (LUN,1001) IERROR,ERR,INT(W(1)) IF (IPASS.EQ.1) THEN WRITE (LUN, 1002) ELSE WRITE (LUN, 1003) ENDIF ENDIF RETURN C 1001 FORMAT ('1',20X,'SUBROUTINE BLKTRI EXAMPLE'/// 1 10X,'THE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS'// 2 32X,'IERROR = 0'/ 3 18X,'DISCRETIZATION ERROR = 1.6478E-05'/ 4 12X,'REQUIRED LENGTH OF W ARRAY = 823'// 5 10X,'THE OUTPUT FROM YOUR COMPUTER IS'// 6 32X,'IERROR =',I2/ 7 18X,'DISCRETIZATION ERROR =',1PE12.5/ 8 12X,'REQUIRED LENGTH OF W ARRAY =', I4) 1002 FORMAT (60X,'PASS'/) 1003 FORMAT (60X,'FAIL'/) END *DECK QXBVSP SUBROUTINE QXBVSP (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QXBVSP C***PURPOSE Quick check for BVSUP. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (QXBVSP-S, QXDBVS-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED BVSUP, PASS C***COMMON BLOCKS SAVEX C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901014 Made editorial changes and added correct result to C output. (RWC) C 910708 Minor modifications in use of KPRINT. (WRB) C***END PROLOGUE QXBVSP INTEGER ITMP(9), IWORK(100) DIMENSION Y(4,15),XPTS(15),A(2,4),ALPHA(2),B(2,4),BETA(2), 1 YANS(2,15),WORK(1000) CHARACTER*4 MSG COMMON /SAVEX/ XSAVE, TERM DATA YANS(1,1),YANS(2,1),YANS(1,2),YANS(2,2), 1 YANS(1,3),YANS(2,3),YANS(1,4),YANS(2,4), 2 YANS(1,5),YANS(2,5),YANS(1,6),YANS(2,6), 3 YANS(1,7),YANS(2,7),YANS(1,8),YANS(2,8), 4 YANS(1,9),YANS(2,9),YANS(1,10),YANS(2,10), 5 YANS(1,11),YANS(2,11),YANS(1,12),YANS(2,12), 6 YANS(1,13),YANS(2,13),YANS(1,14),YANS(2,14), 7 YANS(1,15),YANS(2,15)/ 8 5.000000000E+00,-6.888880126E-01, 8.609248635E+00, 9 -1.083092311E+00, 1.674923836E+01,-2.072210073E+00, 1 3.351098494E+01,-4.479263780E+00, 6.601103894E+01, 2 -8.909222513E+00, 8.579580988E+01,-1.098742758E+01, 3 1.106536877E+02,-1.402469444E+01, 1.421228220E+02, 4 -1.742236546E+01, 1.803383474E+02,-2.086465851E+01, 5 2.017054332E+02,-1.990879843E+01, 2.051622475E+02, 6 -1.324886978E+01, 2.059197452E+02, 1.051529813E+01, 7 1.972191446E+02, 9.320592785E+01, 1.556894846E+02, 8 3.801682434E+02, 1.818989404E-12, 1.379853993E+03/ DATA XPTS(1),XPTS(2),XPTS(3),XPTS(4),XPTS(5), 1 XPTS(6),XPTS(7),XPTS(8),XPTS(9),XPTS(10), 2 XPTS(11),XPTS(12),XPTS(13),XPTS(14),XPTS(15)/ 3 60.,55.,50.,45.,40.,38.,36.,34.,32.,31.,30.8,30.6, 4 30.4,30.2,30./ C***FIRST EXECUTABLE STATEMENT QXBVSP IF (KPRINT.GE.2) THEN WRITE (LUN,800) WRITE (LUN,810) ENDIF C C-----INITIALIZE VARIABLES FOR TEST PROBLEM. C DO 10 I = 1, 9 ITMP(I) = 0 10 CONTINUE C TOL = 1.0E-03 XSAVE = 0. NROWY = 4 NCOMP = 2 NXPTS = 15 A(1,1) = 1.0 A(1,2) = 0.0 NROWA = 2 ALPHA(1) = 5.0 NIC = 1 B(1,1) = 1.0 B(1,2) = 0.0 NROWB = 2 BETA(1) = 0.0 NFC = 1 IGOFX = 1 RE = 1.0E-05 AE = 1.0E-05 NDW = 1000 NDIW = 100 NEQIVP = 0 IPASS = 1 C DO 20 I = 1, 15 IWORK(I) = 0 20 CONTINUE C CALL BVSUP(Y,NROWY,NCOMP,XPTS,NXPTS,A,NROWA,ALPHA,NIC,B,NROWB, 1 BETA,NFC,IGOFX,RE,AE,IFLAG,WORK,NDW,IWORK,NDIW,NEQIVP) C C-----IF IFLAG = 0, WE HAVE A SUCCESSFUL SOLUTION; OTHERWISE, SKIP C THE ARGUMENT CHECKING AND GO TO THE END. C IF (IFLAG.NE.0) THEN IPASS = 0 IF (KPRINT .GT. 1) WRITE (LUN,820) IFLAG GO TO 170 ENDIF C C-----CHECK THE ACCURACY OF THE SOLUTION. C NUMORT = IWORK(1) DO 50 J = 1, NXPTS DO 40 L = 1, 2 ABSER = ABS(YANS(L,J)-Y(L,J)) RELER = ABSER/ABS(YANS(L,J)) IF (RELER.GT.TOL .AND. ABSER.GT.TOL) IPASS = 0 40 CONTINUE 50 CONTINUE C C-----CHECK FOR SUPPRESSION OF PRINTING. C IF (KPRINT.EQ.0 .OR. (KPRINT.EQ.1 .AND. IPASS.EQ.1)) GO TO 190 C IF (KPRINT.NE.1 .OR. IPASS.NE.0) THEN IF (KPRINT.GE.3 .OR. IPASS.EQ.0) THEN WRITE (LUN,830) WRITE (LUN,840) NUMORT WRITE (LUN,850) (WORK(J),J = 1, NUMORT) WRITE (LUN,860) DO 60 J = 1, NXPTS MSG = 'PASS' ABSER = ABS(YANS(1,J)-Y(1,J)) RELER = ABSER/ABS(YANS(1,J)) IF (RELER.GT.TOL .AND. ABSER.GT.TOL) MSG = 'FAIL' ABSER = ABS(YANS(2,J)-Y(2,J)) RELER = ABSER/ABS(YANS(2,J)) IF (RELER.GT.TOL .AND. ABSER.GT.TOL) MSG = 'FAIL' WRITE (LUN,870) XPTS(J),Y(1,J),Y(2,J),YANS(1,J), * YANS(2,J),MSG 60 CONTINUE ENDIF ENDIF C C-----SEND MESSAGE INDICATING PASSAGE OR FAILURE OF TESTS. C CALL PASS (LUN, 1, IPASS) C C-----ERROR MESSAGE TESTS. C IF (KPRINT.EQ.1) GO TO 190 KONT = 1 WRITE (LUN,880) C C-----NROWY LESS THAN NCOMP C KOUNT = 1 NROWY = 1 150 DO 160 I = 1, 15 IWORK(I) = 0 160 CONTINUE CALL BVSUP(Y,NROWY,NCOMP,XPTS,NXPTS,A,NROWA,ALPHA,NIC,B,NROWB, 1 BETA,NFC,IGOFX,RE,AE,IFLAG,WORK,NDW,IWORK,NDIW,NEQIVP) GO TO (80,90,100,110,120,130,140), KOUNT C 80 WRITE (LUN,900) IFLAG IF (IFLAG .EQ. -2) ITMP(KONT) = 1 KONT = KONT + 1 C C-----IGOFX NOT EQUAL TO 0 OR 1 C KOUNT = 2 NROWY = 2 IGOFX = 3 GO TO 150 C 90 WRITE (LUN,900) IFLAG IF (IFLAG .EQ. -2) ITMP(KONT) = 1 KONT = KONT + 1 C C-----RE OR AE NEGATIVE C KOUNT = 3 IGOFX = 1 RE = -1. AE = -2. GO TO 150 C 100 WRITE (LUN,900) IFLAG IF (IFLAG .EQ. -2) ITMP(KONT) = 1 KONT = KONT + 1 C C-----NROWA LESS THAN NIC C KOUNT = 4 RE = 1.0E-05 AE = 1.0E-05 NROWA = 0 C 110 WRITE (LUN,900) IFLAG IF (IFLAG .EQ. -2) ITMP(KONT) = 1 KONT = KONT + 1 C-----NROWB LESS THAN NFC KOUNT = 5 NROWA = 2 NROWB = 0 C 120 WRITE (LUN,900) IFLAG IF (IFLAG .EQ. -2) ITMP(KONT) = 1 KONT = KONT + 1 C-----STORAGE ALLOCATION IS INSUFFICIENT KOUNT = 6 NROWB = 2 NDIW = 17 GO TO 150 C 130 WRITE (LUN,910) IFLAG IF (IFLAG .EQ. -1) ITMP(KONT) = 1 KONT = KONT + 1 C-----INCORRECT ORDERING OF XPTS KOUNT = 7 NDIW = 100 SVE = XPTS(1) XPTS(1) = XPTS(4) XPTS(4) = SVE GO TO 150 C 140 WRITE (LUN,900) IFLAG IF (IFLAG .EQ. -2) ITMP(KONT) = 1 C C-----SEE IF IFLAG TESTS PASSED C 170 IPSS = 1 DO 180 I = 1, KONT IPSS = IPSS*ITMP(I) 180 CONTINUE C CALL PASS (LUN, 2, IPSS) C C SEE IF ALL TESTS PASSED. C IPASS = IPASS*IPSS C 190 IF (IPASS .EQ. 1 .AND. KPRINT .GT. 1) WRITE (LUN,980) IF (IPASS .EQ. 0 .AND. KPRINT .NE. 0) WRITE (LUN,990) RETURN C 800 FORMAT ('1') 810 FORMAT (/' BVSUP QUICK CHECK') 820 FORMAT (10X,'IFLAG =',I2) 830 FORMAT (/' ACCURACY TEST') 840 FORMAT (/' NUMBER OF ORTHONORMALIZATIONS =',I3) 850 FORMAT (/' ORTHONORMALIZATION POINTS ARE'/(1X,4F10.2)) 860 FORMAT (//20X,'CALCULATION',30X,'TRUE SOLUTION'/ * 2X,'X',14X,'Y',17X,'Y-PRIME',15X,'Y',17X,'Y-PRIME'/) 870 FORMAT (F5.1,4E20.7,5X,A) 880 FORMAT (/' (7) TESTS OF IFLAG VALUES') 900 FORMAT (/' IFLAG SHOULD BE -2, IFLAG =',I3) 910 FORMAT (/' IFLAG SHOULD BE -1, IFLAG =',I3) 980 FORMAT (/' ****************BVSUP PASSED ALL TESTS***************') 990 FORMAT (/' ****************BVSUP FAILED SOME TESTS**************') END *DECK QXCRT SUBROUTINE QXCRT (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QXCRT C***PURPOSE C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * * C * F I S H P A K * C * * C * * C * A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF * C * * C * SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS * C * * C * (VERSION 3 , JUNE 1979) * C * * C * BY * C * * C * JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET * C * * C * OF * C * * C * THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH * C * * C * BOULDER, COLORADO (80307) U.S.A. * C * * C * WHICH IS SPONSORED BY * C * * C * THE NATIONAL SCIENCE FOUNDATION * C * * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C C PROGRAM TO ILLUSTRATE THE USE OF SUBROUTINE HWSCRT TO SOLVE C THE EQUATION C C (D/DX)(DU/DX) + (D/DY)(DU/DY) - 4*U C C = (2 - (4 + PI**2/4)*X**2)*COS((Y+1)*PI/2) C C WITH THE BOUNDARY CONDITIONS C ON THE RECTANGLE 0 .LT. X .LT. 2, -1 .LT. Y .LT. 3 WITH THE C C U(0,Y) = 0 C -1 .LE. Y .LE. 3 C (DU/DX)(2,Y) = 4*COS((Y+1)*PI/2) C C AND WITH U PERIODIC IN Y. C THE X-INTERVAL WILL BE DIVIDED INTO 40 PANELS AND THE C Y-INTERVAL WILL BE DIVIDED INTO 80 PANELS. C C***ROUTINES CALLED HWSCRT, PIMACH C***REVISION HISTORY (YYMMDD) C 800103 DATE WRITTEN C 890718 Changed computation of PI to use PIMACH. (WRB) C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Added PASS/FAIL message and cleaned up FORMATs. (RWC) C***END PROLOGUE QXCRT DIMENSION F(45,82), BDB(81), W(1200), X(41), Y(81) C***FIRST EXECUTABLE STATEMENT QXCRT C C FROM DIMENSION STATEMENT WE GET VALUE OF IDIMF. ALSO NOTE THAT W C IS DIMENSIONED 6*(N+1) + 8*(M+1). C IDIMF = 45 ERMAX=1.E-3 A = 0. B = 2. M = 40 MBDCND = 2 C = -1. D = 3. N = 80 NBDCND = 0 ELMBDA = -4. C C AUXILIARY QUANTITIES. C PI = PIMACH(DUM) PIBY2 = PI/2. PISQ = PI**2 MP1 = M+1 NP1 = N+1 C C GENERATE AND STORE GRID POINTS FOR THE PURPOSE OF COMPUTING C BOUNDARY DATA AND THE RIGHT SIDE OF THE HELMHOLTZ EQUATION. C DO 101 I=1,MP1 X(I) = (I-1)/20.0E0 101 CONTINUE DO 102 J=1,NP1 Y(J) = -1.0E0+(J-1)/20.0E0 102 CONTINUE C C GENERATE BOUNDARY DATA. C DO 103 J=1,NP1 BDB(J) = 4.*COS((Y(J)+1.)*PIBY2) 103 CONTINUE C C BDA, BDC, AND BDD ARE DUMMY VARIABLES. C DO 104 J=1,NP1 F(1,J) = 0. 104 CONTINUE C C GENERATE RIGHT SIDE OF EQUATION. C DO 106 I=2,MP1 DO 105 J=1,NP1 F(I,J) = (2.-(4.+PISQ/4.)*X(I)**2)*COS((Y(J)+1.)*PIBY2) 105 CONTINUE 106 CONTINUE CALL HWSCRT(A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,ELMBDA,F, 1 IDIMF,PERTRB,IERROR,W) C C COMPUTE DISCRETIZATION ERROR. THE EXACT SOLUTION IS C U(X,Y) = X**2*COS((Y+1)*PIBY2) C ERR = 0. DO 108 I=1,MP1 DO 107 J=1,NP1 Z = ABS(F(I,J)-X(I)**2*COS((Y(J)+1.)*PIBY2)) IF (Z .GT. ERR) ERR = Z 107 CONTINUE 108 CONTINUE C IPASS = 1 IF (ERR.GT.ERMAX) IPASS = 0 IF (KPRINT.EQ.0) RETURN IF (KPRINT.GE.2 .OR. IPASS.EQ.0) THEN WRITE (LUN,1001) IERROR,ERR,INT(W(1)) IF (IPASS.EQ.1) THEN WRITE (LUN, 1002) ELSE WRITE (LUN, 1003) ENDIF ENDIF RETURN C 1001 FORMAT ('1',20X,'SUBROUTINE HWSCRT EXAMPLE'/// 1 10X,'THE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS'// 2 32X,'IERROR = 0'/ 3 18X,'DISCRETIZATION ERROR = 5.36508E-04'/ 4 12X,'REQUIRED LENGTH OF W ARRAY = 880'// 5 10X,'THE OUTPUT FROM YOUR COMPUTER IS'// 6 32X,'IERROR =',I2/ 7 18X,'DISCRETIZATION ERROR =',1PE12.5/ 8 12X,'REQUIRED LENGTH OF W ARRAY =',I4) 1002 FORMAT (60X,'PASS'/) 1003 FORMAT (60X,'FAIL'/) END *DECK QXCSP SUBROUTINE QXCSP (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QXCSP C***PURPOSE C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * * C * F I S H P A K * C * * C * * C * A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF * C * * C * SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS * C * * C * (VERSION 3 , JUNE 1979) * C * * C * BY * C * * C * JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET * C * * C * OF * C * * C * THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH * C * * C * BOULDER, COLORADO (80307) U.S.A. * C * * C * WHICH IS SPONSORED BY * C * * C * THE NATIONAL SCIENCE FOUNDATION * C * * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C C PROGRAM TO ILLUSTRATE THE USE OF HWSCSP C C***ROUTINES CALLED HWSCSP, PIMACH C***REVISION HISTORY (YYMMDD) C 800103 DATE WRITTEN C 890718 Changed computation of PI to use PIMACH. (WRB) C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Added PASS/FAIL message and cleaned up FORMATs. (RWC) C***END PROLOGUE QXCSP DIMENSION F(48,33), BDTF(33), W(1200), R(33), THETA(48) C***FIRST EXECUTABLE STATEMENT QXCSP C C THE VALUE OF IDIMF IS THE FIRST DIMENSION OF F. SINCE M=36, N=32, C L=N THEREFORE K=5 AND W IS DIMENSIONED 2*(L+1)*(K-1) + 6*(M+N) C + MAX(4*N,6*M) + 14 = 902. C ERMAX=1.E-3 PI = PIMACH(DUM) INTL = 0 TS = 0. TF = PI/2. M = 36 MBDCND = 6 RS = 0. RF = 1. N = 32 NBDCND = 5 ELMBDA = 0. IDIMF = 48 C C GENERATE AND STORE GRID POINTS FOR THE PURPOSE OF COMPUTING THE C BOUNDARY DATA AND THE RIGHT SIDE OF THE EQUATION. C MP1 = M+1 DTHETA = TF/M DO 101 I=1,MP1 THETA(I) = (I-1)*DTHETA 101 CONTINUE NP1 = N+1 DR = 1.0E0/N DO 102 J=1,NP1 R(J) = (J-1)*DR 102 CONTINUE C C GENERATE NORMAL DERIVATIVE DATA AT EQUATOR C DO 103 J=1,NP1 BDTF(J) = 0. 103 CONTINUE C C COMPUTE BOUNDARY DATA ON THE SURFACE OF THE SPHERE C DO 104 I=1,MP1 F(I,N+1) = COS(THETA(I))**4 104 CONTINUE C C COMPUTE RIGHT SIDE OF EQUATION C DO 106 I=1,MP1 CI4 = 12.0E0*COS(THETA(I))**2 DO 105 J=1,N F(I,J) = CI4*R(J)**2 105 CONTINUE 106 CONTINUE C CALL HWSCSP (INTL,TS,TF,M,MBDCND,BDTS,BDTF,RS,RF,N,NBDCND,BDRS, 1 BDRF,ELMBDA,F,IDIMF,PERTRB,IERROR,W) C C COMPUTE DISCRETIZATION ERROR C ERR = 0. DO 108 I=1,MP1 CI4 = COS(THETA(I))**4 DO 107 J=1,N Z = ABS(F(I,J)-CI4*R(J)**4) IF (Z .GT. ERR) ERR = Z 107 CONTINUE 108 CONTINUE C IPASS = 1 IF (ERR.GT.ERMAX) IPASS = 0 IF (KPRINT.NE.0) THEN IF (KPRINT.GE.2 .OR. IPASS.EQ.0) THEN WRITE (LUN,1001) IERROR,ERR,INT(W(1)) IF (IPASS.EQ.1) THEN WRITE (LUN, 1003) ELSE WRITE (LUN, 1004) ENDIF ENDIF ENDIF C C THE FOLLOWING PROGRAM ILLUSTRATES THE USE OF HWSCSP TO SOLVE C A THREE DIMENSIONAL PROBLEM WHICH HAS LONGITUDINAL DEPENDENCE C MBDCND = 2 NBDCND = 1 DPHI = PI/72. ELMBDA = -2.0E0*(1.0E0-COS(DPHI))/DPHI**2 C C COMPUTE BOUNDARY DATA ON THE SURFACE OF THE SPHERE C DO 109 I=1,MP1 F(I,N+1) = SIN(THETA(I)) 109 CONTINUE C C COMPUTE RIGHT SIDE OF THE EQUATION C DO 111 J=1,N DO 110 I=1,MP1 F(I,J) = 0. 110 CONTINUE 111 CONTINUE C CALL HWSCSP (INTL,TS,TF,M,MBDCND,BDTS,BDTF,RS,RF,N,NBDCND,BDRS, 1 BDRF,ELMBDA,F,IDIMF,PERTRB,IERROR,W) C C COMPUTE DISCRETIZATION ERROR (FOURIER COEFFICIENTS) C ERR = 0. DO 113 I=1,MP1 SI = SIN(THETA(I)) DO 112 J=1,NP1 Z = ABS(F(I,J)-R(J)*SI) IF (Z .GT. ERR) ERR = Z 112 CONTINUE 113 CONTINUE C IF (ERR.GT.ERMAX) IPASS = 0 IF (KPRINT.EQ.0) RETURN IF (KPRINT.GE.2 .OR. IPASS.EQ.0) THEN WRITE (LUN,1002) IERROR,ERR,INT(W(1)) IF (IPASS.EQ.1) THEN WRITE (LUN, 1003) ELSE WRITE (LUN, 1004) ENDIF ENDIF RETURN C 1001 FORMAT ('1',20X,'SUBROUTINE HWSCSP EXAMPLE 1'/// 1 10X,'THE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS'// 2 32X,'IERROR = 0'/ 3 18X,'DISCRETIZATION ERROR = 7.99842E-04'/ 4 12X,'REQUIRED LENGTH OF W ARRAY = 775'// 5 10X,'THE OUTPUT FROM YOUR COMPUTER IS'// 6 32X,'IERROR =',I2/ 7 18X,'DISCRETIZATION ERROR =',1PE12.5/ 8 12X,'REQUIRED LENGTH OF W ARRAY =',I4) 1002 FORMAT ('1',20X,'SUBROUTINE HWSCSP EXAMPLE 2'/// 1 10X,'THE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS'// 2 32X,'IERROR = 0'/ 3 18X,'DISCRETIZATION ERROR = 5.86824E-05'/ 4 12X,'REQUIRED LENGTH OF W ARRAY = 775'// 5 10X,'THE OUTPUT FROM YOUR COMPUTER IS'// 6 32X,'IERROR =',I2/ 7 18X,'DISCRETIZATION ERROR =',1PE12.5/ 8 12X,'REQUIRED LENGTH OF W ARRAY =',I4) 1003 FORMAT (60X,'PASS'/) 1004 FORMAT (60X,'FAIL'/) END *DECK QXCYL SUBROUTINE QXCYL (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QXCYL C***PURPOSE C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * * C * F I S H P A K * C * * C * * C * A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF * C * * C * SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS * C * * C * (VERSION 3 , JUNE 1979) * C * * C * BY * C * * C * JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET * C * * C * OF * C * * C * THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH * C * * C * BOULDER, COLORADO (80307) U.S.A. * C * * C * WHICH IS SPONSORED BY * C * * C * THE NATIONAL SCIENCE FOUNDATION * C * * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C C PROGRAM TO ILLUSTRATE THE USE OF SUBROUTINE HWSCYL TO SOLVE C THE EQUATION C C (1/R)(D/DR)(R*(DU/DR)) + (D/DZ)(DU/DZ) C C = (2*R*Z)**2*(4*Z**2 + 3*R**2) C C ON THE RECTANGLE 0 .LT. R .LT. 1, 0 .LT. Z .LT. 1 WITH THE C BOUNDARY CONDITIONS C C U(0,Z) UNSPECIFIED C 0 .LE. Z .LE. 1 C (DU/DR)(1,Z) = 4*Z**4 C C AND C C (DU/DZ)(R,0) = 0 C 0 .LE. R .LE. 1 C (DU/DZ)(R,1) = 4*R**4 . C C THE R-INTERVAL WILL BE DIVIDED INTO 50 PANELS AND THE C Z-INTERVAL WILL BE DIVIDED INTO 100 PANELS. C C***ROUTINES CALLED HWSCYL C***REVISION HISTORY (YYMMDD) C 800103 DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Added PASS/FAIL message and cleaned up FORMATs. (RWC) C***END PROLOGUE QXCYL DIMENSION F(75,105), BDA(101), BDB(101), BDC(51), BDD(51), 1 W(1200), R(51), Z(101) C***FIRST EXECUTABLE STATEMENT QXCYL C C FROM DIMENSION STATEMENT WE GET VALUE OF IDIMF. ALSO NOTE THAT W C IS DIMENSIONED 6*(N+1) + 8*(M+1). C IDIMF = 75 ERMAX=1.E-3 A = 0. B = 1. M = 50 MBDCND = 6 C = 0. D = 1. N = 100 NBDCND = 3 ELMBDA = 0. C C AUXILIARY QUANTITIES. C MP1 = M+1 NP1 = N+1 C C GENERATE AND STORE GRID POINTS FOR THE PURPOSE OF COMPUTING C BOUNDARY DATA AND THE RIGHT SIDE OF THE POISSON EQUATION. C DO 101 I=1,MP1 R(I) = (I-1)/50.0E0 101 CONTINUE DO 102 J=1,NP1 Z(J) = (J-1)/100.0E0 102 CONTINUE C C GENERATE BOUNDARY DATA. C DO 103 J=1,NP1 BDB(J) = 4.*Z(J)**4 103 CONTINUE DO 104 I=1,MP1 BDC(I) = 0. BDD(I) = 4.*R(I)**4 104 CONTINUE C C BDA IS A DUMMY VARIABLE. C C C GENERATE RIGHT SIDE OF EQUATION. C DO 106 I=1,MP1 DO 105 J=1,NP1 F(I,J) = 4.*R(I)**2*Z(J)**2*(4.*Z(J)**2+3.*R(I)**2) 105 CONTINUE 106 CONTINUE CALL HWSCYL(A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,ELMBDA,F, 1 IDIMF,PERTRB,IERROR,W) C C COMPUTE DISCRETIZATION ERROR BY MINIMIZING OVER ALL A THE FUNCTION C NORM(F(I,J) - A*1 - U(R(I),Z(J))). THE EXACT SOLUTION IS C U(R,Z) = (R*Z)**4 + ARBITRARY CONSTANT. C X = 0. DO 108 I=1,MP1 DO 107 J=1,NP1 X = X+F(I,J)-(R(I)*Z(J))**4 107 CONTINUE 108 CONTINUE X = X/(NP1*MP1) DO 110 I=1,MP1 DO 109 J=1,NP1 F(I,J) = F(I,J)-X 109 CONTINUE 110 CONTINUE ERR = 0. DO 112 I=1,MP1 DO 111 J=1,NP1 X = ABS(F(I,J)-(R(I)*Z(J))**4) IF (X .GT. ERR) ERR = X 111 CONTINUE 112 CONTINUE C IPASS = 1 IF (ERR.GT.ERMAX) IPASS = 0 IF (KPRINT.EQ.0) RETURN IF (KPRINT.GE.2 .OR. IPASS.EQ.0) THEN WRITE (LUN,1001) IERROR,PERTRB,ERR,INT(W(1)) IF (IPASS.EQ.1) THEN WRITE (LUN, 1002) ELSE WRITE (LUN, 1003) ENDIF ENDIF RETURN C 1001 FORMAT ('1',20X,'SUBROUTINE HWSCYL EXAMPLE'/// 1 10X,'THE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS'// 2 32X,'IERROR = 0'/ 3 32X,'PERTRB = 2.26734E-04'/ 4 18X,'DISCRETIZATION ERROR = 3.73672E-04'/ 5 12X,'REQUIRED LENGTH OF W ARRAY = 1118'// 6 10X,'THE OUTPUT FROM YOUR COMPUTER IS'// 7 32X,'IERROR =',I2/ 8 32X,'PERTRB =',E12.5/ 9 18X,'DISCRETIZATION ERROR =',1PE12.5/ A 12X,'REQUIRED LENGTH OF W ARRAY =',I4) 1002 FORMAT (60X,'PASS'/) 1003 FORMAT (60X,'FAIL'/) END *DECK QXDABM SUBROUTINE QXDABM (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QXDABM C***PURPOSE Test the DEPAC routine DDEABM. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (QXABM-S, QXDABM-D) C***KEYWORDS QUICK CHECK C***AUTHOR Chow, Jeff, (LANL) C***DESCRIPTION C C *Usage: C C INTEGER LUN, KPRINT, IPASS C C CALL QXDABM (LUN, KPRINT, IPASS) C C *Arguments: C C LUN :IN is the unit number to which output is to be written. C C KPRINT:IN controls the amount of output, as specified in the C SLATEC Guidelines. C C IPASS:OUT will contain a pass/fail flag. IPASS=1 is good. C IPASS=0 indicates one or more tests failed. C C *Description: C C DDEABM is tested by solving the equations of motion of a body C moving in a plane about a spherical earth, namely C (D/DT)(D/DT)X = -G*X/R**3 C (D/DT)(D/DT)Y = -G*Y/R**3 C where G = 1, R = SQRT(X**2 + Y**2) and C X(0) = 1 C (D/DT)X(0) = 0 C Y(0) = 0 C (D/DT)Y(0) = 1. C C***ROUTINES CALLED D1MACH, DDEABM, DFDEQC C***REVISION HISTORY (YYMMDD) C 810801 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900415 Code extensively revised. (WRB) C***END PROLOGUE QXDABM C C Declare arguments. C INTEGER LUN, KPRINT, IPASS C C Declare local variables. C INTEGER IDID, INFO(15), IPAR, IWORK(51), N, LIW, LRW, NSTEP DOUBLE PRECISION ABSERR, D1MACH, R, RELERR, RELTOL, RPAR, + RWORK(214), T, TOUT, U(4) EXTERNAL DFDEQC C***FIRST EXECUTABLE STATEMENT QXDABM IF (KPRINT .GE. 2) WRITE (LUN, 9000) C C Initialize problem. C N = 4 LRW = 214 LIW = 51 T = 0.0D0 TOUT = 8.0D0*ATAN(1.0D0) U(1) = 1.0D0 U(2) = 0.0D0 U(3) = 0.0D0 U(4) = 1.0D0 IPASS = 1 NSTEP = 0 RELTOL = SQRT(D1MACH(4)) RELERR = 0.1D0*RELTOL ABSERR = RELERR**1.5D0 INFO(1) = 0 INFO(2) = 0 INFO(3) = 1 INFO(4) = 0 IF (KPRINT .GT. 2) WRITE (LUN, 9010) RELERR, ABSERR, T, (1.0D0) C 100 CALL DDEABM (DFDEQC, N, T, U, TOUT, INFO, RELERR, ABSERR, + IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR) R = SQRT(U(1)*U(1)+U(2)*U(2)) IF (ABS(R-1.0D0) .GT. RELTOL) IPASS = 0 IF (KPRINT .GT. 2) WRITE (LUN, 9020) T, R INFO(1) = 1 IF (IDID .EQ. 1) GO TO 100 C C For the double precision version, we allow the integrator to take C up to 2000 steps before we declare failure. C IF (IDID .EQ. -1) THEN NSTEP = NSTEP + 500 IF (NSTEP .LT. 2000) GOTO 100 ENDIF C C Finish up. C IF (IDID .LT. 1) IPASS = 0 IF (KPRINT.GT.1 .AND. IDID.LT.1) WRITE (LUN, 9030) IDID IF (KPRINT.GT.1 .AND. IPASS.EQ.1) WRITE (LUN, 9040) IF (KPRINT.GE.1 .AND. IPASS.EQ.0) WRITE (LUN, 9050) RETURN C C FORMATs. C 9000 FORMAT ('1'/' ------------ DDEABM QUICK CHECK OUTPUT', + ' ------------') 9010 FORMAT (/ ' RELERR = ', D16.8, ' ABSERR =', D16.8 / + 12X, 'T', 19X, 'R' / 2D20.8) 9020 FORMAT (2D20.8) 9030 FORMAT (1X, 'ERROR RETURN FROM DDEABM. IDID = ', I3) 9040 FORMAT (/ ' ------------ DDEABM PASSED TESTS ------------') 9050 FORMAT (/ ' ************ DDEABM FAILED TESTS ************') END *DECK QXDBDF SUBROUTINE QXDBDF (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QXDBDF C***PURPOSE Test the DEPAC routine DDEBDF. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (QXBDF-S, QXDBDF-D) C***KEYWORDS QUICK CHECK C***AUTHOR Chow, Jeff, (LANL) C***DESCRIPTION C C *Usage: C C INTEGER LUN, KPRINT, IPASS C C CALL QXDBDF (LUN, KPRINT, IPASS) C C *Arguments: C C LUN :IN is the unit number to which output is to be written. C C KPRINT:IN controls the amount of output, as specified in the C SLATEC Guidelines. C C IPASS:OUT will contain a pass/fail flag. IPASS=1 is good. C IPASS=0 indicates one or more tests failed. C C *Description: C C DDEBDF is tested by solving the equations of motion of a body C moving in a plane about a spherical earth, namely C (D/DT)(D/DT)X = -G*X/R**3 C (D/DT)(D/DT)Y = -G*Y/R**3 C where G = 1, R = SQRT(X**2 + Y**2) and C X(0) = 1 C (D/DT)X(0) = 0 C Y(0) = 0 C (D/DT)Y(0) = 1. C C***ROUTINES CALLED D1MACH, DDEBDF, DFDEQC, DJAC C***REVISION HISTORY (YYMMDD) C 810801 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900415 Code extensively revised. (WRB) C***END PROLOGUE QXDBDF C C Declare arguments. C INTEGER LUN, KPRINT, IPASS C C Declare local variables. C INTEGER IDID, INFO(15), IPAR, IWORK(60), N, LIW, LRW, NSTEP DOUBLE PRECISION ABSERR, D1MACH, R, RELTOL, RELERR, RPAR, + RWORK(306), T, TOUT, U(4) EXTERNAL DFDEQC, DJAC C***FIRST EXECUTABLE STATEMENT QXDBDF IF (KPRINT .GE. 2) WRITE (LUN, 9000) C C Initialize problem. C N = 4 LRW = 306 LIW = 60 T = 0.0D0 TOUT = 8.0D0*ATAN(1.0D0) U(1) = 1.0D0 U(2) = 0.0D0 U(3) = 0.0D0 U(4) = 1.0D0 IPASS = 1 NSTEP = 0 RELTOL = MAX(SQRT(D1MACH(4)),1.D-9) RELERR = MAX(0.0001D0*RELTOL,1.D-12) ABSERR = RELERR**1.5D0 INFO(1) = 0 INFO(2) = 0 INFO(3) = 1 INFO(4) = 0 INFO(5) = 1 INFO(6) = 0 IF (KPRINT .GT. 2) WRITE (LUN, 9010) RELERR, ABSERR, T, (1.0D0) C 100 CALL DDEBDF (DFDEQC, N, T, U, TOUT, INFO, RELERR, ABSERR, + IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, DJAC) R = SQRT(U(1)*U(1)+U(2)*U(2)) IF (ABS(R-1.0D0) .GT. RELTOL) IPASS = 0 IF (KPRINT .GT. 2) WRITE (LUN, 9020) T, R INFO(1) = 1 IF (IDID .EQ. 1) GO TO 100 C C For the double precision version, we allow the integrator to take C up to 2000 steps before we declare failure. C IF (IDID .EQ. -1) THEN NSTEP = NSTEP + 500 IF (NSTEP .LT. 2000) GOTO 100 ENDIF C C Finish up. C IF (IDID .LT. 1) IPASS = 0 IF (KPRINT.GT.1 .AND. IDID.LT.1) WRITE (LUN, 9030) IDID IF (KPRINT.GT.1 .AND. IPASS.EQ.1) WRITE (LUN, 9040) IF (KPRINT.GE.1 .AND. IPASS.EQ.0) WRITE (LUN, 9050) RETURN C C FORMATs. C 9000 FORMAT ('1'/' ------------ DDEBDF QUICK CHECK OUTPUT', + ' ------------') 9010 FORMAT (/ ' RELERR = ', D16.8, ' ABSERR =', D16.8 / + 12X, 'T', 19X, 'R' / 2D20.8) 9020 FORMAT (2D20.8) 9030 FORMAT (1X, 'ERROR RETURN FROM DDEBDF. IDID = ', I3) 9040 FORMAT (/ ' ------------ DDEBDF PASSED TESTS ------------') 9050 FORMAT (/ ' ************ DDEBDF FAILED TESTS ************') END *DECK QXDBVS SUBROUTINE QXDBVS (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QXDBVS C***PURPOSE Quick check for DBVSUP. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (QXBVSP-S, QXDBVS-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED DBVSUP, PASS C***COMMON BLOCKS DSAVEX C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901014 Made editorial changes and added correct result to C output. (RWC) C 910708 Minor modifications in use of KPRINT. (WRB) C***END PROLOGUE QXDBVS INTEGER ITMP(9), IWORK(100) DOUBLE PRECISION WORK(1000),AE,RE,XSAVE,SVE,TERM,TOL DOUBLE PRECISION Y(4,15),XPTS(15),A(2,4),ALPHA(2),B(2,4),BETA(2), * YANS(2,15),RELER,ABSER CHARACTER*4 MSG COMMON /DSAVEX/ XSAVE, TERM DATA YANS(1,1),YANS(2,1),YANS(1,2),YANS(2,2), 1 YANS(1,3),YANS(2,3),YANS(1,4),YANS(2,4), 2 YANS(1,5),YANS(2,5),YANS(1,6),YANS(2,6), 3 YANS(1,7),YANS(2,7),YANS(1,8),YANS(2,8), 4 YANS(1,9),YANS(2,9),YANS(1,10),YANS(2,10), 5 YANS(1,11),YANS(2,11),YANS(1,12),YANS(2,12), 6 YANS(1,13),YANS(2,13),YANS(1,14),YANS(2,14), 7 YANS(1,15),YANS(2,15)/ 8 5.000000000D+00,-6.888880126D-01, 8.609248635D+00, 9 -1.083092311D+00, 1.674923836D+01,-2.072210073D+00, 1 3.351098494D+01,-4.479263780D+00, 6.601103894D+01, 2 -8.909222513D+00, 8.579580988D+01,-1.098742758D+01, 3 1.106536877D+02,-1.402469444D+01, 1.421228220D+02, 4 -1.742236546D+01, 1.803383474D+02,-2.086465851D+01, 5 2.017054332D+02,-1.990879843D+01, 2.051622475D+02, 6 -1.324886978D+01, 2.059197452D+02, 1.051529813D+01, 7 1.972191446D+02, 9.320592785D+01, 1.556894846D+02, 8 3.801682434D+02, 1.818989404D-12, 1.379853993D+03/ DATA XPTS(1),XPTS(2),XPTS(3),XPTS(4),XPTS(5), 1 XPTS(6),XPTS(7),XPTS(8),XPTS(9),XPTS(10), 2 XPTS(11),XPTS(12),XPTS(13),XPTS(14),XPTS(15)/ 3 60.0D+00,55.0D+00,50.0D+00,45.0D+00,40.0D+00,38.0D+00, 4 36.0D+00,34.0D+00,32.0D+00,31.0D+00,30.8D+00,30.6D+00, 5 30.4D+00,30.2D+00,30.0D+00/ C***FIRST EXECUTABLE STATEMENT QXDBVS IF (KPRINT.GE.2) THEN WRITE (LUN,800) WRITE (LUN,810) ENDIF C C-----INITIALIZE VARIABLES FOR TEST PROBLEM. C DO 10 I = 1, 9 ITMP(I) = 0 10 CONTINUE C TOL = 1.0D-03 XSAVE = 0.0D+00 NROWY = 4 NCOMP = 2 NXPTS = 15 A(1,1) = 1.0D+00 A(1,2) = 0.0D+00 NROWA = 2 ALPHA(1) = 5.0D+00 NIC = 1 B(1,1) = 1.0D+00 B(1,2) = 0.0D+00 NROWB = 2 BETA(1) = 0.0D+00 NFC = 1 IGOFX = 1 RE = 1.0D-05 AE = 1.0D-05 NDW = 1000 NDIW = 100 NEQIVP = 0 IPASS = 1 C DO 20 I = 1, 15 IWORK(I) = 0 20 CONTINUE C CALL DBVSUP(Y,NROWY,NCOMP,XPTS,NXPTS,A,NROWA,ALPHA,NIC,B,NROWB, 1 BETA,NFC,IGOFX,RE,AE,IFLAG,WORK,NDW,IWORK,NDIW,NEQIVP) C C-----IF IFLAG = 0, WE HAVE A SUCCESSFUL SOLUTION; OTHERWISE, SKIP C THE ARGUMENT CHECKING AND GO TO THE END. C IF (IFLAG.NE.0) THEN IPASS = 0 IF (KPRINT .GT. 1) WRITE (LUN,820) IFLAG GO TO 170 ENDIF C C-----CHECK THE ACCURACY OF THE SOLUTION. C NUMORT = IWORK(1) DO 50 J = 1, NXPTS DO 40 L = 1, 2 ABSER = ABS(YANS(L,J)-Y(L,J)) RELER = ABSER/ABS(YANS(L,J)) IF (RELER.GT.TOL .AND. ABSER.GT.TOL) IPASS = 0 40 CONTINUE 50 CONTINUE C C-----CHECK FOR SUPPRESSION OF PRINTING. C IF (KPRINT.EQ.0 .OR. (KPRINT.EQ.1 .AND. IPASS.EQ.1)) GO TO 190 C IF (KPRINT.NE.1 .OR. IPASS.NE.0) THEN IF (KPRINT.GE.3 .OR. IPASS.EQ.0) THEN WRITE (LUN,830) WRITE (LUN,840) NUMORT WRITE (LUN,850) (WORK(J),J = 1, NUMORT) WRITE (LUN,860) DO 60 J = 1, NXPTS MSG = 'PASS' ABSER = ABS(YANS(1,J)-Y(1,J)) RELER = ABSER/ABS(YANS(1,J)) IF (RELER.GT.TOL .AND. ABSER.GT.TOL) MSG = 'FAIL' ABSER = ABS(YANS(2,J)-Y(2,J)) RELER = ABSER/ABS(YANS(2,J)) IF (RELER.GT.TOL .AND. ABSER.GT.TOL) MSG = 'FAIL' WRITE (LUN,870) XPTS(J),Y(1,J),Y(2,J),YANS(1,J), * YANS(2,J),MSG 60 CONTINUE ENDIF ENDIF C C-----SEND MESSAGE INDICATING PASSAGE OR FAILURE OF TESTS. C CALL PASS (LUN, 1, IPASS) C C-----ERROR MESSAGE TESTS. C IF (KPRINT.EQ.1) GO TO 190 KONT = 1 WRITE (LUN,880) C C-----NROWY LESS THAN NCOMP C KOUNT = 1 NROWY = 1 150 DO 160 I = 1, 15 IWORK(I) = 0 160 CONTINUE CALL DBVSUP(Y,NROWY,NCOMP,XPTS,NXPTS,A,NROWA,ALPHA,NIC,B,NROWB, 1 BETA,NFC,IGOFX,RE,AE,IFLAG,WORK,NDW,IWORK,NDIW,NEQIVP) GO TO (80,90,100,110,120,130,140), KOUNT C 80 WRITE (LUN,900) IFLAG IF (IFLAG .EQ. -2) ITMP(KONT) = 1 KONT = KONT + 1 C C-----IGOFX NOT EQUAL TO 0 OR 1 C KOUNT = 2 NROWY = 2 IGOFX = 3 GO TO 150 C 90 WRITE (LUN,900) IFLAG IF (IFLAG .EQ. -2) ITMP(KONT) = 1 KONT = KONT + 1 C C-----RE OR AE NEGATIVE C KOUNT = 3 IGOFX = 1 RE = -1.0D+00 AE = -2.0D+00 GO TO 150 C 100 WRITE (LUN,900) IFLAG IF (IFLAG .EQ. -2) ITMP(KONT) = 1 KONT = KONT + 1 C C-----NROWA LESS THAN NIC C KOUNT = 4 RE = 1.0D-05 AE = 1.0D-05 NROWA = 0 C 110 WRITE (LUN,900) IFLAG IF (IFLAG .EQ. -2) ITMP(KONT) = 1 KONT = KONT + 1 C-----NROWB LESS THAN NFC KOUNT = 5 NROWA = 2 NROWB = 0 C 120 WRITE (LUN,900) IFLAG IF (IFLAG .EQ. -2) ITMP(KONT) = 1 KONT = KONT + 1 C-----STORAGE ALLOCATION IS INSUFFICIENT KOUNT = 6 NROWB = 2 NDIW = 17 GO TO 150 C 130 WRITE (LUN,910) IFLAG IF (IFLAG .EQ. -1) ITMP(KONT) = 1 KONT = KONT + 1 C-----INCORRECT ORDERING OF XPTS KOUNT = 7 NDIW = 100 SVE = XPTS(1) XPTS(1) = XPTS(4) XPTS(4) = SVE GO TO 150 C 140 WRITE (LUN,900) IFLAG IF (IFLAG .EQ. -2) ITMP(KONT) = 1 C C-----SEE IF IFLAG TESTS PASSED C 170 IPSS = 1 DO 180 I = 1, KONT IPSS = IPSS*ITMP(I) 180 CONTINUE C CALL PASS (LUN, 2, IPSS) C C-----SEE IF ALL TESTS PASSED. C IPASS = IPASS*IPSS C 190 IF (IPASS .EQ. 1 .AND. KPRINT .GT. 1) WRITE (LUN,980) IF (IPASS .EQ. 0 .AND. KPRINT .NE. 0) WRITE (LUN,990) RETURN C 800 FORMAT ('1') 810 FORMAT (/' DBVSUP QUICK CHECK') 820 FORMAT (10X,'IFLAG =',I2) 830 FORMAT (/' ACCURACY TEST') 840 FORMAT (/' NUMBER OF ORTHONORMALIZATIONS =',I3) 850 FORMAT (/' ORTHONORMALIZATION POINTS ARE'/(1X,4F10.2)) 860 FORMAT (//20X,'CALCULATION',30X,'TRUE SOLUTION'/ * 2X,'X',14X,'Y',17X,'Y-PRIME',15X,'Y',17X,'Y-PRIME'/) 870 FORMAT (F5.1,4E20.7,5X,A) 880 FORMAT (/' (7) TESTS OF IFLAG VALUES') 900 FORMAT (/' IFLAG SHOULD BE -2, IFLAG =',I3) 910 FORMAT (/' IFLAG SHOULD BE -1, IFLAG =',I3) 980 FORMAT (/' ***************DBVSUP PASSED ALL TESTS***************') 990 FORMAT (/' ***************DBVSUP FAILED SOME TESTS**************') END *DECK QXDRKF SUBROUTINE QXDRKF (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QXDRKF C***PURPOSE Test the DEPAC routine DDERKF. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (QXRKF-S, QXDRKF-D) C***KEYWORDS QUICK CHECK C***AUTHOR Chow, Jeff, (LANL) C***DESCRIPTION C C *Usage: C C INTEGER LUN, KPRINT, IPASS C C CALL QXDRKF (LUN, KPRINT, IPASS) C C *Arguments: C C LUN :IN is the unit number to which output is to be written. C C KPRINT:IN controls the amount of output, as specified in the C SLATEC Guidelines. C C IPASS:OUT will contain a pass/fail flag. IPASS=1 is good. C IPASS=0 indicates one or more tests failed. C C *Description: C C DDERKF is tested by solving the equations of motion of a body C moving in a plane about a spherical earth, namely C (D/DT)(D/DT)X = -G*X/R**3 C (D/DT)(D/DT)Y = -G*Y/R**3 C where G = 1, R = SQRT(X**2 + Y**2) and C X(0) = 1 C (D/DT)X(0) = 0 C Y(0) = 0 C (D/DT)Y(0) = 1. C C***ROUTINES CALLED D1MACH, DDERKF, DFDEQC C***REVISION HISTORY (YYMMDD) C 810801 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900415 Code extensively revised. (WRB) C***END PROLOGUE QXDRKF C C Declare arguments. C INTEGER LUN, KPRINT, IPASS C C Declare local variables. C INTEGER IDID, INFO(15), IPAR, IWORK(34), N, LIW, LRW, NSTEP DOUBLE PRECISION ABSERR, D1MACH, R, RELERR, RELTOL, RPAR, + RWORK(61), T, TOUT, U(4) EXTERNAL DFDEQC C***FIRST EXECUTABLE STATEMENT QXDRKF IF (KPRINT .GE. 2) WRITE (LUN, 9000) C C Initialize problem. C N = 4 LRW = 61 LIW = 34 T = 0.0D0 TOUT = 8.0D0*ATAN(1.0D0) U(1) = 1.0D0 U(2) = 0.0D0 U(3) = 0.0D0 U(4) = 1.0D0 IPASS = 1 NSTEP = 0 RELTOL = MAX(SQRT(D1MACH(4)),1.D-10) RELERR = MAX(.1D0*RELTOL,1.D-12) ABSERR = RELERR**1.5D0 INFO(1) = 0 INFO(2) = 0 INFO(3) = 1 INFO(4) = 0 IF (KPRINT .GT. 2) WRITE (LUN, 9010) RELERR, ABSERR, T, (1.0D0) C 100 CALL DDERKF (DFDEQC, N, T, U, TOUT, INFO, RELERR, ABSERR, + IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR) R = SQRT(U(1)*U(1)+U(2)*U(2)) IF (ABS(R-1.0D0) .GT. RELTOL) IPASS = 0 IF (KPRINT .GT. 2) WRITE (LUN, 9020) T, R INFO(1) = 1 IF (IDID .EQ. 1) GO TO 100 C C For the double precision version, we allow the integrator to take C up to 2000 steps before we declare failure. C IF (IDID .EQ. -1) THEN NSTEP = NSTEP + 500 IF (NSTEP .LT. 2000) GOTO 100 ENDIF C C Finish up. C IF (IDID .LT. 1) IPASS = 0 IF (KPRINT.GT.1 .AND. IDID.LT.1) WRITE (LUN, 9030) IDID IF (KPRINT.GT.1 .AND. IPASS.EQ.1) WRITE (LUN, 9040) IF (KPRINT.GE.1 .AND. IPASS.EQ.0) WRITE (LUN, 9050) RETURN C C FORMATs. C 9000 FORMAT ('1'/' ------------ DDERKF QUICK CHECK OUTPUT', + ' ------------') 9010 FORMAT (/ ' RELERR = ', D16.8, ' ABSERR =', D16.8 / + 12X, 'T', 19X, 'R' / 2D20.8) 9020 FORMAT (2D20.8) 9030 FORMAT (1X, 'ERROR RETURN FROM DDERKF. IDID = ', I3) 9040 FORMAT (/ ' ------------ DDERKF PASSED TESTS ------------') 9050 FORMAT (/ ' ************ DDERKF FAILED TESTS ************') END *DECK QXGBUN SUBROUTINE QXGBUN (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QXGBUN C***PURPOSE C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * * C * F I S H P A K * C * * C * * C * A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF * C * * C * SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS * C * * C * (VERSION 3 , JUNE 1979) * C * * C * BY * C * * C * JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET * C * * C * OF * C * * C * THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH * C * * C * BOULDER, COLORADO (80307) U.S.A. * C * * C * WHICH IS SPONSORED BY * C * * C * THE NATIONAL SCIENCE FOUNDATION * C * * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C PROGRAM TO ILLUSTRATE THE USE OF SUBROUTINE GENBUN C C***ROUTINES CALLED GENBUN, PIMACH C***REVISION HISTORY (YYMMDD) C 750701 DATE WRITTEN C 890718 Changed computation of PI to use PIMACH. (WRB) C 890911 Removed unnecessary intrinsics. (WRB) C 891009 Removed unreferenced variable. (WRB) C 891009 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Added PASS/FAIL message and cleaned up FORMATs. (RWC) C***END PROLOGUE QXGBUN DIMENSION F(25,130), A(20), B(20), C(20), W(1200), X(20), Y(120) C***FIRST EXECUTABLE STATEMENT QXGBUN C C FROM DIMENSION STATEMENT WE GET VALUE OF IDIMY. ALSO NOTE THAT C W(.) IS DIMENSIONED 6*N + 5*M. C ERMAX=1.E-2 IDIMY = 25 MPEROD = 1 M = 20 DELTAX = 1.0E0/M NPEROD = 0 N = 120 PI = PIMACH(DUM) DELTAY = 2.0E0*PI/N C C GENERATE AND STORE GRID POINTS FOR THE PURPOSE OF COMPUTING C COEFFICIENTS AND RIGHT SIDE OF EQUATION. C DO 100 I=1,M X(I) = (I-1)*DELTAX 100 CONTINUE DO 105 J=1,N Y(J) = -PI + (J-1)*DELTAY 105 CONTINUE C C GENERATE COEFFICIENTS. C S = (DELTAY/DELTAX)**2 T = S*DELTAX A(1) = 0. B(1) = -2.0E0*S C(1) = 2.0E0*S DO 110 I=2,M A(I) = (1.+X(I))**2*S + (1.+X(I))*T C(I) = (1.+X(I))**2*S - (1.+X(I))*T B(I) = -2.0E0*(1.0E0+X(I))**2*S 110 CONTINUE C(M) = 0. C C GENERATE RIGHT SIDE OF EQUATION FOR I = 1 SHOWING INTRODUCTION OF C BOUNDARY DATA. C DYSQ = DELTAY**2 DO 115 J=1,N F(1,J) = DYSQ*(11. + 8./DELTAX)*SIN(Y(J)) 115 CONTINUE C C GENERATE RIGHT SIDE. C MM1 = M-1 DO 125 I=2,MM1 DO 120 J=1,N F(I,J) = DYSQ*3.*(1.+X(I))**4*SIN(Y(J)) 120 CONTINUE 125 CONTINUE C C GENERATE RIGHT SIDE FOR I = M SHOWING INTRODUCTION OF C BOUNDARY DATA. C DO 130 J=1,N F(M,J) = DYSQ*(3.*(1.+X(M))**4 - 16.*((1.+X(M))/DELTAX)**2 + + 16.*(1.+X(M))/DELTAX)*SIN(Y(J)) 130 CONTINUE CALL GENBUN(NPEROD,N,MPEROD,M,A,B,C,IDIMY,F,IERROR,W) C C COMPUTE DISCRETIZATION ERROR. THE EXACT SOLUTION IS C U(X,Y) = (1+X)**4*SIN(Y) C ERR = 0. DO 140 I=1,M DO 135 J=1,N Z = ABS(F(I,J)-(1.+X(I))**4*SIN(Y(J))) IF (Z .GT. ERR) ERR = Z 135 CONTINUE 140 CONTINUE C IPASS = 1 IF (ERR.GT.ERMAX) IPASS = 0 IF (KPRINT.EQ.0) RETURN IF (KPRINT.GE.2 .OR. IPASS.EQ.0) THEN WRITE (LUN,1001) IERROR, ERR, INT(W(1)) IF (IPASS.EQ.1) THEN WRITE (LUN, 1002) ELSE WRITE (LUN, 1003) ENDIF ENDIF RETURN C 1001 FORMAT ('1',20X,'SUBROUTINE GENBUN EXAMPLE'/// 1 10X,'THE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS'// 2 32X,'IERROR = 0'/ 3 18X,'DISCRETIZATION ERROR = 7.94113E-03'/ 4 12X,'REQUIRED LENGTH OF W ARRAY = 740'// 5 10X,'THE OUTPUT FROM YOUR COMPUTER IS'// 6 32X,'IERROR =',I2/ 7 18X,'DISCRETIZATION ERROR =',1PE12.5/ 8 12X,'REQUIRED LENGTH OF W ARRAY =',I4) 1002 FORMAT (60X,'PASS'/) 1003 FORMAT (60X,'FAIL'/) END *DECK QXPLR SUBROUTINE QXPLR (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QXPLR C***PURPOSE C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * * C * F I S H P A K * C * * C * * C * A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF * C * * C * SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS * C * * C * (VERSION 3 , JUNE 1979) * C * * C * BY * C * * C * JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET * C * * C * OF * C * * C * THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH * C * * C * BOULDER, COLORADO (80307) U.S.A. * C * * C * WHICH IS SPONSORED BY * C * * C * THE NATIONAL SCIENCE FOUNDATION * C * * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C C PROGRAM TO ILLUSTRATE THE USE OF SUBROUTINE HWSPLR TO SOLVE C THE EQUATION C C (1/R)(D/DR)(R*(DU/DR)) + (1/R**2)(D/DTHETA)(DU/DTHETA) = 16*R**2 C C ON THE QUARTER-DISK 0 .LT. R .LT. 1, 0 .LT. THETA .LT. PI/2 WITH C WITH THE BOUNDARY CONDITIONS C C U(1,THETA) = 1 - COS(4*THETA), 0 .LE. THETA .LE. 1 C C AND C C (DU/DTHETA)(R,0) = (DU/DTHETA)(R,PI/2) = 0, 0 .LE. R .LE. 1. C C (NOTE THAT THE SOLUTION U IS UNSPECIFIED AT R = 0.) C THE R-INTERVAL WILL BE DIVIDED INTO 50 PANELS AND THE C THETA-INTERVAL WILL BE DIVIDED INTO 48 PANELS. C C***ROUTINES CALLED HWSPLR, PIMACH C***REVISION HISTORY (YYMMDD) C 800103 DATE WRITTEN C 890718 Changed computation of PI to use PIMACH. (WRB) C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Added PASS/FAIL message and cleaned up FORMATs. (RWC) C***END PROLOGUE QXPLR DIMENSION F(100,50), BDC(51), BDD(51), W(1200), R(51), THETA(49) C***FIRST EXECUTABLE STATEMENT QXPLR C C FROM DIMENSION STATEMENT WE GET VALUE OF IDIMF. ALSO NOTE THAT W C IS DIMENSIONED 6*(N+1) + 8*(M+1). C IDIMF = 100 ERMAX=1.E-3 A = 0. B = 1. M = 50 MBDCND = 5 C = 0. PI = PIMACH(DUM) D = PI/2. N = 48 NBDCND = 3 ELMBDA = 0. C C AUXILIARY QUANTITIES. C MP1 = M+1 NP1 = N+1 C C GENERATE AND STORE GRID POINTS FOR THE PURPOSE OF COMPUTING C BOUNDARY DATA AND THE RIGHT SIDE OF THE POISSON EQUATION. C DO 101 I=1,MP1 R(I) = (I-1)/50.0E0 101 CONTINUE DO 102 J=1,NP1 THETA(J) = (J-1)*PI/96.0E0 102 CONTINUE C C GENERATE BOUNDARY DATA. C DO 103 I=1,MP1 BDC(I) = 0. BDD(I) = 0. 103 CONTINUE C C BDA AND BDB ARE DUMMY VARIABLES. C DO 104 J=1,NP1 F(MP1,J) = 1.-COS(4.*THETA(J)) 104 CONTINUE C C GENERATE RIGHT SIDE OF EQUATION. C DO 106 I=1,M DO 105 J=1,NP1 F(I,J) = 16.*R(I)**2 105 CONTINUE 106 CONTINUE CALL HWSPLR(A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,ELMBDA,F, 1 IDIMF,PERTRB,IERROR,W) C C COMPUTE DISCRETIZATION ERROR. THE EXACT SOLUTION IS C U(R,THETA) = R**4*(1 - COS(4*THETA)) C ERR = 0. DO 108 I=1,MP1 DO 107 J=1,NP1 Z = ABS(F(I,J)-R(I)**4*(1.-COS(4.*THETA(J)))) IF (Z .GT. ERR) ERR = Z 107 CONTINUE 108 CONTINUE C IPASS = 1 IF (ERR.GT.ERMAX) IPASS = 0 IF (KPRINT.EQ.0) RETURN IF (KPRINT.GE.2 .OR. IPASS.EQ.0) THEN WRITE (LUN,1001) IERROR,ERR,INT(W(1)) IF (IPASS.EQ.1) THEN WRITE (LUN, 1002) ELSE WRITE (LUN, 1003) ENDIF ENDIF RETURN C 1001 FORMAT ('1',20X,'SUBROUTINE HWSPLR EXAMPLE'/// 1 10X,'THE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS'// 2 32X,'IERROR = 0'/ 3 18X,'DISCRETIZATION ERROR = 6.19134E-04'/ 4 12X,'REQUIRED LENGTH OF W ARRAY = 882'// 5 10X,'THE OUTPUT FROM YOUR COMPUTER IS'// 6 32X,'IERROR =',I2/ 7 18X,'DISCRETIZATION ERROR =',1PE12.5/ 8 12X,'REQUIRED LENGTH OF W ARRAY =',I4) 1002 FORMAT (60X,'PASS'/) 1003 FORMAT (60X,'FAIL'/) END *DECK QXRKF SUBROUTINE QXRKF (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QXRKF C***PURPOSE Test the DEPAC routine DERKF. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (QXRKF-S, QXDRKF-D) C***KEYWORDS QUICK CHECK C***AUTHOR Chow, Jeff, (LANL) C***DESCRIPTION C C *Usage: C C INTEGER LUN, KPRINT, IPASS C C CALL QXRKF (LUN, KPRINT, IPASS) C C *Arguments: C C LUN :IN is the unit number to which output is to be written. C C KPRINT:IN controls the amount of output, as specified in the C SLATEC Guidelines. C C IPASS:OUT will contain a pass/fail flag. IPASS=1 is good. C IPASS=0 indicates one or more tests failed. C C *Description: C C DERKF is tested by solving the equations of motion of a body C moving in a plane about a spherical earth, namely C (D/DT)(D/DT)X = -G*X/R**3 C (D/DT)(D/DT)Y = -G*Y/R**3 C where G = 1, R = SQRT(X**2 + Y**2) and C X(0) = 1 C (D/DT)X(0) = 0 C Y(0) = 0 C (D/DT)Y(0) = 1. C C***ROUTINES CALLED DERKF, FDEQC, R1MACH C***REVISION HISTORY (YYMMDD) C 810801 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900415 Code extensively revised. (WRB) C***END PROLOGUE QXRKF C C Declare arguments. C INTEGER LUN, KPRINT, IPASS C C Declare local variables. C INTEGER IDID, INFO(15), IPAR, IWORK(34), N, LIW, LRW REAL ABSERR, R, R1MACH, RELERR, RELTOL, RPAR, RWORK(61), T, TOUT, + U(4) EXTERNAL FDEQC C***FIRST EXECUTABLE STATEMENT QXRKF IF (KPRINT .GE. 2) WRITE (LUN, 9000) C C Initialize problem. C N = 4 LRW = 61 LIW = 34 T = 0.0E0 TOUT = 8.0E0*ATAN(1.0E0) U(1) = 1.0E0 U(2) = 0.0E0 U(3) = 0.0E0 U(4) = 1.0E0 IPASS = 1 RELTOL = SQRT(R1MACH(4)) RELERR = 0.1E0*RELTOL ABSERR = RELERR**1.5E0 INFO(1) = 0 INFO(2) = 0 INFO(3) = 1 INFO(4) = 0 IF (KPRINT .GT. 2) WRITE (LUN, 9010) RELERR, ABSERR, T, (1.0E0) C 100 CALL DERKF (FDEQC, N, T, U, TOUT, INFO, RELERR, ABSERR, + IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR) R = SQRT(U(1)*U(1)+U(2)*U(2)) IF (ABS(R-1.0E0) .GT. RELTOL) IPASS = 0 IF (KPRINT .GT. 2) WRITE (LUN, 9020) T, R INFO(1) = 1 IF (IDID .EQ. 1) GO TO 100 C C Finish up. C IF (IDID .LT. 1) IPASS = 0 IF (KPRINT.GT.1 .AND. IDID.LT.1) WRITE (LUN, 9030) IDID IF (KPRINT.GT.1 .AND. IPASS.EQ.1) WRITE (LUN, 9040) IF (KPRINT.GE.1 .AND. IPASS.EQ.0) WRITE (LUN, 9050) RETURN C C FORMATs. C 9000 FORMAT ('1'/' ------------ DERKF QUICK CHECK OUTPUT', + ' ------------') 9010 FORMAT (/ ' RELERR = ', E16.8, ' ABSERR =', E16.8 / + 12X, 'T', 19X, 'R' / 2E20.8) 9020 FORMAT (2E20.8) 9030 FORMAT (1X, 'ERROR RETURN FROM DERKF. IDID = ', I3) 9040 FORMAT (/ ' ------------ DERKF PASSED TESTS ------------') 9050 FORMAT (/ ' ************ DERKF FAILED TESTS ************') END *DECK QXSSP SUBROUTINE QXSSP (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QXSSP C***PURPOSE C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * * C * F I S H P A K * C * * C * * C * A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF * C * * C * SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS * C * * C * (VERSION 3 , JUNE 1979) * C * * C * BY * C * * C * JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET * C * * C * OF * C * * C * THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH * C * * C * BOULDER, COLORADO (80307) U.S.A. * C * * C * WHICH IS SPONSORED BY * C * * C * THE NATIONAL SCIENCE FOUNDATION * C * * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C C C PROGRAM TO ILLUSTRATE THE USE OF HWSSSP C C***ROUTINES CALLED HWSSSP, PIMACH C***REVISION HISTORY (YYMMDD) C 800103 DATE WRITTEN C 890718 Changed computation of PI to use PIMACH. (WRB) C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Added PASS/FAIL message and cleaned up FORMATs. (RWC) C***END PROLOGUE QXSSP DIMENSION F(19,73), BDTF(73), SINT(19), SINP(73), W(1200) C***FIRST EXECUTABLE STATEMENT QXSSP C C THE VALUE OF IDIMF IS THE FIRST DIMENSION OF F. W IS C DIMENSIONED 11*(M+1)+6*(N+1)=647 SINCE M=18 AND N=72. C PI = PIMACH(DUM) ERMAX=5.E-3 TS = 0.0 TF = PI/2. M = 18 MBDCND = 6 PS = 0.0 PF = PI+PI N = 72 NBDCND = 0 ELMBDA = 0. IDIMF = 19 C C GENERATE SINES FOR USE IN SUBSEQUENT COMPUTATIONS C DTHETA = TF/M MP1 = M+1 DO 101 I=1,MP1 SINT(I) = SIN((I-1)*DTHETA) 101 CONTINUE DPHI = (PI+PI)/N NP1 = N+1 DO 102 J=1,NP1 SINP(J) = SIN((J-1)*DPHI) 102 CONTINUE C C COMPUTE RIGHT SIDE OF EQUATION AND STORE IN F C DO 104 J=1,NP1 DO 103 I=1,MP1 F(I,J) = 2.-6.*(SINT(I)*SINP(J))**2 103 CONTINUE 104 CONTINUE C C STORE DERIVATIVE DATA AT THE EQUATOR C DO 105 J=1,NP1 BDTF(J) = 0. 105 CONTINUE C CALL HWSSSP(TS,TF,M,MBDCND,BDTS,BDTF,PS,PF,N,NBDCND,BDPS,BDPF, 1 ELMBDA,F,IDIMF,PERTRB,IERROR,W) C C COMPUTE DISCRETIZATION ERROR. SINCE PROBLEM IS SINGULAR, THE C SOLUTION MUST BE NORMALIZED. C ERR = 0.0 DO 107 J=1,NP1 DO 106 I=1,MP1 Z = ABS(F(I,J)-(SINT(I)*SINP(J))**2-F(1,1)) IF (Z .GT. ERR) ERR = Z 106 CONTINUE 107 CONTINUE C IPASS = 1 IF (ERR.GT.ERMAX) IPASS = 0 IF (KPRINT.EQ.0) RETURN IF (KPRINT.GE.2 .OR. IPASS.EQ.0) THEN WRITE (LUN,1001) IERROR,ERR,INT(W(1)) IF (IPASS.EQ.1) THEN WRITE (LUN, 1002) ELSE WRITE (LUN, 1003) ENDIF ENDIF RETURN C 1001 FORMAT ('1',20X,'SUBROUTINE HWSSSP EXAMPLE'/// 1 10X,'THE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS'// 2 32X,'IERROR = 0'/ 3 18X,'DISCRETIZATION ERROR = 3.38107E-03'/ 4 12X,'REQUIRED LENGTH OF W ARRAY = 600'// 5 10X,'THE OUTPUT FROM YOUR COMPUTER IS'// 6 32X,'IERROR =',I2/ 7 18X,'DISCRETIZATION ERROR =',1PE12.5 / 8 12X,'REQUIRED LENGTH OF W ARRAY =',I4) 1002 FORMAT (60X,'PASS'/) 1003 FORMAT (60X,'FAIL'/) END *DECK RQRTST SUBROUTINE RQRTST (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE RQRTST C***PURPOSE Quick check for RPQR79. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (RQRTST-S, CQRTST-C) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED NUMXER, PASS, R1MACH, RPQR79, XERCLR, XGETF, XSETF C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF, cleaned up FORMATs C and changed TOL from sqrt R1MACH(3) to sqrt R1MACH(4) for C the IBM 370 mainframes. (RWC) C 911010 Code reworked and simplified. (RWC and WRB) C***END PROLOGUE RQRTST INTEGER ITMP(7) COMPLEX ROOT(7), CHK(7) DIMENSION WORK(63) REAL COEF(8) LOGICAL FATAL C DATA CHK / ( 1.4142135623731, 1.4142135623731), * ( 1.4142135623731, -1.4142135623731), * (0.0, 2.0), (0.0, -2.0), (-2.0, 0.0), * (-1.4142135623731, 1.4142135623731), * (-1.4142135623731, -1.4142135623731) / C***FIRST EXECUTABLE STATEMENT RQRTST IF (KPRINT .GE. 2) WRITE (LUN, 90000) TOL = SQRT(R1MACH(4)) IPASS = 1 C C Initialize variables for testing. C BETA = 0.0078125 DO 20 J=1,8 COEF(J) = BETA BETA = 2.0*BETA 20 CONTINUE C CALL RPQR79 (7, COEF, ROOT, IERR, WORK) C C Check to see if test passed. C DO 10 I=1,7 ITMP(I) = 0 10 CONTINUE C C Check for roots in any order. C DO 40 I=1,7 DO 30 J=1,7 IF (ABS(ROOT(I)-CHK(J)) .LE. TOL) THEN ITMP(J) = 1 GO TO 40 ENDIF 30 CONTINUE 40 CONTINUE C C Check that we found all 7 roots. C IPASS = 1 DO 50 I=1,7 IPASS = IPASS*ITMP(I) 50 CONTINUE C C Print test results. C IF (KPRINT.GE.3 .OR. (KPRINT.GE.2.AND.IPASS.EQ.0)) THEN WRITE (LUN, 90010) WRITE (LUN, 90020) (J,COEF(J), J=1,8) WRITE (LUN, 90030) WRITE (LUN, 90040) (J,ROOT(J), J=1,7) ENDIF IF (KPRINT .GE. 2) THEN CALL PASS (LUN, 1, IPASS) ENDIF C C Trigger 2 error conditions C CALL XGETF (KONTRL) IF (KPRINT .LE. 2) THEN CALL XSETF (0) ELSE CALL XSETF (1) ENDIF FATAL = .FALSE. CALL XERCLR IF (KPRINT .GE. 3) WRITE (LUN, 90060) C C CALL RPQR79 with 0 degree polynomial. C CALL RPQR79 (0, COEF, ROOT, IERR, WORK) IF (NUMXER(NERR) .NE. 3) THEN FATAL = .TRUE. ENDIF CALL XERCLR C C CALL RPQR79 with zero leading coefficient. C COEF(1) = 0.0 CALL RPQR79 (2, COEF, ROOT, IERR, WORK) IF (NUMXER(NERR) .NE. 2) THEN FATAL = .TRUE. ENDIF CALL XERCLR C CALL XSETF (KONTRL) IF (FATAL) THEN IPASS = 0 IF (KPRINT .GE. 2) THEN WRITE (LUN, 90070) ENDIF ELSE IF (KPRINT .GE. 3) THEN WRITE (LUN, 90080) ENDIF ENDIF C IF (IPASS.EQ.1 .AND. KPRINT.GT.1) WRITE (LUN,90100) IF (IPASS.EQ.0 .AND. KPRINT.NE.0) WRITE (LUN,90110) RETURN C 90000 FORMAT ('1', /,' RPQR79 QUICK CHECK') 90010 FORMAT (/, ' CHECK REAL AND IMAGINARY PARTS OF ROOT' / * ' COEFFICIENTS') 90020 FORMAT (/ (I6, 3X, 1P, E22.14)) 90030 FORMAT (// 25X, 'TABLE of ROOTS' // * ' ROOT REAL PART', 12X, 'IMAG PART' / * ' NUMBER', 8X, 2(' of ZERO ', 12X)) 90040 FORMAT (I6, 3X, 1P, 2E22.14) 90060 FORMAT (// ' TRIGGER 2 ERROR CONDITIONS' //) 90070 FORMAT (/ ' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED') 90080 FORMAT (/ ' ALL INCORRECT ARGUMENT TESTS PASSED') 90100 FORMAT (/' **************RPQR79 PASSED ALL TESTS**************') 90110 FORMAT (/' **************RPQR79 FAILED SOME TESTS*************') END *DECK SBOCQX SUBROUTINE SBOCQX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE SBOCQX C***PURPOSE Quick check for SBOCLS. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (SBOCQX-S, DBOCQX-D) C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C MINIMAL TEST DRIVER FOR SBOCLS, BOUNDED CONSTRAINED LEAST C SQUARES SOLVER. DELIVERS THE VALUE IPASS=1 IF 8 TESTS WERE C PASSED. DELIVER THE VALUE IPASS=0 IF ANY ONE OF THEM FAILED. C C RUN FOUR BOUNDED LEAST SQUARES PROBLEMS THAT COME FROM THE C DIPLOME WORK OF P. ZIMMERMANN. C C***ROUTINES CALLED R1MACH, SBOCLS, SBOLS, SCOPY, SNRM2 C***REVISION HISTORY (YYMMDD) C 850310 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901013 Added PASS/FAIL message and cleaned up FORMATs. (RWC) C***END PROLOGUE SBOCQX REAL D(6,5),W(11,11),BL(5,2),BU(5,2),X(30),RW(55),XTRUE(9) REAL C(5,5) REAL BL1(10),BU1(10) INTEGER IND(10),IW(20),IOPT(40) REAL RHS(6,2) CHARACTER*4 MSG C DATA ((C(I,J),I=1,5),J=1,5) /1.,10.,4.,8.,1.,1.,10.,2.,-1.,1.,1., * -3.,-3.,2.,1.,1.,5.,5.,5.,1.,1.,4.,-1.,-3.,1./ DATA ((D(I,J),I=1,6),J=1,5) /-74.,14.,66.,-12.,3.,4.,80.,-69., * -72.,66.,8.,-12.,18.,21.,-5.,-30.,-7.,4.,-11.,28.,7.,-23.,-4., * 4.,-4.,0.,1.,3.,1.,0./ DATA ((BL(I,J),I=1,5),J=1,2) /1.,0.,-1.,1.,-4.,-1.,0.,-3.,1.,-6./ DATA ((BU(I,J),I=1,5),J=1,2) /3.,2.,1.,3.,-2.,3.,4.,1.,5.,-2./ DATA ((RHS(I,J),I=1,6),J=1,2) /51.,-61.,-56.,69.,10.,-12.,-5.,-9., * 708.,4165.,-13266.,8409./ DATA (XTRUE(J),J=1,9) /1.,2.,-1.,3.,-4.,1.,32.,30.,31./ C***FIRST EXECUTABLE STATEMENT SBOCQX MDW = 11 MROWS = 6 NCOLS = 5 MCON = 4 IOPT(1) = 99 IPASS = 1 ITEST = 0 C IF (KPRINT.GE.2) WRITE (LUN, 99998) C DO 50 IB = 1,2 DO 40 IRHS = 1,2 C C TRANSFER DATA TO WORKING ARRAY W(*,*). C DO 10 J = 1,NCOLS CALL SCOPY(MROWS,D(1,J),1,W(1,J),1) 10 CONTINUE C CALL SCOPY(MROWS,RHS(1,IRHS),1,W(1,NCOLS+1),1) C C SET BOUND INDICATOR FLAGS. C DO 20 J = 1,NCOLS IND(J) = 3 20 CONTINUE C CALL SBOLS(W,MDW,MROWS,NCOLS,BL(1,IB),BU(1,IB),IND,IOPT,X, * RNORM,MODE,RW,IW) DO 30 J = 1,NCOLS X(J) = X(J) - XTRUE(J) 30 CONTINUE C SR = SNRM2(NCOLS,X,1) MPASS = 1 IF (SR.GT.10.E3*SQRT(R1MACH(4))) MPASS = 0 IPASS = IPASS*MPASS IF (KPRINT.GE.2) THEN MSG = 'PASS' IF (MPASS.EQ.0) MSG = 'FAIL' ITEST = ITEST + 1 WRITE (LUN, 99999) ITEST, IB, IRHS, SR, MSG ENDIF 40 CONTINUE 50 CONTINUE C C RUN STOER'S PROBLEM FROM 1971 SIAM J. N. ANAL. PAPER. C DO 90 IB = 1,2 DO 80 IRHS = 1,2 CALL SCOPY(11*10,0.E0,0,W,1) CALL SCOPY(NCOLS,BL(1,IB),1,BL1,1) CALL SCOPY(NCOLS,BU(1,IB),1,BU1,1) IND(NCOLS+1) = 2 IND(NCOLS+2) = 1 IND(NCOLS+3) = 2 IND(NCOLS+4) = 3 BU1(NCOLS+1) = 5. BL1(NCOLS+2) = 20. BU1(NCOLS+3) = 30. BL1(NCOLS+4) = 11. BU1(NCOLS+4) = 40. DO 60 J = 1,NCOLS CALL SCOPY(MCON,C(1,J),1,W(1,J),1) CALL SCOPY(MROWS,D(1,J),1,W(MCON+1,J),1) 60 CONTINUE C CALL SCOPY(MROWS,RHS(1,IRHS),1,W(MCON+1,NCOLS+1),1) C C CHECK LENGTHS OF REQD. ARRAYS. C IOPT(01) = 2 IOPT(02) = 11 IOPT(03) = 11 IOPT(04) = 10 IOPT(05) = 30 IOPT(06) = 55 IOPT(07) = 20 IOPT(08) = 40 IOPT(09) = 99 CALL SBOCLS(W,MDW,MCON,MROWS,NCOLS,BL1,BU1,IND,IOPT,X, * RNORMC,RNORM,MODE,RW,IW) DO 70 J = 1,NCOLS + MCON X(J) = X(J) - XTRUE(J) 70 CONTINUE C SR = SNRM2(NCOLS+MCON,X,1) MPASS = 1 IF (SR.GT.10.E3*SQRT(R1MACH(4))) MPASS = 0 IPASS = IPASS*MPASS IF (KPRINT.GE.2) THEN MSG = 'PASS' IF (MPASS.EQ.0) MSG = 'FAIL' ITEST = ITEST + 1 WRITE (LUN, 99999) ITEST, IB, IRHS, SR, MSG ENDIF 80 CONTINUE 90 CONTINUE C C HERE THE VALUE OF IPASS=1 SAYS THAT SBOCLS() HAS PASSED ITS TESTS. C THE VALUE OF IPASS=0 SAYS THAT SBOCLS() HAS NOT PASSED. C IF(KPRINT.GE.3) *WRITE(LUN,'('' IPASS VALUE. (A 1 IS GOOD, 0 IS BAD.)'',I4)')IPASS IF(KPRINT.GE.2.AND.IPASS.EQ.0) WRITE(LUN,10789) RETURN C 10789 FORMAT (' ERROR IN SBOCLS OR SBOLS') 99998 FORMAT (' TEST IB IRHS SR') 99999 FORMAT (3I5, 1P, E20.6, ' TEST ', A, 'ED.') END *DECK SFNCK SUBROUTINE SFNCK (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE SFNCK C***PURPOSE Quick check for the single precision Fullerton C special functions. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Boland, W. Robert, (LANL) C Chow, Jeff, (LANL) C***DESCRIPTION C C This subroutine does a quick check for the single precision C routines in the Fullerton special function library. C C Parameter list- C C LUN input integer value to designate the external C device unit for message output C KPRINT input integer value to specify amount of C printing to be done by quick check C IPASS output value indicating whether tests passed or C failed C C***ROUTINES CALLED ACOSH, AI, AIE, ALI, ALNREL, ASINH, ATANH, BESI0, C BESI0E, BESI1, BESI1E, BESJ0, BESJ1, BESK0, BESK0E, C BESK1, BESK1E, BESKES, BESKS, BESY0, BESY1, BETA, C BETAI, BI, BIE, BINOM, CBRT, CHU, COSDG, COT, DAWS, C E1, EI, ERF, EXPREL, FAC, GAMI, GAMIC, GAMIT, C GAMMA, GAMR, POCH, POCH1, PSI, R1MACH, R9ATN1, C R9LN2R, SINDG, SPENC C***REVISION HISTORY (YYMMDD) C 800901 DATE WRITTEN C 891115 REVISION DATE from Version 3.2 C 891120 Checks of remainder of FNLIB routines added and code C reorganized. (WRB) C 900330 Prologue converted to Version 4.0 format. (BAB) C 900727 Added EXTERNAL statement. (WRB) C***END PROLOGUE SFNCK INTEGER I,LUN,KPRINT,IPASS REAL R1MACH, + Y(105),V(105),ERRMAX,ERRTOL,ABSERR,RELERR, + BESI1,BESI1E,BESJ0,BESJ1,BESK0,BESK0E,BESK1,BESK1E, + BESY0,BESY1,BETA,BETAI,BI,BIE,BINOM,CBRT,CHU,COSDG,COT,DAWS, + E1,EI,ERF,EXPREL,FAC,GAMI,GAMIC,GAMIT,GAMMA,GAMR,POCH,POCH1, + PSI,R9ATN1,R9LN2R,SINDG,SPENC EXTERNAL COT, ERF, GAMMA C C Correct values through different calculations are stored in V(*) C DATA V( 1) / .8344518000 0000000000 0000000000 E+09/ DATA V( 2) / .2250829575 1200000000 0000000000 E+13/ DATA V( 3) / .1307674368 0000000000 0000000000 E+13/ DATA V( 4) / .8222838654 1779228177 2556288000 E+34/ DATA V( 5) /-.2000000000 0000000000 0000000000 E+01/ DATA V( 6) / .9983407900 0000000000 0000000000 E+02/ DATA V( 7) / .8660254037 8443864676 3723170753 E+00/ DATA V( 8) /-.7071067811 8654752440 0844362105 E+00/ DATA V( 9) / .6420926159 3433070300 6419986594 E+00/ DATA V( 10) /-.1830487721 7124519192 6801943897 E+01/ DATA V( 11) /-.2908191279 9355107028 5950148310 E+00/ DATA V( 12) /-.1116064102 7573868712 2866817478 E+00/ DATA V( 13) / .5000000000 0000000000 0000000000 E+00/ DATA V( 14) / .7071067811 8654752440 0844362105 E+00/ DATA V( 15) / .1371498381 4723363824 3285631505 E+00/ DATA V( 16) /-.1000000500 0003333335 8333416027 E-05/ DATA V( 17) / .1001251042 3180339898 4880296644 E+01/ DATA V( 18) / .9950166250 8319464260 9402280122 E+00/ DATA V( 19) / .2437208648 6531505582 4104923715 E+00/ DATA V( 20) / .1931471805 5994530941 7232121458 E+00/ DATA V( 21) / .1111122222 3333344444 0000000000 E+00/ DATA V( 22) / .3141592653 5900000000 0000000000 E+01/ DATA V( 23) / .9983407900 0000000000 0000000000 E-01/ DATA V( 24) /-.1194763217 0000000000 0000000000 E+01/ DATA V( 25) /-.1111122222 3333344444 0000000000 E+00/ DATA V( 26) / .2646652412 0000000000 0000000000 E+01/ DATA V( 27) /-.3786710430 6108797672 7207184637 E+00/ DATA V( 28) / .1045163780 1174927848 4458888919 E+01/ DATA V( 29) / .5597735947 7616081174 6795939295 E+00/ DATA V( 30) / .1000195824 0663265190 1909339800 E+00/ DATA V( 31) / .4542199048 6317357992 0523812663 E+00/ DATA V( 32) / .1895117816 3559367554 6652093433 E+01/ DATA V( 33) / .5822405264 6501250590 2656320160 E+00/ DATA V( 34) / .1644934066 8482264364 7241516665 E+01/ DATA V( 35) / .8862269254 5275801364 9083741687 E+00/ DATA V( 36) /-.3141592653 5897932384 6264338328 E+01/ DATA V( 37) / .3183098861 8379067153 7767526733 E+00/ DATA V( 38) / .8823957200 2038009055 0940262394 E-06/ DATA V( 39) /-.2820947917 7387814347 4039725759 E+00/ DATA V( 40) / .1875000000 0000000000 0000000000 E+01/ DATA V( 41) / .5135166683 8205029558 4635612122 E-01/ DATA V( 42) / .5987500000 0000000000 0000000000 E+02/ DATA V( 43) / .1570796326 7948966192 3132169164 E+01/ DATA V( 44) / .7550061690 3746404275 1871235437 E-03/ DATA V( 45) / .4227843350 9846713939 3487909918 E+00/ DATA V( 46) / .2303001034 2976863752 7259355045 E+01/ DATA V( 47) / .9998566182 6372370688 5830759463 E+00/ DATA V( 48) / .8882907071 8395673587 8281870759 E+00/ DATA V( 49) / .1353352832 3661269189 3999494971 E+00/ DATA V( 50) / .3469303062 9580145617 0933128256 E-03/ DATA V( 51) / .7869386805 7473315279 2400930048 E+00/ DATA V( 52) / .6316733917 7525812329 1222663623 E-01/ DATA V( 53) / .3812815664 6177091614 9261183171 E+00/ DATA V( 54) / .2656250000 0000000000 0000000000 E+00/ DATA V( 55) / .5204998778 1304653768 2746653770 E+00/ DATA V( 56) / .8883882317 0170776406 9578446749 E+00/ DATA V( 57) / .4244363835 0202229593 4042352455 E+00/ DATA V( 58) / .3370006597 4209342338 3019719632 E+00/ DATA V( 59) /-.1775967713 1433830434 7397013056 E+00/ DATA V( 60) / .2238907791 4123566805 1827454628 E+00/ DATA V( 61) /-.3275791375 9146522203 7734321812 E+00/ DATA V( 62) / .5767248077 5687338720 2448242187 E+00/ DATA V( 63) / .5103756726 4974511959 6606592612 E+00/ DATA V( 64) /-.3085176252 4903378007 3648984210 E+00/ DATA V( 65) / .1478631433 9122684480 1050675510 E+00/ DATA V( 66) /-.1070324315 4093754688 8370772230 E+00/ DATA V( 67) / .2279585302 3360672674 3720444020 E+01/ DATA V( 68) / .2723987182 3604446894 5442320700 E+02/ DATA V( 69) / .1590636854 6373290633 8225442450 E+01/ DATA V( 70) / .2433564214 2450527199 1430504400 E+02/ DATA V( 71) / .1138938727 4953343565 2719574910 E+00/ DATA V( 72) / .3691098334 0425942747 3526100740 E-02/ DATA V( 73) / .1398658818 1652242728 4598806997 E+00/ DATA V( 74) / .4044613445 4521642083 6502183700 E-02/ DATA V( 75) / .3085083225 5367103953 3384319255 E+00/ DATA V( 76) / .1835408126 0932835307 3650751820 E+00/ DATA V( 77) / .1639722669 4454235692 6122903850 E+00/ DATA V( 78) / .2152692892 4893765915 8505143243 E+00/ DATA V( 79) / .8415682150 7077141791 9124867127 E+00/ DATA V( 80) / .5478075643 1351898686 8201568700 E+00/ DATA V( 81) / .6002738587 8831258293 6045656600 E+00/ DATA V( 82) / .1033476847 0686885731 7535710603 E+01/ DATA V( 83) / .8862269254 5275801364 9083741000 E+00/ DATA V( 84) / .1329340388 1791370204 7362561200 E+01/ DATA V( 85) / .2880237507 7214635443 5952215970 E+01/ DATA V( 86) / .5604991216 3979286993 1128243359 E+00/ DATA V( 87) / .6725989459 6775144391 7353892000 E+00/ DATA V( 88) / .9640584892 2044373628 1540578570 E+00/ DATA V( 89) / .4610685044 4789455843 9575873876 E+00/ DATA V( 90) / .9221370088 9578911687 9151747751 E+00/ DATA V( 91) / .2316936064 8083348976 9125254500 E+00/ DATA V( 92) / .1572592338 0470489995 2660465400 E-01/ DATA V( 93) / .2932771591 2994736245 0897433147 E+00/ DATA V( 94) / .2193222051 2871206086 2850888400 E+00/ DATA V( 95) / .8542770431 0315549330 0048798776 E+00/ DATA V( 96) / .1878941503 7478950009 0933504950 E+01/ DATA V( 97) / .6748924111 1563021286 5414309867 E+00/ DATA V( 98) / .4647504801 9609251501 9775411670 E+00/ DATA V( 99) / .2499999999 9999999999 9999999880 E+00/ DATA V(100) / .7350086093 0037774536 9706799000 E+00/ DATA V(101) / .4069617876 5067297974 2685260000 E+00/ DATA V(102) / .4482566692 9158295391 6931735480 E+00/ DATA V(103) / .5963473623 2319407434 1078499290 E+00/ DATA V(104) / .7573420861 2217595345 4414369190 E+00/ DATA V(105) / .7578721561 4131210604 3351240000 E+00/ C***FIRST EXECUTABLE STATEMENT SFNCK C C Exercise routines in Category C1. C Y( 1) = BINOM(35,12) Y( 2) = BINOM(50,15) Y( 3) = FAC(15) Y( 4) = FAC(31) C C Exercise routines in Category C2 C Y( 5) = CBRT(-8.E0) Y( 6) = CBRT(.9950306243 6570396447 5039000000 E6) C C Exercise routines in Category C4A. C Y( 7) = COSDG(30.E0) Y( 8) = COSDG(135.E0) Y( 9) = COT(1.E0) Y( 10) = COT(-.5E0) Y( 11) = R9ATN1(.5E0) Y( 12) = R9ATN1(2.E0) Y( 13) = SINDG(30.E0) Y( 14) = SINDG(135.E0) C C Exercise routines in Category C4B. C Y( 15) = ALNREL(.147E0) Y( 16) = ALNREL(-.1E-5) Y( 17) = EXPREL(.25E-2) Y( 18) = EXPREL(-.1E-1) Y( 19) = R9LN2R(.5E0) Y( 20) = R9LN2R(1.E0) C C Exercise routines in Category C4C. C Y( 21) = ACOSH(.1006179316 4909482374 7218929626 E1) Y( 22) = ACOSH(.1159195327 5523908462 8557897777 E2) Y( 23) = ASINH(.1000000001 0129514521 1538706587 E0) Y( 24) = ASINH(-.1499999999 4824063412 4264852207 E1) Y( 25) = ATANH(-.1106572080 4138399806 6515207788 E0) Y( 26) = ATANH(.9899999999 9279130066 3084082410 E0) C C Exercise routines in Category C5. C Y( 27) = ALI(.5E0) Y( 28) = ALI(2.E0) Y( 29) = E1(.5E0) Y( 30) = E1(1.5E0) Y( 31) = EI(.5E0) Y( 32) = EI(1.E0) Y( 33) = SPENC(.5E0) Y( 34) = SPENC(1.E0) Y( 35) = GAMMA(1.5E0) Y( 36) = GAMMA(-.5E0)*GAMMA(1.5E0) Y( 37) = GAMR(-1.5E0)*GAMR(2.5E0) Y( 38) = GAMR(10.5E0) C C Exercise routines in Category C7A. C Y( 39) = POCH(-.5E0,1.5E0) Y( 40) = POCH(.5E0,3.E0) Y( 41) = POCH1(.5E0,2.5E0) Y( 42) = POCH1(10.5E0,2.E0) C C Exercise routines in Category C7B. C Y( 43) = BETA(.5E0,1.5E0) Y( 44) = BETA(5.5E0,5.5E0) C C Exercise routines in Category C7C. C Y( 45) = PSI(2.E0) Y( 46) = PSI(10.5E0) C C Exercise routines in Category C7E. C Y( 47) = GAMI(1.E0,8.85E0) Y( 48) = GAMI(2.E0,3.75E0) Y( 49) = GAMIC(1.E0,2.E0) Y( 50) = GAMIC(2.E0,10.4E0) Y( 51) = GAMIT(1.E0,.5E0) Y( 52) = GAMIT(2.E0,3.75E0) C C Exercise routines in Category C7F. C Y( 53) = BETAI(.5E0,2.E0,1.5E0) Y( 54) = BETAI(.25E0,1.5E0,2.E0) C C Exercise routines in Category C8A. C Y( 55) = ERF(.5E0) Y( 56) = ERF(1.125E0) C C Exercise routines in Category C8C. C Y( 57) = DAWS(.5E0) Y( 58) = DAWS(1.84E0) C C Exercise routines in Category C10A1. C Y( 59) = BESJ0(5.E0) Y( 60) = BESJ0(2.E0) Y( 61) = BESJ1(5.E0) Y( 62) = BESJ1(2.E0) Y( 63) = BESY0(2.E0) Y( 64) = BESY0(5.E0) Y( 65) = BESY1(5.E0) Y( 66) = BESY1(2.E0) C C Exercise routines in Category C10B1. C Y( 67) = BESI0(2.E0) Y( 68) = BESI0(5.E0) Y( 69) = BESI1(2.E0) Y( 70) = BESI1(5.E0) Y( 71) = BESK0(2.E0) Y( 72) = BESK0(5.E0) Y( 73) = BESK1(2.E0) Y( 74) = BESK1(5.E0) Y( 75) = BESI0E(2.E0) Y( 76) = BESI0E(5.E0) Y( 77) = BESI1E(5.E0) Y( 78) = BESI1E(2.E0) Y( 79) = BESK0E(2.E0) Y( 80) = BESK0E(5.E0) Y( 81) = BESK1E(5.E0) Y( 82) = BESK1E(2.E0) C C Exercise routines in Category C10B3. C CALL BESKES(.5E0,2.E0,3,Y(83)) CALL BESKES(.5E0,5.E0,3,Y(86)) CALL BESKS(.5E0,1.E0,2,Y(89)) C C Exercise routines in Category C10D. C Y( 91) = AI(.5E0) Y( 92) = AI(2.5E0) Y( 93) = AIE(.5E0) Y( 94) = AIE(2.5E0) Y( 95) = BI(.5E0) Y( 96) = BI(1.5E0) Y( 97) = BIE(.5E0) Y( 98) = BIE(2.5E0) C C Exercise routines in Category C11. C Y( 99) = CHU(1.E0,2.E0,4.E0) Y(100) = CHU(5.E0/6.E0,5.E0/3.E0,4.E0/3.E0) Y(101) = CHU(.75E0,.75E0,2.5E0) Y(102) = CHU(1.E0,1.E0,1.5E0) Y(103) = CHU(1.E0,1.E0,1.E0) Y(104) = CHU(1.E0,1.E0,-LOG(.5E0)) Y(105) = CHU(.5E0,.5E0,1.E0) C C Check for possible errors C ERRMAX = R1MACH(4) ERRTOL = SQRT(ERRMAX) DO 10 I = 1,105 ABSERR = ABS(V(I)-Y(I)) RELERR = ABSERR/ABS(V(I)) ERRMAX = MAX(RELERR,ERRMAX) IF (RELERR.GT.ERRTOL .AND. KPRINT.GE.2) + WRITE (LUN,620) I,RELERR,ABSERR 10 CONTINUE IPASS = 0 IF (ERRMAX.LE.ERRTOL) IPASS = 1 IF (IPASS.NE.0 .AND. KPRINT.GE.2) WRITE (LUN,610) RETURN C 610 FORMAT (' Single precision Fullerton special function ', + ' routines o.k.') 620 FORMAT (' For I = ', I3, ' test fails with RELERR = ', + E38.30, ' and ABSERR = ', E38.30) END *DECK SGEQC SUBROUTINE SGEQC (LUN, KPRINT, NERR) C***BEGIN PROLOGUE SGEQC C***PURPOSE Quick check for SGEFS and SGEIR. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (SGEQC-S, DGEQC-D, CGEQC-C) C***KEYWORDS QUICK CHECK C***AUTHOR Jacobsen, Nancy, (LANL) C***DESCRIPTION C C Let A*X=B be a SINGLE PRECISION linear system where the C matrix is of the proper type for the Linpack subroutines C being called. The values of A and B and the pre-computed C values of BXEX (the solution vector) are given in DATA C statements. The computed test results for X are compared to C the stored pre-computed values. Failure of the test occurs C when there is less than 80% agreement between the absolute C values. There are 2 tests - one for the normal case and one C for the singular case. A message is printed indicating C whether each subroutine has passed or failed for each case. C C On return, NERR (INTEGER type) contains the total count of C all failures detected. C C***ROUTINES CALLED R1MACH, SGEFS, SGEIR C***REVISION HISTORY (YYMMDD) C 801022 DATE WRITTEN C 891009 Removed unreferenced statement label. (WRB) C 891009 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920601 Code reworked and TYPE section added. (RWC, WRB) C***END PROLOGUE SGEQC C .. Scalar Arguments .. INTEGER KPRINT, LUN, NERR C .. Local Scalars .. REAL ERRCMP, ERRMAX INTEGER I, IND, ITASK, J, KPROG, LDA, N C .. Local Arrays .. REAL A(5,4), ATEMP(5,4), B(4), BTEMP(4), BXEX(4), WORK(20) INTEGER IWORK(4) CHARACTER LIST(2)*4 C .. External Functions .. REAL R1MACH EXTERNAL R1MACH C .. External Subroutines .. EXTERNAL SGEFS, SGEIR C .. Intrinsic Functions .. INTRINSIC ABS, MAX C .. Data statements .. DATA A /5.0E0, 1.0E0, 0.3E0, 2.1E0, 0.0E0, + -1.0E0, -0.5E0, 1.0E0, 1.0E0, 0.0E0, + 4.5E0, -1.0E0, -1.7E0, 2.0E0, 0.0E0, + 0.5E0, 2.0E0, 0.6E0, 1.3E0, 0.0E0/ DATA B /0.0E0, 3.5E0, 3.6E0, 2.4E0/ DATA BXEX /0.10E+01, 0.10E+01, -0.10E+01, 0.10E+01/ DATA LIST /'GEFS', 'GEIR'/ C***FIRST EXECUTABLE STATEMENT SGEQC N = 4 LDA = 5 NERR = 0 ERRCMP = R1MACH(4)**0.8E0 IF (KPRINT .GE. 2) WRITE (LUN,9000) C DO 180 KPROG=1,2 C C First test case - normal C ITASK = 1 DO 100 I=1,N BTEMP(I) = B(I) 100 CONTINUE DO 120 J=1,N DO 110 I=1,N ATEMP(I,J) = A(I,J) 110 CONTINUE 120 CONTINUE IF (KPROG .EQ. 1) THEN CALL SGEFS (ATEMP, LDA, N, BTEMP, ITASK, IND, WORK, IWORK) ELSE CALL SGEIR (ATEMP, LDA, N, BTEMP, ITASK, IND, WORK, IWORK) ENDIF IF (IND .LT. 0) THEN IF (KPRINT .GE. 2) WRITE (LUN, FMT=9010) LIST(KPROG), IND NERR = NERR + 1 ENDIF C C Calculate error for first test C ERRMAX = 0.0E0 C DO 130 I=1,N ERRMAX = MAX(ERRMAX,ABS(BTEMP(I)-BXEX(I))) 130 CONTINUE IF (ERRCMP .GT. ERRMAX) THEN IF (KPRINT .GE. 3) WRITE (LUN, FMT=9010) LIST(KPROG) ELSE IF (KPRINT .GE. 2) WRITE (LUN, FMT=9020) LIST(KPROG), ERRMAX NERR = NERR + 1 ENDIF C C Second test case - singular matrix C ITASK = 1 DO 140 I=1,N BTEMP(I) = B(I) 140 CONTINUE DO 160 J=1,N DO 150 I=1,N ATEMP(I,J) = A(I,J) 150 CONTINUE 160 CONTINUE DO 170 J=1,N ATEMP(1,J) = 0.0E0 170 CONTINUE IF (KPROG .EQ. 1) THEN CALL SGEFS (ATEMP, LDA, N, BTEMP, ITASK, IND, WORK, IWORK) ELSE CALL SGEIR (ATEMP, LDA, N, BTEMP, ITASK, IND, WORK, IWORK) ENDIF IF (IND .EQ. -4) THEN IF (KPRINT .GE. 3) WRITE (LUN, FMT=9030) LIST(KPROG) ELSE IF (KPRINT .GE. 2) WRITE (LUN, FMT=9040) LIST(KPROG), IND NERR = NERR + 1 ENDIF C 180 CONTINUE C IF (KPRINT.GE.3 .AND. NERR.EQ.0) WRITE (LUN,9050) IF (KPRINT.GE.2 .AND. NERR.NE.0) WRITE (LUN,9060) RETURN C 9000 FORMAT (//, 2X, 'SGEFS and SGEIR Quick Check' /) 9010 FORMAT (/, 5X, 'S', A, ' Normal test PASSED') 9020 FORMAT (/, 5X, 'S', A, ' Test FAILED, MAX ABS(ERROR) is', E13.5) 9030 FORMAT (/, 5X, 'S', A, ' Singular test PASSED') 9040 FORMAT (/, 5X, 'S', A, ' Singular test FAILED, IND=', I3) 9050 FORMAT (/, 2X, 'SGEFS and SGEIR Quick Check PASSED' /) 9060 FORMAT (/, 2X, 'SGEFS and SGEIR Quick Check FAILED' /) END *DECK SNLS1Q SUBROUTINE SNLS1Q (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE SNLS1Q C***PURPOSE Quick check for SNLS1E, SNLS1 and SCOV. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C THIS SUBROUTINE PERFORMS A QUICK CHECK ON THE SUBROUTINES SNLS1E C (AND SNLS1) AND SCOV. C C***ROUTINES CALLED ENORM, FCN1, FCN2, FCN3, FDJAC3, PASS, R1MACH, C SCOV, SNLS1E C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE SNLS1Q INTEGER ICNT, ITEST(8) DIMENSION X(2),FVEC(10),FJAC(10,2),FJROW(2),WA(40),IW(2),FJTJ(3) EXTERNAL FCN1,FCN2,FCN3 C***FIRST EXECUTABLE STATEMENT SNLS1Q INFOS=1 FNORMS=0.11151779E+02 M=10 N=2 LWA=40 LDFJAC=10 NPRINT=-1 IFLAG=1 ZERO=0.E0 ONE=1.E0 TOL=SQRT(40.*R1MACH(4)) TOL2=SQRT(TOL) IF (KPRINT.GE.2) WRITE(LUN,1000) C C OPTION=2, THE FULL JACOBIAN IS STORED AND THE USER PROVIDES THE C JACOBIAN. IOPT=2 X(1)=3.E-1 X(2)=4.E-1 CALL SNLS1E(FCN2,IOPT,M,N,X,FVEC,TOL,NPRINT,INFO, * IW,WA,LWA) ICNT=1 FNORM=ENORM(M,FVEC) ITEST(ICNT)=0 IF ((INFO.EQ.INFOS) .AND. (ABS(FNORM-FNORMS)/FNORMS.LE.TOL)) * ITEST(ICNT)=1 IF (KPRINT.EQ.0) GO TO 15 IF ((KPRINT.GE.2.AND.ITEST(ICNT).NE.1).OR.KPRINT.GE.3) * WRITE(LUN,1010) INFOS,FNORMS,INFO,FNORM IF((KPRINT.GE.2).OR.(KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) * CALL PASS (LUN, ICNT, ITEST(ICNT)) 15 CONTINUE C C FORM JAC-TRANSPOSE*JAC SIGMA=FNORM*FNORM/(M-N) IFLAG = 2 CALL FCN2(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) DO 10 I=1,3 10 FJTJ(I)=ZERO DO 11 I=1,M FJTJ(1)=FJTJ(1)+FJAC(I,1)**2 FJTJ(2)=FJTJ(2)+FJAC(I,1)*FJAC(I,2) FJTJ(3)=FJTJ(3)+FJAC(I,2)**2 11 CONTINUE C C CALCULATE COVARIANCE MATRIX CALL SCOV(FCN2,IOPT,M,N,X,FVEC,FJAC,LDFJAC,INFO, *WA(1),WA(N+1),WA(2*N+1),WA(3*N+1)) C C FORM JAC-TRANSPOSE*JAC * COVARIANCE MATRIX C (SHOULD = SIGMA*I) TEMP1=(FJTJ(1)*FJAC(1,1)+FJTJ(2)*FJAC(1,2))/SIGMA TEMP2=(FJTJ(1)*FJAC(1,2)+FJTJ(2)*FJAC(2,2))/SIGMA TEMP3=(FJTJ(2)*FJAC(1,2)+FJTJ(3)*FJAC(2,2))/SIGMA ICNT=5 ITEST(ICNT)=0 IF (INFO.EQ.INFOS .AND. ABS(TEMP1-ONE).LT.TOL2 .AND. * ABS(TEMP2).LT.TOL2 .AND. ABS(TEMP3-ONE).LT.TOL2) *ITEST(ICNT)=1 IF (KPRINT.EQ.0) GO TO 20 IF ((KPRINT.GE.2.AND.ITEST(ICNT).NE.1).OR.KPRINT.GE.3) * WRITE(LUN,1020) INFOS,INFO,TEMP1,TEMP2,TEMP3 IF((KPRINT.GE.2).OR.(KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) * CALL PASS (LUN, ICNT, ITEST(ICNT)) C C OPTION=1, THE FULL JACOBIAN IS STORED AND THE CODE APPROXIMATES C THE JACOBIAN. 20 IOPT=1 X(1)=3.E-1 X(2)=4.E-1 CALL SNLS1E(FCN1,IOPT,M,N,X,FVEC,TOL,NPRINT,INFO, * IW,WA,LWA) ICNT=2 FNORM=ENORM(M,FVEC) ITEST(ICNT)=0 IF ((INFO.EQ.INFOS).AND.(ABS(FNORM-FNORMS)/FNORMS.LE.TOL)) * ITEST(ICNT)=1 IF (KPRINT.EQ.0) GO TO 25 IF ((KPRINT.GE.2.AND.ITEST(ICNT).NE.1).OR.KPRINT.GE.3) * WRITE(LUN,1010) INFOS,FNORMS,INFO,FNORM IF((KPRINT.GE.2).OR.(KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) * CALL PASS (LUN, ICNT, ITEST(ICNT)) 25 CONTINUE C C FORM JAC-TRANSPOSE*JAC SIGMA=FNORM*FNORM/(M-N) IFLAG = 1 CALL FDJAC3(FCN1,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,ZERO,WA) DO 26 I=1,3 26 FJTJ(I)=ZERO DO 27 I=1,M FJTJ(1)=FJTJ(1)+FJAC(I,1)**2 FJTJ(2)=FJTJ(2)+FJAC(I,1)*FJAC(I,2) FJTJ(3)=FJTJ(3)+FJAC(I,2)**2 27 CONTINUE C C CALCULATE COVARIANCE MATRIX CALL SCOV(FCN1,IOPT,M,N,X,FVEC,FJAC,LDFJAC,INFO, *WA(1),WA(N+1),WA(2*N+1),WA(3*N+1)) C C FORM JAC-TRANSPOSE*JAC * COVARIANCE MATRIX C (SHOULD = SIGMA*I) TEMP1=(FJTJ(1)*FJAC(1,1)+FJTJ(2)*FJAC(1,2))/SIGMA TEMP2=(FJTJ(1)*FJAC(1,2)+FJTJ(2)*FJAC(2,2))/SIGMA TEMP3=(FJTJ(2)*FJAC(1,2)+FJTJ(3)*FJAC(2,2))/SIGMA ICNT=6 ITEST(ICNT)=0 IF (INFO.EQ.INFOS .AND. ABS(TEMP1-ONE).LT.TOL2 .AND. * ABS(TEMP2).LT.TOL2 .AND. ABS(TEMP3-ONE).LT.TOL2) *ITEST(ICNT)=1 IF (KPRINT.EQ.0) GO TO 30 IF ((KPRINT.GE.2.AND.ITEST(ICNT).NE.1).OR.KPRINT.GE.3) * WRITE(LUN,1020) INFOS,INFO,TEMP1,TEMP2,TEMP3 IF((KPRINT.GE.2).OR.(KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) * CALL PASS (LUN, ICNT, ITEST(ICNT)) C C OPTION=3, THE FULL JACOBIAN IS NOT STORED ONLY THE PRODUCT OF THE C JACOBIAN TRANSPOSE AND JACOBIAN IS STORED. THE USER PROVIDES THE C THE JACOBIAN ONE ROW AT A TIME. 30 IOPT=3 X(1)=3.E-1 X(2)=4.E-1 CALL SNLS1E(FCN3,IOPT,M,N,X,FVEC,TOL,NPRINT,INFO, * IW,WA,LWA) ICNT=3 FNORM=ENORM(M,FVEC) ITEST(ICNT)=0 IF ((INFO.EQ.INFOS).AND.(ABS(FNORM-FNORMS)/FNORMS.LE.TOL)) * ITEST(ICNT)=1 IF (KPRINT.EQ.0) GO TO 35 IF ((KPRINT.GE.2.AND.ITEST(ICNT).NE.1).OR.KPRINT.GE.3) * WRITE(LUN,1010) INFOS,FNORMS,INFO,FNORM IF((KPRINT.GE.2).OR.(KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) * CALL PASS (LUN, ICNT, ITEST(ICNT)) 35 CONTINUE C C FORM JAC-TRANSPOSE*JAC SIGMA=FNORM*FNORM/(M-N) DO 36 I=1,3 36 FJTJ(I)=ZERO IFLAG=3 DO 37 I=1,M CALL FCN3(IFLAG,M,N,X,FVEC,FJROW,I) FJTJ(1)=FJTJ(1)+FJROW(1)**2 FJTJ(2)=FJTJ(2)+FJROW(1)*FJROW(2) FJTJ(3)=FJTJ(3)+FJROW(2)**2 37 CONTINUE C C CALCULATE COVARIANCE MATRIX CALL SCOV(FCN3,IOPT,M,N,X,FVEC,FJAC,LDFJAC,INFO, *WA(1),WA(N+1),WA(2*N+1),WA(3*N+1)) C C FORM JAC-TRANSPOSE*JAC * COVARIANCE MATRIX C (SHOULD = SIGMA*I) TEMP1=(FJTJ(1)*FJAC(1,1)+FJTJ(2)*FJAC(1,2))/SIGMA TEMP2=(FJTJ(1)*FJAC(1,2)+FJTJ(2)*FJAC(2,2))/SIGMA TEMP3=(FJTJ(2)*FJAC(1,2)+FJTJ(3)*FJAC(2,2))/SIGMA ICNT=7 ITEST(ICNT)=0 IF (INFO.EQ.INFOS .AND. ABS(TEMP1-ONE).LT.TOL2 .AND. * ABS(TEMP2).LT.TOL2 .AND. ABS(TEMP3-ONE).LT.TOL2) *ITEST(ICNT)=1 IF (KPRINT.EQ.0) GO TO 40 IF ((KPRINT.GE.2.AND.ITEST(ICNT).NE.1).OR.KPRINT.GE.3) * WRITE(LUN,1020) INFOS,INFO,TEMP1,TEMP2,TEMP3 IF((KPRINT.GE.2).OR.(KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) * CALL PASS (LUN, ICNT, ITEST(ICNT)) C C TEST IMPROPER INPUT PARAMETERS 40 LWA=35 IOPT=2 X(1)=3.E-1 X(2)=4.E-1 CALL SNLS1E(FCN2,IOPT,M,N,X,FVEC,TOL,NPRINT,INFO, * IW,WA,LWA) ICNT=4 ITEST(ICNT)=0 IF (INFO.EQ.0) ITEST(ICNT)=1 IF((KPRINT.GE.2).OR.(KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) * CALL PASS (LUN, ICNT, ITEST(ICNT)) ITEST(8)=1 IF(KPRINT.LT.3) GO TO 999 M=0 CALL SCOV(FCN2,IOPT,M,N,X,FVEC,FJAC,LDFJAC,INFO, *WA(1),WA(N+1),WA(2*N+1),WA(3*N+1)) ICNT=8 ITEST(ICNT)=0 IF (INFO.EQ.0) ITEST(ICNT)=1 IF((KPRINT.GE.2).OR.(KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) * CALL PASS (LUN, ICNT, ITEST(ICNT)) C C SET IPASS 999 IPASS=ITEST(1)*ITEST(2)*ITEST(3)*ITEST(4) IPASS=IPASS*ITEST(5)*ITEST(6)*ITEST(7)*ITEST(8) RETURN 1000 FORMAT(1H1,19H SNLS1E QUICK CHECK/) 1010 FORMAT(41H EXPECTED VALUE OF INFO AND RESIDUAL NORM,I5,E20.9/ * 41H RETURNED VALUE OF INFO AND RESIDUAL NORM,I5,E20.9/) 1020 FORMAT(36H EXPECTED AND RETURNED VALUE OF INFO,I5,10X,I5/ *56H RETURNED PRODUCT OF (J-TRANS*J)*COVARIANCE MATRIX/SIGMA/ *41H (SHOULD = THE IDENTITY -- 1.0, 0.0, 1.0)/3E20.9/) END *DECK SNSQQK SUBROUTINE SNSQQK (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE SNSQQK C***PURPOSE Quick check for SNSQE and SNSQ. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (SNSQQK-S, DNSQQK-D) C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C This subroutine performs a quick check on the subroutine SNSQE C (and SNSQ). C C***ROUTINES CALLED ENORM, PASS, R1MACH, SNSQE, SQFCN2, SQJAC2 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891009 Removed unreferenced variable. (WRB) C 891009 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920310 Code cleaned up and TYPE section added. (RWC, WRB) C***END PROLOGUE SNSQQK C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. REAL FNORM, FNORMS, TOL INTEGER ICNT, INFO, INFOS, IOPT, LWA, N, NPRINT C .. Local Arrays .. REAL FVEC(2), WA(19), X(2) INTEGER ITEST(3) C .. External Functions .. REAL ENORM, R1MACH EXTERNAL ENORM, R1MACH C .. External Subroutines .. EXTERNAL PASS, SNSQE, SQFCN2, SQJAC2 C .. Intrinsic Functions .. INTRINSIC SQRT C***FIRST EXECUTABLE STATEMENT SNSQQK INFOS = 1 FNORMS = 0.0E0 N = 2 LWA = 19 NPRINT = -1 TOL = SQRT(R1MACH(4)) IF (KPRINT .GE. 2) WRITE (LUN,9000) C C Option 1, the user provides the Jacobian. C IOPT = 1 X(1) = -1.2E0 X(2) = 1.0E0 CALL SNSQE (SQFCN2,SQJAC2,IOPT,N,X,FVEC,TOL,NPRINT,INFO,WA,LWA) ICNT = 1 FNORM = ENORM(N,FVEC) ITEST(ICNT) = 0 IF ((INFO.EQ.INFOS) .AND. (FNORM-FNORMS.LE.TOL)) ITEST(ICNT) = 1 C IF (KPRINT .NE. 0) THEN IF ((KPRINT.GE.2 .AND. ITEST(ICNT).NE.1) .OR. KPRINT.GE.3) + WRITE (LUN,9010) INFOS,FNORMS,INFO,FNORM IF ((KPRINT.GE.2) .OR. (KPRINT.EQ.1 .AND. ITEST(ICNT).NE.1)) + CALL PASS (LUN, ICNT, ITEST(ICNT)) ENDIF C C Option 2, the code approximates the Jacobian. C IOPT = 2 X(1) = -1.2E0 X(2) = 1.0E0 CALL SNSQE (SQFCN2,SQJAC2,IOPT,N,X,FVEC,TOL,NPRINT,INFO,WA,LWA) ICNT = 2 FNORM = ENORM(N,FVEC) ITEST(ICNT) = 0 IF ((INFO.EQ.INFOS) .AND. (FNORM-FNORMS.LE.TOL)) ITEST(ICNT) = 1 C IF (KPRINT .NE. 0) THEN IF (KPRINT.GE.3 .OR. (KPRINT.GE.2.AND.ITEST(ICNT).NE.1)) + WRITE (LUN,9010) INFOS, FNORMS, INFO, FNORM IF (KPRINT.GE.2 .OR. (KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) + CALL PASS (LUN, ICNT, ITEST(ICNT)) ENDIF C C Test improper input parameters. C LWA = 15 IOPT = 1 X(1) = -1.2E0 X(2) = 1.0E0 CALL SNSQE (SQFCN2,SQJAC2,IOPT,N,X,FVEC,TOL,NPRINT,INFO,WA,LWA) ICNT = 3 ITEST(ICNT) = 0 IF (INFO .EQ. 0) ITEST(ICNT) = 1 IF (KPRINT.GE.2 .OR. (KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) + CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Set IPASS. C IPASS = ITEST(1)*ITEST(2)*ITEST(3) IF (KPRINT.GE.1 .AND. IPASS.NE.1) WRITE (LUN,9020) IF (KPRINT.GE.2 .AND. IPASS.EQ.1) WRITE (LUN,9030) RETURN 9000 FORMAT ('1' / ' SNSQE QUICK CHECK'/) 9010 FORMAT (' EXPECTED VALUE OF INFO AND RESIDUAL NORM', I5, E20.5 / + ' RETURNED VALUE OF INFO AND RESIDUAL NORM', I5, E20.5 /) 9020 FORMAT (/' **********WARNING -- SNSQE/SNSQ FAILED SOME TESTS****', + '******') 9030 FORMAT (/' ----------SNSQE/SNSQ PASSED ALL TESTS----------') END *DECK SORTQX SUBROUTINE SORTQX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE SORTQX C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED ISORT, SSORT C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE SORTQX DIMENSION X(10),Y(10),IX(10),IY(10) DATA X(1),Y(1),IX(1),IY(1),X(2),Y(2),IX(2),IY(2),X(3),Y(3),IX(3), 1IY(3),X(4),Y(4),IX(4),IY(4),X(5),Y(5),IX(5),IY(5),X(6),Y(6),IX(6), 2IY(6),X(7),Y(7),IX(7),IY(7),X(8),Y(8),IX(8),IY(8),X(9),Y(9),IX(9), 3IY(9),X(10),Y(10),IX(10),IY(10)/ 4 1.,1.,3,3,-1.,-1.,2,2,2.,2.,4,4, -2.,-2.,-2,-2, 2.,2.,2,2, 5 0.,0.,0,0, -2.,-2.,-1,-1, 9.,9.,9,9, -9.,-9.,-9,-9,-0.,-0.,0,0/ C***FIRST EXECUTABLE STATEMENT SORTQX CALL SSORT(X,Y,10,2) IF(KPRINT.GT.2)WRITE(LUN,100) (X(I),Y(I),I=1,10) CALL ISORT(IX,IY,10,2) IF(KPRINT.GT.2)WRITE(LUN,101) (IX(I),IY(I),I=1,10) IPASS=0 IF(IX(1).EQ.-9 .AND. X(1).EQ.-9.)IPASS=1 IF(IPASS .EQ. 1.AND.KPRINT.GE.2) WRITE(LUN,200) IF(IPASS .EQ. 0.AND.KPRINT.NE.0) WRITE(LUN,201) 200 FORMAT(26H NO ERROR IN SSORT PACKAGE ) 201 FORMAT(31H ISORT OR SSORT HAS AN ERROR... ) 100 FORMAT(2E16.8) 101 FORMAT(2I5) RETURN END *DECK SOSFNC REAL FUNCTION SOSFNC (X, K) C***BEGIN PROLOGUE SOSFNC C***PURPOSE Function evaluator for SOS quick check. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Watts, H. A., (SNLA) C***DESCRIPTION C C FUNCTION WHICH EVALUATES THE FUNCTIONS, ONE AT A TIME, C FOR TEST PROGRAM USED IN QUICK CHECK OF SOS. C C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 801001 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE SOSFNC DIMENSION X(2) C***FIRST EXECUTABLE STATEMENT SOSFNC IF (K.EQ.1) SOSFNC=1.E0-X(1) IF (K.EQ.2) SOSFNC=1.E1*(X(2)-X(1)**2) RETURN END *DECK SOSNQX SUBROUTINE SOSNQX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE SOSNQX C***PURPOSE Quick check for SOS. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (SOSNQX-S, DSOSQX-D) C***KEYWORDS QUICK CHECK C***AUTHOR Watts, H. A., (SNLA) C***DESCRIPTION C C This subroutine performs a quick check on the subroutine SOS. C C***ROUTINES CALLED PASS, R1MACH, SNRM2, SOS, SOSFNC C***REVISION HISTORY (YYMMDD) C 801001 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920310 Code cleaned up and TYPE section added. (RWC, WRB) C***END PROLOGUE SOSNQX C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. REAL AER, FNORM, FNORMS, RER, TOLF INTEGER ICNT, IFLAG, IFLAGS, LIW, LWA, N C .. Local Arrays .. REAL FVEC(2), WA(17), X(2) INTEGER ITEST(2), IW(6) C .. External Functions .. REAL R1MACH, SNRM2, SOSFNC EXTERNAL R1MACH, SNRM2, SOSFNC C .. External Subroutines .. EXTERNAL PASS, SOS C .. Intrinsic Functions .. INTRINSIC SQRT C***FIRST EXECUTABLE STATEMENT SOSNQX IFLAGS = 3 FNORMS = 0.0E0 N = 2 LWA = 17 LIW = 6 TOLF = SQRT(R1MACH(4)) RER = SQRT(R1MACH(4)) AER = 0.0E0 IF (KPRINT .GE. 2) WRITE (LUN,9000) C C Test the code with proper input values. C IFLAG = 0 X(1) = -1.2E0 X(2) = 1.0E0 CALL SOS (SOSFNC,N,X,RER,AER,TOLF,IFLAG,WA,LWA,IW,LIW) ICNT = 1 FVEC(1) = SOSFNC(X,1) FVEC(2) = SOSFNC(X,2) FNORM = SNRM2(N,FVEC,1) ITEST(ICNT) = 0 IF (IFLAG.LE.IFLAGS .AND. FNORM-FNORMS.LE.RER) ITEST(ICNT) = 1 C IF (KPRINT .NE. 0) THEN IF (KPRINT.GE.3 .OR. (KPRINT.GE.2.AND.ITEST(ICNT).NE.1)) + WRITE (LUN,9010) IFLAGS,FNORMS,IFLAG,FNORM IF (KPRINT.GE.2 .OR. (KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) + CALL PASS (LUN,ICNT,ITEST(ICNT)) ENDIF C C Test improper input parameters. C LWA = 15 IFLAG = 0 X(1) = -1.2E0 X(2) = 1.0E0 CALL SOS (SOSFNC,N,X,RER,AER,TOLF,IFLAG,WA,LWA,IW,LIW) ICNT = 2 ITEST(ICNT) = 0 IF (IFLAG .EQ. 9) ITEST(ICNT) = 1 IF (KPRINT.GE.2 .OR. (KPRINT.EQ.1.AND.ITEST(ICNT).NE.1)) + CALL PASS (LUN,ICNT,ITEST(ICNT)) C C Set IPASS. C IPASS = ITEST(1)*ITEST(2) IF (KPRINT.GE.1 .AND. IPASS.NE.1) WRITE (LUN,9020) IF (KPRINT.GE.2 .AND. IPASS.EQ.1) WRITE (LUN,9030) RETURN 9000 FORMAT ('1' / ' SOS QUICK CHECK' /) 9010 FORMAT (' EXPECTED VALUE OF IFLAG AND RESIDUAL NORM', I5, E20.5 / + ' RETURNED VALUE OF IFLAG AND RESIDUAL NORM', I5, E20.5 /) 9020 FORMAT (/' **********WARNING -- SOS FAILED SOME TESTS**********') 9030 FORMAT (/' ----------SOS PASSED ALL TESTS----------') END *DECK SPLPQX SUBROUTINE SPLPQX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE SPLPQX C***PURPOSE Quick check for SPLP. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (SPLPQX-S, DPLPQX-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED PASS, SCOPY, SPLP, USRMAT C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 901013 Added additional printout on failure. (RWC) C***END PROLOGUE SPLPQX EXTERNAL USRMAT REAL COSTS(37) DIMENSION PRGOPT(50), DATTRV(210), BL(60), BU(60) DIMENSION IND(60), PRIMAL(60), DUALS(60), IBASIS(60) DIMENSION WORK(800), IWORK(900), ISOLN(14) DIMENSION D(14,37) C***FIRST EXECUTABLE STATEMENT SPLPQX IF(KPRINT.GE.2) WRITE(LUN,999) 999 FORMAT ('1 SPLP QUICK CHECK') ICNT=1 ZERO = 0.0 C C DEFINE WORKING ARRAY LENGTHS C LIW = 900 LW = 800 MRELAS = 14 NVARS = 37 C C DEFINE THE ARRAY COSTS(*) FOR THE OBJECTIVE FUNCTION C COSTS(1) = 1.030 COSTS(2) = 0.985 COSTS(3) = 0.997 COSTS(4) = 1.036 COSTS(5) = 1.005 COSTS(6) = 0.980 COSTS(7) = 1.004 COSTS(8) = 0.993 COSTS(9) = 1.018 COSTS(10) = 0.947 COSTS(11) = 0.910 COSTS(12) = 1.028 COSTS(13) = 0.957 COSTS(14) = 1.025 COSTS(15) = 1.036 COSTS(16) = 1.060 COSTS(17) = 0.954 COSTS(18) = 0.891 COSTS(19) = 0.921 COSTS(20) = 1.040 COSTS(21) = 0.912 COSTS(22) = 0.926 COSTS(23) = 1.000 COSTS(24) = 0.000 COSTS(25) = 0.000 COSTS(26) = 0.000 COSTS(27) = 0.000 COSTS(28) = 0.000 COSTS(29) = 0.000 COSTS(30) = 0.000 COSTS(31) = 0.000 COSTS(32) = 0.000 COSTS(33) = 0.000 COSTS(34) = 0.000 COSTS(35) = 0.000 COSTS(36) = 0.000 COSTS(37) = 0.000 C C PLACE THE NONZERO INFORMATION ABOUT THE MATRIX IN DATTRV(*) C CALL SCOPY(14*37, ZERO, 0, D, 1) D(1,1) = 1.04000 D(1,23) = 1.00000 D(1,24) = -1.00000 D(2,6) = 0.04125 D(2,7) = 0.05250 D(2,17) = 0.04875 D(2,24) = 1.00000 D(2,25) = -1.00000 D(3,8) = 0.05625 D(3,9) = 0.06875 D(3,11) = 0.02250 D(3,25) = 1.00000 D(3,26) = -1.00000 D(4,2) = 1.04000 D(4,3) = 1.05375 D(4,5) = 1.06125 D(4,12) = 0.08000 D(4,16) = 0.09375 D(4,18) = 0.03750 D(4,19) = 0.04625 D(4,20) = 0.08125 D(4,22) = 0.05250 D(4,26) = 1.00000 D(4,27) = -1.00000 D(5,10) = 0.04375 D(5,27) = 1.00000 D(5,28) = -1.00000 D(6,4) = 1.05875 D(6,13) = 0.04500 D(6,14) = 0.06375 D(6,15) = 0.06625 D(6,21) = 0.05000 D(6,28) = 1.00000 D(6,29) = -1.00000 D(7,6) = 1.04125 D(7,7) = 1.05250 D(7,8) = 1.05625 D(7,9) = 1.06875 D(7,11) = 0.02250 D(7,17) = 0.04875 D(7,29) = 1.00000 D(7,30) = -1.00000 D(8,10) = 1.04375 D(8,12) = 0.08000 D(8,13) = 0.04500 D(8,14) = 0.06375 D(8,15) = 0.06625 D(8,16) = 0.09375 D(8,18) = 0.03750 D(8,19) = 0.04625 D(8,20) = 0.08125 D(8,21) = 0.05000 D(8,22) = 0.05250 D(8,30) = 1.00000 D(8,31) = -1.00000 D(9,11) = 1.02250 D(9,17) = 0.04875 D(9,31) = 1.00000 D(9,32) = -1.00000 D(10,12) = 1.08000 D(10,13) = 1.04500 D(10,14) = 1.06375 D(10,15) = 1.06625 D(10,16) = 1.09375 D(10,18) = 0.03750 D(10,19) = 0.04625 D(10,20) = 0.08125 D(10,21) = 0.05000 D(10,22) = 0.05250 D(10,32) = 1.00000 D(10,33) = -1.00000 D(11,17) = 1.04875 D(11,33) = 1.00000 D(11,34) = -1.00000 D(12,18) = 1.03750 D(12,19) = 1.04625 D(12,20) = 1.08125 D(12,21) = 1.05000 D(12,22) = 0.05250 D(12,34) = 1.00000 D(12,35) = -1.00000 D(13,35) = 1.00000 D(13,36) = -1.00000 D(14,22) = 1.05250 D(14,36) = 1.00000 D(14,37) = -1.00000 KOUNT = 1 DO 20 MM=1,NVARS DATTRV(KOUNT) = -MM DO 10 KK=1,MRELAS IF (D(KK,MM).EQ.ZERO) GO TO 10 KOUNT = KOUNT + 1 DATTRV(KOUNT) = KK KOUNT = KOUNT + 1 DATTRV(KOUNT) = D(KK,MM) 10 CONTINUE KOUNT = KOUNT + 1 20 CONTINUE DATTRV(KOUNT) = ZERO C C NON-NEGATIVITY CONSTRAINT C DO 30 IC=1,NVARS BL(IC) = ZERO IND(IC) = 3 BU(IC) = 10000000.000 30 CONTINUE C C LE CONSTRAINTS C DO 40 IV=1,MRELAS IVV = IV + NVARS IND(IVV) = 3 BL(IVV) = 100.00000 BU(IVV) = 100000000.00000 40 CONTINUE PRGOPT(01) = 18 PRGOPT(02) = 59 PRGOPT(03) = 0 PRGOPT(04) = 1 PRGOPT(05) = 3 PRGOPT(06) = 8 PRGOPT(07) = 10 PRGOPT(08) = 11 PRGOPT(09) = 16 PRGOPT(10) = 17 PRGOPT(11) = 21 PRGOPT(12) = 22 PRGOPT(13) = 24 PRGOPT(14) = 25 PRGOPT(15) = 27 PRGOPT(16) = 28 PRGOPT(17) = 35 PRGOPT(18) = 21 PRGOPT(19) =51 PRGOPT(20) = 0 PRGOPT(21) = 1 CALL SPLP(USRMAT, MRELAS, NVARS, COSTS, PRGOPT, DATTRV, BL, BU, * IND, INFO, PRIMAL, DUALS, IBASIS, WORK, LW, IWORK, LIW) C C LOOK FOR THE KNOWN BASIS AT THE SOLN., NOW IS ISOLN(*). C DO 50 I=1,MRELAS ISOLN(I) = PRGOPT(I+3) 50 CONTINUE C IPASS = 1 DO 70 J=1,MRELAS DO 60 I=1,MRELAS IF (ISOLN(I).EQ.IBASIS(J)) GO TO 70 60 CONTINUE IPASS = 0 GO TO 80 70 CONTINUE C 80 IF (KPRINT.GE.2) WRITE (LUN, 99997) (ISOLN(I), IBASIS(I), * I=1,MRELAS) C IF (KPRINT.GE.2 .OR. (KPRINT.EQ.1.AND.IPASS.NE.1)) * CALL PASS (LUN, ICNT, IPASS) C C HERE IPASS=0 IF CODE FAILED QUICK CHECK; C =1 IF CODE PASSED QUICK CHECK. C IF (KPRINT.GE.1 .AND. IPASS.NE.1) WRITE (LUN,99999) IF (KPRINT.GE.2 .AND. IPASS.EQ.1) WRITE (LUN,99998) RETURN C 99997 FORMAT (/' ISOLN IBASIS'/(2I10)) 99998 FORMAT (/' ************ SPLP PASSED ALL TESTS *****************') 99999 FORMAT (/' ************ SPLP FAILED SOME TESTS ****************') END *DECK SQCK SUBROUTINE SQCK (LUN, KPRINT, NERR) C***BEGIN PROLOGUE SQCK C***PURPOSE Quick check for SPOFS, SPOIR, SNBFS and SNBIR. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Voorhees, E. A., (LANL) C***DESCRIPTION C C QUICK CHECK SUBROUTINE SQCK TESTS THE EXECUTION OF THE C SLATEC SUBROUTINES SPOFS, SPOIR, SNBFS AND SNBIR. C A TITLE LINE AND A SUMMARY LINE ARE ALWAYS OUTPUTTED. C C THE SUMMARY LINE GIVES A COUNT OF THE NUMBER OF C PROBLEMS ENCOUNTERED IN THE TEST IF ANY EXIST. SQCK C CHECKS COMPUTED VS. EXACT SOLUTIONS TO AGREE TO C WITHIN 0.8 TIMES THE WORD LENGTH OF THE COMPUTER C (1.6 IF DOUBLE PRECISION) FOR CASE 1. SQCK ALSO C TESTS ERROR HANDLING BY THE SUBROUTINE (CALLS TO C XERMSG (SQCK SETS IFLAG/KONTRL TO 0)) C USING A SINGULAR MATRIX FOR CASE 2. EACH EXECUTION C PROBLEM DETECTED BY SQCK RESULTS IN AN ADDITIONAL C EXPLANATORY LINE OF OUTPUT. C C SQCK REQUIRES NO INPUT ARGUMENTS. C ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT C OF ALL PROBLEMS DETECTED BY SQCK. C C***ROUTINES CALLED R1MACH, SNBFS, SNBIR, SPOFS, SPOIR C***REVISION HISTORY (YYMMDD) C 800930 DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 891009 Removed unreferenced statement label. (WRB) C 891009 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901009 Routine writes illegal character to column 1, fixed. C Editorial changes made, code fixed to test all four C routines. (RWC) C 901009 Restructured using IF-THEN-ELSE-ENDIF, cleaned up FORMATs, C including removing an illegal character from column 1, and C fixed code to test all four routines. (RWC) C***END PROLOGUE SQCK REAL A(4,4),AT(5,4),ABE(5,7),ABET(5,7),B(4),BT(4),C(4),WORK(35), 1 R,DELX,DELMAX,SIGN,R1MACH CHARACTER*4 LIST(4) INTEGER LDA,N,ML,MU,IND,IWORK(4),NERR,I,J,J1,J2,JD,MLP,K,KCASE, 1 KPROG DATA A/5.0E0,4.0E0,1.0E0,1.0E0,4.0E0,5.0E0,1.0E0,1.0E0, 1 1.0E0,1.0E0,4.0E0,2.0E0,1.0E0,1.0E0,2.0E0,4.0E0/ DATA LIST/'POFS','POIR','NBFS','NBIR'/ C***FIRST EXECUTABLE STATEMENT SQCK IF (KPRINT.GE.3) WRITE (LUN,800) LDA = 5 N = 4 ML = 2 MU = 1 JD = 2*ML+MU+1 NERR = 0 R = R1MACH(4)**0.8E0 C C COMPUTE C VECTOR. C SIGN = 1.0E0 DO 10 I=1,N C(I) = SIGN/I SIGN = -SIGN 10 CONTINUE C C CASE 1 FOR WELL-CONDITIONED MATRIX, CASE 2 FOR SINGULAR MATRIX. C DO 170 KCASE=1,2 DO 140 KPROG=1,4 C SET VECTOR B TO ZERO. DO 11 I=1,N B(I) = 0.0E0 11 CONTINUE C C FORM VECTOR B FOR NON-BANDED. C IF (KPROG.LE.2) THEN DO 13 I=1,N DO 12 J=1,N B(I) = B(I)+A(I,J)*C(J) 12 CONTINUE 13 CONTINUE ELSE C C FORM ABE(NB ARRAY) FROM MATRIX A C AND FORM VECTOR B FOR BANDED. C DO 30 J=1,JD DO 20 I=1,N ABE(I,J) = 0.0E0 20 CONTINUE 30 CONTINUE C MLP = ML+1 DO 50 I=1,N J1 = MAX(1,I-ML) J2 = MIN(N,I+MU) DO 40 J=J1,J2 K = J-I+MLP ABE(I,K) = A(I,J) B(I) = B(I)+(A(I,J)*C(J)) 40 CONTINUE 50 CONTINUE ENDIF C C FORM BT FROM B, AT FROM A, AND ABET FROM ABE. C DO 60 I=1,N BT(I) = B(I) DO 58 J=1,N AT(I,J) = A(I,J) 58 CONTINUE 60 CONTINUE C DO 80 J=1,JD DO 70 I=1,N ABET(I,J) = ABE(I,J) 70 CONTINUE 80 CONTINUE C C MAKE AT AND ABET SINGULAR FOR CASE = 2 C IF (KCASE.EQ.2) THEN DO 88 J=1,N AT(1,J) = 0.0E0 88 CONTINUE C DO 90 J=1,JD ABET(1,J) = 0.0E0 90 CONTINUE ENDIF C C SOLVE FOR X C IF (KPROG.EQ.1) CALL SPOFS (AT,LDA,N,BT,1,IND,WORK) IF (KPROG.EQ.2) CALL SPOIR (AT,LDA,N,BT,1,IND,WORK) IF (KPROG.EQ.3) CALL SNBFS (ABET,LDA,N,ML,MU,BT,1,IND,WORK, * IWORK) IF (KPROG.EQ.4) CALL SNBIR (ABET,LDA,N,ML,MU,BT,1,IND,WORK, * IWORK) C C COMPARE EXACT AND COMPUTED SOLUTIONS FOR CASE 1 C IF (KCASE.EQ.1) THEN DELMAX = 0.0E0 DO 110 I=1,N DELX = ABS(BT(I)-C(I)) DELMAX = MAX(DELMAX,DELX) 110 CONTINUE C IF (R.LE.DELMAX) THEN NERR = NERR+1 WRITE (LUN,801) LIST(KPROG),KCASE,DELMAX ENDIF ELSE C C CHECK CONTROL FOR SINGULAR MATRIX FOR CASE 2 C IF (IND.NE.-4) THEN NERR = NERR+1 WRITE (LUN,802) LIST(KPROG),KCASE,IND ENDIF ENDIF 140 CONTINUE 170 CONTINUE C C SUMMARY PRINT C IF (NERR.NE.0) WRITE (LUN,803) NERR IF (KPRINT.GE.2 .AND. NERR.EQ.0) WRITE (LUN,804) RETURN C 800 FORMAT (/' * SQCK - QUICK CHECK FOR SPOFS, SPOIR, SNBFS AND ', 1 'SNBIR'/) 801 FORMAT (' PROBLEM WITH S', A, ', CASE ', I1, 1 '. MAX ABS ERROR OF', E11.4/) 802 FORMAT (' PROBLEM WITH S', A, ', CASE ', I1, '. IND = ', I2, 1 ' INSTEAD OF -4'/) 803 FORMAT (/' **** SQCK DETECTED A TOTAL OF ', I2,' PROBLEMS. ****'/) 804 FORMAT (' SQCK DETECTED NO PROBLEMS.'/) END *DECK SQFCN2 SUBROUTINE SQFCN2 (N, X, FVEC, IFLAG) C***BEGIN PROLOGUE SQFCN2 C***PURPOSE Evaluate function used in SNSQE. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C SUBROUTINE WHICH EVALUATES THE FUNCTION FOR TEST C PROGRAM USED IN QUICK CHECK OF SNSQE. C C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE SQFCN2 DIMENSION X(*),FVEC(*) C***FIRST EXECUTABLE STATEMENT SQFCN2 FVEC(1)=1.E0-X(1) FVEC(2)=1.E1*(X(2)-X(1)**2) RETURN END *DECK SQJAC2 SUBROUTINE SQJAC2 (N, X, FVEC, FJAC, LDFJAC, IFLAG) C***BEGIN PROLOGUE SQJAC2 C***PURPOSE Evaluate full Jacobian for SNSQE test. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR (UNKNOWN) C***DESCRIPTION C C SUBROUTINE TO EVALUATE THE FULL JACOBIAN FOR TEST PROBLEM USED C IN QUICK CHECK OF SNSQE. C C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE SQJAC2 DIMENSION X(*),FVEC(*),FJAC(LDFJAC,*) C***FIRST EXECUTABLE STATEMENT SQJAC2 FJAC(1,1)=-1.E0 FJAC(1,2)=0.E0 FJAC(2,1)=-2.E1*X(1) FJAC(2,2)=1.E1 RETURN END *DECK STEST SUBROUTINE STEST (LEN, SCOMP, STRUE, SSIZE, SFAC, KPRINT) C***BEGIN PROLOGUE STEST C***PURPOSE Compare arrays SCOMP and STRUE. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (STEST-S, DTEST-D) C***KEYWORDS QUICK CHECK C***AUTHOR Lawson, C. L., (JPL) C***DESCRIPTION C C This subroutine compares arrays SCOMP and STRUE of length LEN to C see if the term by term differences, multiplied by SFAC, are C negligible. In the case of a significant difference, appropriate C messages are written. C C***ROUTINES CALLED R1MACH C***COMMON BLOCKS COMBLA C***REVISION HISTORY (YYMMDD) C 741210 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900820 Modified IF test to use function DIFF and made cosmetic C changes to routine. (WRB) C 901005 Removed usage of DIFF in favour of R1MACH. (RWC) C 910501 Added TYPE record. (WRB) C 920211 Code restructured and information added to the DESCRIPTION C section. (WRB) C***END PROLOGUE STEST REAL SCOMP(*), STRUE(*), SSIZE(*), SFAC, SD, RELEPS, R1MACH LOGICAL PASS COMMON /COMBLA/ NPRINT, ICASE, N, INCX, INCY, MODE, PASS SAVE RELEPS DATA RELEPS /0.0E0/ C***FIRST EXECUTABLE STATEMENT STEST IF (RELEPS .EQ. 0.0E0) RELEPS = R1MACH(4) DO 100 I = 1,LEN SD = ABS(SCOMP(I)-STRUE(I)) IF (SFAC*SD .GT. ABS(SSIZE(I))*RELEPS) THEN C C Here SCOMP(I) is not close to STRUE(I). C IF (PASS) THEN C C Print FAIL message and header. C PASS = .FALSE. IF (KPRINT .GE. 3) THEN WRITE (NPRINT,9000) WRITE (NPRINT,9010) ENDIF ENDIF IF (KPRINT .GE. 3) WRITE (NPRINT,9020) ICASE, N, INCX, INCY, + MODE, I, SCOMP(I), STRUE(I), SD, SSIZE(I) ENDIF 100 CONTINUE RETURN 9000 FORMAT ('+', 39X, 'FAIL') 9010 FORMAT ('0CASE N INCX INCY MODE I', 29X, 'COMP(I)', 29X, + 'TRUE(I)', 2X, 'DIFFERENCE', 5X, 'SIZE(I)' / 1X) 9020 FORMAT (1X, I4, I3, 3I5, I3, 2E36.8, 2E12.4) END *DECK T0 REAL FUNCTION T0 (X) C***BEGIN PROLOGUE T0 C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED F0S C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE T0 REAL A,B,F0S,X,X1,Y C***FIRST EXECUTABLE STATEMENT T0 A = 0.0E+00 B = 0.1E+01 X1 = X+0.1E+01 Y = (B-A)/X1+A T0 = (B-A)*F0S(Y)/X1/X1 RETURN END *DECK T1 REAL FUNCTION T1 (X) C***BEGIN PROLOGUE T1 C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED F1S C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE T1 REAL A,B,F1S,X,X1,Y C***FIRST EXECUTABLE STATEMENT T1 A = 0.0E+00 B = 0.1E+01 X1 = X+0.1E+01 Y = (B-A)/X1+A T1 = (B-A)*F1S(Y)/X1/X1 RETURN END *DECK T2 REAL FUNCTION T2 (X) C***BEGIN PROLOGUE T2 C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED F2S C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE T2 REAL A,B,F2S,X,X1,Y C***FIRST EXECUTABLE STATEMENT T2 A = 0.1E+00 B = 0.1E+01 X1 = X+0.1E+01 Y = (B-A)/X1+A T2 = (B-A)*F2S(Y)/X1/X1 RETURN END *DECK T3 REAL FUNCTION T3 (X) C***BEGIN PROLOGUE T3 C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED F3S C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE T3 REAL A,B,F3S,X,X1,Y C***FIRST EXECUTABLE STATEMENT T3 A = 0.0E+00 B = 0.5E+01 X1 = X+0.1E+01 Y = (B-A)/X1+A T3 = (B-A)*F3S(Y)/X1/X1 RETURN END *DECK T4 REAL FUNCTION T4 (X) C***BEGIN PROLOGUE T4 C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED F4S C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE T4 REAL A,B,F4S,X,X1,Y C***FIRST EXECUTABLE STATEMENT T4 A = 0.0E+00 B = 0.1E+01 X1 = X+0.1E+01 Y = (B-A)/X1+A T4 = (B-A)*F4S(Y)/X1/X1 RETURN END *DECK T5 REAL FUNCTION T5 (X) C***BEGIN PROLOGUE T5 C***PURPOSE Subsidiary to C***LIBRARY SLATEC C***AUTHOR (UNKNOWN) C***ROUTINES CALLED F5S C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE T5 REAL A,B,F5S,X,X1,Y C***FIRST EXECUTABLE STATEMENT T5 A = 0.0E+00 B = 0.1E+01 X1 = X+0.1E+01 Y = (B-A)/X1+A T5 = (B-A)*F5S(Y)/X1/X1 RETURN END *DECK TEST0 PROGRAM TEST0 C***BEGIN PROLOGUE TEST0 C***PURPOSE Driver for testing SLATEC subprogram C AAAAAA C***LIBRARY SLATEC C***CATEGORY Z C***TYPE ALL (TEST0-A) C***KEYWORDS AAAAAA, QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprogram C AAAAAA C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED I1MACH, QC6A, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890713 DATE WRITTEN C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST0 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST0 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test AAAAAA C CALL QC6A(LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST0 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST0 *************') END *DECK TEST1 PROGRAM TEST1 C***BEGIN PROLOGUE TEST1 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY C C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C single precision Fullerton routines C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED I1MACH, SFNCK, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST1 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST1 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test single precision Fullerton routines C CALL SFNCK(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST1 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST1 *************') END *DECK TEST10 PROGRAM TEST10 C***BEGIN PROLOGUE TEST10 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY D1 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C BLAS SUBPROGRAMS C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED BLACHK, I1MACH, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST10 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST10 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test BLAS C CALL BLACHK(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST10 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST10 *************') END *DECK TEST11 PROGRAM TEST11 C***BEGIN PROLOGUE TEST11 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY D2 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C SGEFS SGEIR C DGEFS C CGEFS CGEIR C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED CGEQC, DGEQC, I1MACH, SGEQC, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST11 INTEGER KPRINT, LIN, LUN, NERR, NFAIL C***FIRST EXECUTABLE STATEMENT TEST11 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test LINPACK routines C CALL SGEQC(LUN,KPRINT,NERR) NFAIL = NFAIL + NERR CALL DGEQC(LUN,KPRINT,NERR) NFAIL = NFAIL + NERR CALL CGEQC(LUN,KPRINT,NERR) NFAIL = NFAIL + NERR C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST11 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST11 *************') END *DECK TEST12 PROGRAM TEST12 C***BEGIN PROLOGUE TEST12 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY D2 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C SNBFS SNBIR SPOFS SPOIR C DNBFS DPOFS C CNBFS CNBIR CPOFS CPOIR C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED CQCK, DQCK, I1MACH, SQCK, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST12 INTEGER KPRINT, LIN, LUN, NERR, NFAIL C***FIRST EXECUTABLE STATEMENT TEST12 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test LINPACK routines C CALL SQCK(LUN,KPRINT,NERR) NFAIL = NFAIL+NERR CALL DQCK(LUN,KPRINT,NERR) NFAIL = NFAIL+NERR CALL CQCK(LUN,KPRINT,NERR) NFAIL = NFAIL+NERR C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST12 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST12 *************') END *DECK TEST13 PROGRAM TEST13 C***BEGIN PROLOGUE TEST13 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY D2 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C CGECO CGEDI CGEFA CGESL C CGBCO CGBDI CGBFA CGBSL C CPOCO CPODI CPOFA CPOSL C CPPCO CPPDI CPPFA CPPSL C CPBCO CPBDI CPBFA CPBSL C CSICO CSIDI CSIFA CSISL C CSPCO CSPDI CSPFA CSPSL C CHICO CHIDI CHIFA CHISL C CHPCO CHPDI CHPFA CHPSL C CTRCO CTRDI - CTRSL C CGTSL C CPTSL C CCHDC C CQRDC CQRSL C CSVDC C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED CCHQC, CGBQC, CGECK, CGTQC, CHIQC, CHPQC, CPBQC, C CPOQC, CPPQC, CPTQC, CQRQC, CSIQC, CSPQC, CSVQC, C CTRQC, I1MACH, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST13 INTEGER KPRINT, LIN, LUN, NERR, NFAIL C***FIRST EXECUTABLE STATEMENT TEST13 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test LINPACK routines C CALL CGECK(LUN,KPRINT,NERR) NFAIL = NFAIL + NERR CALL CGBQC(LUN,KPRINT,NERR) NFAIL = NFAIL + NERR CALL CPOQC(LUN,KPRINT,NERR) NFAIL = NFAIL + NERR CALL CPPQC(LUN,KPRINT,NERR) NFAIL = NFAIL + NERR CALL CPBQC(LUN,KPRINT,NERR) NFAIL = NFAIL + NERR CALL CSIQC(LUN,KPRINT,NERR) NFAIL = NFAIL + NERR CALL CSPQC(LUN,KPRINT,NERR) NFAIL = NFAIL + NERR CALL CHIQC(LUN,KPRINT,NERR) NFAIL = NFAIL + NERR CALL CHPQC(LUN,KPRINT,NERR) NFAIL = NFAIL + NERR CALL CTRQC(LUN,KPRINT,NERR) NFAIL = NFAIL + NERR CALL CGTQC(LUN,KPRINT,NERR) NFAIL = NFAIL + NERR CALL CPTQC(LUN,KPRINT,NERR) NFAIL = NFAIL + NERR CALL CCHQC(LUN,KPRINT,NERR) NFAIL = NFAIL + NERR CALL CQRQC(LUN,KPRINT,NERR) NFAIL = NFAIL + NERR CALL CSVQC(LUN,KPRINT,NERR) NFAIL = NFAIL + NERR C C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST13 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST13 *************') END *DECK TEST14 PROGRAM TEST14 C***BEGIN PROLOGUE TEST14 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY D2 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C SGEEV CGEEV C SSIEV CHIEV C SSPEV C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED EISQX1, EISQX2, I1MACH, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST14 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST14 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test SGEEV and CGEEV C CALL EISQX1(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test SSIEV, CHIEV and SSPEV C CALL EISQX2(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST14 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST14 *************') END *DECK TEST15 PROGRAM TEST15 C***BEGIN PROLOGUE TEST15 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY D5, D9 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C LSEI SGLSS C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED I1MACH, LSEIQX, QCGLSS, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST15 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST15 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test LSEI C CALL LSEIQX(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test SGLSS C CALL QCGLSS(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST15 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST15 *************') END *DECK TEST16 PROGRAM TEST16 C***BEGIN PROLOGUE TEST16 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY D5, D9 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C DLSEI DGLSS C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED DLSEIT, DQCGLS, I1MACH, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST16 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST16 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test DLSEI C CALL DLSEIT(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DGLSS C CALL DQCGLS(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST16 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST16 *************') END *DECK TEST17 PROGRAM TEST17 C***BEGIN PROLOGUE TEST17 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY E1, E3 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C POLINT POLCOF POLYVL C DPLINT DPOLCF DPOLVL C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED DPNTCK, I1MACH, PNTCHK, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C 920225 Added CALL to DPNTCK. (WRB) C***END PROLOGUE TEST17 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST17 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test POLINT, POLCOF and POLYVL. C CALL PNTCHK(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DPLINT, DPOLCF and DPOLVL. C CALL DPNTCK(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST17 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST17 *************') END *DECK TEST18 PROGRAM TEST18 C***BEGIN PROLOGUE TEST18 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY E, E1A, E3 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C BFQAD BINT4 BINTK BSPDR BSPEV BSPPP C BSPVD BSPVN BSQAD BVALU INTRV PFQAD C PPQAD PPVAL C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED BSPCK, I1MACH, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST18 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST18 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test single precision B-Spline package C CALL BSPCK(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST18 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST18 *************') END *DECK TEST19 PROGRAM TEST19 C***BEGIN PROLOGUE TEST19 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY E, E1A, E3 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C DBFQAD DBINT4 DBINTK DBSPDR DBSPEV DBSPPP C DBSPVD DBSPVN DBSQAD DBVALU DINTRV DPFQAD C DPPQAD DPPVAL C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED DBSPCK, I1MACH, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST19 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST19 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test double precision B-Spline package C CALL DBSPCK(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST19 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST19 *************') END *DECK TEST2 PROGRAM TEST2 C***BEGIN PROLOGUE TEST2 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY C C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C double precision Fullerton routines C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED DFNCK, I1MACH, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST2 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST2 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test double precision Fullerton routines C CALL DFNCK(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST2 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST2 *************') END *DECK TEST20 PROGRAM TEST20 C***BEGIN PROLOGUE TEST20 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY E1A C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C PCHIP C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED I1MACH, PCHQK1, PCHQK2, PCHQK3, PCHQK4, XERMAX, C XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 900314 Added new quick checks PCHQK3, PCHQK4. (FNF) C 900315 Corrected category record. (FNF) C 900321 Moved IPASS to call sequences for SLATEC standards. (FNF) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST20 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST20 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test PCHIP evaluators C CALL PCHQK1(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test PCHIP integrators C CALL PCHQK2(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test PCHIP interpolators C CALL PCHQK3(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test PCHIP monotonicity checker C CALL PCHQK4(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST20 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST20 *************') END *DECK TEST21 PROGRAM TEST21 C***BEGIN PROLOGUE TEST21 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY E1A C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C DPCHIP C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED DPCHQ1, DPCHQ2, DPCHQ3, DPCHQ4, I1MACH, XERMAX, C XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 900319 Corrected category record. (FNF) C 900320 Added new quick checks DPCHQ3, DPCHQ4. (FNF) C 900321 Moved IPASS to call sequences for SLATEC standards. (FNF) C 900322 Corrected list of routines called. (FNF) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST21 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST21 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test DPCHIP evaluators C CALL DPCHQ1(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DPCHIP integrators C CALL DPCHQ2(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DPCHIP interpolators C CALL DPCHQ3(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DPCHIP monotonicity checker C CALL DPCHQ4(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST21 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST21 *************') END *DECK TEST22 PROGRAM TEST22 C***BEGIN PROLOGUE TEST22 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY F1A C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C RPZERO CPZERO C FZERO DFZERO C RPQR79 CPQR79 C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED CPRPQX, CQRTST, DFZTST, FZTEST, I1MACH, RQRTST, C XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST22 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST22 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test CPZERO and RPZERO C CALL CPRPQX(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test FZERO C CALL FZTEST(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DFZERO C CALL DFZTST(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test RPQR79 C CALL RQRTST(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test CPQR79 C CALL CQRTST(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST22 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST22 *************') END *DECK TEST23 PROGRAM TEST23 C***BEGIN PROLOGUE TEST23 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY F2 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C SNSQE SNSQ SOS C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED I1MACH, SNSQQK, SOSNQX, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST23 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST23 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test SNSQE and SNSQ C CALL SNSQQK(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test SOS C CALL SOSNQX(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST23 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST23 *************') END *DECK TEST24 PROGRAM TEST24 C***BEGIN PROLOGUE TEST24 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY F2 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C DNSQE DNSQ DSOS C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED DNSQQK, DSOSQX, I1MACH, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST24 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST24 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test DNSQE and DNSQ C CALL DNSQQK(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DSOS C CALL DSOSQX(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST24 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST24 *************') END *DECK TEST25 PROGRAM TEST25 C***BEGIN PROLOGUE TEST25 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY G2 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C SPLP SBOCLS C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED I1MACH, SBOCQX, SPLPQX, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST25 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST25 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test SPLP package C CALL SPLPQX(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test SBOCLS package C CALL SBOCQX(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST25 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST25 *************') END *DECK TEST26 PROGRAM TEST26 C***BEGIN PROLOGUE TEST26 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY G2 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C DSPLP DBOCLS C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED DBOCQX, DPLPQX, I1MACH, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST26 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST26 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test DSPLP package C CALL DPLPQX(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DBOCLS package C CALL DBOCQX(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST26 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST26 *************') END *DECK TEST27 PROGRAM TEST27 C***BEGIN PROLOGUE TEST27 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY H2 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C QAG QAGI QAGP QAGS QAWC C QAWF QAWO QAWS QNG C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED CQAG, CQAGI, CQAGP, CQAGS, CQAWC, CQAWF, CQAWO, C CQAWS, CQNG, I1MACH, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST27 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST27 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test single precision QUADPACK routines C C Test QAG. C CALL CQAG (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test QAGS. C CALL CQAGS (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test QAGP. C CALL CQAGP (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test QAGI. C CALL CQAGI (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test QAWO. C CALL CQAWO (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test QAWF. C CALL CQAWF (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test QAWS. C CALL CQAWS (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test QAWC. C CALL CQAWC (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test QNG. C CALL CQNG (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST27 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST27 *************') END *DECK TEST28 PROGRAM TEST28 C***BEGIN PROLOGUE TEST28 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY H2 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C DQAG DQAGI DQAGP DQAGS DQAWC C DQAWF DQAWO DQAWS DQNG C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED CDQAG, CDQAGI, CDQAGP, CDQAGS, CDQAWC, CDQAWF, C CDQAWO, CDQAWS, CDQNG, I1MACH, XERMAX, XSETF, C XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST28 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST28 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test double precision QUADPACK routines C C Test DQAG. C CALL CDQAG (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DQAGS. C CALL CDQAGS (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DQAGP. C CALL CDQAGP (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DQAGI. C CALL CDQAGI (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DQAWO. C CALL CDQAWO (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DQAWF. C CALL CDQAWF (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DQAWS. C CALL CDQAWS (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DQAWC. C CALL CDQAWC (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DQNG. C CALL CDQNG (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST28 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST28 *************') END *DECK TEST29 PROGRAM TEST29 C***BEGIN PROLOGUE TEST29 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY H2 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C AVINT GAUS8 QNC79 C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED AVNTST, I1MACH, QG8TST, QN79QX, XERMAX, XSETF, C XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST29 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST29 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test AVINT C CALL AVNTST(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test GAUS8 C CALL QG8TST(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test QNC79 C CALL QN79QX(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST29 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST29 *************') END *DECK TEST3 PROGRAM TEST3 C***BEGIN PROLOGUE TEST3 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY C C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C complex Fullerton routines C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED CFNCK, I1MACH, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST3 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST3 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test complex Fullerton routines C CALL CFNCK(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST3 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST3 *************') END *DECK TEST30 PROGRAM TEST30 C***BEGIN PROLOGUE TEST30 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY H2 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C DAVINT DGAUS8 DQNC79 C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED DAVNTS, DQG8TS, DQN79Q, I1MACH, XERMAX, XSETF, C XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST30 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST30 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test DAVINT C CALL DAVNTS(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DGAUS8 C CALL DQG8TS(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DQNC79 C CALL DQN79Q(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST30 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST30 *************') END *DECK TEST31 PROGRAM TEST31 C***BEGIN PROLOGUE TEST31 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY I1 C***TYPE SINGLE PRECISION (TEST31-S, TEST32-D) C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C DEABM DEBDF DERKF BVSUP C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED I1MACH, QXABM, QXBDF, QXBVSP, QXRKF, XERMAX, XSETF, C XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST31 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST31 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test DEABM C CALL QXABM(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DEBDF C CALL QXBDF(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DERKF C CALL QXRKF(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test BVSUP C CALL QXBVSP(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST31 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST31 *************') END *DECK TEST32 PROGRAM TEST32 C***BEGIN PROLOGUE TEST32 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY I1 C***TYPE DOUBLE PRECISION (TEST31-S, TEST32-D) C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C DDEABM DDEBDF DDERKF DBVSUP C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED I1MACH, QXDABM, QXDBDF, QXDBVS, QXDRKF, XERMAX, C XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST32 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST32 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test DDEABM C CALL QXDABM(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DDEBDF C CALL QXDBDF(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DDERKF C CALL QXDRKF(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DBVSUP C CALL QXDBVS(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST32 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST32 *************') END *DECK TEST33 PROGRAM TEST33 C***BEGIN PROLOGUE TEST33 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY I2 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C HWSCRT C HWSPLR C HWSCYL C HWSSSP C HWSCSP C GENBUN C BLKTRI C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED I1MACH, QXBLKT, QXCRT, QXCSP, QXCYL, QXGBUN, QXPLR, C QXSSP, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST33 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST33 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test HWSCRT C CALL QXCRT(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test HWSPLR C CALL QXPLR(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test HWSCYL C CALL QXCYL(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test HWSSSP C CALL QXSSP(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test HWSCSP C CALL QXCSP(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test GENBUN C CALL QXGBUN(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test BLKTRI C CALL QXBLKT(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST33 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST33 *************') END *DECK TEST34 PROGRAM TEST34 C***BEGIN PROLOGUE TEST34 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY J1 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C COSQB COSQF COSQI COST COSTI EZFFTB C EZFFTF RFFTB RFFTF RFFTI SINQB SINQF C SINQI SINT SINTI C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED FFTQX, I1MACH, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST34 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST34 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test FFT package C CALL FFTQX(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST34 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST34 *************') END *DECK TEST35 PROGRAM TEST35 C***BEGIN PROLOGUE TEST35 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY K1, E3, K6, L C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C SNLS1E SNLS1 SCOV C BVALU CV FC C POLFIT PCOEF PVALUE C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED FCQX, I1MACH, PFITQX, SNLS1Q, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST35 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST35 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test SNLS1E and SNLS1 C CALL SNLS1Q(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test FC (also BVALU and CV) C CALL FCQX(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test POLFIT (also PCOEF and PVALUE) C CALL PFITQX(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST35 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST35 *************') END *DECK TEST36 PROGRAM TEST36 C***BEGIN PROLOGUE TEST36 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY K1, E3, K6, L C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C DNLS1E DNLS1 DCOV C DBVALU DCV DFC C DPOLFT DPCOEF DP1VLU C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED DFCQX, DNLS1Q, DPFITT, I1MACH, XERMAX, XSETF, C XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST36 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST36 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test DNLS1E and DNLS1 C CALL DNLS1Q(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DFC (also DBVALU and DCV) C CALL DFCQX(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DPOLFT (also DPCOEF and DPLVlU) C CALL DPFITT(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST36 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST36 *************') END *DECK TEST37 PROGRAM TEST37 C***BEGIN PROLOGUE TEST37 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY N6 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C ISORT SSORT C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED I1MACH, SORTQX, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST37 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST37 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test SORT programs C CALL SORTQX(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST37 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST37 *************') END *DECK TEST4 PROGRAM TEST4 C***BEGIN PROLOGUE TEST4 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY C C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C EXINT GAUS8 C BESI BESK C BESJ BESY C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED BIKCK, BJYCK, EG8CK, I1MACH, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST4 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST4 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test EXINT and GAUS8 C CALL EG8CK(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test BESI and BESK C CALL BIKCK(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test BESJ and BESY C CALL BJYCK(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST4 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST4 *************') END *DECK TEST5 PROGRAM TEST5 C***BEGIN PROLOGUE TEST5 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY C C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C DEXINT DGAUS8 C DBESI DBESK C DBESJ DBESY C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED DBIKCK, DBJYCK, DEG8CK, I1MACH, XERMAX, XSETF, C XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST5 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST5 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test DEXINT and DQAUS8 C CALL DEG8CK(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DBESI and DBESK C CALL DBIKCK(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DBESJ and DBESY C CALL DBJYCK(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST5 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST5 *************') END *DECK TEST6 PROGRAM TEST6 C***BEGIN PROLOGUE TEST6 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY C C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C BSKIN PSIFN C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED I1MACH, QCKIN, QCPSI, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST6 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST6 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test single precision special function routines C CALL QCKIN(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 CALL QCPSI(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST6 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST6 *************') END *DECK TEST7 PROGRAM TEST7 C***BEGIN PROLOGUE TEST7 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY C C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C DBSKIN DPSIFN C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED DQCKIN, DQCPSI, I1MACH, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST7 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST7 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test double precision special function routines C CALL DQCKIN(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 CALL DQCPSI(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST7 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST7 *************') END *DECK TEST8 PROGRAM TEST8 C***BEGIN PROLOGUE TEST8 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY C14 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C RC RD RF RJ C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED I1MACH, QCRC, QCRD, QCRF, QCRJ, XERMAX, XSETF, C XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST8 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST8 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test single precision Carlson elliptic routines C CALL QCRC(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 CALL QCRD(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 CALL QCRF(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 CALL QCRJ(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST8 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST8 *************') END *DECK TEST9 PROGRAM TEST9 C***BEGIN PROLOGUE TEST9 C***PURPOSE Driver for testing SLATEC subprograms C***LIBRARY SLATEC C***CATEGORY C14 C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprograms C DRC DRD DRF DRJ C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED I1MACH, QCDRC, QCDRD, QCDRF, QCDRJ, XERMAX, XSETF, C XSETUN C***REVISION HISTORY (YYMMDD) C 890618 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900524 Cosmetic changes to code. (WRB) C***END PROLOGUE TEST9 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST9 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test double precision Carlson elliptic routines C CALL QCDRC(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 CALL QCDRD(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 CALL QCDRF(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 CALL QCDRJ(LUN,KPRINT,IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST9 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST9 *************') END *DECK UIVP SUBROUTINE UIVP (X, Y, YP) C***BEGIN PROLOGUE UIVP C***PURPOSE Dummy routine for BVSUP quick check. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (UIVP-S, DUIVP-D) C***KEYWORDS QUICK CHECK C***AUTHOR Watts, H. A., (SNLA) C***DESCRIPTION C C This routine is never called; it is here to prevent loaders from C complaining about undefined externals while testing BVSUP. C C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 750601 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920401 Variables declaration and TYPE sections added. (WRB) C***END PROLOGUE UIVP C .. Scalar Arguments .. REAL X C .. Array Arguments .. REAL Y(*), YP(*) C***FIRST EXECUTABLE STATEMENT UIVP STOP END *DECK UVEC SUBROUTINE UVEC (X, Y, YP) C***BEGIN PROLOGUE UVEC C***PURPOSE Dummy routine for BVSUP quick check. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (UVEC-S, DUVEC-D) C***KEYWORDS QUICK CHECK C***AUTHOR Watts, H. A., (SNLA) C***DESCRIPTION C C This routine is never called; it is here to prevent loaders from C complaining about undefined externals while testing BVSUP. C C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 750601 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920401 Variables declaration and TYPE sections added. (WRB) C***END PROLOGUE UVEC C .. Scalar Arguments .. REAL X C .. Array Arguments .. REAL Y(*), YP(*) C***FIRST EXECUTABLE STATEMENT UVEC STOP END *DECK CDB2QX SUBROUTINE CDB2QX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CDB2QX C***PURPOSE Quick check for CDRVB2. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***DESCRIPTION C C ALL CHECK PROGRAM C C PART OF CDRVB1,2,3 PACKAGE, COMPLEX VERSION C C***ROUTINES CALLED CDRVB2, CF2, CG2, R1MACH C***COMMON BLOCKS CCONS2 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE CDB2QX PARAMETER(LENW=263, LENIW=23) EXTERNAL CF2, CG2 COMPLEX WORK(LENW), Y(3) REAL ALFA, EPS, EWT(1), R1MACH, T, TOUT INTEGER IWORK(LENIW) COMMON /CCONS2/ ALFA DATA N /3/, EWT(1) /.00001E0/, MITER /0/, IMPL /0/ C***FIRST EXECUTABLE STATEMENT CDB2QX EPS = R1MACH(4)**(1.E0/3.E0) ALFA = 1.E0 IF (KPRINT .GE. 3) THEN WRITE(LUN, '(// '' *****'' / '' CDRVB2 TEST'' / 8 '' IF THE FOLLOWING TEST IS SUCCESSFUL, THE LAST LINE OF THIS'' 8 / '' OUTPUT FILE (APPROXIMATELY 45 LINES BEYOND THIS POINT)'' 8 / '' SHOULD BE -- CDRVB2 TEST PASSED.'' 8 / '' ANY OTHER FINAL MESSAGE INDICATES SOME TEST FAILURE.'' 8 / '' *****'')') WRITE(LUN, '(/ '' EPS ='', 1PE15.5)') EPS WRITE(LUN, '(/ '' A = '', 1PE10.2 // 1X, ''CYCLE'', 3X, 8 ''TIME'', 6X, ''Y(1)'', 16X, ''Y(2)'', 14X, ''MINT'', 1X, 8 ''MITER'', 1X, ''IMPL'', 1X, ''NFE'', 1X, ''NJE'')') ALFA ENDIF DO 50 MINT = 1,3 IF (MINT.EQ.2) THEN NROOT = 1 ELSE NROOT = 0 ENDIF T = 0.E0 Y(1) = CMPLX(10.E0, 10.E0) Y(2) = CMPLX(0.E0) Y(3) = CMPLX(10.E0, 10.E0) NSTATE = 1 TOUT = 10.E0 10 CALL CDRVB2 (N, T, Y, CF2, TOUT, NSTATE, NROOT, EPS, EWT, 8 MINT,WORK,LENW,IWORK,LENIW,CG2) IF (NSTATE.NE.2 .AND. NSTATE.NE.5) GO TO 60 NSTEP = IWORK(3) NFE = IWORK(4) NJE = IWORK(5) IF (NSTATE.EQ.5) THEN IF (KPRINT.GE.3) WRITE(LUN, '(I6, 1P5E10.2, I5, I6, I5, 2I4)') 8 NSTEP, T, (Y(I), I=1,2), MINT, MITER, IMPL, NFE, NJE IF (ABS(ABS(Y(1)) - 1.E0).GT.EPS**(2.E0/3.E0)) GO TO 60 GO TO 10 ELSE IF (KPRINT.GE.3) WRITE(LUN, '(I6, 1P5E10.2, I5, I6, I5, 2I4)') 8 NSTEP, TOUT, (Y(I), I=1,2), MINT, MITER, IMPL, NFE, NJE IF (ABS(1.E0 - ABS(Y(1))*1.5E0).GT.EPS**(2.E0/3.E0) .OR. 8 ABS(1.E0 - ABS(Y(2))*3.E0).GT.EPS**(2.E0/3.E0) .OR. 8 ABS(1.E0 - ABS(Y(3))).GT.EPS**(2.E0/3.E0)) GO TO 60 ENDIF 50 CONTINUE IPASS = 1 IF (KPRINT .GT. 1) THEN WRITE(LUN, 8 '(// '' *****'' /'' CDRVB2 TEST PASSED'' / '' *****'')') ENDIF RETURN 60 IPASS = 0 IF (KPRINT .GT. 0) THEN WRITE(LUN, '(// '' *****'' / '' CDRVB2 TEST FAILED'' / 8 '' *****'' //)') ENDIF RETURN END *DECK CDB3QX SUBROUTINE CDB3QX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CDB3QX C***PURPOSE Quick check for CDRVB3. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***DESCRIPTION C C ALL CHECK PROGRAM C C PART OF CDRVB1,2,3 PACKAGE, COMPLEX VERSION C C***ROUTINES CALLED CDRVB3, CF3, CFA3, CG3, CJAC3, R1MACH C***COMMON BLOCKS CCONS3 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE CDB3QX PARAMETER(LENW=294, LENIW=23) EXTERNAL CF3, CJAC3, CFA3, CG3 COMPLEX WORK(LENW), Y(3) REAL ALFA, EPS, EWT(1), HMAX, R1MACH, T, TOUT INTEGER IWORK(LENIW) COMMON /CCONS3/ ALFA, IMPL, MITER DATA N /3/, EWT(1) /.00001E0/, IERROR /3/, ML /2/, MU /2/, 8 HMAX /15.E0/, NDE /2/, MXSTEP /1000/ C***FIRST EXECUTABLE STATEMENT CDB3QX EPS = R1MACH(4)**(1.E0/3.E0) ALFA = 1.E0 IF (KPRINT .GE. 3) THEN WRITE(LUN, '(// '' *****'' / '' CDRVB3 TEST'' / 8 '' IF THE FOLLOWING TEST IS SUCCESSFUL, THE LAST LINE OF THIS'' 8 / '' OUTPUT FILE (APPROXIMATELY 45 LINES BEYOND THIS POINT)'' 8 / '' SHOULD BE -- CDRVB3 TEST PASSED.'' 8 / '' ANY OTHER FINAL MESSAGE INDICATES SOME TEST FAILURE.'' 8 / '' *****'')') WRITE(LUN, '(/ '' EPS ='', 1PE15.5)') EPS WRITE(LUN, '(/ '' A = '', 1PE10.2 // 1X, ''CYCLE'', 3X, 8 ''TIME'', 6X, ''Y(1)'', 16X, ''Y(2)'', 14X, ''MINT'', 1X, 8 ''MITER'', 1X, ''IMPL'', 1X, ''NFE'', 1X, ''NJE'')') ALFA ENDIF DO 50 IMPLP1 = 1,3 DO 50 MINT = 1,3 DO 50 MITERP = 1,6 MITER = MITERP - 1 IMPL = IMPLP1 - 1 IF (MITER .EQ. 3) GO TO 50 IF (IMPL.GT.0 .AND. MITER.EQ.0) GO TO 50 IF (IMPL.EQ.2 .AND. MINT.EQ.1) GO TO 50 IF (MINT.EQ.3 .AND. (IMPL.NE.0 .OR. MITER.EQ.0 .OR. 8 MITER.EQ.3)) GO TO 50 IF (MINT.EQ.1 .OR. MINT.EQ.3) THEN MXORD = 12 ELSE IF (MINT.EQ.2) THEN MXORD = 5 ENDIF IF (MINT.EQ.2 .AND. MITER.EQ.2 .AND. IMPL.EQ.0) THEN NROOT = 1 ELSE NROOT = 0 ENDIF T = 0.E0 Y(1) = CMPLX(10.E0, 10.E0) Y(2) = CMPLX(0.E0) Y(3) = CMPLX(10.E0, 10.E0) NSTATE = 1 TOUT = 10.E0 NTASK = 1 10 CALL CDRVB3 (N, T, Y, CF3, NSTATE, TOUT, NTASK, NROOT, EPS, EWT, 8 IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, 8 WORK,LENW,IWORK,LENIW,CJAC3,CFA3,NDE,MXSTEP,CG3) IF (NSTATE.NE.2 .AND. NSTATE.NE.5) GO TO 60 NSTEP = IWORK(3) NFE = IWORK(4) NJE = IWORK(5) IF (NSTATE.EQ.5) THEN IF (KPRINT.GE.3) WRITE(LUN, '(I6, 1P5E10.2, I5, I6, I5, 2I4)') 8 NSTEP, T, (Y(I), I=1,2), MINT, MITER, IMPL, NFE, NJE IF (ABS(ABS(Y(1)) - 1.E0).GT.EPS**(2.E0/3.E0)) GO TO 60 GO TO 10 ELSE IF (KPRINT.GE.3) WRITE(LUN, '(I6, 1P5E10.2, I5, I6, I5, 2I4)') 8 NSTEP, TOUT, (Y(I), I=1,2), MINT, MITER, IMPL, NFE, NJE IF (ABS(1.E0 - ABS(Y(1))*1.5E0).GT.EPS**(2.E0/3.E0) .OR. 8 ABS(1.E0 - ABS(Y(2))*3.E0).GT.EPS**(2.E0/3.E0) .OR. 8 ABS(1.E0 - ABS(Y(3))).GT.EPS**(2.E0/3.E0)) GO TO 60 ENDIF 50 CONTINUE IPASS = 1 IF (KPRINT .GT. 1) THEN WRITE(LUN, 8 '(// '' *****'' /'' CDRVB3 TEST PASSED'' / '' *****'')') ENDIF RETURN 60 IPASS = 0 IF (KPRINT .GT. 0) THEN WRITE(LUN, '(// '' *****'' / '' CDRVB3 TEST FAILED'' / 8 '' *****'' //)') ENDIF RETURN END *DECK CF2 SUBROUTINE CF2 (N, T, Y, YP) C***BEGIN PROLOGUE CF2 C***PURPOSE Derivative evaluator for CDB2QX. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***ROUTINES CALLED (NONE) C***COMMON BLOCKS CCONS2 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE CF2 COMPLEX Y(*), YP(*) REAL ALFA,T COMMON /CCONS2/ ALFA C***FIRST EXECUTABLE STATEMENT CF2 YP(1) = 1.E0 + ALFA*(Y(2) - Y(1)) - Y(1)*Y(3) YP(2) = ALFA*(Y(1) - Y(2)) - Y(2)*Y(3) YP(3) = 1.E0 - Y(3)*(Y(1) + Y(2)) END *DECK CF3 SUBROUTINE CF3 (N, T, Y, YP) C***BEGIN PROLOGUE CF3 C***PURPOSE Derivative evaluator for CDB3QX. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***ROUTINES CALLED (NONE) C***COMMON BLOCKS CCONS3 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE CF3 COMPLEX Y(*), YP(*) REAL ALFA,T COMMON /CCONS3/ ALFA, IMPL, MITER C***FIRST EXECUTABLE STATEMENT CF3 YP(1) = 1.E0 + ALFA*(Y(2) - Y(1)) - Y(1)*Y(3) YP(2) = ALFA*(Y(1) - Y(2)) - Y(2)*Y(3) IF (IMPL.EQ.0 .OR. IMPL.EQ.1) THEN YP(3) = 1.E0 - Y(3)*(Y(1) + Y(2)) ELSE IF (IMPL.EQ.2) THEN YP(3) = Y(1) + Y(2) - Y(3) ENDIF END *DECK CFA3 SUBROUTINE CFA3 (N, T, Y, A, MATDIM, ML, MU, NDE) C***BEGIN PROLOGUE CFA3 C***PURPOSE Matrix evaluator for CDB3QX. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***ROUTINES CALLED (NONE) C***COMMON BLOCKS CCONS3 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE CFA3 COMPLEX A(MATDIM,*),Y(*) REAL ALFA,T COMMON /CCONS3/ ALFA, IMPL, MITER C***FIRST EXECUTABLE STATEMENT CFA3 IF (IMPL.EQ.0 .OR. IMPL.EQ.1) THEN IF (MITER.EQ.1 .OR. MITER.EQ.2 .OR. MITER.EQ.3) THEN DO 20 J = 1,N DO 10 I = 1,N 10 A(I,J) = 0.E0 20 A(J,J) = 1.E0 ELSE IF (MITER.EQ.4) THEN DO 50 J = 1,N DO 40 I = 1,N I1 = I + MU + 1 - J 40 A(I1,J) = 0.E0 50 A(MU+1,J) = 1.E0 ENDIF ELSE IF (IMPL.EQ.2) THEN A(1,1) = 1.E0 A(2,1) = 1.E0 ENDIF END *DECK CG2 REAL FUNCTION CG2 (N, T, Y, IROOT) C***BEGIN PROLOGUE CG2 C***PURPOSE Algebric equation evaluator for CDB2QX. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE CG2 COMPLEX Y(*) REAL T C***FIRST EXECUTABLE STATEMENT CG2 CG2 = ABS(Y(1)) - 1.E0 END *DECK CG3 REAL FUNCTION CG3 (N, T, Y, IROOT) C***BEGIN PROLOGUE CG3 C***PURPOSE Algebric equation evaluator for CDB3QX. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE CG3 COMPLEX Y(*) REAL T C***FIRST EXECUTABLE STATEMENT CG3 CG3 = ABS(Y(1)) - 1.E0 END *DECK CJAC3 SUBROUTINE CJAC3 (N, T, Y, DFDY, MATDIM, ML, MU) C***BEGIN PROLOGUE CJAC3 C***PURPOSE Jacobian evaluator for CDB3QX. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***ROUTINES CALLED (NONE) C***COMMON BLOCKS CCONS3 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE CJAC3 COMPLEX DFDY(MATDIM,*),Y(*) REAL ALFA,T COMMON /CCONS3/ ALFA, IMPL, MITER C***FIRST EXECUTABLE STATEMENT CJAC3 IF (MITER.EQ.1 .OR. MITER.EQ.3) THEN DFDY(1,1) = -ALFA - Y(3) DFDY(1,2) = ALFA DFDY(1,3) = -Y(1) DFDY(2,1) = ALFA DFDY(2,2) = -ALFA - Y(3) DFDY(2,3) = -Y(2) IF (IMPL.EQ.0 .OR. IMPL.EQ.1) THEN DFDY(3,1) = -Y(3) DFDY(3,2) = -Y(3) DFDY(3,3) = -Y(1) - Y(2) ELSE IF (IMPL.EQ.2) THEN DFDY(3,1) = 1.E0 DFDY(3,2) = 1.E0 DFDY(3,3) = -1.E0 ENDIF ELSE IF (MITER.EQ.4) THEN DFDY(3,1) = -ALFA - Y(3) DFDY(2,2) = ALFA DFDY(1,3) = -Y(1) DFDY(4,1) = ALFA DFDY(3,2) = DFDY(3,1) DFDY(2,3) = -Y(2) IF (IMPL.EQ.0 .OR. IMPL.EQ.1) THEN DFDY(5,1) = -Y(3) DFDY(4,2) = -Y(3) DFDY(3,3) = -Y(1) - Y(2) ELSE IF (IMPL.EQ.2) THEN DFDY(5,1) = 1.E0 DFDY(4,2) = 1.E0 DFDY(3,3) = -1.E0 ENDIF ENDIF END *DECK D114F0 REAL FUNCTION D114F0 (K, X) C***BEGIN PROLOGUE D114F0 C***PURPOSE Integrand evaluator for GAUSS quick check D114QX. C***LIBRARY CLAMS C***AUTHOR (UNKNOWN) C***ROUTINES CALLED XERMSG C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C 920701 Declarations section restructured. (WRB) C***END PROLOGUE D114F0 C .. Scalar Arguments .. REAL X INTEGER K C .. External Subroutines .. EXTERNAL XERMSG C***FIRST EXECUTABLE STATEMENT D114F0 IF (K .EQ. 1) THEN D114F0 = X**3 ELSE CALL XERMSG ('CLAMS', 'D114F0', 'K .NE. 1', 300, 2) ENDIF RETURN END *DECK D114F1 REAL FUNCTION D114F1 (K, X) C***BEGIN PROLOGUE D114F1 C***PURPOSE Integrand evaluator for GAUSS quick check D114QX. C***LIBRARY CLAMS C***AUTHOR (UNKNOWN) C***ROUTINES CALLED XERMSG C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C 920701 Declarations section restructured. (WRB) C***END PROLOGUE D114F1 C .. Scalar Arguments .. REAL X INTEGER K C .. External Subroutines .. EXTERNAL XERMSG C***FIRST EXECUTABLE STATEMENT D114F1 IF (K .EQ. 1) THEN D114F1 = X**2 ELSE CALL XERMSG ('CLAMS', 'D114F1', 'K .NE. 1', 301, 2) ENDIF RETURN END *DECK D114F2 REAL FUNCTION D114F2 (K, X) C***BEGIN PROLOGUE D114F2 C***PURPOSE Integrand evaluator for GAUSS quick check D114QX. C***LIBRARY CLAMS C***AUTHOR (UNKNOWN) C***ROUTINES CALLED XERMSG C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C 920701 Declarations section restructured. (WRB) C***END PROLOGUE D114F2 C .. Scalar Arguments .. REAL X INTEGER K C .. External Subroutines .. EXTERNAL XERMSG C***FIRST EXECUTABLE STATEMENT D114F2 IF (K .EQ. 1) THEN D114F2 = X**2 ELSE CALL XERMSG ('CLAMS', 'D114F2', 'K .NE. 1', 302, 2) ENDIF RETURN END *DECK D114F3 REAL FUNCTION D114F3 (K, X) C***BEGIN PROLOGUE D114F3 C***PURPOSE Integrand evaluator for GAUSS quick check D114QX. C***LIBRARY CLAMS C***AUTHOR (UNKNOWN) C***ROUTINES CALLED XERMSG C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C 920701 Declarations section restructured. (WRB) C***END PROLOGUE D114F3 C .. Scalar Arguments .. REAL X INTEGER K C .. External Subroutines .. EXTERNAL XERMSG C***FIRST EXECUTABLE STATEMENT D114F3 IF (K .EQ. 1) THEN D114F3 = X**7 ELSE CALL XERMSG ('CLAMS', 'D114F3', 'K .NE. 1', 303, 2) ENDIF RETURN END *DECK D114F4 REAL FUNCTION D114F4 (K, X) C***BEGIN PROLOGUE D114F4 C***PURPOSE Integrand evaluator for GAUSS quick check D114QX. C***LIBRARY CLAMS C***AUTHOR (UNKNOWN) C***ROUTINES CALLED XERMSG C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C 920701 Declarations section restructured. (WRB) C***END PROLOGUE D114F4 C .. Scalar Arguments .. REAL X INTEGER K C .. External Subroutines .. EXTERNAL XERMSG C***FIRST EXECUTABLE STATEMENT D114F4 IF (K .EQ. 1) THEN D114F4 = X**19 ELSE CALL XERMSG ('CLAMS', 'D114F4', 'K .NE. 1', 304, 2) ENDIF RETURN END *DECK D114QX SUBROUTINE D114QX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE D114QX C***PURPOSE Quick check for GAUSS. C***LIBRARY CLAMS C***AUTHOR (UNKNOWN) C***ROUTINES CALLED CBSHV, D114F0, D114F1, D114F2, D114F3, D114F4, C GAUSS, HRMTE, LAGRE, LGNDR, LGNDRX, R1MACH C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C 920701 Declarations section restructured and some code cleaned. C (WRB) C***END PROLOGUE D114QX C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. REAL ERRTOL, PI, RELERR INTEGER I, M, N C .. Local Arrays .. REAL ANS(5), Y(5) C .. External Functions .. REAL D114F0, D114F1, D114F2, D114F3, D114F4, GAUSS, R1MACH EXTERNAL D114F0, D114F1, D114F2, D114F3, D114F4, GAUSS, R1MACH C .. External Subroutines .. EXTERNAL CBSHV, HRMTE, LAGRE, LGNDR, LGNDRX C .. Intrinsic Functions .. INTRINSIC ABS, SQRT C .. Data statements .. DATA PI /3.141592653589793238462643/ C***FIRST EXECUTABLE STATEMENT D114QX IF (KPRINT .GE. 2) WRITE (LUN,9000) C IPASS = 1 ANS(1) = 0.25 ANS(2) = 0.5*PI ANS(3) = 0.5*SQRT(PI) ANS(4) = 5040.0 ANS(5) = 0.05 N = 1 M = 8 Y(1) = GAUSS (N,D114F0,M,LGNDR) Y(2) = GAUSS (N,D114F1,M,CBSHV) Y(3) = GAUSS (N,D114F2,M,HRMTE) Y(4) = GAUSS (N,D114F3,M,LAGRE) M = 19 Y(5) = GAUSS (N,D114F4,M,LGNDRX) ERRTOL = SQRT(R1MACH(4)) DO 10 I = 1,5 IF (KPRINT .GE. 3) WRITE (LUN, 9010) I,Y(I),I,ANS(I) RELERR = ABS(Y(I)-ANS(I))/ANS(I) IF (RELERR .GT. ERRTOL) THEN IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN,9020) I,Y(I),I,ANS(I) ENDIF 10 CONTINUE IF (IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN, 9030) IF (IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN, 9040) RETURN C 9000 FORMAT (/ ' GAUSS Quick Check' /) 9010 FORMAT (' Y(', I2, ') =', E22.13, 10X, 'ANS(', I2, ') =', + E22.13) 9020 FORMAT (' D114QX FAILED, Y(', I2, ') =', E22.13, 5X, + 'ANS(', I2, ') =', E22.13) 9030 FORMAT (' GAUSS and its associated routines are correct.' /) 9040 FORMAT (' GAUSS and its associated routines are incorrect.' /) END *DECK D117QX SUBROUTINE D117QX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE D117QX C***PURPOSE Quick check for SPL1D1 and SPL1D2. C***LIBRARY CLAMS C***AUTHOR (UNKNOWN) C***ROUTINES CALLED R1MACH, SPL1D1, SPL1D2, SPLINT C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C 920701 Declarations section restructured and some code cleaned. C (WRB) C***END PROLOGUE D117QX C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. REAL ERRTOL, RELERR INTEGER I, IJ, N C .. Local Arrays .. REAL A(4), ANS(4), B(4), C(4), F(4), W(4), X(4), Y(4) INTEGER IOP(2) C .. External Functions .. REAL R1MACH, SPLINT EXTERNAL R1MACH, SPLINT C .. External Subroutines .. EXTERNAL SPL1D1, SPL1D2 C .. Intrinsic Functions .. INTRINSIC ABS, SQRT C .. Data statements .. DATA X /-1.0, 0.0, 1.0, 3.0/, F /4*0.0/ DATA ANS(1), ANS(2), ANS(3)/0.5, 0.5, -1.0/ C***FIRST EXECUTABLE STATEMENT D117QX IF (KPRINT .GE. 2) WRITE (LUN,9000) C IPASS = 1 N = 4 IJ = 1 W(1) = -4.0 W(N) = -2.0 IOP(1) = 3 IOP(2) = 3 CALL SPL1D1 (N,X,F,W,IOP,IJ,A,B,C) CALL SPL1D2 (N,X,F,W,IJ,2.,Y) ANS(4) = 1.0/3.0 Y(4) = SPLINT (N,X,F,W,IJ,X(1),X(4)) ERRTOL = SQRT (R1MACH(4)) DO 10 I = 1,4 IF (KPRINT .GE. 3) WRITE(LUN,9010) I,Y(I),I,ANS(I) RELERR = ABS((Y(I)-ANS(I))/ANS(I)) IF (RELERR .GT. ERRTOL) THEN IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN,9020) I,Y(I),I,ANS(I) ENDIF 10 CONTINUE IF (IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN, 9030) IF (IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN, 9040) RETURN C 9000 FORMAT (/ ' SPLINT Quick Check' /) 9010 FORMAT (' Y(', I2, ') =', E22.13, 10X, 'ANS(', I2, ') =', + E22.13) 9020 FORMAT (' D117QX FAILED, Y(', I2, ') =', E22.13, ' ANS(', I2, + ') =', E22.13) 9030 FORMAT (' SPLINT and its associated routines are correct.' /) 9040 FORMAT (' SPLINT and its associated routines are incorrect.' /) END *DECK D118QX SUBROUTINE D118QX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE D118QX C***PURPOSE Quick check for SPL2D1, SPL2D2 and SPLIN2. C***LIBRARY CLAMS C***AUTHOR (UNKNOWN) C***ROUTINES CALLED R1MACH, SPL2D1, SPL2D2, SPLIN2 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C 920701 Declarations section restructured and some code cleaned. C (WRB) C***END PROLOGUE D118QX C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. REAL ERRTOL, RELERR INTEGER I, MAXY, NX, NY C .. Local Arrays .. REAL ANS(2), APP(2), F(4,4), FX(4,4), FXY(4,4), FY(4,4), T1(4), + T2(4), T3(4), X(4), Y(4) INTEGER IBD(6) C .. External Functions .. REAL R1MACH, SPL2D2, SPLIN2 EXTERNAL R1MACH, SPL2D2, SPLIN2 C .. External Subroutines .. EXTERNAL SPL2D1 C .. Intrinsic Functions .. INTRINSIC ABS, SQRT C .. Data statements .. DATA X /0.0, 1.0, 2.0, 3.0/ DATA Y /0.0, 1.0, 2.0, 3.0/ DATA F /0.0, 1.0, 8.0, 27.0, 1.0, 2.0, 9.0, 28.0, 8.0, 9.0, 16.0, + 35.0, 27.0, 28.0, 35.0, 54.0/ DATA ANS /9.0, 7.5/ C***FIRST EXECUTABLE STATEMENT D118QX IF (KPRINT .GE. 2) WRITE (LUN,9000) C IPASS = 1 NX = 4 NY = 4 MAXY = 4 DO 10 I = 1,4 FX(I,1) = 0.0 FY(1,I) = 0.0 FX(I,4) = 27.0 FY(4,I) = 27.0 10 CONTINUE FXY(1,1) = 0.0 FXY(4,1) = 0.0 FXY(1,4) = 0.0 FXY(4,4) = 0.0 IBD(1) = 3 IBD(2) = 3 IBD(3) = 3 IBD(4) = 3 IBD(5) = 1 IBD(6) = 1 CALL SPL2D1 (NX,X,NY,Y,F,FX,FY,FXY,MAXY,IBD,T1,T2,T3) APP(1) = SPL2D2 (1.5,1.5,NX,X,NY,Y,F,FX,FY,FXY,MAXY,0,2) APP(2) = SPLIN2 (NX,X,NY,Y,F,FX,FY,FXY,MAXY,1.0,2.0,1.0,2.0,T1,T2) ERRTOL = SQRT(R1MACH(4)) DO 20 I = 1,2 IF (KPRINT .GE. 3) WRITE (LUN, 9010) I,APP(I),I,ANS(I) RELERR = ABS(APP(I)-ANS(I))/ANS(I) IF (RELERR .GT. ERRTOL) THEN IPASS = 0 IF (KPRINT .GE. 2) WRITE (LUN,9020) I,APP(I),I,ANS(I) ENDIF 20 CONTINUE IF (IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN, 9030) IF (IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN, 9040) RETURN C 9000 FORMAT (/ ' SPLIN2 Quick Check' /) 9010 FORMAT (' APP(', I2, ') =', E22.13, 10X, 'ANS(', I2, ') =', + E22.13) 9020 FORMAT (' D118QX FAILED, APP(', I2, ') =', E22.13, 5X, 'ANS(', + I2,') =', E22.13) 9030 FORMAT (' SPLIN2 and its associated routines are correct.' /) 9040 FORMAT (' SPLIN2 and its associated routines are incorrect.' /) END *DECK D123F1 DOUBLE PRECISION FUNCTION D123F1 (X) C***BEGIN PROLOGUE D123F1 C***PURPOSE Integrand evaluator for GENGSQ quick check D123QX. C***LIBRARY CLAMS C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C 920701 Declarations section restructured. (WRB) C***END PROLOGUE D123F1 C .. Scalar Arguments .. DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT D123F1 D123F1 = X**6 RETURN END *DECK D123F2 DOUBLE PRECISION FUNCTION D123F2 (X) C***BEGIN PROLOGUE D123F2 C***PURPOSE Integrand evaluator for GENGSQ quick check D123QX. C***LIBRARY CLAMS C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C 920701 Declarations section restructured. (WRB) C***END PROLOGUE D123F2 C .. Scalar Arguments .. DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT D123F2 D123F2 = X**2 RETURN END *DECK D123QX SUBROUTINE D123QX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE D123QX C***PURPOSE Quick check for GENGSQ. C***LIBRARY CLAMS C***AUTHOR (UNKNOWN) C***ROUTINES CALLED D123F1, D123F2, D123W1, D123W2, D1MACH, GENGSQ C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C 920701 Declarations section restructured and some code cleaned. C (WRB) C***END PROLOGUE D123QX C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. DOUBLE PRECISION EL, EPS, ER, ERRTOL, FM, HALFPI, RELERR INTEGER I, ISWTCH, JORTH, JS, N, NIT C .. Local Arrays .. DOUBLE PRECISION A(8), ANS(2), B(8), G(8), W(8), Y(2) C .. External Functions .. DOUBLE PRECISION D123F1, D123F2, D123W1, D123W2, D1MACH EXTERNAL D123F1, D123F2, D123W1, D123W2, D1MACH C .. External Subroutines .. EXTERNAL GENGSQ C .. Intrinsic Functions .. INTRINSIC ABS, SQRT C .. Data statements .. DATA HALFPI /1.570796326794896619231322D0/ C***FIRST EXECUTABLE STATEMENT D123QX IF (KPRINT .GE. 2) WRITE (LUN,9000) C IPASS = 1 ANS(1) = 2.0D0/7.0D0 ANS(2) = HALFPI ERRTOL = SQRT(D1MACH(4)) EPS = D1MACH(4)**0.75D0 EL = -1.0D0 ER = 1.0D0 N = 8 JORTH = 0 JS = 0 CALL GENGSQ (N,B,G,A,W,D123W1,JS,EL,ER,FM,JORTH,EPS,ISWTCH,NIT) Y(1) = 0.0D0 DO 10 I = 1,N Y(1) = Y(1) + W(I)*D123F1(A(I)) 10 CONTINUE JS = 1 CALL GENGSQ (N,B,G,A,W,D123W2,JS,EL,ER,FM,JORTH,EPS,ISWTCH,NIT) Y(2) = 0.0D0 DO 20 I = 1,N Y(2) = Y(2) + W(I)*D123F2(A(I)) 20 CONTINUE DO 30 I = 1,2 IF (KPRINT .GE. 3) THEN WRITE (UNIT=LUN,FMT=9010) I,Y(I),I,ANS(I) ENDIF RELERR = ABS(Y(I)-ANS(I))/ANS(I) IF (RELERR .GT. ERRTOL) THEN IPASS = 0 IF (KPRINT .GE. 2) WRITE (UNIT=LUN,FMT=9020) I,Y(I),I,ANS(I) ENDIF 30 CONTINUE IF (IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN, 9030) IF (IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN, 9040) RETURN C 9000 FORMAT (/ ' GENGSQ Quick Check' /) 9010 FORMAT (' Y(', I2, ') =', D35.26 / ' ANS(', I2, ') =', D35.26) 9020 FORMAT (' D123QX FAILED, Y(', I2, ') =', D35.26 / 14X, 'ANS(', + I2, ') =', D35.26) 9030 FORMAT (' GENGSQ and its associated routines are correct.' /) 9040 FORMAT (' GENGSQ and its associated routines are incorrect. '/) END *DECK D123W1 DOUBLE PRECISION FUNCTION D123W1 (X) C***BEGIN PROLOGUE D123W1 C***PURPOSE Weight function evaluator for GENGSQ quick check D123QX. C***LIBRARY CLAMS C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C 920701 Declarations section restructured. (WRB) C***END PROLOGUE D123W1 C .. Scalar Arguments .. DOUBLE PRECISION X C***FIRST EXECUTABLE STATEMENT D123W1 D123W1 = 1.0D0 RETURN END *DECK D123W2 DOUBLE PRECISION FUNCTION D123W2 (X) C***BEGIN PROLOGUE D123W2 C***PURPOSE Weight function evaluator for GENGSQ quick check D123QX. C***LIBRARY CLAMS C***AUTHOR (UNKNOWN) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C 920701 Declarations section restructured. (WRB) C***END PROLOGUE D123W2 C .. Scalar Arguments .. DOUBLE PRECISION X C .. Intrinsic Functions .. INTRINSIC SQRT C***FIRST EXECUTABLE STATEMENT D123W2 D123W2 = 1.0D0/SQRT(1.0D0-X**2) RETURN END *DECK DDB2QX SUBROUTINE DDB2QX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DDB2QX C***PURPOSE Quick check for DDRVB2. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***DESCRIPTION C C ALL CHECK PROGRAM C C PART OF DDRVB1,2,3 PACKAGE, DOUBLE PRECISION VERSION C C***ROUTINES CALLED D1MACH, DDRVB2, DF2, DG2 C***COMMON BLOCKS DCONS2 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C 920715 Modified code to allow a second call to DDRVB2. (WRB) C***END PROLOGUE DDB2QX PARAMETER(LENW=263, LENIW=23) EXTERNAL DF2, DG2 DOUBLE PRECISION ALFA, EPS, EWT(1), D1MACH, T, TOUT, 1 WORK(LENW), Y(3) INTEGER IWORK(LENIW) COMMON /DCONS2/ ALFA DATA N /3/, EWT(1) /.00001D0/, MITER /0/, IMPL /0/ C***FIRST EXECUTABLE STATEMENT DDB2QX EPS = D1MACH(4)**(1.D0/3.D0) ALFA = 1.D0 IF (KPRINT .GE. 3) THEN WRITE(LUN, '(// '' *****'' / '' DDRVB2 TEST'' / 8 '' IF THE FOLLOWING TEST IS SUCCESSFUL, THE LAST LINE OF THIS'' 8 / '' OUTPUT FILE (APPROXIMATELY 45 LINES BEYOND THIS POINT)'' 8 / '' SHOULD BE -- DDRVB2 TEST PASSED.'' 8 / '' ANY OTHER FINAL MESSAGE INDICATES SOME TEST FAILURE.'' 8 / '' *****'')') WRITE(LUN, '(/ '' EPS ='', 1PD15.5)') EPS WRITE(LUN, '(/ '' A = '', 1PD10.2 // 1X, ''CYCLE'', 3X, 8 ''TIME'', 6X, ''Y(1)'', 6X, ''Y(2)'', 6X, ''Y(3)'', 4X, 8 ''MINT'', 1X, ''MITER'', 1X, ''IMPL'', 1X, ''NFE'', 1X, 8 ''NJE'')') ALFA ENDIF DO 50 MINT = 1,3 IF (MINT.EQ.2) THEN NROOT = 1 ELSE NROOT = 0 ENDIF T = 0.D0 Y(1) = 10.D0 Y(2) = 0.D0 Y(3) = 10.D0 NSTATE = 1 TOUT = 10.D0 CALL XGETF (KONTRL) CALL XSETF (0) CALL XERCLR ICALL = 0 10 CALL DDRVB2 (N, T, Y, DF2, TOUT, NSTATE, NROOT, EPS, EWT, 8 MINT,WORK,LENW,IWORK,LENIW,DG2) ICALL = ICALL + 1 IF (MSTATE.EQ.3 .AND. ICALL.LE.2) GO TO 10 CALL XSETF (KONTRL) CALL XERCLR IF (NSTATE.NE.2 .AND. NSTATE.NE.5) GO TO 60 NSTEP = IWORK(3) NFE = IWORK(4) NJE = IWORK(5) IF (NSTATE.EQ.5) THEN IF (KPRINT.GE.3) WRITE(LUN, '(I6, 1P4D10.2, I5, I6, I5, 2I4)') 8 NSTEP, T, (Y(I), I=1,3), MINT, MITER, IMPL, NFE, NJE IF (ABS(Y(1) - 1.D0).GT.EPS**(2.D0/3.D0)) GO TO 60 GO TO 10 ELSE IF (KPRINT.GE.3) WRITE(LUN, '(I6, 1P4D10.2, I5, I6, I5, 2I4)') 8 NSTEP, TOUT, (Y(I), I=1,3), MINT, MITER, IMPL, NFE, NJE IF (ABS(1.D0 - Y(1)*1.5D0).GT.EPS**(2.D0/3.D0) .OR. 8 ABS(1.D0 - Y(2)*3.D0).GT.EPS**(2.D0/3.D0) .OR. 8 ABS(1.D0 - Y(3)).GT.EPS**(2.D0/3.D0)) GO TO 60 ENDIF 50 CONTINUE IPASS = 1 IF (KPRINT .GT. 1) THEN WRITE(LUN, 8 '(// '' *****'' /'' DDRVB2 TEST PASSED'' / '' *****'')') ENDIF RETURN 60 IPASS = 0 IF (KPRINT .GT. 0) THEN WRITE(LUN, '(// '' *****'' / '' DDRVB2 TEST FAILED'' / 8 '' *****'' //)') ENDIF RETURN END *DECK DDB3QX SUBROUTINE DDB3QX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DDB3QX C***PURPOSE Quick check for DDRVB3. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***DESCRIPTION C C ALL CHECK PROGRAM C C PART OF DDRVB1,2,3 PACKAGE, DOUBLE PRECISION VERSION C C***ROUTINES CALLED D1MACH, DDRVB3, DF3, DFA3, DG3, DJAC3 C***COMMON BLOCKS DCONS3 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C 920715 Changed MXSTEP to 1500. (WRB) C***END PROLOGUE DDB3QX PARAMETER(LENW=294, LENIW=23) EXTERNAL DF3, DJAC3, DFA3, DG3 DOUBLE PRECISION ALFA, EPS, EWT(1), HMAX, D1MACH, T, TOUT, 1 WORK(LENW), Y(3) INTEGER IWORK(LENIW) COMMON /DCONS3/ ALFA, IMPL, MITER DATA N /3/, EWT(1) /.00001D0/, IERROR /3/, ML /2/, MU /2/, 8 HMAX /15.D0/, NDE /2/, MXSTEP /1500/ C***FIRST EXECUTABLE STATEMENT DDB3QX EPS = D1MACH(4)**(1.D0/3.D0) ALFA = 1.D0 IF (KPRINT .GE. 3) THEN WRITE(LUN, '(// '' *****'' / '' DDRVB3 TEST'' / 8 '' IF THE FOLLOWING TEST IS SUCCESSFUL, THE LAST LINE OF THIS'' 8 / '' OUTPUT FILE (APPROXIMATELY 45 LINES BEYOND THIS POINT)'' 8 / '' SHOULD BE -- DDRVB3 TEST PASSED.'' 8 / '' ANY OTHER FINAL MESSAGE INDICATES SOME TEST FAILURE.'' 8 / '' *****'')') WRITE(LUN, '(/ '' EPS ='', 1PD15.5)') EPS WRITE(LUN, '(/ '' A = '', 1PD10.2 // 1X, ''CYCLE'', 3X, 8 ''TIME'', 6X, ''Y(1)'', 6X, ''Y(2)'', 6X, ''Y(3)'', 4X, 8 ''MINT'', 1X, ''MITER'', 1X, ''IMPL'', 1X, ''NFE'', 1X, 8 ''NJE'')') ALFA ENDIF DO 50 IMPLP1 = 1,3 DO 50 MINT = 1,3 DO 50 MITERP = 1,6 MITER = MITERP - 1 IMPL = IMPLP1 - 1 IF (MITER .EQ. 3) GO TO 50 IF (IMPL.GT.0 .AND. MITER.EQ.0) GO TO 50 IF (IMPL.EQ.2 .AND. MINT.EQ.1) GO TO 50 IF (MINT.EQ.3 .AND. (IMPL.NE.0 .OR. MITER.EQ.0 .OR. 8 MITER.EQ.3)) GO TO 50 IF (MINT.EQ.1 .OR. MINT.EQ.3) THEN MXORD = 12 ELSE IF (MINT.EQ.2) THEN MXORD = 5 ENDIF IF (MINT.EQ.2 .AND. MITER.EQ.2 .AND. IMPL.EQ.0) THEN NROOT = 1 ELSE NROOT = 0 ENDIF T = 0.D0 Y(1) = 10.D0 Y(2) = 0.D0 Y(3) = 10.D0 NSTATE = 1 TOUT = 10.D0 NTASK = 1 10 CALL DDRVB3 (N, T, Y, DF3, NSTATE, TOUT, NTASK, NROOT, EPS, EWT, 8 IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, 8 WORK,LENW,IWORK,LENIW,DJAC3,DFA3,NDE,MXSTEP,DG3) IF (NSTATE.NE.2 .AND. NSTATE.NE.5) GO TO 60 NSTEP = IWORK(3) NFE = IWORK(4) NJE = IWORK(5) IF (NSTATE.EQ.5) THEN IF (KPRINT.GE.3) WRITE(LUN, '(I6, 1P4D10.2, I5, I6, I5, 2I4)') 8 NSTEP, T, (Y(I), I=1,3), MINT, MITER, IMPL, NFE, NJE IF (ABS(Y(1) - 1.D0).GT.EPS**(2.D0/3.D0)) GO TO 60 GO TO 10 ELSE IF (KPRINT.GE.3) WRITE(LUN, '(I6, 1P4D10.2, I5, I6, I5, 2I4)') 8 NSTEP, TOUT, (Y(I), I=1,3), MINT, MITER, IMPL, NFE, NJE IF (ABS(1.D0 - Y(1)*1.5D0).GT.EPS**(2.D0/3.D0) .OR. 8 ABS(1.D0 - Y(2)*3.D0).GT.EPS**(2.D0/3.D0) .OR. 8 ABS(1.D0 - Y(3)).GT.EPS**(2.D0/3.D0)) GO TO 60 ENDIF 50 CONTINUE IPASS = 1 IF (KPRINT .GT. 1) THEN WRITE(LUN, 8 '(// '' *****'' /'' DDRVB3 TEST PASSED'' / '' *****'')') ENDIF RETURN 60 IPASS = 0 IF (KPRINT .GT. 0) THEN WRITE(LUN, '(// '' *****'' / '' DDRVB3 TEST FAILED'' / 8 '' *****'' //)') ENDIF RETURN END *DECK DF2 SUBROUTINE DF2 (N, T, Y, YP) C***BEGIN PROLOGUE DF2 C***PURPOSE Derivative evaluator for DDB2QX. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***ROUTINES CALLED (NONE) C***COMMON BLOCKS DCONS2 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE DF2 DOUBLE PRECISION ALFA,T,Y(*),YP(*) COMMON /DCONS2/ ALFA C***FIRST EXECUTABLE STATEMENT DF2 YP(1) = 1.D0 + ALFA*(Y(2) - Y(1)) - Y(1)*Y(3) YP(2) = ALFA*(Y(1) - Y(2)) - Y(2)*Y(3) YP(3) = 1.D0 - Y(3)*(Y(1) + Y(2)) END *DECK DF3 SUBROUTINE DF3 (N, T, Y, YP) C***BEGIN PROLOGUE DF3 C***PURPOSE Derivative evaluator for DDB3QX. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***ROUTINES CALLED (NONE) C***COMMON BLOCKS DCONS3 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE DF3 DOUBLE PRECISION ALFA,T,Y(*),YP(*) COMMON /DCONS3/ ALFA, IMPL, MITER C***FIRST EXECUTABLE STATEMENT DF3 YP(1) = 1.D0 + ALFA*(Y(2) - Y(1)) - Y(1)*Y(3) YP(2) = ALFA*(Y(1) - Y(2)) - Y(2)*Y(3) IF (IMPL.EQ.0 .OR. IMPL.EQ.1) THEN YP(3) = 1.D0 - Y(3)*(Y(1) + Y(2)) ELSE IF (IMPL.EQ.2) THEN YP(3) = Y(1) + Y(2) - Y(3) ENDIF END *DECK DFA3 SUBROUTINE DFA3 (N, T, Y, A, MATDIM, ML, MU, NDE) C***BEGIN PROLOGUE DFA3 C***PURPOSE Matrix evaluator for DDB3QX. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***ROUTINES CALLED (NONE) C***COMMON BLOCKS DCONS3 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE DFA3 DOUBLE PRECISION A(MATDIM,*),ALFA,T,Y(*) COMMON /DCONS3/ ALFA, IMPL, MITER C***FIRST EXECUTABLE STATEMENT DFA3 IF (IMPL.EQ.0 .OR. IMPL.EQ.1) THEN IF (MITER.EQ.1 .OR. MITER.EQ.2 .OR. MITER.EQ.3) THEN DO 20 J = 1,N DO 10 I = 1,N 10 A(I,J) = 0.D0 20 A(J,J) = 1.D0 ELSE IF (MITER.EQ.4) THEN DO 50 J = 1,N DO 40 I = 1,N I1 = I + MU + 1 - J 40 A(I1,J) = 0.D0 50 A(MU+1,J) = 1.D0 ENDIF ELSE IF (IMPL.EQ.2) THEN A(1,1) = 1.D0 A(2,1) = 1.D0 ENDIF END *DECK DG2 DOUBLE PRECISION FUNCTION DG2 (N, T, Y, IROOT) C***BEGIN PROLOGUE DG2 C***PURPOSE Algebric equation evaluator for DDB2QX. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE DG2 DOUBLE PRECISION T, Y(*) C***FIRST EXECUTABLE STATEMENT DG2 DG2 = Y(1) - 1.D0 END *DECK DG3 DOUBLE PRECISION FUNCTION DG3 (N, T, Y, IROOT) C***BEGIN PROLOGUE DG3 C***PURPOSE Algebric equation evaluator for DDB3QX. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE DG3 DOUBLE PRECISION T, Y(*) C***FIRST EXECUTABLE STATEMENT DG3 DG3 = Y(1) - 1.D0 END *DECK DJAC3 SUBROUTINE DJAC3 (N, T, Y, DFDY, MATDIM, ML, MU) C***BEGIN PROLOGUE DJAC3 C***PURPOSE Jacobian evaluator for DDB3QX. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***ROUTINES CALLED (NONE) C***COMMON BLOCKS DCONS3 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE DJAC3 DOUBLE PRECISION ALFA,DFDY(MATDIM,*),T,Y(*) COMMON /DCONS3/ ALFA, IMPL, MITER C***FIRST EXECUTABLE STATEMENT DJAC3 IF (MITER.EQ.1 .OR. MITER.EQ.3) THEN DFDY(1,1) = -ALFA - Y(3) DFDY(1,2) = ALFA DFDY(1,3) = -Y(1) DFDY(2,1) = ALFA DFDY(2,2) = -ALFA - Y(3) DFDY(2,3) = -Y(2) IF (IMPL.EQ.0 .OR. IMPL.EQ.1) THEN DFDY(3,1) = -Y(3) DFDY(3,2) = -Y(3) DFDY(3,3) = -Y(1) - Y(2) ELSE IF (IMPL.EQ.2) THEN DFDY(3,1) = 1.D0 DFDY(3,2) = 1.D0 DFDY(3,3) = -1.D0 ENDIF ELSE IF (MITER.EQ.4) THEN DFDY(3,1) = -ALFA - Y(3) DFDY(2,2) = ALFA DFDY(1,3) = -Y(1) DFDY(4,1) = ALFA DFDY(3,2) = DFDY(3,1) DFDY(2,3) = -Y(2) IF (IMPL.EQ.0 .OR. IMPL.EQ.1) THEN DFDY(5,1) = -Y(3) DFDY(4,2) = -Y(3) DFDY(3,3) = -Y(1) - Y(2) ELSE IF (IMPL.EQ.2) THEN DFDY(5,1) = 1.D0 DFDY(4,2) = 1.D0 DFDY(3,3) = -1.D0 ENDIF ENDIF END *DECK F146QX SUBROUTINE F146QX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE F146QX C***PURPOSE Quick check for ISAMIN, ISMAX and ISMIN. C***LIBRARY CLAMS C***AUTHOR (UNKNOWN) C***ROUTINES CALLED ISAMIN, ISMAX, ISMIN C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C 920701 Declarations section restructured and some code cleaned. C (WRB) C***END PROLOGUE F146QX C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. INTEGER I, INC, N C .. Local Arrays .. REAL X(19) INTEGER IANS(3), IND(3) C .. External Functions .. INTEGER ISAMIN, ISMAX, ISMIN EXTERNAL ISAMIN, ISMAX, ISMIN C .. Data statements .. DATA X / 0.0, -1.0, 1.0, -2.0, 2.0, -3.0, 3.0, -4.0, 4.0, + -5.0, 5.0, -6.0, 6.0, -7.0, 7.0, -8.0, 8.0, -9.0, 9.0 / C***FIRST EXECUTABLE STATEMENT F146QX IF (KPRINT .GE. 2) WRITE (UNIT=LUN,FMT=9000) C IPASS = 1 N = 19 INC = 1 IF (KPRINT .GE. 3) WRITE (UNIT=LUN,FMT=9010) (X(I),I=1,N) IND(1) = ISAMIN (N,X,INC) IND(2) = ISMAX (N,X,INC) IND(3) = ISMIN (N,X,INC) IF (KPRINT .GE. 3) THEN DO 10 I = 1,3 WRITE (UNIT=LUN,FMT=9020) I,IND(I),IND(I),X(IND(I)) 10 CONTINUE ENDIF IANS(1) = 1 IANS(2) = 19 IANS(3) = 18 DO 20 I = 1,3 IF (IND(I) .NE. IANS(I)) THEN IPASS = 0 IF (KPRINT .GE. 2) + WRITE (UNIT=LUN,FMT=9030) I,IND(I),I,IANS(I) ENDIF 20 CONTINUE IF (IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN, 9040) IF (IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN, 9050) RETURN C 9000 FORMAT (/ ' ISAMIN, ISMAX, and ISMIN Quick Check' /) 9010 FORMAT (' Elements of array X:', 2(/ 10F7.2)) 9020 FORMAT (' IND(', I2, ') =', I2, 5X, 'X(', I2, ') =', F7.2) 9030 FORMAT (' F146QX FAILED, IND(', I2, ') =', I2, 5X, 'IANS(', I2, + ') =', I2) 9040 FORMAT (' ISAMIN, ISMAX, and ISMIN are correct.' /) 9050 FORMAT (' At least one of ISAMIN, ISMAX and ISMIN is incorrect.' + /) END *DECK FA SUBROUTINE FA (N, T, Y, A, MATDIM, ML, MU, NDE) C***BEGIN PROLOGUE FA C***SUBSIDIARY C***PURPOSE Dummy matrix evaluation routine for SDRIVE quick checks. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE FA C***FIRST EXECUTABLE STATEMENT FA RETURN END *DECK ICMMQX SUBROUTINE ICMMQX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE ICMMQX C***PURPOSE Quick check for ICAMIN. C***LIBRARY CLAMS C***AUTHOR Boland, W. Robert, (LANL) C***ROUTINES CALLED ICAMIN C***REVISION HISTORY (YYMMDD) C 910408 DATE WRITTEN C 920701 Declarations section restructured and some code cleaned. C (WRB) C***END PROLOGUE ICMMQX C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. INTEGER I, IANS, INC, IND, N C .. Local Arrays .. COMPLEX X(8) C .. External Functions .. INTEGER ICAMIN EXTERNAL ICAMIN C .. Data statements .. DATA X / (0.E0, -1.E0), (1.E0, -2.E0), (2.E0, -3.E0), + (3.E0, -4.E0), (-5.E0, 5.E0), (-6.E0, 6.E0), + (-7.E0, 7.E0), (-8.E0, 8.E0) / C***FIRST EXECUTABLE STATEMENT ICMMQX IF (KPRINT .GE. 2) WRITE (UNIT=LUN,FMT=9000) C IPASS = 1 N = 8 INC = 1 IF (KPRINT .GE. 3) WRITE (UNIT=LUN,FMT=9010) (X(I),I=1,N) IND = ICAMIN (N,X,INC) IF (KPRINT .GE. 3) WRITE (UNIT=LUN,FMT=9020) IND,IND,X(IND) IANS = 1 IF (IND .NE. IANS) THEN IPASS = 0 IF (KPRINT .GE. 2) WRITE (UNIT=LUN,FMT=9030) IND,IANS ENDIF IF (IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN, 9040) IF (IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN, 9050) RETURN C 9000 FORMAT (/ ' ICAMIN Quick Check' /) 9010 FORMAT (' Elements of array X:' / + 4(' (', F5.2, ', ', F5.2, '), ') / + 3(' (', F5.2, ', ', F5.2, '), '), ' (', F5.2, ', ', F5.2, + ')') 9020 FORMAT (' IND =', I2, 5X, 'X(', I2, ') = (', F5.2, ', ', F5.2, + ')') 9030 FORMAT (' ICMMQX failed, IND =', I2, 5X, 'IANS =', I2) 9040 FORMAT (' ICAMIN is correct.' /) 9050 FORMAT (' ICAMIN is incorrect.' /) END *DECK IDMMQX SUBROUTINE IDMMQX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE IDMMQX C***PURPOSE Quick check for IDAMIN, IDMAX and IDMIN. C***LIBRARY CLAMS C***AUTHOR Boland, W. Robert, (LANL) C***ROUTINES CALLED IDAMIN, IDMAX, IDMIN C***REVISION HISTORY (YYMMDD) C 910408 DATE WRITTEN C 920701 Declarations section restructured. (WRB) C***END PROLOGUE IDMMQX C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. INTEGER I, INC, N C .. Local Arrays .. DOUBLE PRECISION X(19) INTEGER IANS(3), IND(3) C .. External Functions .. INTEGER IDAMIN, IDMAX, IDMIN EXTERNAL IDAMIN, IDMAX, IDMIN C .. Data statements .. DATA X / 0.0D0, -1.0D0, 1.0D0, -2.0D0, 2.0D0, -3.0D0, 3.0D0, + -4.0D0, 4.0D0, -5.0D0, 5.0D0, -6.0D0, 6.0D0, -7.0D0, + 7.0D0, -8.0D0, 8.0D0, -9.0D0, 9.0D0 / C***FIRST EXECUTABLE STATEMENT IDMMQX IF (KPRINT .GE. 2) WRITE (UNIT=LUN,FMT=9000) C IPASS = 1 N = 19 INC = 1 IF (KPRINT .GE. 3) WRITE (UNIT=LUN,FMT=9010) (X(I),I=1,N) IND(1) = IDAMIN (N,X,INC) IND(2) = IDMAX (N,X,INC) IND(3) = IDMIN (N,X,INC) IF (KPRINT .GE. 3) THEN DO 10 I = 1,3 WRITE (UNIT=LUN,FMT=9020) I,IND(I),IND(I),X(IND(I)) 10 CONTINUE ENDIF IANS(1) = 1 IANS(2) = 19 IANS(3) = 18 DO 20 I = 1,3 IF (IND(I) .NE. IANS(I)) THEN IPASS = 0 IF (KPRINT .GE. 2) + WRITE (UNIT=LUN,FMT=9030) I,IND(I),I,IANS(I) ENDIF 20 CONTINUE IF (IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN, 9040) IF (IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN, 9050) RETURN C 9000 FORMAT (/ ' IDAMIN, IDMAX, and IDMIN Quick Check' /) 9010 FORMAT (' Elements of array X:', 2(/ 10F7.2)) 9020 FORMAT (' IND(', I2, ') =', I2, 5X, 'X(', I2 ,') =', F7.2) 9030 FORMAT (' IDMMQX failed, IND(', I2, ') =', I2, 5X, 'IANS(', I2, + ') =', I2) 9040 FORMAT (' IDAMIN, IDMAX, and IDMIN are correct.' /) 9050 FORMAT (' IDAMIN, IDMAX, and IDMIN are incorrect.' /) END *DECK JACOBN SUBROUTINE JACOBN (N, T, Y, DFDY, MATDIM, ML, MU) C***BEGIN PROLOGUE JACOBN C***SUBSIDIARY C***PURPOSE Dummy Jacobian evaluation routine for SDRIVE quick checks. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE JACOBN C***FIRST EXECUTABLE STATEMENT JACOBN RETURN END *DECK M120QX SUBROUTINE M120QX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE M120QX C***PURPOSE Quick check for QQSORT. C***LIBRARY CLAMS C***AUTHOR (UNKNOWN) C***ROUTINES CALLED QQSORT C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C 920701 Declarations section restructured and some code cleaned. C (WRB) C***END PROLOGUE M120QX C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. INTEGER I, IM1, N C .. Local Arrays .. REAL X(19) INTEGER J(19), L(19) C .. External Subroutines .. EXTERNAL QQSORT C .. Data statements .. DATA X / 0.0, -1.0, 1.0, -2.0, 2.0, -3.0, 3.0, -4.0, 4.0, + -5.0, 5.0, -6.0, 6.0, -7.0, 7.0, -8.0, 8.0, -9.0, 9.0 / C***FIRST EXECUTABLE STATEMENT M120QX IF (KPRINT .GE. 2) WRITE (LUN,9000) C IPASS = 1 N = 19 IF (KPRINT .GE. 3) WRITE (UNIT=LUN,FMT=9010) (X(I),I=1,N) CALL QQSORT (N,X,J,L,L) IF (KPRINT .GE. 3) WRITE (UNIT=LUN,FMT=9020) (X(I),I=1,N) DO 10 I = 2,N IM1 = I - 1 IF (X(IM1) .GE. X(I)) THEN IPASS = 0 IF (KPRINT .GE. 2) + WRITE (UNIT=LUN,FMT=9030) IM1,X(IM1),I,X(I) ENDIF 10 CONTINUE IF (IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN, 9040) IF (IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN, 9050) RETURN C 9000 FORMAT (/ ' QQSORT Quick Check' /) 9010 FORMAT (' Array elements before sorting', 2(/, 10F7.0)) 9020 FORMAT (' Array elements after sorting', 2(/, 10F7.0)) 9030 FORMAT (' M120QX FAILED, X(', I2, ') =', F7.0, 5X, 'X(', I2, + ') =', F7.0) 9040 FORMAT (' QQSORT is correct.' /) 9050 FORMAT (' QQSORT is incorrect.' /) END *DECK SDB2QX SUBROUTINE SDB2QX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE SDB2QX C***PURPOSE Quick check for SDRVB2. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***DESCRIPTION C C ALL CHECK PROGRAM C C PART OF SDRVB1,2,3 PACKAGE, SINGLE PRECISION VERSION C C***ROUTINES CALLED R1MACH, SDRVB2, SF2, SG2 C***COMMON BLOCKS SCONS2 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE SDB2QX PARAMETER(LENW=263, LENIW=23) EXTERNAL SF2, SG2 REAL ALFA, EPS, EWT(1), R1MACH, T, TOUT, 1 WORK(LENW), Y(3) INTEGER IWORK(LENIW) COMMON /SCONS2/ ALFA DATA N /3/, EWT(1) /.00001E0/, MITER /0/, IMPL /0/ C***FIRST EXECUTABLE STATEMENT SDB2QX EPS = R1MACH(4)**(1.E0/3.E0) ALFA = 1.E0 IF (KPRINT .GE. 3) THEN WRITE(LUN, '(// '' *****'' / '' SDRVB2 TEST'' / 8 '' IF THE FOLLOWING TEST IS SUCCESSFUL, THE LAST LINE OF THIS'' 8 / '' OUTPUT FILE (APPROXIMATELY 45 LINES BEYOND THIS POINT)'' 8 / '' SHOULD BE -- SDRVB2 TEST PASSED.'' 8 / '' ANY OTHER FINAL MESSAGE INDICATES SOME TEST FAILURE.'' 8 / '' *****'')') WRITE(LUN, '(/ '' EPS ='', 1PE15.5)') EPS WRITE(LUN, '(/ '' A = '', 1PE10.2 // 1X, ''CYCLE'', 3X, 8 ''TIME'', 6X, ''Y(1)'', 6X, ''Y(2)'', 6X, ''Y(3)'', 4X, 8 ''MINT'', 1X, ''MITER'', 1X, ''IMPL'', 1X, ''NFE'', 1X, 8 ''NJE'')') ALFA ENDIF DO 50 MINT = 1,3 IF (MINT.EQ.2) THEN NROOT = 1 ELSE NROOT = 0 ENDIF T = 0.E0 Y(1) = 10.E0 Y(2) = 0.E0 Y(3) = 10.E0 NSTATE = 1 TOUT = 10.E0 10 CALL SDRVB2 (N, T, Y, SF2, TOUT, NSTATE, NROOT, EPS, EWT, 8 MINT,WORK,LENW,IWORK,LENIW,SG2) IF (NSTATE.NE.2 .AND. NSTATE.NE.5) GO TO 60 NSTEP = IWORK(3) NFE = IWORK(4) NJE = IWORK(5) IF (NSTATE.EQ.5) THEN IF (KPRINT.GE.3) WRITE(LUN, '(I6, 1P4E10.2, I5, I6, I5, 2I4)') 8 NSTEP, T, (Y(I), I=1,3), MINT, MITER, IMPL, NFE, NJE IF (ABS(Y(1) - 1.E0).GT.EPS**(2.E0/3.E0)) GO TO 60 GO TO 10 ELSE IF (KPRINT.GE.3) WRITE(LUN, '(I6, 1P4E10.2, I5, I6, I5, 2I4)') 8 NSTEP, TOUT, (Y(I), I=1,3), MINT, MITER, IMPL, NFE, NJE IF (ABS(1.E0 - Y(1)*1.5E0).GT.EPS**(2.E0/3.E0) .OR. 8 ABS(1.E0 - Y(2)*3.E0).GT.EPS**(2.E0/3.E0) .OR. 8 ABS(1.E0 - Y(3)).GT.EPS**(2.E0/3.E0)) GO TO 60 ENDIF 50 CONTINUE IPASS = 1 IF (KPRINT .GT. 1) THEN WRITE(LUN, 8 '(// '' *****'' /'' SDRVB2 TEST PASSED'' / '' *****'')') ENDIF RETURN 60 IPASS = 0 IF (KPRINT .GT. 0) THEN WRITE(LUN, '(// '' *****'' / '' SDRVB2 TEST FAILED'' / 8 '' *****'' //)') ENDIF RETURN END *DECK SDB3QX SUBROUTINE SDB3QX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE SDB3QX C***PURPOSE Quick check for SDRVB3. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***DESCRIPTION C C ALL CHECK PROGRAM C C PART OF SDRVB1,2,3 PACKAGE, SINGLE PRECISION VERSION C C***ROUTINES CALLED R1MACH, SDRVB3, SF3, SFA3, SG3, SJAC3 C***COMMON BLOCKS SCONS3 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE SDB3QX PARAMETER(LENW=294, LENIW=23) EXTERNAL SF3, SJAC3, SFA3, SG3 REAL ALFA, EPS, EWT(1), HMAX, R1MACH, T, TOUT, 1 WORK(LENW), Y(3) INTEGER IWORK(LENIW) COMMON /SCONS3/ ALFA, IMPL, MITER DATA N /3/, EWT(1) /.00001E0/, IERROR /3/, ML /2/, MU /2/, 8 HMAX /15.E0/, NDE /2/, MXSTEP /1000/ C***FIRST EXECUTABLE STATEMENT SDB3QX EPS = R1MACH(4)**(1.E0/3.E0) ALFA = 1.E0 IF (KPRINT .GE. 3) THEN WRITE(LUN, '(// '' *****'' / '' SDRVB3 TEST'' / 8 '' IF THE FOLLOWING TEST IS SUCCESSFUL, THE LAST LINE OF THIS'' 8 / '' OUTPUT FILE (APPROXIMATELY 45 LINES BEYOND THIS POINT)'' 8 / '' SHOULD BE -- SDRVB3 TEST PASSED.'' 8 / '' ANY OTHER FINAL MESSAGE INDICATES SOME TEST FAILURE.'' 8 / '' *****'')') WRITE(LUN, '(/ '' EPS ='', 1PE15.5)') EPS WRITE(LUN, '(/ '' A = '', 1PE10.2 // 1X, ''CYCLE'', 3X, 8 ''TIME'', 6X, ''Y(1)'', 6X, ''Y(2)'', 6X, ''Y(3)'', 4X, 8 ''MINT'', 1X, ''MITER'', 1X, ''IMPL'', 1X, ''NFE'', 1X, 8 ''NJE'')') ALFA ENDIF DO 50 IMPLP1 = 1,3 DO 50 MINT = 1,3 DO 50 MITERP = 1,6 MITER = MITERP - 1 IMPL = IMPLP1 - 1 IF (MITER .EQ. 3) GO TO 50 IF (IMPL.GT.0 .AND. MITER.EQ.0) GO TO 50 IF (IMPL.EQ.2 .AND. MINT.EQ.1) GO TO 50 IF (MINT.EQ.3 .AND. (IMPL.NE.0 .OR. MITER.EQ.0 .OR. 8 MITER.EQ.3)) GO TO 50 IF (MINT.EQ.1 .OR. MINT.EQ.3) THEN MXORD = 12 ELSE IF (MINT.EQ.2) THEN MXORD = 5 ENDIF IF (MINT.EQ.2 .AND. MITER.EQ.2 .AND. IMPL.EQ.0) THEN NROOT = 1 ELSE NROOT = 0 ENDIF T = 0.E0 Y(1) = 10.E0 Y(2) = 0.E0 Y(3) = 10.E0 NSTATE = 1 TOUT = 10.E0 NTASK = 1 10 CALL SDRVB3 (N, T, Y, SF3, NSTATE, TOUT, NTASK, NROOT, EPS, EWT, 8 IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, 8 WORK,LENW,IWORK,LENIW,SJAC3,SFA3,NDE,MXSTEP,SG3) IF (NSTATE.NE.2 .AND. NSTATE.NE.5) GO TO 60 NSTEP = IWORK(3) NFE = IWORK(4) NJE = IWORK(5) IF (NSTATE.EQ.5) THEN IF (KPRINT.GE.3) WRITE(LUN, '(I6, 1P4E10.2, I5, I6, I5, 2I4)') 8 NSTEP, T, (Y(I), I=1,3), MINT, MITER, IMPL, NFE, NJE IF (ABS(Y(1) - 1.E0).GT.EPS**(2.E0/3.E0)) GO TO 60 GO TO 10 ELSE IF (KPRINT.GE.3) WRITE(LUN, '(I6, 1P4E10.2, I5, I6, I5, 2I4)') 8 NSTEP, TOUT, (Y(I), I=1,3), MINT, MITER, IMPL, NFE, NJE IF (ABS(1.E0 - Y(1)*1.5E0).GT.EPS**(2.E0/3.E0) .OR. 8 ABS(1.E0 - Y(2)*3.E0).GT.EPS**(2.E0/3.E0) .OR. 8 ABS(1.E0 - Y(3)).GT.EPS**(2.E0/3.E0)) GO TO 60 ENDIF 50 CONTINUE IPASS = 1 IF (KPRINT .GT. 1) THEN WRITE(LUN, 8 '(// '' *****'' /'' SDRVB3 TEST PASSED'' / '' *****'')') ENDIF RETURN 60 IPASS = 0 IF (KPRINT .GT. 0) THEN WRITE(LUN, '(// '' *****'' / '' SDRVB3 TEST FAILED'' / 8 '' *****'' //)') ENDIF RETURN END *DECK SF2 SUBROUTINE SF2 (N, T, Y, YP) C***BEGIN PROLOGUE SF2 C***PURPOSE Derivative evaluator for SDB2QX. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***ROUTINES CALLED (NONE) C***COMMON BLOCKS SCONS2 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE SF2 REAL ALFA,T,Y(*),YP(*) COMMON /SCONS2/ ALFA C***FIRST EXECUTABLE STATEMENT SF2 YP(1) = 1.E0 + ALFA*(Y(2) - Y(1)) - Y(1)*Y(3) YP(2) = ALFA*(Y(1) - Y(2)) - Y(2)*Y(3) YP(3) = 1.E0 - Y(3)*(Y(1) + Y(2)) END *DECK SF3 SUBROUTINE SF3 (N, T, Y, YP) C***BEGIN PROLOGUE SF3 C***PURPOSE Derivative evaluator for SDB3QX. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***ROUTINES CALLED (NONE) C***COMMON BLOCKS SCONS3 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE SF3 REAL ALFA,T,Y(*),YP(*) COMMON /SCONS3/ ALFA, IMPL, MITER C***FIRST EXECUTABLE STATEMENT SF3 YP(1) = 1.E0 + ALFA*(Y(2) - Y(1)) - Y(1)*Y(3) YP(2) = ALFA*(Y(1) - Y(2)) - Y(2)*Y(3) IF (IMPL.EQ.0 .OR. IMPL.EQ.1) THEN YP(3) = 1.E0 - Y(3)*(Y(1) + Y(2)) ELSE IF (IMPL.EQ.2) THEN YP(3) = Y(1) + Y(2) - Y(3) ENDIF END *DECK SFA3 SUBROUTINE SFA3 (N, T, Y, A, MATDIM, ML, MU, NDE) C***BEGIN PROLOGUE SFA3 C***PURPOSE Matrix evaluator for SDB3QX. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***ROUTINES CALLED (NONE) C***COMMON BLOCKS SCONS3 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE SFA3 REAL A(MATDIM,*),ALFA,T,Y(*) COMMON /SCONS3/ ALFA, IMPL, MITER C***FIRST EXECUTABLE STATEMENT SFA3 IF (IMPL.EQ.0 .OR. IMPL.EQ.1) THEN IF (MITER.EQ.1 .OR. MITER.EQ.2 .OR. MITER.EQ.3) THEN DO 20 J = 1,N DO 10 I = 1,N 10 A(I,J) = 0.E0 20 A(J,J) = 1.E0 ELSE IF (MITER.EQ.4) THEN DO 50 J = 1,N DO 40 I = 1,N I1 = I + MU + 1 - J 40 A(I1,J) = 0.E0 50 A(MU+1,J) = 1.E0 ENDIF ELSE IF (IMPL.EQ.2) THEN A(1,1) = 1.E0 A(2,1) = 1.E0 ENDIF END *DECK SG2 REAL FUNCTION SG2 (N, T, Y, IROOT) C***BEGIN PROLOGUE SG2 C***PURPOSE Algebric equation evaluator for SDB2QX. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE SG2 REAL T, Y(*) C***FIRST EXECUTABLE STATEMENT SG2 SG2 = Y(1) - 1.E0 END *DECK SG3 REAL FUNCTION SG3 (N, T, Y, IROOT) C***BEGIN PROLOGUE SG3 C***PURPOSE Algebric equation evaluator for SDB3QX. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE SG3 REAL T, Y(*) C***FIRST EXECUTABLE STATEMENT SG3 SG3 = Y(1) - 1.E0 END *DECK SJAC3 SUBROUTINE SJAC3 (N, T, Y, DFDY, MATDIM, ML, MU) C***BEGIN PROLOGUE SJAC3 C***PURPOSE Jacobian evaluator for SDB3QX. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***ROUTINES CALLED (NONE) C***COMMON BLOCKS SCONS3 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE SJAC3 REAL ALFA,DFDY(MATDIM,*),T,Y(*) COMMON /SCONS3/ ALFA, IMPL, MITER C***FIRST EXECUTABLE STATEMENT SJAC3 IF (MITER.EQ.1 .OR. MITER.EQ.3) THEN DFDY(1,1) = -ALFA - Y(3) DFDY(1,2) = ALFA DFDY(1,3) = -Y(1) DFDY(2,1) = ALFA DFDY(2,2) = -ALFA - Y(3) DFDY(2,3) = -Y(2) IF (IMPL.EQ.0 .OR. IMPL.EQ.1) THEN DFDY(3,1) = -Y(3) DFDY(3,2) = -Y(3) DFDY(3,3) = -Y(1) - Y(2) ELSE IF (IMPL.EQ.2) THEN DFDY(3,1) = 1.E0 DFDY(3,2) = 1.E0 DFDY(3,3) = -1.E0 ENDIF ELSE IF (MITER.EQ.4) THEN DFDY(3,1) = -ALFA - Y(3) DFDY(2,2) = ALFA DFDY(1,3) = -Y(1) DFDY(4,1) = ALFA DFDY(3,2) = DFDY(3,1) DFDY(2,3) = -Y(2) IF (IMPL.EQ.0 .OR. IMPL.EQ.1) THEN DFDY(5,1) = -Y(3) DFDY(4,2) = -Y(3) DFDY(3,3) = -Y(1) - Y(2) ELSE IF (IMPL.EQ.2) THEN DFDY(5,1) = 1.E0 DFDY(4,2) = 1.E0 DFDY(3,3) = -1.E0 ENDIF ENDIF END *DECK TEST90 PROGRAM TEST90 C***BEGIN PROLOGUE TEST90 C***PURPOSE Driver for testing non-SLATEC subprograms C***LIBRARY CLAMS C***CATEGORY I1A2, I1A1B C***TYPE ALL (TEST90-A) C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR Boland, W. Robert, C-10, Los Alamos National Laboratory C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing non-SLATEC subprograms C GAUSS CBSHV HRMTE LAGRE LGNDR LGNDRX C GENGSQ GAUSSQ PHI STLTJS C QQSORT C SPLIN2 SPL2D1 SPL1D1 SPL2D2 SPL2D3 C SPLINT SPINTG SPL1D1 SPL1D2 C ISAMIN ISMAX ISMIN C ICAMIN C IDAMIN IDMAX IDMIN C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED D114QX, D117QX, D118QX, D123QX, F146QX, I1MACH, C ICMMQX, IDMMQX, M120QX, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 901205 Cosmetic changes to code. (WRB) C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C 910828 Added calls to ICMMQX and IDMMQX. (WRB) C***END PROLOGUE TEST90 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST90 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test GAUSS, etc. C CALL D114QX (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test GENGSQ, etc. C CALL D123QX (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test QQSORT C CALL M120QX (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test SPLIN2, etc. C CALL D118QX (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test SPLINT, etc. C CALL D117QX (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test ISAMIN, ISMAX and ISMIN. C CALL F146QX (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test ICAMIN. C CALL ICMMQX (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test IDAMIN, IDMAX and IDMIN. C CALL IDMMQX (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST90 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST90 *************') END *DECK TEST91 PROGRAM TEST91 C***BEGIN PROLOGUE TEST91 C***PURPOSE Driver for testing non-SLATEC subprograms C***LIBRARY CLAMS C***CATEGORY I1A2, I1A1B C***TYPE ALL (TEST91-A) C***KEYWORDS QUICK CHECK DRIVER C***AUTHOR Boland, W. Robert, C-10, Los Alamos National Laboratory C***DESCRIPTION C C *Usage: C One input data record is required C READ (LIN, '(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing non-SLATEC subprograms C SDRVB2 SDRVB3 C DDRVB2 DDRVB3 C CDRVB2 CDRVB3 C C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro C and Lee Walton, Guide to the SLATEC Common Mathema- C tical Library, April 10, 1990. C***ROUTINES CALLED CDB2QX, CDB3QX, DDB2QX, DDB3QX, I1MACH, SDB2QX, C SDB3QX, XERMAX, XSETF, XSETUN C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 901205 Cosmetic changes to code. (WRB) C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE TEST91 INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C***FIRST EXECUTABLE STATEMENT TEST91 LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (LIN, '(I1)') KPRINT CALL XERMAX(1000) CALL XSETUN(LUN) IF (KPRINT .LE. 1) THEN CALL XSETF(0) ELSE CALL XSETF(1) ENDIF C C Test SDRVB2 C CALL SDB2QX (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DDRVB2 C CALL DDB2QX (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test CDRVB2 C CALL CDB2QX (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test SDRVB3 C CALL SDB3QX (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test DDRVB3 C CALL DDB3QX (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test CDRVB3 C CALL CDB3QX (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (LUN, 9000) ELSE WRITE (LUN, 9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TEST91 PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TEST91 *************') END *DECK USERS SUBROUTINE USERS (Y, YH, YWT, SAVE1, SAVE2, T, H, EL, IMPL, N, + NDE, IFLAG) C***BEGIN PROLOGUE USERS C***SUBSIDIARY C***PURPOSE Dummy matrix solution routine for SDRIVE quick checks. C***LIBRARY CLAMS C***AUTHOR Kahaner, D. K., (NIST) C Sutherland, C. D., (LANL) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 910815 Prologue filled out and brought up to the SLATEC 1990 C standard. (WRB) C***END PROLOGUE USERS C***FIRST EXECUTABLE STATEMENT USERS RETURN END