      PROGRAM HOST14
C
C     PROBLEM 14
C
C  REFERENCE:  PROBLEMS TO TEST PARALLEL AND VECTOR LANGUAGES
C              CSD-TR 516, COMPUTER SCIENCE, PURDUE UNIVERSITY
C              JOHN R. RICE, MAY 1, 1985
C
C              REVISED BY JOHN R. RICE AND J. JING, OCT. 1, 1990
C
C
C      *************************************************
C      *      Adapted for FORTRAN D benchmarking       *
C      *    by  T. HAUPT  (haupt@sccs.npac.syr.edu)    *
C      *                                               *
C      *    Northeast Parallel Architectures Center    *
C      *   at Syracuse University, Syracuse, NY, USA   *
C      *************************************************
C
C
C       VERSION MIMD/iPSC860-1.00-HOST   (F77+mp)
C       ==================================================
C
      INCLUDE 'picl_def.h'
      INTEGER KASES,JFUNK,NFUNK
      PARAMETER (KASES=4)
      INTEGER N(KASES)
      DATA N / 8192,16384,65536,262144/
      DATA NFUNK /3/
      INTEGER METH,IFUN,NK
      REAL RESULT,TRUE,A,B,ERROR

      DOUBLE PRECISION HOST_SEC, NODE_SEC, STARTTIME
      INTEGER*4 TIMESIZE, TIMETYPE
      DATA TIMESIZE,TIMETYPE /8,10/
      INTEGER*4 ME,HOST,ALLNODES
      INTEGER*4 NPROCS,TOP,ORD,DIR
      INTEGER*4 INITTYPE
      DATA INITTYPE /1/
      DATA TOP,ORD,DIR,ALLNODES /1,1,1,-1/
C -----------------------------------------------------------
C           parameters of the initial broadcast
C -----------------------------------------------------------
      INTEGER*4 MSG(5),MSGSIZE
      DATA MSGSIZE /20/
      EQUIVALENCE (MSG(1),NK),(MSG(2),A),(MSG(3),B)
      EQUIVALENCE (MSG(4),METH),(MSG(5),IFUN)
C -----------------------------------------------------------
C      parameters of messages with partial results
C -----------------------------------------------------------
      INTEGER*4 PARTTYPE,HTYPE
      DATA PARTTYPE,HTYPE /20,21/
      REAL PSUM(4),H

      WRITE(6,*) 'enter the number of processors'
      READ(5,*) NPROCS
      CALL open0(NPROCS,ME,HOST)
      CALL load0("node14",ALLNODES)
      CALL setarc0(NPROCS, TOP, ORD, DIR)
C      DO  IFUN=1,NFUNK
C     remember: there is corresponding ENDDO (!)
      IFUN=2
      CALL FVALS(A,B,TRUE,IFUN)
      DO  K = 1, KASES
         NK=N(K)
       DO METH=1,3
      STARTTIME=clock0()
       DO MANY=1,50
          CALL bcast0(MSG,MSGSIZE,INITTYPE,HOST)
        CALL recv0(H,4,HTYPE)
        IF(METH.EQ.1) THEN
          CALL gsum0(PSUM,1,4,PARTTYPE,HOST)
          RESULT=(PSUM(1)*2.0+F(A,IFUN)+F(B,IFUN))*H/2.0
        ENDIF
        IF(METH.EQ.2) THEN
          CALL gsum0(PSUM,2,4,PARTTYPE,HOST)
          RESULT=(PSUM(1)*4.0+PSUM(2)*2.0+F(A,IFUN)+F(B,IFUN))*H/3.0
        ENDIF
        IF(METH.EQ.3) THEN
          CALL gsum0(PSUM,3,4,PARTTYPE,HOST)
          RESULT=((PSUM(1)+PSUM(3))*5.0+PSUM(2)*8.0)*H/18.0

        ENDIF

       ENDDO
      HOST_SEC=clock0()-STARTTIME

      CALL recv0(NODE_SEC,TIMESIZE,TIMETYPE)
         ERROR = RESULT - TRUE
         PRINT *, ' '
         PRINT *,'PROBLEM 14 WITH N = ',NK
         PRINT *,'METHOD',METH,' FUNCTION ',IFUN
         PRINT *,'GIVES INTEGRAL ESTIMATE =', RESULT
         PRINT *,'ERROR (ESTIMATE-TRUE VALUE) = ',ERROR
      PRINT *, 'TIME ON NODE 0 =',NODE_SEC,' SECONDS'
      PRINT *, 'TIME ON HOST 0 =',HOST_SEC,' SECONDS'
        ENDDO
       ENDDO
C      ENDDO
C     stop processes on nodes
C
      NK=-1
      CALL bcast0(MSG,MSGSIZE,INITTYPE,HOST)
      CALL close0(1)
      STOP
      END



      FUNCTION F (X,IFUN)
      INTEGER IFUN
      REAL X

      IF (IFUN.EQ.1) F = EXP(X)
      IF (IFUN.EQ.2) F = SQRT(ABS(X-.2345))
      IF (IFUN.EQ.3) F = 1.+X*X+1./(1.+100.*X*X)
      RETURN
      END

      SUBROUTINE FVALS (A,B,TRUE,IFUN)
      IF (IFUN.EQ.1) THEN
         A = 0.
         B = 1.
         TRUE = 1.71828182845
      ENDIF
      IF (IFUN.EQ.2) THEN
         A = 0.
         B = 1.
         TRUE = .5222099422093
      ENDIF
      IF (IFUN.EQ.3) THEN
         A = -1.
         B = 2.
         TRUE = 6.29919656054
      ENDIF
      RETURN
      END


