*
* $Id$
*
* $Log$
* Revision 1.2  1997/02/04 17:36:57  mclareni
* Merge Winnt and 97a versions
*
* Revision 1.1.1.1.2.1  1997/01/21 11:32:21  mclareni
* All mods for Winnt 96a on winnt branch
*
* Revision 1.1.1.1  1996/02/15 17:48:44  mclareni
* Kernlib
*
*
#include "kernnumt/pilot.h"
          SUBROUTINE F003CH(NREP,LWORK,W,OK)
          REAL      W(LWORK)
          LOGICAL   OK, OKT
#include "kernnumt/sysdat.inc"
          OK  =  .TRUE.
          DO 100    JREP  =  1, NREP
             CALL TF003(LWORK,W,OKT)
             OK  =  OK .AND. OKT
 100         CONTINUE
          RETURN
          END
          SUBROUTINE TF003(LWORK,W,OK)
          DIMENSION           W(LWORK), HT(3)
#include "kernnumt/sysdat.inc"
#include "ch3dat.inc"
          LOGICAL             OK,       ROK,      DOK,      COK
          REAL                RZERO(1), RALPHA(1),RBETA(1)
          DOUBLE PRECISION    DZERO(1), DALPHA(1),DBETA(1)
          COMPLEX             CZERO(1), CALPHA(1),CBETA(1)
          DOUBLE PRECISION    DMBIL
          COMPLEX      CMBIL
          EXTERNAL  RMADD,    RMBIL,    RMCPY,    RMUTL,    RRSCL
          EXTERNAL  RMMNA,    RMMNS,    RMMPA,    RMMPS,    RMMPY
          EXTERNAL  RMRAN,    RMRANT,   RMSCL,    RMSET,    RMSUB
          EXTERNAL  RUMNA,    RUMNS,    RUMPA,    RUMPS,    RUMPY
          EXTERNAL  DMADD,    DMBIL,    DMCPY,    DMUTL,    DRSCL
          EXTERNAL  DMMNA,    DMMNS,    DMMPA,    DMMPS,    DMMPY
          EXTERNAL  DMRAN,    DMRANT,   DMSCL,    DMSET,    DMSUB
          EXTERNAL  DUMNA,    DUMNS,    DUMPA,    DUMPS,    DUMPY
          EXTERNAL  CMADD,    CMBIL,    CMCPY,    CMUTL,    CRSCL
          EXTERNAL  CMMNA,    CMMNS,    CMMPA,    CMMPS,    CMMPY
          EXTERNAL  CMRAN,    CMRANT,   CMSCL,    CMSET,    CMSUB
          EXTERNAL  CUMNA,    CUMNS,    CUMPA,    CUMPS,    CUMPY
          EXTERNAL  RMBILT,   RVADD,    RVDIST,   RVSET,    RVSUB
          EXTERNAL  RVCPY,    RVSCA,    RVSCL,    RVSCS,    RVMAXA
          EXTERNAL  DMBILT,   DVADD,    DVDIST,   DVSET,    DVSUB
          EXTERNAL  DVCPY,    DVSCA,    DVSCL,    DVSCS,    DVMAXA
          EXTERNAL  CMBILT,   CVADD,    CVDIST,   CVSET,    CVSUB
          EXTERNAL  CVCPY,    CVSCA,    CVSCL,    CVSCS,    CVMAXA
          CHARACTER*4         HT
          DATA      HT        /  'R   ', 'D   ', 'C  '  /
          DATA      RZERO     /  0.     /
          DATA      DZERO     /  0.D0   /
          DATA      CZERO     / (0.,0.) /
          DATA      RALPHA,   RBETA     /  -100.,   +100.       /
          DATA      DALPHA,   DBETA     /  -100.D0, +100.D0     /
          DATA      CALPHA,   CBETA     / (-100.,-100.),(+100.,+100.)/
          WRITE(IOUNIT,1001)
          HTYPE   =  HT(1)
          LENGTH  =  1
          TRELPR  =  RELPRT(1)
          LTAB    =  LTABT(1)
          CALL XF003(LWORK,W,RZERO,RALPHA,RBETA,ROK,
     +              RMADD,RMBILT,RMCPY,RMMNA,RMMNS,RMMPA,RMMPS,RMMPY,
     +              RMRAN,RMRANT,RMSCL,RMSET,RMSUB,RMUTL,RRSCL,
     +              RUMNA,RUMNS,RUMPA,RUMPS,RUMPY,RVMAXA,
     +              RVADD,RVCPY,RVDIST,RVSCA,RVSCL,RVSCS,RVSET,RVSUB)
          WRITE(IOUNIT,1002)
          HTYPE   =  HT(2)
          LENGTH  =  2
          TRELPR  =  RELPRT(2)
          LTAB    =  LTABT(2)
          CALL XF003(LWORK,W,DZERO,DALPHA,DBETA,DOK,
     +              DMADD,DMBILT,DMCPY,DMMNA,DMMNS,DMMPA,DMMPS,DMMPY,
     +              DMRAN,DMRANT,DMSCL,DMSET,DMSUB,DMUTL,DRSCL,
     +              DUMNA,DUMNS,DUMPA,DUMPS,DUMPY,DVMAXA,
     +              DVADD,DVCPY,DVDIST,DVSCA,DVSCL,DVSCS,DVSET,DVSUB)
          WRITE(IOUNIT,1003)
          HTYPE   =  HT(3)
          LENGTH  =  2
          TRELPR  =  RELPRT(1)
          LTAB    =  LTABT(3)
          CALL XF003(LWORK,W,CZERO,CALPHA,CBETA,COK,
     +              CMADD,CMBILT,CMCPY,CMMNA,CMMNS,CMMPA,CMMPS,CMMPY,
     +              CMRAN,CMRANT,CMSCL,CMSET,CMSUB,CMUTL,CRSCL,
     +              CUMNA,CUMNS,CUMPA,CUMPS,CUMPY,CVMAXA,
     +              CVADD,CVCPY,CVDIST,CVSCA,CVSCL,CVSCS,CVSET,CVSUB)
          OK  =  ROK .AND. DOK .AND. COK
  90      IF(.NOT. OK)  WRITE(IOUNIT,1004)
          IF(      OK)  WRITE(IOUNIT,1005)
          RETURN
1001      FORMAT(17H1F003.  TYPE = R. )
1002      FORMAT(17H1F003.  TYPE = D. )
1003      FORMAT(17H1F003.  TYPE = C. )
1004      FORMAT(/ 5X, 37H ????? TEST OF F003 HAS FAILED. ????? )
1005      FORMAT(/35X, 44HACCEPTANCE TEST OF F003 HAS BEEN SUCCESSFUL. )
          END
          SUBROUTINE XF003(LWORK,W,ZERO,ALPHA,BETA,OK,
     +              MADD,MBILT,MCPY,MMNA,MMNS,MMPA,MMPS,MMPY,
     +              MRAN,MRANT,MSCL,MSET,MSUB,MUTL,RSCL,
     +              UMNA,UMNS,UMPA,UMPS,UMPY,VMAXA,
     +              VADD,VCPY,VDIST,VSCA,VSCL,VSCS,VSET,VSUB)
          REAL      W(LWORK), ZERO(2), ALPHA(2), BETA(2)
          EXTERNAL  CMMPYC,   CCMMPY
          EXTERNAL  CUMPYC,   CCUMPY
          LOGICAL   OK, OKN, OKT
          DIMENSION HN(2,15), HNAME(2)
          CHARACTER*4    HN, HNAME
