home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 10 / 10.iso / l / l292 / 1.ddi / MULREG.FOR < prev    next >
Encoding:
Text File  |  1990-05-02  |  3.6 KB  |  130 lines
  1.  
  2.  
  3.  
  4.       SUBROUTINE MatTxTiX (aryin, numrow, numcol, aryout)
  5.       INCLUDE 'STDHDR.FOR'
  6.       REAL aryin(0:maxr,0:maxc), aryout(0:maxc,0:maxc)
  7.       INTEGER numrow, numcol,i, j, k
  8.  
  9.       DO i = 0, numcol - 1
  10.         DO j = 0, numcol - 1
  11.           aryout(i, j) = 0.0
  12.           DO k = 0, numrow - 1
  13.             aryout(i, j) = aryout(i, j) + aryin(k, j) * aryin(k, i)
  14.           END DO
  15.         END DO
  16.       END DO
  17.       END ! MatTxTiX
  18.  
  19.  
  20.  
  21.       SUBROUTINE MatYTiX (aryy, aryx, numrow, numcol, aryout)
  22.       INCLUDE 'STDHDR.FOR'
  23.       REAL aryy(0:maxr), aryx(0:maxr,0:maxc), aryout(0:maxc)
  24.       INTEGER numrow, numcol,i, k
  25.  
  26.       DO i = 0, numcol - 1
  27.         aryout(i) = 0.0
  28.         DO k = 0, numrow - 1
  29.           aryout(i) = aryout(i) + aryy(k) * aryx(k, i)
  30.         END DO
  31.       END DO
  32.       END !SUB  MatYtiX
  33.  
  34.  
  35.  
  36.       SUBROUTINE MultipleReg (indvardat, depvardat, numiv,
  37.      +  numobs, regcoef, yest, resid, see, coefsig, rsq, r, regerror)
  38.        INCLUDE 'STDHDR.FOR'
  39.       REAL indvardat(0:maxr,0:maxc),depvardat(0:maxr), regcoef(0:maxc)
  40.       REAL yest(0:maxr), resid(0:maxr), coefsig(0:maxc),see,r,rsq
  41.  
  42.       REAL regmat[ALLOCATABLE](:,:), aryinv[ALLOCATABLE](:,:)
  43.       REAL arya[ALLOCATABLE](:,:), aryg[ALLOCATABLE](:)
  44.       INTEGER numiv, numobs,i, j, numcol, iErr
  45.       LOGICAL regerror
  46.  
  47.       ALLOCATE(regmat(0:maxr, 0:maxc), aryinv(0:maxc, 0:maxc),STAT=iErr)
  48.       CALL CheckMem(iErr)
  49.       ALLOCATE(arya(0:maxc, 0:maxc), aryg(0:maxc), STAT = iErr)
  50.       CALL CheckMem(iErr)
  51.  
  52.       DO i = 0, numobs - 1
  53.         DO j = 0, numiv - 1
  54.           regmat(i, j + 1) = indvardat(i, j)
  55.         END DO
  56.         regmat(i, 0) = 1.0
  57.       END DO
  58.  
  59.       numcol = numiv + 1
  60.  
  61.       CALL MatTxTiX(regmat, numobs, numcol, arya)
  62.  
  63.       CALL MatYTiX(depvardat, regmat, numobs, numcol, aryg)
  64.  
  65.       CALL GaussJordan(arya, aryg, numcol, regcoef, aryinv, regdet)
  66.  
  67.       CALL ResAnalysis(regmat, depvardat, regcoef, aryinv, numobs,
  68.      + numcol, yest, resid, see, coefsig, rsq, r)
  69.  
  70.       IF (regdet .LT. .0000001) THEN
  71.         regerror = .TRUE.
  72.       ELSE
  73.         regerror = .FALSE.
  74.       END IF
  75.  
  76.       DEALLOCATE(regmat,STAT=iErr)
  77.       CALL CheckMem(iErr)
  78.       DEALLOCATE(aryinv,STAT=iErr)
  79.       CALL CheckMem(iErr)
  80.       DEALLOCATE(arya,STAT=iErr)
  81.       CALL CheckMem(iErr)
  82.       DEALLOCATE(aryg,STAT=iErr)
  83.       CALL CheckMem(iErr)
  84.  
  85.       END !SUB   MultipleReg
  86.  
  87.  
  88.  
  89.  
  90.  
  91.  
  92.       SUBROUTINE ResAnalysis (regmat, ymat, regcoef,
  93.      + aryinv, numrow, numcol, yest, resid, see, coefsig, rsq, r)
  94.       INCLUDE 'STDHDR.FOR'
  95.       REAL regmat(0:maxr, 0:maxc), ymat(0:maxr), regcoef(0:maxc)
  96.       REAL aryinv(0:maxc, 0:maxc), yest(0:maxr), resid(0:maxr)
  97.       REAL coefsig(0:maxc), see,rsq, r, sumressq, sumy, sumysq
  98.       INTEGER numrow, numcol,i, j, nxx
  99.  
  100.  
  101.       sumressq = 0.0
  102.       sumy = 0.0
  103.       sumysq = 0.0
  104.       DO i = 0, numrow - 1
  105.         yest(i) = 0.0
  106.         DO j = 0, numcol - 1
  107.           yest(i) = yest(i) + regcoef(j) * regmat(i, j)
  108.         END DO
  109.         resid(i) = yest(i) - ymat(i)
  110.         sumressq = sumressq + resid(i)**2
  111.         sumy = sumy + ymat(i)
  112.         sumysq = sumysq + ymat(i)**2
  113.       END DO
  114.       IF (numrow .EQ. numcol) THEN
  115.         nxx = 1
  116.       ELSE
  117.         nxx = numrow - numcol
  118.       END IF
  119.       see = SQRT(sumressq / REAL(nxx))
  120.       DO i = 0, numcol - 1
  121.         coefsig(i) = see * SQRT(aryinv(i, i))
  122.       END DO
  123.       rsq = (1.0 - sumressq / (sumysq - sumy ** 2 / REAL(numrow)))
  124.       r = SQRT(rsq)
  125.       END !SUB ResAnalysis
  126.  
  127.  
  128.  
  129.  
  130. ! 5/2/90 modified MultipleRec to correctly deallocate all arrays