* * $Id: c331m.F,v 1.1.1.1 1996/04/01 15:01:17 mclareni Exp $ * * $Log: c331m.F,v $ * Revision 1.1.1.1 1996/04/01 15:01:17 mclareni * Mathlib gen * * #include "gen/pilot.h" SUBROUTINE C331M C Routine to test the MATHLIB routines FCONC and DFCONC (C331) #include "gen/imp64.inc" #if defined(CERNLIB_DOUBLE) REAL FCONC, RP0,RP1 #endif DIMENSION X(9,7),TAU(9,7),TP0(9,7),TP1(9,7) C Set numerical tolerance for testing the S/D versions DIMENSION TOL(2) C LOGICAL LTEST #include "iorc.inc" DATA TOL / 5D-6,9D-12 / #if !defined(CERNLIB_VAX) DATA ((X(K,J),TAU(K,J),TP0(K,J),TP1(K,J),J=1,7),K=1,2) #endif #if defined(CERNLIB_VAX) DATA ((X(K,J),TAU(K,J),TP0(K,J),TP1(K,J),J=1,5),K=1,2) #endif +/-0.85D0, 0.0D0, 0.172792365589726D+01, 0.106348504438122D+01, + -0.85D0, 0.1D0, 0.176055579795247D+01, 0.111428492723234D+01, + -0.85D0, 3.0D0, 0.708076720354774D+03, 0.262015377817868D+04, + -0.85D0, 15.0D0, 0.995351051386203D+16, 0.157061271647300D+18, + -0.85D0, 18.0D0, 0.213559166310321D+20, 0.401143223315723D+21, #if !defined(CERNLIB_VAX) + -0.85D0, 30.0D0, 0.502882282799443D+33, 0.154850067002561D+35, + -0.85D0, 50.0D0, 0.114853555724960D+56, 0.583433672092147D+57, #endif + 0.05D0, 0.0D0, 0.116721346104925D+01, 0.255324173328592D+00, + 0.05D0, 0.1D0, 0.117416110457565D+01, 0.266284488007617D+00, + 0.05D0, 3.0D0, 0.223002372256560D+02, 0.653083675516493D+02, + 0.05D0, 15.0D0, 0.832539896514758D+09, 0.124602625334050D+11, + 0.05D0, 18.0D0, 0.728014608715714D+11, 0.130809483546260D+13 #if !defined(CERNLIB_VAX) + ,0.05D0, 30.0D0, 0.474978510888165D+19, 0.142354773848121D+21, + 0.05D0, 50.0D0, 0.595637227483640D+32, 0.297654571351601D+34 #endif + / DATA ((X(K,J),TAU(K,J),TP0(K,J),TP1(K,J),J=1,7),K=3,4) +/ 0.15D0, 0.0D0, 0.114290227541689D+01, 0.228721183160561D+00, + 0.15D0, 0.1D0, 0.114881070198791D+01, 0.238456190469288D+00, + 0.15D0, 3.0D0, 0.166570294809630D+02, 0.478811235368669D+02, + 0.15D0, 15.0D0, 0.185339345854915D+09, 0.276443022458954D+10, + 0.15D0, 18.0D0, 0.119850157932402D+11, 0.214735095475346D+12, + 0.15D0, 30.0D0, 0.233906368434292D+18, 0.699844455934608D+19, + 0.15D0, 50.0D0, 0.392583542498121D+30, 0.195983890802043D+32, + 0.50D0, 0.0D0, 0.107318200714937D+01, 0.149336210855378D+00, + 0.50D0, 0.1D0, 0.107616218472410D+01, 0.155520072675137D+00, + 0.50D0, 3.0D0, 0.594747030548720D+01, 0.156513798367978D+02, + 0.50D0, 15.0D0, 0.738310469096391D+06, 0.108529607763471D+08, + 0.50D0, 18.0D0, 0.155820278247129D+08, 0.275828912884288D+09, + 0.50D0, 30.0D0, 0.345488450377325D+13, 0.102629608073766D+15, + 0.50D0, 50.0D0, 0.333355145696150D+22, 0.165704014290283D+24/ DATA ((X(K,J),TAU(K,J),TP0(K,J),TP1(K,J),J=1,7),K=5,6) +/ 1.25D0, 0.0D0, 0.970773111746025D+00,-0.820885921881589D-01, + 1.25D0, 0.1D0, 0.969613109761301D+00,-0.853206241123639D-01, + 1.25D0, 3.0D0, 0.176601420188522D+00,-0.166005261400180D+01, + 1.25D0, 15.0D0,-0.234210486318489D+00, 0.810019610436777D+00, + 1.25D0, 18.0D0, 0.137196910943607D+00, 0.291605592654195D+01, + 1.25D0, 30.0D0, 0.683151098249044D-01,-0.466870444518395D+01, + 1.25D0, 50.0D0,-0.100507196976784D+00,-0.406190239059643D+01, + 2.00D0, 0.0D0, 0.901286299360454D+00,-0.136668749688719D+00, + 2.00D0, 0.1D0, 0.897446734802733D+00,-0.141822463184673D+00, + 2.00D0, 3.0D0,-0.349226063814295D+00, 0.175152750423642D+00, + 2.00D0, 15.0D0, 0.155579039937278D+00,-0.347105321195284D+00, + 2.00D0, 18.0D0,-0.864871081507048D-01, 0.209751593671441D+01, + 2.00D0, 30.0D0, 0.579838395893315D-01,-0.286205918205584D+01, + 2.00D0, 50.0D0,-0.523610425906931D-01,-0.336440002503789D+01/ DATA ((X(K,J),TAU(K,J),TP0(K,J),TP1(K,J),J=1,7),K=7,8) +/ 50.0D0, 0.0D0, 0.381449133325901D+00,-0.127073707441687D+00, + 50.0D0, 0.1D0, 0.363601410956604D+00,-0.128301173299577D+00, + 50.0D0, 3.0D0, 0.594490895999762D-01,-0.109711149219891D+00, + 50.0D0, 15.0D0, 0.196056487310569D-01, 0.313519074062231D+00, + 50.0D0, 18.0D0, 0.243140192068021D-01,-0.206296938327517D+00, + 50.0D0, 30.0D0, 0.133243263206639D-01, 0.464785737940045D+00, + 50.0D0, 50.0D0,-0.158259704464400D-01, 0.110840613233526D+00, + 100.0D0, 0.0D0, 0.300917485881994D+00,-0.105445282031567D+00, + 100.0D0, 0.1D0, 0.282683425153849D+00,-0.105377693918764D+00, + 100.0D0, 3.0D0,-0.369404429618043D-01,-0.641011401326534D-01, + 100.0D0, 15.0D0,-0.203978275371718D-01, 0.535777344182317D-01, + 100.0D0, 18.0D0, 0.177972587583743D-01,-0.118319097830749D+00, + 100.0D0, 30.0D0, 0.687164390187623D-02,-0.388790301110631D+00, + 100.0D0, 50.0D0, 0.109793204340196D-01,-0.135728594318267D+00/ DATA ((X(K,J),TAU(K,J),TP0(K,J),TP1(K,J),J=1,7),K=9,9) +/500.0D0, 0.0D0, 0.166973293482238D+00,-0.633550202215359D-01, + 500.0D0, 0.1D0, 0.150559960772726D+00,-0.614291013330736D-01, + 500.0D0, 3.0D0, 0.103141322981132D-01,-0.586574917691987D-01, + 500.0D0, 15.0D0,-0.608071088154388D-02,-0.100782787587720D+00, + 500.0D0, 18.0D0,-0.436499253685024D-02, 0.131585490808197D+00, + 500.0D0, 30.0D0, 0.403912746341894D-02, 0.151323730560296D+00, + 500.0D0, 50.0D0, 0.283023423292637D-02, 0.207478489416956D+00/ CALL HEADER('C331',0) LTEST=.TRUE. C C--- Number of functions to test #if defined(CERNLIB_DOUBLE) NF=1 #endif #if !defined(CERNLIB_DOUBLE) NF=2 #endif C DO 200 JF=NF,2 ERRMAX=0D0 DO 1 IX = 1,9 IF(IX .EQ. 1 .OR. IX .EQ. 7) WRITE(LOUT,100) DO 1 IT = 1,7 C****** because of FCONC and IEEE ranges for single precision #if defined(CERNLIB_QIEEE) IF ( JF.EQ.1 .AND. IX.LE.2 .AND. IT.GE.6 ) GOTO 1 #endif #if defined(CERNLIB_VAX) IF ( IX.LE.2 .AND. IT.GE.6 ) GOTO 1 #endif #if defined(CERNLIB_DOUBLE) IF(JF.EQ.1) THEN RP0= FCONC(SNGL(X(IX,IT)),SNGL(TAU(IX,IT)),0) RP1= FCONC(SNGL(X(IX,IT)),SNGL(TAU(IX,IT)),1) ERRMAX= MAX (SNGL(ERRMAX),ABS((RP0-SNGL(TP0(IX,IT)))/RP0), + ABS((RP1-SNGL(TP1(IX,IT)))/RP1)) WRITE(LOUT,'(1X,F10.2,F10.1,2D26.15,1P,2D10.1)') 1 X(IX,IT),TAU(IX,IT),RP0,RP1,ABS((RP0-TP0(IX,IT))/RP0), 2 ABS((RP1-TP1(IX,IT))/RP1) ENDIF IF(JF.EQ.2) THEN P0=DFCONC(X(IX,IT),TAU(IX,IT),0) P1=DFCONC(X(IX,IT),TAU(IX,IT),1) ERRMAX= MAX (ERRMAX,ABS((P0-TP0(IX,IT))/P0), + ABS((P1-TP1(IX,IT))/P1)) WRITE(LOUT,'(1X,F10.2,F10.1,2D26.15,1P,2D10.1)') 1 X(IX,IT),TAU(IX,IT),P0,P1,ABS((P0-TP0(IX,IT))/P0), 2 ABS((P1-TP1(IX,IT))/P1) ENDIF #endif #if !defined(CERNLIB_DOUBLE) P0= FCONC(X(IX,IT),TAU(IX,IT),0) P1= FCONC(X(IX,IT),TAU(IX,IT),1) ERRMAX= MAX (ERRMAX,ABS(( P0-TP0(IX,IT))/ P0), + ABS(( P1-TP1(IX,IT))/ P1)) WRITE(LOUT,'(1X,F10.2,F10.1,2D26.15,1P,2D10.1)') 1 X(IX,IT),TAU(IX,IT),P0,P1,ABS((P0-TP0(IX,IT))/P0), 2 ABS((P1-TP1(IX,IT))/P1) #endif 1 CONTINUE #if !defined(CERNLIB_DOUBLE) WRITE(LOUT,'(/'' Largest Error was'',1P,D10.1)') ERRMAX #endif #if defined(CERNLIB_DOUBLE) IF(JF.EQ.1) +WRITE(LOUT,'(/'' FCONC Largest Error was'',1P,D10.1)') ERRMAX IF(JF.EQ.2) +WRITE(LOUT,'(''DFCONC Largest Error was'',1P,D10.1/)') ERRMAX #endif LTEST=LTEST.AND.(ERRMAX.LE.TOL(JF)) 200 CONTINUE WRITE(LOUT,'(/''TESTING ERROR MESSAGES:''/)') #if defined(CERNLIB_DOUBLE) P0=DFCONC(X(1,1),TAU(1,1),-1) RP0= FCONC(SNGL(X(1,1)),SNGL(TAU(1,1)),-1) P0=DFCONC(-1+1D-6,TAU(1,5),1) RP0= FCONC(-1+1E-6,SNGL(TAU(1,5)),1) #endif #if !defined(CERNLIB_DOUBLE) P0= FCONC(X(1,1),TAU(1,1),-1) P0= FCONC(-1+1E-6,TAU(1,5),1) #endif 100 FORMAT(/1X,8X,'X',7X,'TAU',14X,'P',28X,'P1',15X,'Error'/) WRITE(LOUT,'(1X)') IRC=ITEST('C331',LTEST) CALL PAGEND('C331') RETURN END