#include "kernnumt/sysdat.inc"
#include "ch3dat.inc"
          DATA      HN     /  'M   ', 'ADD ',
     +                        'M   ', 'BIL ',
     +                        'M   ', 'CPY ',
     +                        'M   ', 'MPY ',
     +                        'M   ', 'RAN ',
     +                        'M   ', 'SCL ',
     +                        'M   ', 'SET ',
     +                        'M   ', 'SUB ',
     +                        'M   ', 'UTL ',
     +                        'R   ', 'SCL ',
     +                        'U   ', 'MPY ',
     +                        'C   ', 'MMPY',
     +                        'M   ', 'MPYC',
     +                        'C   ', 'UMPY',
     +                        'U   ', 'MPYC'  /
          NDX2F(I,J)  =  ((J-1)*IDIM + I-1)*LENGTH + 1
          OK  =  .TRUE.
          LF   =  LWORK / 15
          LG   =  (LWORK - 6*LF) / 3
          LA   =  1
          LB   =  LA + LF
          LC   =  LB + LF
          LX   =  LC + LF
          LR   =  LX + LF
          LT   =  LR + LF
          LGA  =  LT + LF
          LGB  =  LGA + LG
          LGC  =  LGB + LG
          IRDIM  =  LG
          CALL RVSET(IRDIM,VOID(1),W(LGC),W(LGC+1))
          IF(HTYPE .EQ. 'C   ')  NTEST  =  15
          IF(HTYPE .NE. 'C   ')  NTEST  =  11
          CCFLAG  =  .FALSE.
          DO 300    JTEST  =  1, NTEST
             OKT  =  .TRUE.
             IF(JTEST .EQ. 3) CALL RVSET(IRDIM,VOID(1),W(LGC),W(LGC+1))
             HNAME(1)  =  HN(1,JTEST)
             HNAME(2)  =  HN(2,JTEST)
             WRITE(IOUNIT,1001)  HTYPE, HNAME
             KNTSKP  =  LTAB
  20         DO 200  JTAB  =  1, LTAB
                M  =  MTAB(JTAB)
                N  =  NTAB(JTAB)
                IDIM  =  MAX0(M,N,1)
                IF(IDIM .GE. 3  .AND.  IDIM .LE. 7)  IDIM  =  IDIM + 3
                IF(LF .LT. LENGTH*IDIM**2)  GOTO 200
                KNTSKP  =  KNTSKP - 1
                L12  =  NDX2F(1,2)
                L21  =  NDX2F(2,1)
                L22  =  NDX2F(2,2)
                L2   =  L21
                GOTO(01, 02, 03, 04, 05, 06, 07, 08, 09, 10,
     +               11, 12, 13, 14, 15),  JTEST
  01            CALL TMADD(M,N,W(LA),W(LB),W(LC),W(LT),IRDIM,W(LGA),
     +                      W(LGB),W(LGC),ALPHA,BETA,OKN,
     +                      MCPY,MADD,MRAN,VDIST,VADD,VSET)
                GOTO 99
  02            CALL TMBIL(N,W(LA),W(LB),W(LC),W(LR),W(LT),IRDIM,
     +                     W(LGA),W(LGB),W(LGC),ALPHA,BETA,OKN,
     +                     MBILT,MCPY,MMPY,MRAN,VCPY,VDIST,VMAXA)
                GOTO 99
  03            CALL TMCPY(M,N,W(LA),W(LC),IRDIM,W(LGA),W(LGC),
     +                     ALPHA,BETA,OKN,
     +                     MCPY,MRAN,VDIST,VSET)
                GOTO 99
  04            CALL TMMPY(M,N,W(LA),W(LB),W(LC),W(LR),W(LT),IRDIM,
     +              W(LGA),W(LGB),W(LGC),ZERO,ALPHA,BETA,OKN,
     +              MMNA,MMNS,MMPA,MMPS,MMPY,MCPY,MRAN,
     +              VADD,VDIST,VMAXA,VSCA,VSCS,VSET,VSUB)
                GOTO 99
  05            CALL TMRAN(M,N,W(LC),IRDIM,W(LGC),ALPHA,BETA,OKN,
     +                     MRAN,MRANT,MCPY,MSET,VDIST,VSET)
                GOTO 99
  06            CALL TMSCL(M,N,W(LA),W(LC),W(LT),IRDIM,W(LGA),
     +                     W(LGC),ALPHA,BETA,OKN,
     +                     MCPY,MSCL,MRAN,VDIST,VMAXA,VSCL,VSET)
                GOTO 99
  07            CALL TMSET(M,N,W(LA),W(LC),IRDIM,
     +                      W(LGC),ALPHA,BETA,OKN,
     +                      MSET,MRAN,VDIST,VSET)
                GOTO 99
  08            CALL TMADD(M,N,W(LA),W(LB),W(LC),W(LT),IRDIM,W(LGA),
     +                      W(LGB),W(LGC),ALPHA,BETA,OKN,
     +                      MCPY,MSUB,MRAN,VDIST,VSUB,VSET)
                GOTO 99
  09            CALL TMUTL(N,W(LA),W(LC),IRDIM,W(LGC),ALPHA,BETA,OKN,
     +                     MUTL,MCPY,MRAN,VCPY,VDIST,VSET)
                GOTO 99
  10            CALL TRSCL(M,N,W(LA),W(LB),W(LC),W(LT),IRDIM,W(LGA),
     +                     W(LGB),W(LGC),ALPHA,BETA,OKN,
     +                     MCPY,RSCL,MRAN,VDIST,VMAXA,VSCL,VSET)
                GOTO 99
  11            CALL TUMPY(N,W(LA),W(LB),W(LC),W(LR),W(LT),IRDIM,
     +              W(LGA),W(LGB),W(LGC),ZERO,ALPHA,BETA,OKN,
     +              UMNA,UMNS,UMPA,UMPS,UMPY,MCPY,MRAN,
     +              VADD,VDIST,VMAXA,VSCA,VSCS,VSET,VSUB)
                GOTO 99
  12            CCFLAG  =  .TRUE.
                CALL TCMMPY(M,N,W(LA),W(LB),W(LC),W(LR),W(LT),IRDIM,
     +              W(LGA),W(LGB),W(LGC),ZERO,ALPHA,BETA,OKN,
     +              CCMMPY,MCPY,MRAN,VDIST,VMAXA,VSET)
                GOTO 99
  13            CALL TMMPY(M,N,W(LA),W(LB),W(LC),W(LR),W(LT),IRDIM,
     +              W(LGA),W(LGB),W(LGC),ZERO,ALPHA,BETA,OKN,
     +              DUMMY,DUMMY,DUMMY,DUMMY,CMMPYC,MCPY,MRAN,
     +              VADD,VDIST,VMAXA,VSCA,VSCS,VSET,VSUB)
                GOTO 99
  14            CALL TCUMPY(N,W(LA),W(LB),W(LC),W(LR),W(LT),IRDIM,
     +              W(LGA),W(LGB),W(LGC),ZERO,ALPHA,BETA,OKN,
     +              CCUMPY,MCPY,MRAN,VDIST,VMAXA,VSET)
                GOTO 99
  15            CALL TUMPY(N,W(LA),W(LB),W(LC),W(LR),W(LT),IRDIM,
     +              W(LGA),W(LGB),W(LGC),ZERO,ALPHA,BETA,OKN,
     +              DUMMY,DUMMY,DUMMY,DUMMY,CUMPYC,MCPY,MRAN,
     +              VADD,VDIST,VMAXA,VSCA,VSCS,VSET,VSUB)
  99            OKT  =  OKT .AND. OKN
 200            CONTINUE
             IF(.NOT. OKT)  WRITE(IOUNIT,1010)
             IF(      OKT)  WRITE(IOUNIT,1011)
             OK  =  OK .AND. OKT
 300         CONTINUE
          CCFLAG  =  .FALSE.
          IF(KNTSKP .NE. 0)  WRITE(*,1014)  KNTSKP
          IF(.NOT. OK)  WRITE(IOUNIT,1012)  HTYPE
          IF(      OK)  WRITE(IOUNIT,1013)  HTYPE
          RETURN
1001      FORMAT(/ 9H TEST OF , 2A1,A4 )
1010      FORMAT(/ 5X, 37H ????? FEATURE TEST HAS FAILED. ????? )
1011      FORMAT( 15X, 25H FEATURE TEST SUCCESSFUL. )
1012      FORMAT(/ 5X, 21H ????? TEST FOR TYPE , A1,
     +           18H HAS FAILED. ????? )
1013      FORMAT(/25X, 15H TEST FOR TYPE , A1,12H SUCCESSFUL. )
1014      FORMAT( 20X, 11HWARNING ..., I3,
     +         52H CONFIGURATIONS HAVE BEEN SKIPPED FOR WANT OF SPACE.)
          END
          SUBROUTINE TMADD(M,N,A,B,C,T,IRDIM,GA,GB,GC,ALPHA,BETA,OK,
     +                     MCPY,MFCN,MRAN,VDIST,VFCN,VSET)
          REAL      A(*), B(*), C(*), T(*), GA(*), GB(*), GC(*)
          REAL      ALPHA(2),   BETA(2)
          LOGICAL   OK,   OKL
          REAL      E,   R0,   RES
          EXTERNAL  VDIST,    VSET
