home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Professional / OS2PRO194.ISO / os2 / prgramer / adaptor / examples / purdue / prob06.fcm < prev    next >
Encoding:
Text File  |  1993-06-26  |  3.4 KB  |  144 lines
  1.       PROGRAM PROB06
  2. C
  3. C     PROBLEM 6
  4. C
  5. C  REFERENCE:  PROBLEMS TO TEST PARALLEL AND VECTOR LANGUAGES
  6. C              CSD-TR 516, COMPUTER SCIENCE, PURDUE UNIVERSITY
  7. C              JOHN R. RICE, MAY 1, 1985
  8. C
  9. C              REVISED BY JOHN R. RICE AND J. JING, OCT. 1, 1990
  10. C
  11. C
  12. C      *************************************************
  13. C      *      Adapted for FORTRAN D benchmarking       *
  14. C      *    by  T. HAUPT  (haupt@sccs.npac.syr.edu)    *
  15. C      *                                               *
  16. C      *    Northeast Parallel Architectures Center    *
  17. C      *   at Syracuse University, Syracuse, NY, USA   *
  18. C      *************************************************
  19. C
  20. C
  21. C       VERSION SIMD/CM2-1.00
  22. C       ==================================================
  23. C
  24.       INCLUDE '/usr/include/cm/paris-configuration-fort.h'
  25.       INTEGER KASES,K,NK
  26.       PARAMETER (KASES=4)
  27.       INTEGER N(KASES)
  28. cmf$  layout n(:serial)
  29.       REAL SOLUT
  30.       DATA N / 8196,16384,65536,262144/
  31. C
  32. C               LOOP OVER KASES
  33. C
  34.       DO  K = 1, KASES
  35.          NK=N(K)
  36.       CALL CM_TIMER_CLEAR(0)
  37.       CALL CM_TIMER_START(0)
  38.          DO MANY=1,20
  39.          CALL DOIT(NK,SOLUT)
  40.         ENDDO
  41.       CALL CM_TIMER_STOP(0)
  42.  
  43.          PRINT *,'PROBLEM 6 WITH N = ',NK
  44.          PRINT *,'GIVES SOLUTION =', SOLUT
  45.       CALL CM_TIMER_PRINT(0)
  46.  
  47.       ENDDO
  48.  
  49.       STOP
  50.       END
  51.  
  52.  
  53.  
  54.       SUBROUTINE DOIT(NK,SOLUT)
  55.       INTEGER NK
  56.       REAL SOLUT
  57.       DOUBLE PRECISION, ARRAY(NK) :: L,D,T,X,Y,U, LL, UL, YL, LR, UR
  58.       INTEGER II,K,LIMIT
  59.  
  60. c      L=0.88-0.1*SIN([1:NK]*12.36)
  61. c      D=1.0d00+0.01*COS([1:NK]*8.11)
  62. c      U=0.75+0.2*SIN([1:NK]*36.12+3.2)
  63.       L=1.0d00
  64.       D=0.5d00
  65.       U=0.5d00
  66.       Y=1.0d00
  67.       X=0.0
  68.       T=0.0
  69. C
  70. C
  71. C      LIMIT = LOG BASE 2 OF N
  72. C
  73.          LIMIT = 1.44269504*ALOG(FLOAT(NK))+.01
  74.          K = 1
  75. C
  76. C                                 MAIN LOOP
  77. C
  78.          DO II = 1, LIMIT
  79.  
  80.                L=L/D
  81.                U=U/D
  82.                Y=Y/D
  83.  
  84. C
  85. C                         T IS A TEMPORARY ARRAY
  86. C                   COMPUTE AND ASSIGN TO D, COMPUTE Y
  87. C
  88.            LL(1:NK-K) = L(K+1:NK)
  89.            UR(1:NK-K) = U(K+1:NK)
  90.            UL(K+1:NK) = U(1:NK-K)
  91.            YL(K+1:NK) = Y(1:NK-K)
  92.            LR(K+1:NK) = L(1:NK-K)
  93.  
  94.            D(1:K) = 1.0    - U(1:K)*LL(1:K)
  95.            T(1:K) = Y(1:K) - U(1:K)*LL(1:K)
  96.  
  97.            D(K+1:NK-K) = 1.0 - L(K+1:NK-K)*UL(K+1:NK-K) -
  98.      +                  U(K+1:NK-K)*LL(K+1:NK-K)
  99.            T(K+1:NK-K) = Y(K+1:NK-K)   - L(K+1:NK-K)*YL(K+1:NK-K) -
  100.      +                  U(K+1:NK-K)*LL(K+1:NK-K)
  101.  
  102.            D(NK-K+1:NK) = 1.0        - L(NK-K+1:NK)*UL(NK-K+1:NK)
  103.            T(NK-K+1:NK) = Y(NK-K+1:NK) - L(NK-K+1:NK)*YL(NK-K+1:NK)
  104. C
  105. C                          ASSIGN TO Y, COMPUTE L
  106. C
  107.             Y=T
  108.             T(1:K)=0
  109.             T(K+1:NK)=-L(K+1:NK)*LR(K+1:NK)
  110. C
  111. C                          ASSIGN TO L, COMPUTE U
  112. C
  113.             L=T
  114.             T(1:NK-K)=U(1:NK-K)*UR(1:NK-K)
  115.             T(NK-K+1:NK)=0
  116. C
  117. C                          ASSIGN TO U
  118. C
  119.             U=T
  120.  
  121.             K = 2*K
  122.  
  123.       ENDDO
  124.  
  125.       X=Y/D
  126.       SOLUT=SUM(X)
  127. C-------------------- to be removed -------------
  128. C+SELF,IF=F77,F77PAR,IPSC860,IF=-HOST.
  129. C      FSUM = 0.0
  130. C+SELF,IF=F77,F77PAR.
  131. C      DO I = 1, N-2
  132. C+SELF,IF=IPSC860,IF=NODE.
  133. C      DO I=ME+1,N,NPROCS
  134. C+SELF,IF=F77,F77PAR,IPSC860,IF=-HOST.
  135. C        FSUM = FSUM+EXP(A+H*I)
  136. C      ENDDO
  137. C
  138. C+SELF,IF=CM2,CM5,DECMPP.
  139. C      FSUM=SUM(EXP(A+H*[1:N]))
  140. C
  141. C-----------------end to be removed --------------
  142.  
  143.       END
  144.