PROGRAM TEST C C David M. Smith 6-14-96 C C This is a test program for ZMLIB 1.1, a multiple-precision complex C arithmetic package. Most of the ZM routines are tested, and the C results are checked to 50 significant digits. C C This program uses both ZMLIB.f and FMLIB.f. C C These five common blocks contain information that must be saved C between calls, so they should be declared in the main program. C The parameter statement defines array sizes and pointers, and C contains the FMLIB parameters, followed by ZMLIB parameters. C C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C INTEGER JFORMZ,JPRNTZ C COMMON /ZMUSER/ JFORMZ,JPRNTZ C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C C Declare arrays for ZM complex variables (MA, MB, MC, MD) C and for FM real variables (MAFM, MBFM). All are in C unpacked format. C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ), * MD(0:LUNPKZ),MAFM(0:LUNPCK),MBFM(0:LUNPCK) C C Character strings used for input and output. C CHARACTER *160 ST1,ST2 INTEGER KLOG,NCASE,NERROR C C Set precision to give at least 50 significant digits C and initialize the FMLIB package. C CALL ZMSET(50) C C Write output to the standard FM output (unit KW, defined C in subroutine FMSET), and also to the file TESTZM.LOG. C KLOG = 18 OPEN (KLOG,FILE='TESTZM.LOG') C C NERROR is the number of errors found. C NCASE is the number of cases tested. C NERROR = 0 C C Test input and output conversion. C CALL TEST1(MA,MB,MC,MD,MAFM,MBFM,ST1,ST2,NCASE,NERROR,KLOG) C C Test add and subtract. C CALL TEST2(MA,MB,MC,MD,MAFM,MBFM,ST1,ST2,NCASE,NERROR,KLOG) C C Test multiply, divide and square root. C CALL TEST3(MA,MB,MC,MD,MAFM,MBFM,ST1,ST2,NCASE,NERROR,KLOG) C C Test exponentials. C CALL TEST4(MA,MB,MC,MD,MAFM,MBFM,ST1,ST2,NCASE,NERROR,KLOG) C C Test logarithms. C CALL TEST5(MA,MB,MC,MD,MAFM,MBFM,ST1,ST2,NCASE,NERROR,KLOG) C C Test trigonometric functions. C CALL TEST6(MA,MB,MC,MD,MAFM,MBFM,ST1,ST2,NCASE,NERROR,KLOG) C C Test inverse trigonometric functions. C CALL TEST7(MA,MB,MC,MD,MAFM,MBFM,ST1,ST2,NCASE,NERROR,KLOG) C C Test hyperbolic functions. C CALL TEST8(MA,MB,MC,MD,MAFM,MBFM,ST1,ST2,NCASE,NERROR,KLOG) C C End of tests. C IF (NERROR.EQ.0) THEN WRITE (KW,110) NCASE WRITE (KLOG,110) NCASE 110 FORMAT(///1X,I5,' cases tested. No errors were found.'/) ELSE C C Write some of the initialized values in common. C WRITE (KLOG,*)' NDIG,MBASE,JFORM1,JFORM2,KRAD = ' WRITE (KLOG,*) NDIG,MBASE,JFORM1,JFORM2,KRAD WRITE (KLOG,*)' KW,NTRACE,LVLTRC,KFLAG,KWARN,KROUND = ' WRITE (KLOG,*) KW,NTRACE,LVLTRC,KFLAG,KWARN,KROUND WRITE (KLOG,*)' NCALL,MXEXP,MXEXP2,KACCSW,MEXPUN,MEXPOV' WRITE (KLOG,*) NCALL,MXEXP,MXEXP2,KACCSW,MEXPUN,MEXPOV WRITE (KLOG,*)' MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX = ' WRITE (KLOG,*) MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX WRITE (KLOG,*)' MAXINT,INTMAX,SPMAX,DPMAX = ' WRITE (KLOG,*) MAXINT,INTMAX,SPMAX,DPMAX WRITE (KLOG,*)' ALOGMB,ALOGM2,ALOGMX,ALOGMT,DLOGMB,DLOGTN =' WRITE (KLOG,*) ALOGMB,ALOGM2,ALOGMX,ALOGMT,DLOGMB,DLOGTN WRITE (KLOG,*)' DLOGTW,DLOGTP,DLOGPI,DPPI =' WRITE (KLOG,*) DLOGTW,DLOGTP,DLOGPI,DPPI WRITE (KLOG,*)' DPEPS,DLOGEB =' WRITE (KLOG,*) DPEPS,DLOGEB C WRITE (KW,120) NCASE,NERROR WRITE (KLOG,120) NCASE,NERROR 120 FORMAT(///1X,I5,' cases tested.',I4,' error(s) found.'/) ENDIF WRITE (KW,*)' End of run.' C STOP END SUBROUTINE TEST1(MA,MB,MC,MD,MAFM,MBFM,ST1,ST2,NCASE,NERROR,KLOG) C C Input and output testing. C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ), * MD(0:LUNPKZ),MAFM(0:LUNPCK),MBFM(0:LUNPCK) C C Logical function for comparing FM numbers. C LOGICAL FMCOMP C CHARACTER *160 ST1,ST2 INTEGER KLOG,NCASE,NERROR C WRITE (KW,110) 110 FORMAT(/' Testing input and output routines.') C NCASE = 1 CALL ZMST2M('123 + 456 i',MA) CALL ZM2I2M(123,456,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-48,MBFM) C C Use the .NOT. because FMCOMP returns FALSE for special C cases like MD = UNKNOWN, and these should be treated C as errors for these tests. C IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMST2M',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 2 ST1 = '0.3505154639175257731958762886597938144329896907216495 + ' * // '0.7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(ST1,MA) CALL ZM2I2M(34,71,MC) CALL ZMDIVI(MC,97,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-50,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMST2M',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 3 ST1 = '0.3505154639175257731958762886597938144329896907216495E-5 ' * //'+ 0.7319587628865979381443298969072164948453608247422680D-5 i' CALL ZMST2M(ST1,MA) CALL ZM2I2M(34,71,MC) CALL ZMDIVI(MC,9700000,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-55,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMST2M',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 4 ST1 = '7.699115044247787610619469026548672566371681415929204e 03 ' * //'- 5.221238938053097345132743362831858407079646017699115M 03 I' CALL ZMST2M(ST1,MA) CALL ZM2I2M(87,-59,MC) CALL ZMDIVI(MC,113,MC) CALL ZMMPYI(MC,10000,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-47,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMST2M',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 5 ST1 = '7.699115044247787610619469026548672566371681415929204e+3 ' * //'- 5.221238938053097345132743362831858407079646017699115M+3 i' CALL ZMST2M(ST1,MA) CALL ZMFORM('F53.33','F50.30',MA,ST2) CALL ZMST2M(ST2,MA) ST1 = '7699.115044247787610619469026548673 ' * // '-5221.238938053097345132743362831858 i' CALL ZMST2M(ST1,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-30,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMFORM',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 6 ST1 = '7.699115044247787610619469026548672566371681415929204e+3 ' * //'- 5.221238938053097345132743362831858407079646017699115M+3 i' CALL ZMST2M(ST1,MA) CALL ZMFORM('I9','I7',MA,ST2) CALL ZMST2M(ST2,MA) ST1 = '7699 -5221 i' CALL ZMST2M(ST1,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(0,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMFORM',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 7 ST1 = '7.699115044247787610619469026548672566371681415929204e+3 ' * //'- 5.221238938053097345132743362831858407079646017699115M+3 i' CALL ZMST2M(ST1,MA) CALL ZMFORM('E59.50','E58.49',MA,ST2) CALL ZMST2M(ST2,MA) ST1 = '7.6991150442477876106194690265486725663716814159292E3' * //'- 5.221238938053097345132743362831858407079646017699E3 i' CALL ZMST2M(ST1,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-48,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMFORM',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 8 ST1 = '7.699115044247787610619469026548672566371681415929204e+3 ' * //'- 5.221238938053097345132743362831858407079646017699115M+3 i' CALL ZMST2M(ST1,MA) CALL ZMFORM('1PE59.50','1PE58.49',MA,ST2) CALL ZMST2M(ST2,MA) CALL ZMST2M(ST1,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-44,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMFORM',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C RETURN END SUBROUTINE TEST2(MA,MB,MC,MD,MAFM,MBFM,ST1,ST2,NCASE,NERROR,KLOG) C C Test add and subtract. C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ), * MD(0:LUNPKZ),MAFM(0:LUNPCK),MBFM(0:LUNPCK) C LOGICAL FMCOMP C CHARACTER *160 ST1,ST2 INTEGER KLOG,NCASE,NERROR C WRITE (KW,110) 110 FORMAT(/' Testing add and subtract routines.') C NCASE = 9 CALL ZMST2M('123 + 456 i',MA) CALL ZMST2M('789 - 543 i',MB) CALL ZMADD(MA,MB,MA) CALL ZM2I2M(912,-87,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(0,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMADD ',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 10 ST1 = '.7699115044247787610619469026548672566371681415929204 ' * //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) ST1 = '.3505154639175257731958762886597938144329896907216495 ' * //'+ .7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(ST1,MB) CALL ZMADD(MA,MB,MA) ST2 = '1.1204269683423045342578231913146610710701578323145698 ' * //'+ 0.2098348690812882036310555606240306541373962229723565 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-49,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMADD ',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 11 ST1 = '.7699115044247787610619469026548672566371681415929204 ' * //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) ST1 = '.3505154639175257731958762886597938144329896907216495 ' * //'+ .7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(ST1,MB) CALL ZMSUB(MA,MB,MA) ST2 = '0.4193960405072529878660706139950734422041784508712709 ' * //'- 1.2540826566919076726576042331904023355533254265121795 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-49,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMSUB ',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 12 ST1 = '.7699115044247787610619469026548672566371681415929204E3 ' * //'- .5221238938053097345132743362831858407079646017699115E3 i' CALL ZMST2M(ST1,MA) ST1 = '.3505154639175257731958762886597938144329896907216495 ' * //'+ .7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(ST1,MB) CALL ZMSUB(MA,MB,MA) ST2 = '769.5609889608612352887510263662074628227351519021987045 ' * //'- 522.8558525681963324514186661800930572028099625946537725 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-47,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMSUB ',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C RETURN END SUBROUTINE TEST3(MA,MB,MC,MD,MAFM,MBFM,ST1,ST2,NCASE,NERROR,KLOG) C C Test multiply, divide and square root. C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ), * MD(0:LUNPKZ),MAFM(0:LUNPCK),MBFM(0:LUNPCK) C LOGICAL FMCOMP C CHARACTER *160 ST1,ST2 INTEGER KLOG,NCASE,NERROR C WRITE (KW,110) 110 FORMAT(/' Testing multiply, divide and square root routines.') C NCASE = 13 CALL ZMST2M('123 + 456 i',MA) CALL ZMST2M('789 - 543 i',MB) CALL ZMMPY(MA,MB,MA) CALL ZM2I2M(344655,292995,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(0,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMMPY ',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 14 ST1 = '.7699115044247787610619469026548672566371681415929204 ' * //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) ST1 = '.3505154639175257731958762886597938144329896907216495 ' * //'+ .7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(ST1,MB) CALL ZMMPY(MA,MB,MA) ST2 = '0.6520390475321594745005017790347596022260742632971444 ' * //'+ 0.3805309734513274336283185840707964601769911504424779 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-50,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMMPY ',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 15 ST1 = '.7699115044247787610619469026548672566371681415929204 ' * //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) ST1 = '.3505154639175257731958762886597938144329896907216495 ' * //'+ .7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(ST1,MB) CALL ZMDIV(MA,MB,MA) ST2 = '-.1705178497731560089737969128653459210208765017614861 ' * //'- 1.1335073636829696356072949942949842987114804337239972 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-49,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMDIV ',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 16 ST1 = '.7699115044247787610619469026548672566371681415929204 ' * //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMMPYI(MA,36,MA) ST2 = '27.7168141592920353982300884955752212389380530973451327 ' * //'- 18.7964601769911504424778761061946902654867256637168142 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-48,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMMPYI',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 17 ST1 = '.7699115044247787610619469026548672566371681415929204 ' * //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMDIVI(MA,37,MA) ST2 = '2.080841903850753408275532169337479071992346328629514E-2 ' * //'- 1.411145658933269552738579287251853623535039464243004E-2 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-52,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMDIVI',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 18 ST1 = '.7699115044247787610619469026548672566371681415929204 ' * //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMSQR(MA,MA) ST2 = '0.3201503641632077688150990680554467851828647505677813 ' * //'- 0.8039783851515388832328295089670295246299631921058814 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-50,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMSQR ',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 19 ST1 = '.7699115044247787610619469026548672566371681415929204 ' * //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMSQRT(MA,MA) ST2 = '0.9219999909012323458336720551458583330580388434229845 ' * //'- 0.2831474506279259570386845864488094697732718981999941 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-50,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMSQRT',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C RETURN END SUBROUTINE TEST4(MA,MB,MC,MD,MAFM,MBFM,ST1,ST2,NCASE,NERROR,KLOG) C C Test exponentials. C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ), * MD(0:LUNPKZ),MAFM(0:LUNPCK),MBFM(0:LUNPCK) C LOGICAL FMCOMP C CHARACTER *160 ST1,ST2 INTEGER KLOG,NCASE,NERROR C WRITE (KW,110) 110 FORMAT(/' Testing exponential routines.') C NCASE = 20 ST1 = '.7699115044247787610619469026548672566371681415929204 ' * //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMEXP(MA,MA) ST2 = '1.8718374504057787925867989348073888855260008469310002 ' * //'- 1.0770279996847678711699041910427261417963102075889234 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-49,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMEXP ',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 21 ST1 = '5.7699115044247787610619469026548672566371681415929204 ' * //'- 4.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMEXP(MA,MA) ST2 = '-60.6144766542152809520229386164396710991242264070603612 ' * //'+ 314.7254994809539691403004121118801578835669635535466592 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-47,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMEXP ',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 22 ST1 = '1.7699115044247787610619469026548672566371681415929204 ' * //'- 1.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMIPWR(MA,45,MA) ST2 = '31595668743300099.70429472191424818167262151605608585179 ' * //'- 19209634448276799.67717448173630165852744930837930753788 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-33,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMIPWR',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 23 ST1 = '1.7699115044247787610619469026548672566371681415929204 ' * //'- 1.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMIPWR(MA,-122,MA) ST2 = '3.1000215641022021714480000129414241564868699479432E-46 ' * //'- 1.1687846789859477815450163510927243367234863123667E-45 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-93,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMIPWR',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 24 ST1 = '.7699115044247787610619469026548672566371681415929204 ' * //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) ST1 = '.3505154639175257731958762886597938144329896907216495 ' * //'+ .7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(ST1,MB) CALL ZMPWR(MA,MB,MA) ST2 = '1.4567089343012352449621841355636496276866203747888724 ' * //'- 0.3903177712261966292764255714390622205129978923650749 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-49,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMPWR ',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 25 ST1 = '.3505154639175257731958762886597938144329896907216495 ' * //'+ .7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(ST1,MA) ST1 = '2.7699115044247787610619469026548672566371681415929204 ' * //'- 0.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MB) CALL ZMPWR(MA,MB,MA) ST2 = '-1.0053105716678380336247948739245187868180079734997482 ' * // '- 0.0819537653234704467729051473979237153087038930127116 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-49,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMPWR ',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 26 ST1 = '0.7699115044247787610619469026548672566371681415929204 ' * //'- 0.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMRPWR(MA,2,7,MA) ST2 = '0.9653921326136512316639621651337975772631340364271270 ' * //'- 0.1659768285667051396562270035411852432430188906482848 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-50,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMRPWR',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 27 ST1 = '0.7699115044247787610619469026548672566371681415929204 ' * //'- 0.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMRPWR(MA,-19,7,MA) ST2 = '-0.0567985880053556315170006800325686036902111276420647 ' * // '+ 1.2154793972711356706410882510363594270389067962568571 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-49,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMRPWR',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C RETURN END SUBROUTINE TEST5(MA,MB,MC,MD,MAFM,MBFM,ST1,ST2,NCASE,NERROR,KLOG) C C Test logarithms. C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ), * MD(0:LUNPKZ),MAFM(0:LUNPCK),MBFM(0:LUNPCK) C LOGICAL FMCOMP C CHARACTER *160 ST1,ST2 INTEGER KLOG,NCASE,NERROR C WRITE (KW,110) 110 FORMAT(/' Testing logarithm routines.') C NCASE = 28 ST1 = '.7699115044247787610619469026548672566371681415929204 ' * //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMLN(MA,MA) ST2 = '-0.0722949652393911311212450699415231782692434885813725 ' * //'- 0.5959180055163009910007765127008371205749515965219804 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-50,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMLN ',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 29 ST1 = '.7699115044247787610619469026548672566371681415929204E28 ' * //'- .5221238938053097345132743362831858407079646017699115E28 i' CALL ZMST2M(ST1,MA) CALL ZMLN(MA,MA) ST2 = '64.4000876385938880213825156612206746345615981930242708 ' * //'- 0.5959180055163009910007765127008371205749515965219804 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-48,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMLN ',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 30 ST1 = '.7699115044247787610619469026548672566371681415929204 ' * //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMLG10(MA,MA) ST2 = '-0.0313973044728549715287589498363619677438302809470943 ' * //'- 0.2588039014625211035392823012785304771809982053965284 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-50,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMLG10',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 31 ST1 = '.7699115044247787610619469026548672566371681415929204E82 ' * //'- .5221238938053097345132743362831858407079646017699115E82 i' CALL ZMST2M(ST1,MA) CALL ZMLG10(MA,MA) ST2 = '81.9686026955271450284712410501636380322561697190529057 ' * //'- 0.2588039014625211035392823012785304771809982053965284 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-48,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMLG10',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C RETURN END SUBROUTINE TEST6(MA,MB,MC,MD,MAFM,MBFM,ST1,ST2,NCASE,NERROR,KLOG) C C Test trigonometric functions. C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ), * MD(0:LUNPKZ),MAFM(0:LUNPCK),MBFM(0:LUNPCK) C LOGICAL FMCOMP C CHARACTER *160 ST1,ST2 INTEGER KLOG,NCASE,NERROR C WRITE (KW,110) 110 FORMAT(/' Testing trigonometric routines.') C NCASE = 32 ST1 = '.7699115044247787610619469026548672566371681415929204 ' * //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMCOS(MA,MA) ST2 = '0.8180802525254482451348613286211514555816444253416895 ' * //'+ 0.3801751200076938035500853542125525088505055292851393 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-50,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMCOS ',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 33 ST1 = '34.7699115044247787610619469026548672566371681415929204 ' * //'- 42.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMCOS(MA,MA) ST2 = '-1432925478410268113.5816466154230974355002592549420099 ' * //'- 309002816679456015.00151246245263842483282458519462258 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-31,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMCOS ',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 34 ST1 = '.7699115044247787610619469026548672566371681415929204 ' * //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMSIN(MA,MA) ST2 = '0.7931260548991613428648822413402447097755865697557818 ' * //'- 0.3921366045897070762848927655743167937790944353110710 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-50,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMSIN ',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 35 ST1 = '34.7699115044247787610619469026548672566371681415929204 ' * //'- 42.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMSIN(MA,MA) ST2 = '-3.090028166794560150015124624526384249047272360765358E17 ' * //'+ 1.432925478410268113581646615423097435166828182950161E18 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-31,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMSIN ',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 36 ST1 = '.7699115044247787610619469026548672566371681415929204 ' * //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMTAN(MA,MA) ST2 = '0.6141156219447569167198437040270236055089243090199979 ' * //'- 0.7647270337230070156308196055474639461102792169274526 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-50,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMTAN ',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 37 ST1 = '35.7699115044247787610619469026548672566371681415929204 ' * //'- 43.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMTAN(MA,MA) ST2 = '2.068934241218867332441292427642153175237611151321340E-38 ' * //'- 1.000000000000000000000000000000000000023741659169354 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-49,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMTAN ',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 38 ST1 = '0.3505154639175257731958762886597938144329896907216495 ' * //'+ 0.7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(ST1,MA) CALL ZMCSSN(MA,MA,MC) ST2 = '1.2022247452809115256533054407001508718694617802593324 ' * //'- 0.2743936538120352873902095801531325075994392065668943 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-49,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMCSSN',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 39 ST1 = '0.3505154639175257731958762886597938144329896907216495 ' * //'+ 0.7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(ST1,MA) CALL ZMCSSN(MA,MC,MA) ST2 = '0.4395486978082638069281369170831952476351663772871008 ' * //'+ 0.7505035100906417134864779281080728222900154610025883 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-50,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMCSSN',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C RETURN END SUBROUTINE TEST7(MA,MB,MC,MD,MAFM,MBFM,ST1,ST2,NCASE,NERROR,KLOG) C C Test inverse trigonometric functions. C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ), * MD(0:LUNPKZ),MAFM(0:LUNPCK),MBFM(0:LUNPCK) C LOGICAL FMCOMP C CHARACTER *160 ST1,ST2 INTEGER KLOG,NCASE,NERROR C WRITE (KW,110) 110 FORMAT(/' Testing inverse trigonometric routines.') C NCASE = 40 ST1 = '.7699115044247787610619469026548672566371681415929204 ' * //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMACOS(MA,MA) ST2 = '0.8797127900868121872960714368309657795959216549012347 ' * //'+ 0.6342141347945396859119941874681961111936156338608130 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-50,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMACOS',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 41 ST1 = '.7699115044247787610619469026548672566371681415929204E12 ' * //'- .5221238938053097345132743362831858407079646017699115E12 i' CALL ZMST2M(ST1,MA) CALL ZMACOS(MA,MA) ST2 = '0.5959180055163009910007767810953294528367807973983794 ' * //'+28.2518733312491023865118844008522768856672089946951468 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-48,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMACOS',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 42 ST1 = '.7699115044247787610619469026548672566371681415929204 ' * //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMASIN(MA,MA) ST2 = '0.6910835367080844319352502548087856625026630447863182 ' * //'- 0.6342141347945396859119941874681961111936156338608130 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-50,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMASIN',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 43 ST1 = '.7699115044247787610619469026548672566371681415929204E13 ' * //'- .5221238938053097345132743362831858407079646017699115E13 i' CALL ZMST2M(ST1,MA) CALL ZMASIN(MA,MA) ST2 = '0.9748783212785956282305451762549693982010148111568094 ' * //'-30.5544584242431480705298759613446206186670533428066404 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-48,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMASIN',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 44 ST1 = '.7699115044247787610619469026548672566371681415929204 ' * //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMATAN(MA,MA) ST2 = '0.7417952692265900376512911713942700568648670953521258 ' * //'- 0.3162747143126729004878357203292329539837025170484857 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-50,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMATAN',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 45 ST1 = '.7699115044247787610619469026548672566371681415929204E13 ' * //'- .5221238938053097345132743362831858407079646017699115E13 i' CALL ZMST2M(ST1,MA) CALL ZMATAN(MA,MA) ST2 = ' 1.570796326794807650905529836436131532596233124329403 ' * //'-6.033484162895927601809954710695221401671437742867605E-14 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-49,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMATAN',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C RETURN END SUBROUTINE TEST8(MA,MB,MC,MD,MAFM,MBFM,ST1,ST2,NCASE,NERROR,KLOG) C C Test hyperbolic functions. C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ), * MD(0:LUNPKZ),MAFM(0:LUNPCK),MBFM(0:LUNPCK) C LOGICAL FMCOMP C CHARACTER *160 ST1,ST2 INTEGER KLOG,NCASE,NERROR C WRITE (KW,110) 110 FORMAT(/' Testing hyperbolic routines.') C NCASE = 46 ST1 = '.7699115044247787610619469026548672566371681415929204 ' * //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMCOSH(MA,MA) ST2 = '1.1365975275870879962259716562608779977957563621412079 ' * //'- 0.4230463404769118342540441830446134405410543954181579 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-49,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMCOSH',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 47 ST1 = '34.7699115044247787610619469026548672566371681415929204 ' * //'- 42.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMCOSH(MA,MA) ST2 = '69552104658681.7558589320148420094288419217262200765435 ' * //'+ 626163773308016.884007302915197616300902876551542156676 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-35,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMCOSH',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 48 ST1 = '.7699115044247787610619469026548672566371681415929204 ' * //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMSINH(MA,MA) ST2 = '0.7352399228186907963608272785465108877302444847897922 ' * //'- 0.6539816592078560369158600079981127012552558121707655 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-50,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMSINH',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 49 ST1 = '34.7699115044247787610619469026548672566371681415929204 ' * //'- 42.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMSINH(MA,MA) ST2 = '6.955210465868175585893201484192181376093291191637290E 13 ' * //'+ 6.261637733080168840073029151984050820616907795167046E 14 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-35,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMSINH',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 50 ST1 = '.7699115044247787610619469026548672566371681415929204 ' * //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMTANH(MA,MA) ST2 = '0.7562684782933185240709480231996041186654551038993505 ' * //'- 0.2938991498221693198532255749292372853685311106820169 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-50,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMTANH',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 51 ST1 = '35.7699115044247787610619469026548672566371681415929204 ' * //'- 43.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(ST1,MA) CALL ZMTANH(MA,MA) ST2 = '9.999999999999999999999999999998967653135180689424497E-01 ' * //'+ 1.356718776492102400812550018433337461876455254467192E-31 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-50,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMTANH',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 52 ST1 = '0.3505154639175257731958762886597938144329896907216495 ' * //'+ 0.7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(ST1,MA) CALL ZMCHSH(MA,MA,MC) ST2 = '0.7900326499280864816444807620997665088044412803737969 ' * //'+ 0.2390857359988804105051429301542214823277594407302781 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-50,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMCHSH',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C NCASE = 53 ST1 = '0.3505154639175257731958762886597938144329896907216495 ' * //'+ 0.7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(ST1,MA) CALL ZMCHSH(MA,MC,MA) ST2 = '0.2661087555034471983220879532235334422670297141428191 ' * //'+ 0.7098057980612199357870532628105009808447460332437714 i' CALL ZMST2M(ST2,MC) CALL ZMSUB(MA,MC,MD) CALL ZMABS(MD,MAFM) CALL FMI2M(10,MBFM) CALL FMIPWR(MBFM,-50,MBFM) IF (.NOT.FMCOMP(MAFM,'LE',MBFM)) THEN CALL ERRPRT('ZMCHSH',MA,'MA',MC,'MC',MD,'MD', * NCASE,NERROR,KLOG) ENDIF C RETURN END SUBROUTINE ERRPRT(NROUT,M1,NAME1,M2,NAME2,M3,NAME3, * NCASE,NERROR,KLOG) C C Print error messages. C C M1 is the value to be tested, as computed by the routine named NROUT. C M2 is the reference value, usually converted using ZMST2M. C M3 is ABS(M1-M2), and ERRPRT is called if this is too big. C NAME1,NAME2,NAME3 are strings identifying which variables in main C correspond to M1,M2,M3. C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION M1(0:LUNPKZ),M2(0:LUNPKZ),M3(0:LUNPKZ) C CHARACTER *2 NAME1,NAME2,NAME3 CHARACTER *6 NROUT INTEGER KLOG,KWSAVE,NCASE,NERROR C NERROR = NERROR + 1 WRITE (KW,110) NCASE,NROUT WRITE (KLOG,110) NCASE,NROUT 110 FORMAT(//' Error in case',I3,'. The routine', * ' being tested was ',A6) C C Temporarily change KW to KLOG so ZMPRNT C will write to the log file. C KWSAVE = KW KW = KLOG WRITE (KLOG,120) NAME1 120 FORMAT(1X,A2,' =') CALL ZMPRNT(M1) WRITE (KLOG,120) NAME2 CALL ZMPRNT(M2) WRITE (KLOG,120) NAME3 CALL ZMPRNT(M3) KW = KWSAVE RETURN END