#include "kernnumt/sysdat.inc"
#include "ch3dat.inc"
          NDX2F(I,J)  =  ((J-1)*IDIM + I-1)*LENGTH + 1
          IRESF(RES)  =  NINT(RES/TRELPR)
          OK  =  .TRUE.
          IF(M .LE. 0  .OR.  N .LE. 0)  GOTO 12
          CALL MRAN(M,N,ALPHA,BETA,A,A(L12),A(L21))
          CALL MRAN(M,N,ALPHA,BETA,B,B(L12),B(L21))
          CALL KFLUSH
          CALL MFCN(M,N,A,A(L12),A(L21),B,B(L12),B(L21),C,C(L12),C(L21))
          R0  =  0.
          DO 10     I  =  1, M
             I1  =  NDX2F(I,1)
             I2  =  NDX2F(I,2)
             CALL VFCN(N,A(I1),A(I2),B(I1),B(I2),T,T(L2))
             E   =  VDIST(N,C(I1),C(I2),T,T(L2))
             R0  =  AMAX1(R0,E)
  10         CONTINUE
          N0  =  IRESF(R0)
          M0  =  5
          OK  =  N0 .LE. M0
          IF(.NOT. OK)  WRITE(IOUNIT,1000)  M, N, IDIM, M0, N0, R0
  12      DO 13     JCNFG  =  1, NCNFG
             CALL CNFGMX(M,N,IRDIM,LA,LA12,LA21)
             CALL CNFGMX(M,N,IRDIM,LB,LB12,LB21)
             CALL CNFGMX(M,N,IRDIM,LC,LC12,LC21)
             CALL MCPY(M,N,A,A(L12),A(L21),GA(LA),GA(LA12),GA(LA21))
             CALL MCPY(M,N,B,B(L12),B(L21),GB(LB),GB(LB12),GB(LB21))
             CALL KFLUSH
             CALL MFCN(M,N,GA(LA),GA(LA12),GA(LA21),
     +                     GB(LB),GB(LB12),GB(LB21),
     +                     GC(LC),GC(LC12),GC(LC21))
             CALL CHECKL(M,N,C,IRDIM,GC,LC,LC12,LC21,OKL,VDIST,VSET)
             IF(.NOT. OKL)  WRITE(IOUNIT,1001)  M,N,JCNFG,LC,LC12,LC21
             OK  =  OK .AND. OKL
  13         CONTINUE
          RETURN
1000      FORMAT(/ 25H ??? ARITHMETIC ERROR ???, 5I8,1P,E12.3 )
1001      FORMAT(/ 20H ??? LOGIC ERROR ???, 6I8 )
          END
          SUBROUTINE TMBIL(N,A,B,C,R,T,IRDIM,GA,GB,GC,
     +                        ALPHA,BETA,OK,
     +                        MBILT,MCPY,MMPY,MRAN,VCPY,VDIST,VMAXA)
          REAL      A(*),     B(*),     C(*),     R(*),     T(*)
          REAL      GA(*),    GB(*),    GC(*)
          REAL      ALPHA(2), BETA(2)
          LOGICAL   OK,       OKL,      OKZERO
          EXTERNAL  VDIST
          COMMON    /DATBIL/  OKZERO
          REAL      R0,       RES
#include "kernnumt/sysdat.inc"
#include "ch3dat.inc"
          IRESF(RES)  =  NINT(RES/TRELPR)
          OK  =  .TRUE.
          OKZERO  =  .TRUE.
          CALL MRAN(1,N,ALPHA,BETA,A,A(L2),DMY)
          CALL MRAN(1,N,ALPHA,BETA,C,C(L2),DMY)
          CALL MRAN(N,N,ALPHA,BETA,B,B(L12),B(L21))
          CALL KFLUSH
          CALL MBILT(N,A,A(L2),B,B(L12),B(L21),C,C(L2),R)
          IF(N .LE. 0)  GOTO 12
          CALL MMPY(N,N,B,B(L12),B(L21),C,C(L2),T,T(L2))
          CALL MMPY(1,N,A,A(L2),DMY,T,T(L2),T,DMY)
          R0  =  VDIST(1,R,DMY,T,DMY)
          IF(R0 .EQ. 0.)  GOTO 11
          CALL VMAXA(1,T,DUMMY,IDUMMY,ABSREF)
          R0  =  R0 / ABSREF
  11      N0  =  IRESF(R0)
          M0  =  300
          OK  =  N0 .LE. M0
          IF(.NOT. OK) WRITE(IOUNIT,1000) N, M0, N0, R0
  12      OK  =  OK .AND. OKZERO
          IF(.NOT. OK) RETURN
          DO 13     JCNFG  =  1, NCNFG
             CALL CNFGMX(N,1,IRDIM,LA,LDMY,LA2)
             CALL CNFGMX(N,1,IRDIM,LC,LDMY,LC2)
             CALL CNFGMX(N,N,IRDIM,LB,LB12,LB21)
             CALL VCPY(N,A,A(L2),GA(LA),GA(LA2))
             CALL VCPY(N,C,C(L2),GC(LC),GC(LC2))
             CALL MCPY(N,N,B,B(L12),B(L21),GB(LB),GB(LB12),GB(LB21))
             CALL KFLUSH
             CALL MBILT(N,GA(LA),GA(LA2),GB(LB),GB(LB12),GB(LB21),
     +                     GC(LC),GC(LC2),T)
             R0  =  VDIST(1,R,DMY,T,DMY)
             N0  =  IRESF(R0)
             OKL =  N0 .EQ. 0
             IF(.NOT. OKL) WRITE(IOUNIT,1001) N,JCNFG,N0,R0
             OK  =  OK .AND. OKL
  13         CONTINUE
          RETURN
1000      FORMAT(/ 25H ??? ARITHMETIC ERROR ???, 3I8,1P,E12.3)
1001      FORMAT(/ 20H ??? LOGIC ERROR ???,3I8,1P,E12.3)
          END
          SUBROUTINE          RMBILT(N,X,X2,Y,Y12,Y21,Z,Z2,R)
          REAL      X(*), X2(*), Y(*), Y12(*), Y21(*), Z(*), Z2(*)
          REAL      R, RMBIL
#include "kernnumt/sysdat.inc"
#include "ch3dat.inc"
          COMMON    /DATBIL/  OKZERO
          LOGICAL             OKZERO
          R  =  RMBIL(N,X,X2,Y,Y12,Y21,Z,Z2)
          OKZERO  =  N .GT. 0  .OR.  R .EQ. 0.
          IF(.NOT. OKZERO)  WRITE(IOUNIT,1000)  N, R
          RETURN
