Subversion Repositories openrisc

! { dg-do compile }

! { dg-require-effective-target vect_double }

module lfk_prec

 integer, parameter :: dp=kind(1.d0)

end module lfk_prec

!***********************************************

SUBROUTINE kernel(tk)

!***********************************************************************

!                                                                      *

!            KERNEL     executes 24 samples of Fortran computation     *

!               TK(1) - total cpu time to execute only the 24 kernels. *

!               TK(2) - total Flops executed by the 24 Kernels         *

!***********************************************************************

!                                                                      *

!     L. L. N. L.   F O R T R A N   K E R N E L S:   M F L O P S       *

!                                                                      *

!   These kernels measure  Fortran  numerical  computation rates for a *

!   spectrum of  CPU-limited  computational  structures.  Mathematical *

!   through-put is measured  in  units  of  millions of floating-point *

!   operations executed per Second, called Mega-Flops/Sec.             *

!                                                                      *

!   This program  measures  a realistic  CPU performance range for the *

!   Fortran programming system  on  a  given day.  The CPU performance *

!   rates depend  strongly  on  the maturity of the Fortran compiler's *

!   ability to translate Fortran code into efficient machine code.     *

!   [ The CPU hardware  capability  apart  from  compiler maturity (or *

!   availability), could be measured (or simulated) by programming the *

!   kernels in assembly  or machine code directly.  These measurements *

!   can also  serve  as a framework for tracking the maturation of the *

!   Fortran compiler during system development.]                       *

!                                                                      *

!     Fonzi's Law: There is not now and there never will be a language *

!                  in which it is the least bit difficult to write     *

!                  bad programs.                                       *

!                                                    F.H.MCMAHON  1972 *

!***********************************************************************

!     l1 :=  param-dimension governs the size of most 1-d arrays

!     l2 :=  param-dimension governs the size of most 2-d arrays

!     Loop :=  multiple pass control to execute kernel long enough to ti

!    me.

!     n  :=  DO loop control for each kernel.  Controls are set in subr.

!     SIZES

!     ******************************************************************

use lfk_prec

implicit double precision  (a-h,o-z)

!IBM  IMPLICIT  REAL*8           (A-H,O-Z)

REAL(kind=dp), INTENT(inout)                        :: tk

INTEGER :: test !!,AND

COMMON/alpha/mk,ik,im,ml,il,mruns,nruns,jr,iovec,npfs(8,3,47)

COMMON/beta/tic,times(8,3,47),see(5,3,8,3),terrs(8,3,47),csums(8,3  &

    ,47),fopn(8,3,47),dos(8,3,47)

COMMON/spaces/ion,j5,k2,k3,loop1,laps,loop,m,kr,lp,n13h,ibuf,nx,l,  &

    npass,nfail,n,n1,n2,n13,n213,n813,n14,n16,n416,n21,nt1,nt2,last,idebug  &

    ,mpy,loop2,mucho,mpylim,intbuf(16)

COMMON/spacer/a11,a12,a13,a21,a22,a23,a31,a32,a33,ar,br,c0,cr,di,dk  &

    ,dm22,dm23,dm24,dm25,dm26,dm27,dm28,dn,e3,e6,expmax,flx,q,qa,r,ri  &

    ,s,scale,sig,stb5,t,xnc,xnei,xnm

COMMON/space0/time(47),csum(47),ww(47),wt(47),ticks,fr(9),terr1(47  &

    ),sumw(7),start,skale(47),bias(47),ws(95),total(47),flopn(47),iq(7  &

    ),npf,npfs1(47)

COMMON/spacei/wtp(3),mul(3),ispan(47,3),ipass(47,3)

!     ******************************************************************

INTEGER :: e,f,zone

COMMON/ispace/e(96),f(96),ix(1001),ir(1001),zone(300)

COMMON/space1/u(1001),v(1001),w(1001),x(1001),y(1001),z(1001),g(1001)  &

    ,du1(101),du2(101),du3(101),grd(1001),dex(1001),xi(1001),ex(1001)  &

    ,ex1(1001),dex1(1001),vx(1001),xx(1001),rx(1001),rh(2048),vsp(101)  &

    ,vstp(101),vxne(101),vxnd(101),ve3(101),vlr(101),vlin(101),b5(101)  &

    ,plan(300),d(300),sa(101),sb(101)

