/*  Library File: SingColl.GL                                 */
  /*                                                            */
  /*  Created:      Abstracted 4 Apr 92 from PANELVC.GP by FJR  */
  /*                                                            */
  /*  Last modified:                                            */
  /*    13 Apr 92   FJR Submatrices now stacked in block vector */
  /*                    Improved coding efficiency              */
  /*    17 Aug 92   FJR  Corrected 0 cols test: maxc==minc==0   */
  /*    18 Aug 92   FJR Used DOTFEQ instead of ==               */
  /*    20 May 93   FJR Added varCo parameter to TestSing       */
  /*    03 Jun 93   FJR Corrected name-writing in TestSing      */
  /*    04 Jun 93   FJR Added name parameters to procs          */
  /*    12 Jun 94   FJR Changed "varCo"s to "multiple"s         */
  /*    23 Jun 94   FJR Fudge for TestColl on -ve matrices      */
  /*    15 Aug 94   FJR TestColl slightly less memory-wasting!  */
  /*    24 Oct 94   FJR Lower case file names for Unix          */
  /*                                                            */
  /*  Given matrices containing one or more square submatrices, */
  /*  run tests for singularity and multicollinearity on them   */
  /*  and return Boolean results.                               */


  /*  Exported:                                                 */
  /*    TestSing    Singularity test;  opt. to show blank rows  */
  /*    TestColl    Multicollinearity test                      */


  #INCLUDE "seldelfr.gl";               /*  for SelectR         */



  PROC (1) = TestSing (name, nSubs, xx, showName, names, sty, fmt, multiple);

    /*  Check x'x matrix for singularity in all its submatrices */
    /*  In:                                                     */
    /*    name      Name of matrix being tested                 */
    /*    nSubs     No. of submatrices                          */
    /*    xx        X'X matrix bits NSubsK x K                  */
    /*    showName  Display names of guilty rows                */
    /*    names     Group names                                 */
    /*    sty,fmt   Name print format,  for use with PRINTFM    */
    /*    multiple  no. of multiple groupings (to print names)  */
    /*  Out:                                                    */
    /*    anyBad    At least one matrix was singular            */

    LOCAL i;
    LOCAL anyBad;
    LOCAL size;
    LOCAL rStart;
    LOCAL rEnd;
    LOCAL temp;
    LOCAL bigNames;


      anyBad = 0;
      size = COLS (xx);
      FORMAT /RD 2, 0;

      i = 1;
      PRINT "Testing " $name " for singularity...";
      DO WHILE (i <= nSubs) AND NOT anyBad;

        PRINT i;;
        rStart = (i-1)*size + 1;
        rEnd = rStart + size - 1;
        temp = xx[rStart:rEnd,.];
        anyBad = FEQ((1/COND(temp))+1, 1);
        i = i + 1;

      ENDO;
      PRINT;

      IF anyBad AND showName;

        /*  Show blank rows for the guilty submatrix            */

        PRINT "Zero columns for submatrix " i-1 ":";
        i = DOTFEQ(MINC(temp), 0) .AND DOTFEQ(MAXC(temp), 0);
        IF SUMC(i) > 0;
          bigNames = names;
          DO WHILE multiple > 1;
            bigNames = bigNames | names;
            multiple = multiple - 1;
          ENDO;
          CALL PRINTFM (SelectR(bigNames, i), sty, fmt);
        ELSE;
          PRINT "No zero columns";
        ENDIF;

      ENDIF;


      RETP (anyBad);

    ENDP;                                       /*  TestSing    */



  PROC (1) = TestColl (name, nSubs, xx);

    /*  Check x'x submatrices for multicollinearity             */
    /*  In:                                                     */
    /*    name      Name of matrix being tested                 */
    /*    nSubs No. of submatrices                              */
    /*    xx    X'X matrix bits nSubsK x K                      */
    /*  Out:                                                    */
    /*    anyColl   At least one submat displays collinearity   */
    /*  NB  See Greene 1990,  p280                              */

    LOCAL i;
    LOCAL anyColl;
    LOCAL size;
    LOCAL rStart;
    LOCAL rEnd;
    LOCAL tempX;
    LOCAL diagX;
    LOCAL rootVec;


      anyColl = 0;
      size = COLS (xx);
      FORMAT /RD 1, 0;

      i = 1;
      PRINT "Testing " $name " for multicollinearity...";

      DO WHILE (i <= nSubs) AND NOT anyColl;

        PRINT i "cond: ";;
        rStart = (i-1)*size + 1;
        rEnd = rStart + size - 1;
        tempX = xx[rStart:rEnd,.];
        diagX = DIAG(tempX);
        IF diagX >= 0;
/**
          rootVec = SQRT(diagX);
          rootVec = INVPD(DIAGRV(EYE(size),rootVec)));
          anyColl = COND(rootVec*tempX*rootVec);
**/
          rootVec = ONES(size,1)./SQRT(diagX);
          tempX = rootVec.*tempX;
          tempX = tempX.*rootVec';
          anyColl = COND(tempX);
        ELSE;
          anyColl = -1;
        ENDIF;
        PRINT anyColl "  ";;
        anyColl = anyColl>20;
        i = i + 1;

      ENDO;
      PRINT;

      RETP (anyColl);

    ENDP;                                       /*  TestColl    */


/*  END SingColl.GL */