1000      FORMAT(/ 25H ??? RMBIL(N=0,... NOT 0 ,I5,E12.3)
          END
          SUBROUTINE          DMBILT(N,X,X2,Y,Y12,Y21,Z,Z2,R)
          DOUBLE PRECISION X(*),X2(*),Y(*),Y12(*),Y21(*),Z(*),Z2(*)
          DOUBLE PRECISION R, DMBIL
#include "kernnumt/sysdat.inc"
#include "ch3dat.inc"
          COMMON    /DATBIL/  OKZERO
          LOGICAL             OKZERO
          R  =  DMBIL(N,X,X2,Y,Y12,Y21,Z,Z2)
          OKZERO  =  N .GT. 0  .OR.  SNGL(R) .EQ. 0.
          IF(.NOT. OKZERO)  WRITE(IOUNIT,1000)  N
          RETURN
1000      FORMAT(/ 25H ??? DMBIL(N=0,... NOT 0 ,I5)
          END
          SUBROUTINE          CMBILT(N,X,X2,Y,Y12,Y21,Z,Z2,R)
          COMPLEX  X(*), X2(*), Y(*), Y12(*), Y21(*), Z(*), Z2(*)
          COMPLEX  R, CMBIL
#include "kernnumt/sysdat.inc"
#include "ch3dat.inc"
          COMMON    /DATBIL/  OKZERO
          LOGICAL             OKZERO
          R  =  CMBIL(N,X,X2,Y,Y12,Y21,Z,Z2)
          OKZERO  =  N .GT. 0  .OR.  CABS(R) .EQ. 0.
          IF(.NOT. OKZERO)  WRITE(IOUNIT,1000)  N, R
          RETURN
1000      FORMAT(/ 25H ??? CMBIL(N=0,... NOT 0 ,I5,2E12.3)
          END
          SUBROUTINE TMCPY(M,N,A,C,IRDIM,GA,GC,ALPHA,BETA,OK,
     +                     MFCN,MRAN,VDIST,VSET)
          REAL                A(*),     C(*),     GA(*),    GC(*)
          REAL                ALPHA(2), BETA(2)
          LOGICAL             OK,       OKL,      OKM
          EXTERNAL            VDIST
#include "kernnumt/sysdat.inc"
#include "ch3dat.inc"
          NDX2F(I,J)  =  ((J-1)*IDIM + I-1)*LENGTH + 1
          OK  =  .TRUE.
          CALL MRAN(M,N,ALPHA,BETA,A,A(L12),A(L21))
          CALL MFCN(M,N,A,A(L12),A(L21),C,C(L12),C(L21))
          IF(M .LE. 0)  GOTO 12
          DO 10     I  =  1, M
             I1  =  NDX2F(I,1)
             I2  =  NDX2F(I,2)
             E   =  VDIST(N,A(I1),A(I2),C(I1),C(I2))
             OKM =  E .EQ. 0
             OK  =  OK .AND. OKM
             IF(.NOT. OKM) WRITE(IOUNIT,1000)  M,N,E
  10         CONTINUE
          IF(.NOT. OK)  RETURN
  12      DO 13     JCNFG  =  1, NCNFG
             CALL CNFGMX(M,N,IRDIM,LA,LA12,LA21)
             CALL CNFGMX(M,N,IRDIM,LC,LC12,LC21)
             CALL MFCN(M,N,A,A(L12),A(L21),GA(LA),GA(LA12),GA(LA21))
             CALL KFLUSH
             CALL MFCN(M,N,GA(LA),GA(LA12),GA(LA21),
     +                 GC(LC),GC(LC12),GC(LC21))
             CALL CHECKL(M,N,C,IRDIM,GC,LC,LC12,LC21,OKL,VDIST,VSET)
             IF(.NOT. OKL) WRITE(IOUNIT,1001)  M,N
             OK  =  OK .AND. OKL
  13         CONTINUE
          RETURN
1000      FORMAT(/ 31H ??? ARITHMETIC ERROR ???   M =,I3,2X,3HN =,
     +            I3,1P,E12.3)
1001      FORMAT(/ 26H ??? LOGIC ERROR ???   M =,I3,2X,3HN =,I3)
          END
          SUBROUTINE TMMPY(M,N,A,B,C,R,T,IRDIM,GA,GB,GC,ZERO,ALPHA,BETA,
     +                     OK,MMNA,MMNS,MMPA,MMPS,MMPY,MCPY,MRAN,
     +                     VADD,VDIST,VMAXA,VSCA,VSCS,VSET,VSUB)
          REAL      A(*), B(*), C(*), R(*), T(*), GA(*), GB(*), GC(*)
          REAL      ZERO(2),    ALPHA(2),   BETA(2),     R0,    RES
          COMPLEX   BCONJG
          LOGICAL   OK,       OKA,      OKL
          EXTERNAL  VDIST,    VSET
#include "kernnumt/sysdat.inc"
#include "ch3dat.inc"
          NDX1F(J)    =  (J-1)*LENGTH + 1
          NDX2F(I,J)  =  ((J-1)*IDIM + I-1)*LENGTH + 1
          IRESF(RES)  =  NINT(RES/TRELPR)
          OK  =  .TRUE.
          IF(CCFLAG)  THEN
             MFUNCT  =  5
          ELSE
             MFUNCT  =  1
          ENDIF
          DO 40     JFUNCT  =  MFUNCT, 5
             IF(M .LE. 0  .OR.  N .LE. 0)  GOTO 30
             CALL MRAN(M,N,ALPHA,BETA,A,A(L12),A(L21))
             CALL MRAN(N,1,ALPHA,BETA,B,DUMMY,B(L2))
             CALL MRAN(M,1,ALPHA,BETA,C,DUMMY,C(L2))
             CALL MCPY(M,1,C,DUMMY,C(L2),R,DUMMY,R(L2))
             CALL VSET(M,ZERO,T(1),T(L2))
             DO 10  J  =  1, N
                LJ   =  NDX1F(J)
                L1J  =  NDX2F(1,J)
                L2J  =  NDX2F(2,J)
                IF(CCFLAG) THEN
                   BCONJG  =  CMPLX(B(LJ),-B(LJ+1))
                   CALL VSCA(M,BCONJG,A(L1J),A(L2J),T,T(L2),T,T(L2))
                ELSE
                   CALL VSCA(M,B(LJ),A(L1J),A(L2J),T,T(L2),T,T(L2))
                ENDIF
  10            CONTINUE
             GOTO(11,12,13,14,15), JFUNCT
  11         CALL VSUB(M,C(1),C(L2),T(1),T(L2),T(1),T(L2))
             CALL KFLUSH
             CALL MMNA(M,N,A,A(L12),A(L21),B,B(L2),C,C(L2))
             GOTO 20
  12         CALL VADD(M,T(1),T(L2),C(1),C(L2),T(1),T(L2))
             CALL VSCS(M,ZERO,T(1),T(L2),T(1),T(L2),T(1),T(L2))
             CALL KFLUSH
             CALL MMNS(M,N,A,A(L12),A(L21),B,B(L2),C,C(L2))
             GOTO 20
  13         CALL VADD(M,T(1),T(L2),C(1),C(L2),T(1),T(L2))
             CALL KFLUSH
             CALL MMPA(M,N,A,A(L12),A(L21),B,B(L2),C,C(L2))
             GOTO 20
  14         CALL VSUB(M,T(1),T(L2),C(1),C(L2),T(1),T(L2))
             CALL KFLUSH
             CALL MMPS(M,N,A,A(L12),A(L21),B,B(L2),C,C(L2))
             GOTO 20
  15         CALL KFLUSH
             CALL MMPY(M,N,A,A(L12),A(L21),B,B(L2),C,C(L2))
  20         R0  =  VDIST(M,C,C(L2),T,T(L2))
             IF(R0 .NE. 0.)  THEN
                CALL VMAXA(M,T,T(L2),IDUMMY,ABSREF)
                R0  =  R0 / ABSREF
             ENDIF
             N0  =  IRESF(R0)
             M0  =  40
             OKA =  N0 .LE. M0
             IF(.NOT. OKA) WRITE(IOUNIT,1000) JFUNCT,M,N,IDIM,M0,N0,R0
             OK  =  OK .AND. OKA
             IF(.NOT. OK)  RETURN
  30         DO 39  JCNFG  =  1, NCNFG
                CALL CNFGMX(M,N,IRDIM,LA,LA12,LA21)
                CALL CNFGMX(N,1,IRDIM,LB,LB12,LB21)
                CALL CNFGMX(M,1,IRDIM,LC,LC12,LC21)
                CALL MCPY(M,N,A,A(L12),A(L21),GA(LA),GA(LA12),GA(LA21))
                CALL MCPY(N,1,B,DMY,B(L2),GB(LB),DMY,GB(LB21))
                IF(N .GT. 0)
     +             CALL MCPY(M,1,R,DMY,R(L2),GC(LC),DMY,GC(LC21))
                GOTO(31,32,33,34,35),  JFUNCT
  31            CALL KFLUSH
                CALL MMNA(M,N,GA(LA),GA(LA12),GA(LA21),GB(LB),GB(LB21),
     +                                                 GC(LC),GC(LC21))
                GOTO 38
  32            CALL KFLUSH
                CALL MMNS(M,N,GA(LA),GA(LA12),GA(LA21),GB(LB),GB(LB21),
     +                                                 GC(LC),GC(LC21))
                GOTO 38
  33            CALL KFLUSH
                CALL MMPA(M,N,GA(LA),GA(LA12),GA(LA21),GB(LB),GB(LB21),
     +                                                 GC(LC),GC(LC21))
                GOTO 38
  34            CALL KFLUSH
                CALL MMPS(M,N,GA(LA),GA(LA12),GA(LA21),GB(LB),GB(LB21),
     +                                                 GC(LC),GC(LC21))
                GOTO 38
  35            CALL KFLUSH
                CALL MMPY(M,N,GA(LA),GA(LA12),GA(LA21),GB(LB),GB(LB21),
     +                                                 GC(LC),GC(LC21))
                GOTO 38
  38            IF(N .GT. 0)
     +           CALL CHECKL(M,1,C,IRDIM,GC,LC,LC12,LC21,OKL,VDIST,VSET)
                IF(N .LE. 0)
     +           CALL CHECKL(0,0,C,IRDIM,GC,LC,LC12,LC21,OKL,VDIST,VSET)
                IF(.NOT.OKL) WRITE(IOUNIT,1001) JFUNCT,M,N,JCNFG,LC,
     +                                            LC12,LC21
                OK  =  OK .AND. OKL
  39            CONTINUE
  40         CONTINUE
          RETURN
1000      FORMAT(/ 26H ??? ARITHMETIC ERROR ??? ,6I8,1P,E12.3)
1001      FORMAT(/ 21H ??? LOGIC ERROR ??? ,7I8)
          END
          SUBROUTINE TCMMPY(M,N,A,B,C,R,T,IRDIM,GA,GB,GC,ZERO,
     +                ALPHA,BETA,OK,MMPY,MCPY,MRAN,VDIST,VMAXA,VSET)
          REAL      A(*), B(*), C(*), R(*), T(*), GA(*), GB(*), GC(*)
          REAL      ZERO(2),    ALPHA(2),   BETA(2),     R0,    RES
          LOGICAL   OK,       OKA,      OKL
          EXTERNAL  VDIST,    VSET
#include "kernnumt/sysdat.inc"
#include "ch3dat.inc"
          NDX1F(J)    =  (J-1)*LENGTH + 1
          NDX2F(I,J)  =  ((J-1)*IDIM + I-1)*LENGTH + 1
          IRESF(RES)  =  NINT(RES/TRELPR)
          OK  =  .TRUE.
          IF(M .LE. 0  .OR.  N .LE. 0)  GOTO 30
          CALL MRAN(M,N,ALPHA,BETA,A,A(L12),A(L21))
          CALL MRAN(N,1,ALPHA,BETA,B,DUMMY,B(L2))
          CALL MRAN(M,1,ALPHA,BETA,C,DUMMY,C(L2))
          CALL MCPY(M,1,C,DUMMY,C(L2),R,DUMMY,R(L2))
          DO 10     I  =  1, M
             LI   =  NDX1F(I)
             LI1  =  NDX2F(I,1)
             LI2  =  NDX2F(I,2)
             CALL CCVDOT(N,A(LI1),A(LI2),B,B(L2),T(LI))
  10         CONTINUE
          CALL KFLUSH
          CALL MMPY(M,N,A,A(L12),A(L21),B,B(L2),C,C(L2))
          R0  =  VDIST(M,C,C(L2),T,T(L2))
          IF(R0 .NE. 0.)  THEN
             CALL VMAXA(M,T,T(L2),IDUMMY,ABSREF)
             R0  =  R0 / ABSREF
          ENDIF
          N0  =  IRESF(R0)
          M0  =  40
          OKA =  N0 .LE. M0
          IF(.NOT. OKA) WRITE(IOUNIT,1000) M,N,IDIM,M0,N0,R0
          OK  =  OK .AND. OKA
          IF(.NOT. OK)  RETURN
  30      DO 39  JCNFG  =  1, NCNFG
             CALL CNFGMX(M,N,IRDIM,LA,LA12,LA21)
             CALL CNFGMX(N,1,IRDIM,LB,LB12,LB21)
             CALL CNFGMX(M,1,IRDIM,LC,LC12,LC21)
             CALL MCPY(M,N,A,A(L12),A(L21),GA(LA),GA(LA12),GA(LA21))
             CALL MCPY(N,1,B,DMY,B(L2),GB(LB),DMY,GB(LB21))
             IF(N .GT. 0)
     +          CALL MCPY(M,1,R,DMY,R(L2),GC(LC),DMY,GC(LC21))
             CALL KFLUSH
             CALL MMPY(M,N,GA(LA),GA(LA12),GA(LA21),GB(LB),GB(LB21),
     +                                              GC(LC),GC(LC21))
             IF(N .GT. 0)
     +        CALL CHECKL(M,1,C,IRDIM,GC,LC,LC12,LC21,OKL,VDIST,VSET)
             IF(N .LE. 0)
     +        CALL CHECKL(0,0,C,IRDIM,GC,LC,LC12,LC21,OKL,VDIST,VSET)
             IF(.NOT.OKL) WRITE(IOUNIT,1001) M,N,JCNFG,LC,LC12,LC21
             OK  =  OK .AND. OKL
  39         CONTINUE
          RETURN
1000      FORMAT(/ 26H ??? ARITHMETIC ERROR ??? ,5I8,1P,E12.3)
1001      FORMAT(/ 21H ??? LOGIC ERROR ??? ,6I8)
          END
          SUBROUTINE CCVDOT(N,X,X2,Y,Y2,DOT)
          COMPLEX   X(*), X2(*), Y(*), Y2(*), DOT, CVMPYC
          DOT  =  CVMPYC(N,Y,Y2,X,X2)
          RETURN
          END
          SUBROUTINE TMRAN(M,N,C,IRDIM,GC,ALPHA,BETA,OK,
     +                    MRAN,MRANT,MCPY,MSET,VDIST,VSET)
          REAL      C(*), GC(*), ALPHA(2), BETA(2)
          LOGICAL   OK,   OKL,   OKC
          REAL      E1,   E2,   R0,   R1,   R2,   P,    Q
          EXTERNAL  VDIST,    VSET
#include "kernnumt/sysdat.inc"
#include "ch3dat.inc"
          NDX2F(I,J)  =  ((J-1)*IDIM + I-1)*LENGTH + 1
          OK  =  .TRUE.
          R0  =  VDIST(1,ALPHA,DMY,BETA,DMY)
          R1  =  0.
          R2  =  0.
          CALL MSET(M,N,ALPHA,C,C(L12),C(L21))
          CALL KFLUSH
          CALL MRAN(M,N,ALPHA,BETA,C,C(L12),C(L21))
          IF(M .LE. 0)  GOTO 12
          DO 10     I  =  1, M
             I1  =  NDX2F(I,1)
             I2  =  NDX2F(I,2)
             E1  =  VDIST(N,C(I1),C(I2),ALPHA,ALPHA)
             E2  =  VDIST(N,C(I1),C(I2),BETA,BETA)
             R1  =  AMAX1(R1,E1)
             R2  =  AMAX1(R2,E2)
  10         CONTINUE
          OK  =  AMAX1(R1,R2) .LT. R0
          IF(.NOT. OK)  WRITE(IOUNIT,1000)  M, N, IDIM, R0, R1, R2
  12      DO 13     JCNFG  =  1, NCNFG
             CALL CNFGMX(M,N,IRDIM,LC,LC12,LC21)
             CALL KFLUSH
             CALL MRAN(M,N,ALPHA,BETA,GC(LC),GC(LC12),GC(LC21))
             CALL MCPY(M,N,GC(LC),GC(LC12),GC(LC21),C,C(L12),C(L21))
             CALL CHECKL(M,N,C,IRDIM,GC,LC,LC12,LC21,OKL,VDIST,VSET)
             IF(.NOT. OKL)  WRITE(IOUNIT,1001)  M,N,JCNFG,LC,LC12,LC21
             OK  =  OK .AND. OKL
  13         CONTINUE
          P  =  -1.
          Q  =  +3.
          AMEAN   =  (P+Q) / 2.
          SIGMA2  =  (Q-P)**2 / 12.
          K  =  1000
          CALL MRANT(P,Q,C(1),C(1),K)
          CALL RVVAR(K,AMEAN,C(1),C(2),CM,CM2,DUMMY)
          DM   =  ABS(CM - AMEAN)
          DM2  =  ABS(CM2-SIGMA2)
          CL   =  2.*ABS(Q - P) / SQRT(3.*FLOAT(K))
          CL2  =  8.*SIGMA2  / SQRT(5.*FLOAT(K))
          OKC  =  DM .LE. CL  .AND.  DM2 .LE. CL2
          IF(.NOT. OKC)  WRITE(IOUNIT,1002) M,N,K,P,Q, AMEAN,CM,DM,CL,
     +                                          SIGMA2,CM2,DM2,CL2
          OK  =  OK .AND .OKC
          RETURN
1000      FORMAT(/ 25H ??? ARITHMETIC ERROR ???,  3I8, 1P, 3E12.3)
1001      FORMAT(/ 20H ??? LOGIC ERROR ???,  6I8)
1002      FORMAT(/ 27H ??? DISTRIBUTION ERROR ???,  3I8,
     +           / 1X, 2F8.2, 5X, 4F12.3,
     +           / 22X,           4F12.3 )
          END
          SUBROUTINE          RMRANT(P,Q,T,R,K)
          REAL                T(K), R(K)
          CALL RMRAN(K,1,P,Q,R(1),DMY,R(2))
          RETURN
          END
          SUBROUTINE          DMRANT(P,Q,T,R,K)
          DOUBLE PRECISION    T(K), PHI, PSI
          REAL                R(K)
          PHI  =  DBLE(P)
          PSI  =  DBLE(Q)
          CALL DMRAN(K,1,PHI,PSI,T(1),DMY,T(2))
          DO 10     J  =  1, K
             R(J)  =  SNGL(T(J))
  10         CONTINUE
          RETURN
          END
          SUBROUTINE          CMRANT(P,Q,T,R,K)
          COMPLEX             T(K), PHI, PSI
          REAL                R(K)
          PHI  =  CMPLX(P,P)
          PSI  =  CMPLX(Q,Q)
          CALL CMRAN(K,1,PHI,PSI,T(1),DMY,T(2))
          DO 10     J  =  1, K
             R(2*J-1)  =  REAL(T(J))
             R(2*J)    =  AIMAG(T(J))
  10         CONTINUE
          K  =  2 * K
          RETURN
          END
          SUBROUTINE TMSCL(M,N,A,C,T,IRDIM,GA,GC,ALPHA,BETA,OK,
     +                     MCPY,MSCL,MRAN,VDIST,VMAXA,VSCL,VSET)
          REAL      A(*), C(*), T(*), GA(*), GC(*)
          REAL      ALPHA(2),   BETA(2)
          LOGICAL   OK,   OKL
          REAL      E,   R0,   RES
          EXTERNAL  VDIST,    VSET
#include "kernnumt/sysdat.inc"
#include "ch3dat.inc"
          NDX2F(I,J)  =  ((J-1)*IDIM + I-1)*LENGTH + 1
          IRESF(RES)  =  NINT(RES/TRELPR)
          OK  =  .TRUE.
          IF(M .LE. 0  .OR.  N .LE. 0)  GOTO 12
          CALL MRAN(M,N,ALPHA,BETA,A,A(L12),A(L21))
          CALL KFLUSH
          CALL MSCL(M,N,A,A,A(L12),A(L21),C,C(L12),C(L21))
          R0  =  0.
          DO 10     I  =  1, M
             I1  =  NDX2F(I,1)
             I2  =  NDX2F(I,2)
             CALL VSCL(N,A,A(I1),A(I2),T,T(L2))
             E   =  VDIST(N,C(I1),C(I2),T,T(L2))
             CALL VMAXA(N,T,T(L2),IDUMMY,ABSREF)
             R0  =  AMAX1(R0,E/ABSREF)
  10         CONTINUE
          N0  =  IRESF(R0)
          M0  =  20
          OK  =  N0 .LE. M0
          IF(.NOT. OK)  WRITE(IOUNIT,1000)  M, N, IDIM, M0, N0, R0
  12      DO 13     JCNFG  =  1, NCNFG
             CALL CNFGMX(M,N,IRDIM,LA,LA12,LA21)
             CALL CNFGMX(M,N,IRDIM,LC,LC12,LC21)
             CALL MCPY(M,N,A,A(L12),A(L21),GA(LA),GA(LA12),GA(LA21))
             CALL KFLUSH
             CALL MSCL(M,N,A,GA(LA),GA(LA12),GA(LA21),
     +                       GC(LC),GC(LC12),GC(LC21))
             CALL CHECKL(M,N,C,IRDIM,GC,LC,LC12,LC21,OKL,VDIST,VSET)
             IF(.NOT. OKL)  WRITE(IOUNIT,1001)  M,N,JCNFG,LC,LC12,LC21
             OK  =  OK .AND. OKL
  13         CONTINUE
          RETURN
1000      FORMAT(/ 25H ??? ARITHMETIC ERROR ???, 5I8,1P,E12.3 )
1001      FORMAT(/ 20H ??? LOGIC ERROR ???, 6I8 )
          END
          SUBROUTINE TMSET(M,N,A,C,IRDIM,GC,ALPHA,BETA,OK,
     +                     MSET,MRAN,VDIST,VSET)
          REAL      A(*), C(*), GC(*)
          REAL      ALPHA(2),   BETA(2)
          LOGICAL   OK,   OKL
          REAL      E,   R0,   RES
          EXTERNAL  VDIST,    VSET
#include "kernnumt/sysdat.inc"
#include "ch3dat.inc"
          NDX2F(I,J)  =  ((J-1)*IDIM + I-1)*LENGTH + 1
          IRESF(RES)  =  NINT(RES/TRELPR)
          OK  =  .TRUE.
          IF(M .LE. 0  .OR.  N .LE. 0)  GOTO 12
          CALL MRAN(1,1,ALPHA,BETA,A,DMY,DMY)
          CALL KFLUSH
          CALL MSET(M,N,A,C,C(L12),C(L21))
          R0  =  0.
          DO 10     I  =  1, M
             I1  =  NDX2F(I,1)
             I2  =  NDX2F(I,2)
             E   =  VDIST(N,C(I1),C(I2),A,A)
             R0  =  AMAX1(R0,E)
  10         CONTINUE
          N0  =  IRESF(R0)
          M0  =  0
          OK  =  N0 .LE. M0
          IF(.NOT. OK)  WRITE(IOUNIT,1000)  M, N, IDIM, M0, N0, R0
  12      DO 13     JCNFG  =  1, NCNFG
             CALL CNFGMX(M,N,IRDIM,LC,LC12,LC21)
             CALL KFLUSH
             CALL MSET(M,N,A,GC(LC),GC(LC12),GC(LC21))
             CALL CHECKL(M,N,C,IRDIM,GC,LC,LC12,LC21,OKL,VDIST,VSET)
             IF(.NOT. OKL)  WRITE(IOUNIT,1001)  M,N,JCNFG,LC,LC12,LC21
             OK  =  OK .AND. OKL
  13         CONTINUE
          RETURN
1000      FORMAT(/ 25H ??? ARITHMETIC ERROR ???, 5I8,1P,E12.3 )
1001      FORMAT(/ 20H ??? LOGIC ERROR ???, 6I8 )
          END
          SUBROUTINE TMUTL(N,A,C,IRDIM,GC,ALPHA,BETA,OK,
     +                     MUTL,MCPY,MRAN,VCPY,VDIST,VSET)
          REAL                A(*),     C(*),     GC(*)
          REAL                ALPHA(2), BETA(2)
          LOGICAL             OK,       OKL
          EXTERNAL  VDIST
#include "kernnumt/sysdat.inc"
#include "ch3dat.inc"
          NDX2F(I,J)  =  ((J-1)*IDIM + I-1)*LENGTH + 1
          OK  =  .TRUE.
          CALL MRAN(N,N,ALPHA,BETA,A,A(L12),A(L21))
          IF(N .LE. 0)  GOTO 12
          DO 11     I  =  1, N
             II  =  NDX2F(I,I)
             II1 =  NDX2F(I,I+1)
             I1I =  NDX2F(I+1,I)
             CALL VCPY(N-I+1,A(II),A(II1),C(II),C(II1))
             CALL VCPY(N-I+1,A(II),A(II1),C(II),C(I1I))
  11         CONTINUE
  12      DO 13     JCNFG  =  1, NCNFG
             CALL CNFGMX(N,N,IRDIM,LC,LC12,LC21)
             CALL MCPY(N,N,A,A(L12),A(L21),GC(LC),GC(LC12),GC(LC21))
             CALL KFLUSH
             CALL MUTL(N,GC(LC),GC(LC12),GC(LC21))
             CALL CHECKL(N,N,C,IRDIM,GC,LC,LC12,LC21,OKL,VDIST,VSET)
             IF(.NOT. OKL) WRITE(IOUNIT,1001)  N
             OK  =  OK .AND. OKL
  13         CONTINUE
          RETURN
1001      FORMAT(/ 26H ??? LOGIC ERROR ???   N =, I3)
          END
          SUBROUTINE TRSCL(M,N,A,B,C,T,IRDIM,GA,GB,GC,ALPHA,BETA,OK,
     +                     MCPY,RSCL,MRAN,VDIST,VMAXA,VSCL,VSET)
          REAL      A(*), B(*), C(*), T(*), GA(*), GB(*), GC(*)
          REAL      ALPHA(2),   BETA(2)
          LOGICAL   OK,   OKL
          REAL      E,   R0,   RES
          EXTERNAL  VDIST,    VSET
#include "kernnumt/sysdat.inc"
#include "ch3dat.inc"
          NDX1F(J)    =  (J-1)*LENGTH + 1
          NDX2F(I,J)  =  ((J-1)*IDIM + I-1)*LENGTH + 1
          IRESF(RES)  =  NINT(RES/TRELPR)
          OK  =  .TRUE.
          IF(M .LE. 0  .OR.  N .LE. 0)  GOTO 12
          CALL MRAN(1,M,ALPHA,BETA,A,A(L2),DMY)
          CALL MRAN(M,N,ALPHA,BETA,B,B(L12),B(L21))
          CALL KFLUSH
          CALL RSCL(M,N,A,A(L2),B,B(L12),B(L21),C,C(L12),C(L21))
          R0  =  0.
          DO 10     I  =  1, M
             ID  =  NDX1F(I)
             I1  =  NDX2F(I,1)
             I2  =  NDX2F(I,2)
             CALL VSCL(N,A(ID),B(I1),B(I2),T,T(L2))
             E   =  VDIST(N,C(I1),C(I2),T,T(L2))
             CALL VMAXA(N,T,T(L2),IDUMMY,ABSREF)
             R0  =  AMAX1(R0,E/ABSREF)
  10         CONTINUE
          N0  =  IRESF(R0)
          M0  =  20
          OK  =  N0 .LE. M0
          IF(.NOT. OK)  WRITE(IOUNIT,1000)  M, N, IDIM, M0, N0, R0
  12      DO 13     JCNFG  =  1, NCNFG
             CALL CNFGMX(M,1,IRDIM,LA,LDMY,LA2)
             CALL CNFGMX(M,N,IRDIM,LB,LB12,LB21)
             CALL CNFGMX(M,N,IRDIM,LC,LC12,LC21)
             CALL MCPY(1,M,A,A(L2),DMY,GA(LA),GA(LA2),DMY)
             CALL MCPY(M,N,B,B(L12),B(L21),GB(LB),GB(LB12),GB(LB21))
             CALL KFLUSH
             CALL RSCL(M,N,GA(LA),GA(LA2),GB(LB),GB(LB12),GB(LB21),
     +                                    GC(LC),GC(LC12),GC(LC21))
             CALL CHECKL(M,N,C,IRDIM,GC,LC,LC12,LC21,OKL,VDIST,VSET)
             IF(.NOT. OKL)  WRITE(IOUNIT,1001)  M,N,JCNFG,LC,LC12,LC21
             OK  =  OK .AND. OKL
  13         CONTINUE
          RETURN
1000      FORMAT(/ 25H ??? ARITHMETIC ERROR ???, 5I8,1P,E12.3 )
1001      FORMAT(/ 20H ??? LOGIC ERROR ???, 6I8 )
          END
          SUBROUTINE TUMPY(N,A,B,C,R,T,IRDIM,GA,GB,GC,ZERO,ALPHA,BETA,
     +                     OK,UMNA,UMNS,UMPA,UMPS,UMPY,MCPY,MRAN,
     +                     VADD,VDIST,VMAXA,VSCA,VSCS,VSET,VSUB)
          REAL      A(*), B(*), C(*), R(*), T(*), GA(*), GB(*), GC(*)
          REAL      ZERO(2),    ALPHA(2),   BETA(2)
          COMPLEX   BCONJG,   RCONJG
          LOGICAL   OK,       OKA,      OKL
          REAL      R0, RES
          EXTERNAL  VDIST,    VSET
#include "kernnumt/sysdat.inc"
#include "ch3dat.inc"
          NDX1F(J)    =  (J-1)*LENGTH + 1
          NDX2F(I,J)  =  ((J-1)*IDIM + I-1)*LENGTH + 1
          IRESF(RES)  =  NINT(RES/TRELPR)
          OK  =  .TRUE.
          IF(CCFLAG)  THEN
             MFUNCT  =  5
          ELSE
             MFUNCT  =  1
          ENDIF
          DO 40     JFUNCT  =  MFUNCT, 5
             IF(N .LE. 0)  GOTO 30
             CALL MRAN(N,N,ALPHA,BETA,A,A(L12),A(L22))
             CALL MRAN(N,1,ALPHA,BETA,B,DUMMY,B(L2))
             CALL MRAN(N,1,ALPHA,BETA,C,DUMMY,C(L2))
             CALL MCPY(N,1,C,DUMMY,C(L2),R,DUMMY,R(L2))
             CALL VSET(N,ZERO,T(1),T(L2))
             DO 10  J  =  1, N
                LJ   =  NDX1F(J)
                L1J  =  NDX2F(1,J)
                L2J  =  NDX2F(2,J)
                IF(CCFLAG) THEN
                   RCONJG  =  CMPLX(R(LJ),-R(LJ+1))
                   CALL VSCA(J,RCONJG,A(L1J),A(L2J),T,T(L2),T,T(L2))
                ELSE
                   CALL VSCA(J,R(LJ),A(L1J),A(L2J),T,T(L2),T,T(L2))
                ENDIF
  10            CONTINUE
             GOTO(11,12,13,14,15), JFUNCT
  11         CALL VSUB(N,C(1),C(L2),T(1),T(L2),T(1),T(L2))
             CALL KFLUSH
             CALL UMNA(N,A,A(L12),A(L22),C,C(L2),C,C(L2))
             GOTO 18
  12         CALL VADD(N,T(1),T(L2),C(1),C(L2),T(1),T(L2))
             CALL VSCS(N,ZERO,T(1),T(L2),T(1),T(L2),T(1),T(L2))
             CALL KFLUSH
             CALL UMNS(N,A,A(L12),A(L22),C,C(L2),C,C(L2))
             GOTO 18
  13         CALL VADD(N,T(1),T(L2),C(1),C(L2),T(1),T(L2))
             CALL KFLUSH
             CALL UMPA(N,A,A(L12),A(L22),C,C(L2),C,C(L2))
             GOTO 18
  14         CALL VSUB(N,T(1),T(L2),C(1),C(L2),T(1),T(L2))
             CALL KFLUSH
             CALL UMPS(N,A,A(L12),A(L22),C,C(L2),C,C(L2))
             GOTO 18
  15         CALL KFLUSH
             CALL UMPY(N,A,A(L12),A(L22),C,C(L2),C,C(L2))
  18         R0  =  VDIST(N,C,C(L2),T,T(L2))
             IF(R0 .EQ. 0.)  GOTO 19
             CALL VMAXA(N,T,T(L2),IDUMMY,ABSREF)
             R0  =  R0 / ABSREF
  19         N0  =  IRESF(R0)
             M0  =  40
             OKA =  N0 .LE. M0
             IF(.NOT. OKA) WRITE(IOUNIT,1002)  JFUNCT,N,IDIM,M0,N0,R0
             OK  =  OK .AND. OKA
             CALL MCPY(N,1,R,DUMMY,R(L2),C,DUMMY,C(L2))
             CALL VSET(N,ZERO,T(1),T(L2))
             DO 20  J  =  1, N
                LJ   =  NDX1F(J)
                L1J  =  NDX2F(1,J)
                L2J  =  NDX2F(2,J)
                IF(CCFLAG) THEN
                   BCONJG  =  CMPLX(B(LJ),-B(LJ+1))
                   CALL VSCA(J,BCONJG,A(L1J),A(L2J),T,T(L2),T,T(L2))
                ELSE
                   CALL VSCA(J,B(LJ),A(L1J),A(L2J),T,T(L2),T,T(L2))
                ENDIF
  20            CONTINUE
             GOTO(21,22,23,24,25), JFUNCT
  21         CALL VSUB(N,C(1),C(L2),T(1),T(L2),T(1),T(L2))
             CALL KFLUSH
             CALL UMNA(N,A,A(L12),A(L22),B,B(L2),C,C(L2))
             GOTO 28
  22         CALL VADD(N,T(1),T(L2),C(1),C(L2),T(1),T(L2))
             CALL VSCS(N,ZERO,T(1),T(L2),T(1),T(L2),T(1),T(L2))
             CALL KFLUSH
             CALL UMNS(N,A,A(L12),A(L22),B,B(L2),C,C(L2))
             GOTO 28
  23         CALL VADD(N,T(1),T(L2),C(1),C(L2),T(1),T(L2))
             CALL KFLUSH
             CALL UMPA(N,A,A(L12),A(L22),B,B(L2),C,C(L2))
             GOTO 28
  24         CALL VSUB(N,T(1),T(L2),C(1),C(L2),T(1),T(L2))
             CALL KFLUSH
             CALL UMPS(N,A,A(L12),A(L22),B,B(L2),C,C(L2))
             GOTO 28
  25         CALL KFLUSH
             CALL UMPY(N,A,A(L12),A(L22),B,B(L2),C,C(L2))
  28         R0  =  VDIST(N,C,C(L2),T,T(L2))
             IF(R0 .EQ. 0.)  GOTO 29
             CALL VMAXA(N,T,T(L2),IDUMMY,ABSREF)
             R0  =  R0 / ABSREF
  29         N0  =  IRESF(R0)
             M0  =  10
             OKA =  N0 .LE. M0
             IF(.NOT. OKA) WRITE(IOUNIT,1000)  JFUNCT,N,IDIM,M0,N0,R0
             OK  =  OK .AND. OKA
             IF(.NOT. OK)  RETURN
  30         DO 39  JCNFG  =  1, NCNFG
                CALL CNFGMX(N,N,IRDIM,LA,LA12,LA21)
                LA22  =  LA12 + LA21 - LA
                CALL CNFGMX(N,1,IRDIM,LB,LB12,LB21)
                CALL CNFGMX(N,1,IRDIM,LC,LC12,LC21)
                CALL MCPY(N,N,A,A(L12),A(L21),GA(LA),GA(LA12),GA(LA21))
                CALL MCPY(N,1,B,DMY,B(L2),GB(LB),DMY,GB(LB21))
                CALL MCPY(N,1,R,DMY,R(L2),GC(LC),DMY,GC(LC21))
                GOTO(31,32,33,34,35),  JFUNCT
  31            CALL KFLUSH
                CALL UMNA(N,GA(LA),GA(LA12),GA(LA22),GB(LB),GB(LB21),
     +                                                 GC(LC),GC(LC21))
                GOTO 38
  32            CALL KFLUSH
                CALL UMNS(N,GA(LA),GA(LA12),GA(LA22),GB(LB),GB(LB21),
     +                                                 GC(LC),GC(LC21))
                GOTO 38
  33            CALL KFLUSH
                CALL UMPA(N,GA(LA),GA(LA12),GA(LA22),GB(LB),GB(LB21),
     +                                                 GC(LC),GC(LC21))
                GOTO 38
  34            CALL KFLUSH
                CALL UMPS(N,GA(LA),GA(LA12),GA(LA22),GB(LB),GB(LB21),
     +                                                 GC(LC),GC(LC21))
                GOTO 38
  35            CALL KFLUSH
                CALL UMPY(N,GA(LA),GA(LA12),GA(LA22),GB(LB),GB(LB21),
     +                                                 GC(LC),GC(LC21))
                GOTO 38
  38            CALL CHECKL(N,1,C,IRDIM,GC,LC,LC12,LC21,OKL,VDIST,VSET)
                IF(.NOT. OKL) WRITE(IOUNIT,1001) JFUNCT,N,JCNFG,
     +                                            LC,LC12,LC21
                OK  =  OK .AND. OKL
  39            CONTINUE
  40         CONTINUE
          RETURN
1000      FORMAT(/ 26H ??? ARITHMETIC ERROR ??? , 5I8,1P,E12.3)
1001      FORMAT(/ 20H ??? LOGIC ERROR ???,6I8)
1002      FORMAT(/ 26H ??? ERROR FOR Z = Y  ??? , 5I8,1P,E12.3)
          END
          SUBROUTINE TCUMPY(N,A,B,C,R,T,IRDIM,GA,GB,GC,ZERO,ALPHA,BETA,
     +                     OK,UMPY,MCPY,MRAN,VDIST,VMAXA,VSET)
          REAL      A(*), B(*), C(*), R(*), T(*), GA(*), GB(*), GC(*)
          REAL      ZERO(2),    ALPHA(2),   BETA(2),     R0,    RES
          LOGICAL   OK,       OKA,      OKL
          EXTERNAL  VDIST,    VSET
#include "kernnumt/sysdat.inc"
#include "ch3dat.inc"
          NDX1F(J)    =  (J-1)*LENGTH + 1
          NDX2F(I,J)  =  ((J-1)*IDIM + I-1)*LENGTH + 1
          IRESF(RES)  =  NINT(RES/TRELPR)
          OK  =  .TRUE.
          IF(N .LE. 0)  GOTO 30
          CALL MRAN(N,N,ALPHA,BETA,A,A(L12),A(L22))
          CALL MRAN(N,1,ALPHA,BETA,B,DUMMY,B(L2))
          CALL MRAN(N,1,ALPHA,BETA,C,DUMMY,C(L2))
          CALL MCPY(N,1,C,DUMMY,C(L2),R,DUMMY,R(L2))
          CALL VSET(N,ZERO,T(1),T(L2))
          DO 10  I  =  1, N
             LI   =  NDX1F(I)
             LIP  =  NDX1F(I+1)
             LII  =  NDX2F(I,I)
             LIIP =  NDX2F(I,I+1)
             CALL CCVDOT(N-I+1,A(LII),A(LIIP),C(LI),C(LIP),T(LI))
  10         CONTINUE
          CALL KFLUSH
          CALL UMPY(N,A,A(L12),A(L22),C,C(L2),C,C(L2))
          R0  =  VDIST(N,C,C(L2),T,T(L2))
          IF(R0 .EQ. 0.)  GOTO 19
          CALL VMAXA(N,T,T(L2),IDUMMY,ABSREF)
          R0  =  R0 / ABSREF
  19      N0  =  IRESF(R0)
          M0  =  40
          OKA =  N0 .LE. M0
          IF(.NOT. OKA) WRITE(IOUNIT,1002)  N,IDIM,M0,N0,R0
          OK  =  OK .AND. OKA
          CALL MCPY(N,1,R,DUMMY,R(L2),C,DUMMY,C(L2))
          CALL VSET(N,ZERO,T(1),T(L2))
          DO 20  I  =  1, N
             LI   =  NDX1F(I)
             LIP  =  NDX1F(I+1)
             LII  =  NDX2F(I,I)
             LIIP =  NDX2F(I,I+1)
             CALL CCVDOT(N-I+1,A(LII),A(LIIP),B(LI),B(LIP),T(LI))
  20         CONTINUE
          CALL KFLUSH
          CALL UMPY(N,A,A(L12),A(L22),B,B(L2),C,C(L2))
          R0  =  VDIST(N,C,C(L2),T,T(L2))
          IF(R0 .EQ. 0.)  GOTO 29
          CALL VMAXA(N,T,T(L2),IDUMMY,ABSREF)
          R0  =  R0 / ABSREF
  29      N0  =  IRESF(R0)
          M0  =  10
          OKA =  N0 .LE. M0
          IF(.NOT. OKA) WRITE(IOUNIT,1000)  N,IDIM,M0,N0,R0
          OK  =  OK .AND. OKA
          IF(.NOT. OK)  RETURN
  30      DO 39  JCNFG  =  1, NCNFG
             CALL CNFGMX(N,N,IRDIM,LA,LA12,LA21)
             LA22  =  LA12 + LA21 - LA
             CALL CNFGMX(N,1,IRDIM,LB,LB12,LB21)
             CALL CNFGMX(N,1,IRDIM,LC,LC12,LC21)
             CALL MCPY(N,N,A,A(L12),A(L21),GA(LA),GA(LA12),GA(LA21))
             CALL MCPY(N,1,B,DMY,B(L2),GB(LB),DMY,GB(LB21))
             CALL MCPY(N,1,R,DMY,R(L2),GC(LC),DMY,GC(LC21))
             CALL KFLUSH
             CALL UMPY(N,GA(LA),GA(LA12),GA(LA22),GB(LB),GB(LB21),
     +                                              GC(LC),GC(LC21))
             CALL CHECKL(N,1,C,IRDIM,GC,LC,LC12,LC21,OKL,VDIST,VSET)
             IF(.NOT. OKL) WRITE(IOUNIT,1001) N,JCNFG,LC,LC12,LC21
             OK  =  OK .AND. OKL
  39         CONTINUE
          RETURN
1000      FORMAT(/ 26H ??? ARITHMETIC ERROR ??? , 4I8,1P,E12.3)
1001      FORMAT(/ 20H ??? LOGIC ERROR ???,5I8)
1002      FORMAT(/ 26H ??? ERROR FOR Z = Y  ??? , 4I8,1P,E12.3)
          END