COMMON/space2/p(4,512),px(25,101),cx(25,101),vy(101,25),vh(101,7),  &

    vf(101,7),vg(101,7),vs(101,7),za(101,7),zp(101,7),zq(101,7),zr(101  &

    ,7),zm(101,7),zb(101,7),zu(101,7),zv(101,7),zz(101,7),b(64,64),c(64,64)  &

    ,h(64,64),u1(5,101,2),u2(5,101,2),u3(5,101,2)

!     ******************************************************************

dimension zx(1023),xz(447,3),tk(6),mtmp(1)

EQUIVALENCE(zx(1),z(1)),(xz(1,1),x(1))

double precision temp

logical ltmp

!     ******************************************************************

!     STANDARD PRODUCT COMPILER DIRECTIVES MAY BE USED FOR OPTIMIZATION

CALL trace('KERNEL  ')

CALL SPACE

mpy= 1

mpysav= mpylim

loop2= 1

mpylim= loop2

l= 1

loop= 1

lp= loop

it0= test(0)

loop2= mpysav

mpylim= loop2

do

!***********************************************************************

!***  KERNEL 1      HYDRO FRAGMENT

!***********************************************************************

  x(:n)= q+y(:n)*(r*zx(11:n+10)+t*zx(12:n+11))

IF(test(1) <= 0)THEN

  EXIT

END IF

END DO

do

!                   we must execute    DO k= 1,n  repeatedly for accurat

!    e timing

!***********************************************************************

!***  KERNEL 2      ICCG EXCERPT (INCOMPLETE CHOLESKY - CONJUGATE GRADIE

!    NT)

!***********************************************************************

ii= n

ipntp= 0

do while(ii >  1)

ipnt= ipntp

ipntp= ipntp+ii

ii= ishft(ii,-1)

i= ipntp+1

!dir$ vector always

       x(ipntp+2:ipntp+ii+1)=x(ipnt+2:ipntp:2)-v(ipnt+2:ipntp:2) &

     &*x(ipnt+1:ipntp-1:2)-v(ipnt+3:ipntp+1:2)*x(ipnt+3:ipntp+1:2)

END DO

IF(test(2) <= 0)THEN

  EXIT

END IF

END DO

do

!***********************************************************************

!***  KERNEL 3      INNER PRODUCT

!***********************************************************************

q= dot_product(z(:n),x(:n))

IF(test(3) <= 0)THEN

  EXIT

END IF

END DO

m= (1001-7)/2

!***********************************************************************

!***  KERNEL 4      BANDED LINEAR EQUATIONS

!***********************************************************************

fw= 1.000D-25

do

!dir$ vector always

 xz(6,:3)= y(5)*(xz(6,:3)+matmul(y(5:n:5), xz(:n/5,:3)))

IF(test(4) <= 0)THEN

  EXIT

END IF

END DO

do

!***********************************************************************

!***  KERNEL 5      TRI-DIAGONAL ELIMINATION, BELOW DIAGONAL (NO VECTORS

!    )

!***********************************************************************

tmp= x(1)

DO i= 2,n

  tmp= z(i)*(y(i)-tmp)

  x(i)= tmp

END DO

IF(test(5) <= 0)THEN

  EXIT

END IF

END DO

do

!***********************************************************************

!***  KERNEL 6      GENERAL LINEAR RECURRENCE EQUATIONS

!***********************************************************************

DO i= 2,n

  w(i)= 0.0100D0+dot_product(b(i,:i-1),w(i-1:1:-1))

END DO

IF(test(6) <= 0)THEN

  EXIT

END IF

END DO

do

!***********************************************************************

!***  KERNEL 7      EQUATION OF STATE FRAGMENT

!***********************************************************************

  x(:n)= u(:n)+r*(z(:n)+r*y(:n))+t*(u(4:n+3)+r*(u(3:n+2)+r*u(2:n+1))+t*(  &

      u(7:n+6)+q*(u(6:n+5)+q*u(5:n+4))))

