home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / vol269 / matsub.for < prev    next >
Encoding:
Text File  |  1986-05-22  |  10.6 KB  |  219 lines
  1. C [MATSUB.FOR]
  2. C    *** SUBROUTINES FOR VECTOR AND MATRIX HANDLING ***
  3. C
  4. C    Writen by Yoshio MONMA (JUG-CP/M No.43)
  5. C
  6.       SUBROUTINE   TRNSV0(INP0,NX,X,IND)
  7. C
  8. C     ** TRANSFORMATION OF A VECTOR X(NX) **
  9. C
  10. C    * Arguments:
  11. C     INP0       Input data file no. (6-9)
  12. C        NX        Data size, size of vector
  13. C        X(NX)     Data, a vector
  14. C        IND       Transformation code:
  15. C            = 0   No transformation
  16. C            = 1   Linear: (X --> A*X+B)
  17. C            = 2   Inversion: (X --> 1/X)
  18. C            = 3   (X --> LOG10(X))
  19. C            = 4   (X --> LOG(X))
  20. C            = 5   (X --> SQRT(X))
  21. C            = 6   (X --> X**2)
  22. C            = 7   (X --> X**P)
  23. C            = 8   (X --> 10.0**X)
  24. C            = 9   (X --> EXP(X))
  25. C            = 10  Logistic: (X --> LOG(X/1.0-X))
  26. C
  27. C    AUTHOR AND DATE: YOSHIO MONMA, 80-05-02
  28. C
  29.       INTEGER*1       BEL
  30.       REAL*4       X(NX)
  31. C
  32.       DATA BEL/Z'07'/
  33. C
  34.       IF (NX.LE.0.OR.IND.LT.0.OR.IND.GT.10)  GOTO 99
  35.       IF (IND.EQ.0) RETURN
  36. C
  37.       WRITE(2,600)
  38.   600   FORMAT(1H0,10X,'* Transformation of Vector *')
  39.       IF (IND.EQ.1) READ(INP0,500) A,B
  40.   500   FORMAT(2F10.1)
  41.       IF (IND.EQ.7) READ(INP0,500) P
  42. C
  43.       IF (IND.EQ. 1) WRITE(2,601) A,B
  44.       IF (IND.EQ. 2) WRITE(2,602)
  45.       IF (IND.EQ. 3) WRITE(2,603)
  46.       IF (IND.EQ. 4) WRITE(2,604)
  47.       IF (IND.EQ. 5) WRITE(2,605)
  48.       IF (IND.EQ. 6) WRITE(2,606)
  49.       IF (IND.EQ. 7) WRITE(2,607) P
  50.       IF (IND.EQ. 8) WRITE(6,608)
  51.       IF (IND.EQ. 9) WRITE(6,609)
  52.       IF (IND.EQ.10) WRITE(6,610)
  53.   601 FORMAT(1H0,10x,'(X --> A*X+B), A =',1PE10.3,', B =',E10.3)
  54.   602 FORMAT(1H0,10X,'(X --> 1/X)')
  55.   603 FORMAT(1H0,10X,'(X --> LOG10(X))')
  56.   604 FORMAT(1H0,10X,'(X --> LOG(X))')
  57.   605 FORMAT(1H0,10X,'(X --> SQRT(X))')
  58.   606 FORMAT(1H0,10X,'(X --> X**2')
  59.   607 FORMAT(1H0,10X,'(X --> X**P), P =',1PE10.3)
  60.   608 FORMAT(1H0,10X,'(X --> 10.0**X)')
  61.   609 FORMAT(1H0,10X,'(X --> EXP(X))')
  62.   610 FORMAT(1H0,10X,'Logistic: (X --> LOG(X/(1.0-X))')
  63. C
  64.    10 DO 100 I=1,NX
  65.          GOTO (11,12,13,14,15,16,17,18,19,20), IND
  66.    11    X(I) = A*X(I)+B
  67.                                         GOTO 100
  68.    12    IF (X(I).EQ.0.0)               GOTO 99
  69.          X(I) = 1.0/X(I)
  70.                                         GOTO 100
  71.    13    IF (X(I).LE.0.0)               GOTO 99
  72.          X(I) = ALOG10(X(I))
  73.                                         GOTO 100
  74.    14    IF (X(I).LE.0.0)               GOTO 99
  75.          X(I) = ALOG(X(I))
  76.                                         GOTO 100
  77.    15    IF (X(I).LT.0.0)               GOTO 99
  78.          X(I) = SQRT(X(I))
  79.                                         GOTO 100
  80.    16    X(I) = X(I)**2
  81.                                         GOTO 100
  82.    17    X(I) = X(I)**P
  83.                                         GOTO 100
  84.    18    X(I) = 10.0**X(I)
  85.                                         GOTO 100
  86.    19    X(I) = EXP(X(I))
  87.                                         GOTO 100
  88.    20    X(I) = ALOG(X(I)/(1.0-X(I)))    
  89.   100 CONTINUE
  90.       RETURN
  91. C                                       * ERROR PROCESS
  92.    99 WRITE(2,299) BEL,IND
  93.   299 FORMAT (1H0,A1,'*** Error in TRNSV0: IND =',I3)
  94.       STOP 99
  95.       END
  96.  
  97.       SUBROUTINE   MATPRI(TITLE,A,IA,JA,IN,JP)                          
  98. C                                                                       
  99. C     ** PRINT-OUT OF A MATRIX **                                         
  100. C                                                                       
  101. C     * Arguments:
  102. C     TITLE    Title of the matrix (2A8)                             
  103. C     A         Input matrix (one dimensional)
  104. C     IA    Every Ia elements are printed out in the column
  105. C     JA    Every JA elements are printed out in the row
  106. C     IN    No. of columns to be printed out
  107. C     JP    No. of rows to be printed out
  108. C                                                                       
  109. C     * REFERENCE, T.Haga & S.Hashimoto: ó╢▓╖╠▐▌╛╖ ─ ╝¡╛▓╠▐▌╠▐▌╛╖ú, P.11  
  110. C                                                                       
  111.       REAL*4       A(1)                                                 
  112.       REAL*8       TITLE(2)
  113. C
  114.       WRITE(2,200) TITLE                                                
  115.   200   FORMAT(1H0,10X,2A8/)
  116.       J2 = 0                                                            
  117.    10 J1 = J2+1                                                         
  118.       IF (J2+10.LT.JP) J2 = J2+10
  119.       IF (J2+10.GE.JP) J2 = JP
  120.       WRITE(2,210) (J,J=J1,J2)                                          
  121.   210   FORMAT(1H ,12X,10I10)
  122.       IJ1 = 1+(J1-1)*JA                                                 
  123.       IJ2 = 1+(J2-1)*JA                                                 
  124.       DO 20 I=1,IN                                                      
  125.          WRITE(2,230) I,(A(IJ),IJ=IJ1,IJ2,JA)                           
  126.   230      FORMAT(1H ,I15,10F10.4)
  127.          IJ1 = IJ1+IA                                                   
  128.          IJ2 = IJ2+IA                                                   
  129.    20 CONTINUE                                                          
  130.       IF (J2.EQ.JP) RETURN                                              
  131.       WRITE(2,210)                                                      
  132.                                         GOTO 10                         
  133.       E N D                                                             
  134.       SUBROUTINE   VECPRI(TITLE,A,LA,IN)                                
  135. C                                                                       
  136. C     ** PRINT-OUT OF A VECTOR FROM A MATRIX **                              
  137. C                                                                       
  138. C     * Arguments:
  139. C     TITLE        Identification of the vector (A8)
  140. C     LA           Every LA element is taken up
  141. C     A            Input matrix
  142. C     IN           No. of elements to be printed out
  143. C                                                                       
  144. C     * Reference, T.Haga & S.Hashmoto: ó╢▓╖╠▐▌╛╖ ─ ╝¡╛▓╠▐▌╠▐▌╛╖ú, P.18  
  145. C                                                                       
  146.       REAL*4       A(LA,1)                                              
  147.       REAL*8       TITLE
  148. C
  149.       IF (IN.LT.10) I2 = IN
  150.       IF (IN.GE.10) I2 = 10
  151.       WRITE(2,200) TITLE,(A(1,I),I=1,I2)                                
  152.   200   FORMAT(1H0,7X,A8,10F10.4)
  153.       IF (I2.LT.IN) WRITE(2,210) (A(1,I),I=11,IN)                       
  154.   210   FORMAT(1H ,15X,10F10.4)
  155.       RETURN                                                            
  156.       E N D                                                             
  157. C
  158.       SUBROUTINE   CORREL(S,LS,JP,R,LR)                                 
  159. C                                                                       
  160. C     ** Correlation Matrix **                                            
  161. C                                                                       
  162. C     * Arguments                                                       
  163. C     S         SS matrix (═▓╬│▄Ñ╛╖▄ ╖▐«│┌┬)                         
  164. C     LS    Size of S
  165. C     JP    No. of variables (p)                                 
  166. C     R         Correlation matrix
  167. C     LR    Size of R
  168. C                                                                       
  169. C     * REFERENCE, T.Haga & S.Hashimoto: ó╢▓╖╠▐▌╛╖ ─ ╝¡╛▓╠▐▌╠▐▌╛╖ú, P.22  
  170. C                                                                       
  171.       REAL*4       S(LS,LS), R(LR,LR)                                   
  172. C                                                                       
  173.       DO 10 I=1,JP                                                      
  174.          R(I,I) = SQRT(S(I,I))                                          
  175.    10 CONTINUE                                                          
  176.       DO 30 I=2,JP                                                      
  177.          JJ = I-1                                                       
  178.          DO 20 J=1,JJ                                                   
  179.             R(I,J) = S(I,J)/(R(I,I)*R(J,J))                             
  180.             R(J,I) = R(I,J)                                             
  181.    20    CONTINUE                                                       
  182.    30 CONTINUE                                                          
  183. C                                                                       
  184.       DO 55 I=1,JP                                                      
  185.          R(I,I) = 1.0                                                   
  186.    55 CONTINUE                                                          
  187.       RETURN                                                            
  188.       E N D                                                             
  189. C
  190.       SUBROUTINE   SWEEP1(A,LA,K,JP)                                    
  191. C                                                                       
  192. C     ** SWEEP-OUT OF A SQUARE MATRIX **                                  
  193. C                                                                       
  194. C     * Arguments:
  195. C     A            A square matrix with size of LA                      
  196. C     LA           Size of matrix A
  197. C     K            Location of pivot (A(K,K))                           
  198. C     JP           Size of smaller square matrix to be sweeped out
  199. C                                                                       
  200. C     * REFERENCE, T.Haga & S.Hashimoto: ╢▓╖╠▐▌╛╖ ─ ╝¡╛▓╠▐▌╠▐▌╛╖, P.16  
  201. C                                                                       
  202.       REAL*4       A(LA,LA)                                             
  203. C                                                                       
  204.       AKK = A(K,K)                                                      
  205.       A(K,K) = 1.0                                                      
  206.       DO 10 J=1,JP                                                      
  207.          A(K,J) = A(K,J)/AKK                                            
  208.    10 CONTINUE                                                          
  209.       DO 30 I=1,JP                                                      
  210.          IF (I.EQ.K)                    GOTO 30                         
  211.          AIK = A(I,K)                                                   
  212.          A(I,K) = 0.0                                                   
  213.          DO 20 J=1,JP                                                   
  214.             A(I,J) = A(I,J)-AIK*A(K,J)                                  
  215.    20    CONTINUE                                                       
  216.    30 CONTINUE                                                          
  217.       RETURN                                                            
  218.       E N D
  219.