IF(test(7) <= 0)THEN

  EXIT

END IF

END DO

do

!***********************************************************************

!***  KERNEL 8      A.D.I. INTEGRATION

!***********************************************************************

nl1= 1

nl2= 2

fw= 2.000D0

  DO ky= 2,n

DO kx= 2,3

    du1ky= u1(kx,ky+1,nl1)-u1(kx,ky-1,nl1)

    du2ky= u2(kx,ky+1,nl1)-u2(kx,ky-1,nl1)

    du3ky= u3(kx,ky+1,nl1)-u3(kx,ky-1,nl1)

    u1(kx,ky,nl2)= u1(kx,ky,nl1)+a11*du1ky+a12*du2ky+a13  &

        *du3ky+sig*(u1(kx+1,ky,nl1)-fw*u1(kx,ky,nl1)+u1(kx-1,ky,nl1))

    u2(kx,ky,nl2)= u2(kx,ky,nl1)+a21*du1ky+a22*du2ky+a23  &

        *du3ky+sig*(u2(kx+1,ky,nl1)-fw*u2(kx,ky,nl1)+u2(kx-1,ky,nl1))

    u3(kx,ky,nl2)= u3(kx,ky,nl1)+a31*du1ky+a32*du2ky+a33  &

        *du3ky+sig*(u3(kx+1,ky,nl1)-fw*u3(kx,ky,nl1)+u3(kx-1,ky,nl1))

  END DO

END DO

IF(test(8) <= 0)THEN

  EXIT

END IF

END DO

do

!***********************************************************************

!***  KERNEL 9      INTEGRATE PREDICTORS

!***********************************************************************

  px(1,:n)= dm28*px(13,:n)+px(3,:n)+dm27*px(12,:n)+dm26*px(11,:n)+dm25*px(10  &

      ,:n)+dm24*px(9,:n)+dm23*px(8,:n)+dm22*px(7,:n)+c0*(px(5,:n)+px(6,:n))

IF(test(9) <= 0)THEN

  EXIT

END IF

END DO

do

!***********************************************************************

!***  KERNEL 10     DIFFERENCE PREDICTORS

!***********************************************************************

!dir$ unroll(2)

          do k= 1,n

              br= cx(5,k)-px(5,k)

              px(5,k)= cx(5,k)

              cr= br-px(6,k)

              px(6,k)= br

              ar= cr-px(7,k)

              px(7,k)= cr

              br= ar-px(8,k)

              px(8,k)= ar

              cr= br-px(9,k)

              px(9,k)= br

              ar= cr-px(10,k)

              px(10,k)= cr

              br= ar-px(11,k)

              px(11,k)= ar

              cr= br-px(12,k)

              px(12,k)= br

              px(14,k)= cr-px(13,k)

              px(13,k)= cr

            enddo

IF(test(10) <= 0)THEN

  EXIT

END IF

END DO

do

!***********************************************************************

!***  KERNEL 11     FIRST SUM.   PARTIAL SUMS.              (NO VECTORS)

!***********************************************************************

temp= 0

DO k= 1,n

  temp= temp+y(k)

  x(k)= temp

END DO

IF(test(11) <= 0)THEN

  EXIT

END IF

END DO

do

!***********************************************************************

!***  KERNEL 12     FIRST DIFF.

!***********************************************************************

  x(:n)= y(2:n+1)-y(:n)

IF(test(12) <= 0)THEN

  EXIT

END IF

END DO

fw= 1.000D0

!***********************************************************************

!***  KERNEL 13      2-D PIC   Particle In Cell

!***********************************************************************

do

! rounding modes for integerizing make no difference here

          do k= 1,n

              i1= 1+iand(int(p(1,k)),63)

              j1= 1+iand(int(p(2,k)),63)

              p(3,k)= p(3,k)+b(i1,j1)

              p(1,k)= p(1,k)+p(3,k)

              i2= iand(int(p(1,k)),63)

              p(1,k)= p(1,k)+y(i2+32)

              p(4,k)= p(4,k)+c(i1,j1)

              p(2,k)= p(2,k)+p(4,k)

              j2= iand(int(p(2,k)),63)

              p(2,k)= p(2,k)+z(j2+32)

              i2= i2+e(i2+32)

              j2= j2+f(j2+32)

              h(i2,j2)= h(i2,j2)+fw

            enddo

IF(test(13) <= 0)THEN

  EXIT

END IF

END DO

fw= 1.000D0

!***********************************************************************

!***  KERNEL 14      1-D PIC   Particle In Cell

!***********************************************************************

do

  ix(:n)= grd(:n)

!dir$ ivdep

  vx(:n)= ex(ix(:n))-ix(:n)*dex(ix(:n))

  ir(:n)= vx(:n)+flx

  rx(:n)= vx(:n)+flx-ir(:n)

  ir(:n)= iand(ir(:n),2047)+1

  xx(:n)= rx(:n)+ir(:n)

DO k= 1,n

      rh(ir(k))= rh(ir(k))+fw-rx(k)

      rh(ir(k)+1)= rh(ir(k)+1)+rx(k)

END DO

IF(test(14) <= 0)THEN

  EXIT

END IF

END DO

do

!***********************************************************************

!***  KERNEL 15     CASUAL FORTRAN.  DEVELOPMENT VERSION.

!***********************************************************************

!       CASUAL ORDERING OF SCALAR OPERATIONS IS TYPICAL PRACTICE.

!       THIS EXAMPLE DEMONSTRATES THE NON-TRIVIAL TRANSFORMATION

!       REQUIRED TO MAP INTO AN EFFICIENT MACHINE IMPLEMENTATION.

ng= 7

nz= n

ar= 0.05300D0

br= 0.07300D0

!$omp parallel do private(t,j,k,r,s,i,ltmp) if(nz>98)

do j= 2,ng-1

  do k= 2,nz

    i= merge(k-1,k,vf(k,j) <  vf((k-1),j))

    t= merge(br,ar,vh(k,(j+1)) <= vh(k,j))

    r= MAX(vh(i,j),vh(i,j+1))

    s= vf(i,j)

    vy(k,j)= t/s*SQRT(vg(k,j)**2+r*r)

    if(k < nz)then

        ltmp=vf(k,j) >= vf(k,(j-1))

        i= merge(j,j-1,ltmp)

        t= merge(ar,br,ltmp)

        r= MAX(vg(k,i),vg(k+1,i))

        s= vf(k,i)

        vs(k,j)= t/s*SQRT(vh(k,j)**2+r*r)

    endif

  END do

  vs(nz,j)= 0.0D0

END do

  vy(2:nz,ng)= 0.0D0

IF(test(15) <= 0)THEN

  EXIT

END IF

END DO

ii= n/3

!***********************************************************************

!***  KERNEL 16     MONTE CARLO SEARCH LOOP

!***********************************************************************

lb= ii+ii

k2= 0

k3= 0

do

DO m= 1,zone(1)

  j2= (n+n)*(m-1)+1

  DO k= 1,n

    k2= k2+1

    j4= j2+k+k

    j5= zone(j4)

    IF(j5 >= n)THEN

      IF(j5 == n)THEN

        EXIT

      END IF

      k3= k3+1

      IF(d(j5) <  d(j5-1)*(t-d(j5-2))**2+(s-d(j5-3))**2+ (r-d(j5-4))**2)THEN

        go to 200

      END IF

      IF(d(j5) == d(j5-1)*(t-d(j5-2))**2+(s-d(j5-3))**2+ (r-d(j5-4))**2)THEN

        EXIT

      END IF

    ELSE

      IF(j5-n+lb <  0)THEN

        IF(plan(j5) <  t)THEN

          go to 200

        END IF

        IF(plan(j5) == t)THEN

          EXIT

        END IF

      ELSE

        IF(j5-n+ii <  0)THEN

          IF(plan(j5) <  s)THEN

            go to 200

          END IF

          IF(plan(j5) == s)THEN

            EXIT

          END IF

        ELSE

          IF(plan(j5) <  r)THEN

            go to 200

          END IF

          IF(plan(j5) == r)THEN

            EXIT

          END IF

        END IF

      END IF

    END IF

    IF(zone(j4-1) <= 0)THEN

      go to 200

    END IF

  END DO

  EXIT

  200             IF(zone(j4-1) == 0)THEN

    EXIT

  END IF

END DO

IF(test(16) <= 0)THEN

  EXIT

END IF

END DO

dw= 5.0000D0/3.0000D0

!***********************************************************************

!***  KERNEL 17     IMPLICIT, CONDITIONAL COMPUTATION       (NO VECTORS)

!***********************************************************************

!         RECURSIVE-DOUBLING VECTOR TECHNIQUES CAN NOT BE USED

!         BECAUSE CONDITIONAL OPERATIONS APPLY TO EACH ELEMENT.

fw= 1.0000D0/3.0000D0

tw= 1.0300D0/3.0700D0

do

scale= dw

rtmp= fw

e6= tw

DO k= n,2,-1

  e3= rtmp*vlr(k)+vlin(k)

  xnei= vxne(k)

  vxnd(k)= e6

  xnc= scale*e3

!                                      SELECT MODEL

  IF(max(rtmp,xnei) <= xnc)THEN

!                                      LINEAR MODEL

    ve3(k)= e3

    rtmp= e3+e3-rtmp

    vxne(k)= e3+e3-xnei

  ELSE

    rtmp= rtmp*vsp(k)+vstp(k)

!                                      STEP MODEL

    vxne(k)= rtmp

    ve3(k)= rtmp

  END IF

    e6= rtmp

END DO

xnm= rtmp

IF(test(17) <= 0)THEN

  EXIT

END IF

END DO

do

!***********************************************************************

!***  KERNEL 18     2-D EXPLICIT HYDRODYNAMICS FRAGMENT

!***********************************************************************

t= 0.003700D0

s= 0.004100D0

kn= 6

jn= n

  zb(2:jn,2:kn)=(zr(2:jn,2:kn)+zr(2:jn,:kn-1))/(zm(2:jn,2:kn)+zm(:jn-1,2:kn)) &

        *(zp(:jn-1,2:kn)-zp(2:jn,2:kn)+(zq(:jn-1,2:kn)-zq(2:jn,2:kn)))

  za(2:jn,2:kn)=(zr(2:jn,2:kn)+zr(:jn-1,2:kn))/(zm(:jn-1,2:kn)+zm(:jn-1,3:kn+1))  &

        *(zp(:jn-1,3:kn+1)-zp(:jn-1,2:kn)+(zq(:jn-1,3:kn+1)-zq(:jn-1,2:kn)))

  zu(2:jn,2:kn)= zu(2:jn,2:kn)+ &

        s*(za(2:jn,2:kn)*(zz(2:jn,2:kn)-zz(3:jn+1,2:kn)) &

        -za(:jn-1,2:kn)*(zz(2:jn,2:kn)-zz(:jn-1,2:kn)) &

        -zb(2:jn,2:kn)*(zz(2:jn,2:kn)-zz(2:jn,:kn-1))+ &

        zb(2:jn,3:kn+1)*(zz(2:jn, 2:kn)-zz(2:jn,3:kn+1)))

  zv(2:jn,2:kn)= zv(2:jn,2:kn)+ &

        s*(za(2:jn,2:kn)*(zr(2:jn,2:kn)-zr(3:jn+1,2:kn)) &

        -za(:jn-1,2:kn)*(zr(2:jn,2:kn)-zr(:jn-1,2:kn)) &

        -zb(2:jn,2:kn)*(zr(2:jn,2:kn)-zr(2:jn,:kn-1))+ &

        zb(2:jn,3:kn+1)*(zr(2:jn, 2:kn)-zr(2:jn,3:kn+1)))

  zr(2:jn,2:kn)= zr(2:jn,2:kn)+t*zu(2:jn,2:kn)

  zz(2:jn,2:kn)= zz(2:jn,2:kn)+t*zv(2:jn,2:kn)

IF(test(18) <= 0)THEN

  EXIT

END IF

END DO

do

!***********************************************************************

!***  KERNEL 19      GENERAL LINEAR RECURRENCE EQUATIONS    (NO VECTORS)

!***********************************************************************

kb5i= 0

DO k= 1,n

  b5(k+kb5i)= sa(k)+stb5*sb(k)

  stb5= b5(k+kb5i)-stb5

END DO

DO k= n,1,-1

  b5(k+kb5i)= sa(k)+stb5*sb(k)

  stb5= b5(k+kb5i)-stb5

END DO

IF(test(19) <= 0)THEN

  EXIT

END IF

END DO

dw= 0.200D0

!***********************************************************************

!***  KERNEL 20     DISCRETE ORDINATES TRANSPORT: RECURRENCE (NO VECTORS

!***********************************************************************

do

rtmp= xx(1)

DO k= 1,n

  di= y(k)*(rtmp+dk)-g(k)

  dn=merge( max(s,min(z(k)*(rtmp+dk)/di,t)),dw,di /= 0.0)

  x(k)= ((w(k)+v(k)*dn)*rtmp+u(k))/(vx(k)+v(k)*dn)

  rtmp= ((w(k)-vx(k))*rtmp+u(k))*DN/(vx(k)+v(k)*dn)+ rtmp

 xx(k+1)= rtmp

END DO

IF(test(20) <= 0)THEN

  EXIT

END IF

END DO

do

!***********************************************************************

!***  KERNEL 21     MATRIX*MATRIX PRODUCT

!***********************************************************************

    px(:25,:n)= px(:25,:n)+matmul(vy(:25,:25),cx(:25,:n))

IF(test(21) <= 0)THEN

  EXIT

END IF

END DO

expmax= 20.0000D0

!***********************************************************************

!***  KERNEL 22     PLANCKIAN DISTRIBUTION

!***********************************************************************

!      EXPMAX= 234.500d0

fw= 1.00000D0

u(n)= 0.99000D0*expmax*v(n)

do

  y(:n)= u(:n)/v(:n)

  w(:n)= x(:n)/(EXP(y(:n))-fw)

IF(test(22) <= 0)THEN

  EXIT

END IF

END DO

fw= 0.17500D0

!***********************************************************************

!***  KERNEL 23     2-D IMPLICIT HYDRODYNAMICS FRAGMENT

!***********************************************************************

do

      DO k= 2,n

         do j=2,6

             za(k,j)= za(k,j)+fw*(za(k,j+1)*zr(k,j)-za(k,j)+            &

     &          zv(k,j)*za(k-1,j)+(zz(k,j)+za(k+1,j)*                   &

     &          zu(k,j)+za(k,j-1)*zb(k,j)))

      END DO

    END DO

IF(test(23) <= 0)THEN

  EXIT

END IF

END DO

x(n/2)= -1.000D+10

!***********************************************************************

!***  KERNEL 24     FIND LOCATION OF FIRST MINIMUM IN ARRAY

!***********************************************************************

!      X( n/2)= -1.000d+50

do

 m= minloc(x(:n),DIM=1)

IF(test(24) == 0)THEN

  EXIT

END IF

END DO

sum= 0.00D0

som= 0.00D0

DO k= 1,mk

  sum= sum+time(k)

  times(jr,il,k)= time(k)

  terrs(jr,il,k)= terr1(k)

  npfs(jr,il,k)= npfs1(k)

  csums(jr,il,k)= csum(k)

  dos(jr,il,k)= total(k)

  fopn(jr,il,k)= flopn(k)

  som= som+flopn(k)*total(k)

END DO

tk(1)= tk(1)+sum

tk(2)= tk(2)+som

!                        Dumpout Checksums:  file "chksum"

!     WRITE ( 7,706) jr, il

! 706 FORMAT(1X,2I3)

!     WRITE ( 7,707) ( CSUM(k), k= 1,mk)

! 707 FORMAT(5X,'&',1PE23.16,',',1PE23.16,',',1PE23.16,',')

CALL track('KERNEL  ')

RETURN

END SUBROUTINE kernel

! { dg-final { scan-tree-dump-times "vectorized 19 loops" 1 "vect" } }

! { dg-final { cleanup-tree-dump "vect" } }

! { dg-final { cleanup-modules "lfk_prec" } }