gcc/testsuite/gfortran.dg/coarray_36.f

   1 ! { dg-do compile }
   2 ! { dg-options "-fcoarray=lib" }
   3 !
   4 ! PR fortran/64771
   5 !
   6 ! Contributed by Alessandro Fanfarill
   7 !
   8 ! Reduced version of the full NAS CG benchmark
   9 !
  10
  11 !-------------------------------------------------------------------------!
  12 !                                                                         !
  13 !        N  A  S     P A R A L L E L     B E N C H M A R K S  3.3         !
  14 !                                                                         !
  15 !                                   C G                                   !
  16 !                                                                         !
  17 !-------------------------------------------------------------------------!
  18 !                                                                         !
  19 !    This benchmark is part of the NAS Parallel Benchmark 3.3 suite.      !
  20 !    It is described in NAS Technical Reports 95-020 and 02-007           !
  21 !                                                                         !
  22 !    Permission to use, copy, distribute and modify this software         !
  23 !    for any purpose with or without fee is hereby granted.  We           !
  24 !    request, however, that all derived work reference the NAS            !
  25 !    Parallel Benchmarks 3.3. This software is provided "as is"           !
  26 !    without express or implied warranty.                                 !
  27 !                                                                         !
  28 !    Information on NPB 3.3, including the technical report, the          !
  29 !    original specifications, source code, results and information        !
  30 !    on how to submit new results, is available at:                       !
  31 !                                                                         !
  32 !           http://www.nas.nasa.gov/Software/NPB/                         !
  33 !                                                                         !
  34 !    Send comments or suggestions to  npb@nas.nasa.gov                    !
  35 !                                                                         !
  36 !          NAS Parallel Benchmarks Group                                  !
  37 !          NASA Ames Research Center                                      !
  38 !          Mail Stop: T27A-1                                              !
  39 !          Moffett Field, CA   94035-1000                                 !
  40 !                                                                         !
  41 !          E-mail:  npb@nas.nasa.gov                                      !
  42 !          Fax:     (650) 604-3957                                        !
  43 !                                                                         !
  44 !-------------------------------------------------------------------------!
  45
  46
  47 c---------------------------------------------------------------------
  48 c
  49 c Authors: M. Yarrow
  50 c          C. Kuszmaul
  51 c          R. F. Van der Wijngaart
  52 c          H. Jin
  53 c
  54 c---------------------------------------------------------------------
  55
  56
  57 c---------------------------------------------------------------------
  58 c---------------------------------------------------------------------
  59       program cg
  60 c---------------------------------------------------------------------
  61 c---------------------------------------------------------------------
  62       implicit none
  63
  64       integer            na, nonzer, niter
  65       double precision   shift, rcond
  66       parameter(  na=75000,
  67      >     nonzer=13,
  68      >     niter=75,
  69      >     shift=60.,
  70      >     rcond=1.0d-1 )
  71
  72
  73
  74       integer num_proc_rows, num_proc_cols
  75       parameter( num_proc_rows = 2, num_proc_cols = 2)
  76       integer    num_procs
  77       parameter( num_procs = num_proc_cols * num_proc_rows )
  78
  79       integer    nz
  80       parameter( nz = na*(nonzer+1)/num_procs*(nonzer+1)+nonzer
  81      >              + na*(nonzer+2+num_procs/256)/num_proc_cols )
  82
  83       common / partit_size  /  naa, nzz,
  84      >                         npcols, nprows,
  85      >                         proc_col, proc_row,
  86      >                         firstrow,
  87      >                         lastrow,
  88      >                         firstcol,
  89      >                         lastcol,
  90      >                         exch_proc,
  91      >                         exch_recv_length,
  92      >                         send_start,
  93      >                         send_len
  94       integer                  naa, nzz,
  95      >                         npcols, nprows,
  96      >                         proc_col, proc_row,
  97      >                         firstrow,
  98      >                         lastrow,
  99      >                         firstcol,
 100      >                         lastcol,
 101      >                         exch_proc,
 102      >                         exch_recv_length,
 103      >                         send_start,
 104      >                         send_len
 105
 106
 107       common / main_int_mem /  colidx,     rowstr,
 108      >                         iv,         arow,     acol
 109       integer                  colidx(nz), rowstr(na+1),
 110      >                         iv(2*na+1), arow(nz), acol(nz)
 111
 112
 113 c---------------------------------
 114 c     Coarray Decalarations
 115 c---------------------------------
 116       double precision         v(na+1)[0:*], aelt(nz)[0:*], a(nz)[0:*],
 117      >                         x(na/num_proc_rows+2)[0:*],
 118      >                         z(na/num_proc_rows+2)[0:*],
 119      >                         p(na/num_proc_rows+2)[0:*],
 120      >                         q(na/num_proc_rows+2)[0:*],
 121      >                         r(na/num_proc_rows+2)[0:*],
 122      >                         w(na/num_proc_rows+2)[0:*]
 123
 124
 125       common /urando/          amult, tran
 126       double precision         amult, tran
 127
 128
 129
 130       integer            l2npcols
 131       integer            reduce_exch_proc(num_proc_cols)
 132       integer            reduce_send_starts(num_proc_cols)
 133       integer            reduce_send_lengths(num_proc_cols)
 134       integer            reduce_recv_lengths(num_proc_cols)
 135       integer            reduce_rrecv_starts(num_proc_cols)
 136 c---------------------------------
 137 c     Coarray Decalarations
 138 c---------------------------------
 139       integer            reduce_recv_starts(num_proc_cols)[0:*]
 140
 141       integer            i, j, k, it, me, nprocs, root
 142
 143       double precision   zeta, randlc
 144       external           randlc
 145       double precision   rnorm
 146 c---------------------------------
 147 c     Coarray Decalarations
 148 c---------------------------------
 149       double precision   norm_temp1(2)[0:*], norm_temp2(2)[0:*]
 150
 151       double precision   t, tmax, mflops
 152       double precision   u(1), umax(1)
 153       external           timer_read
 154       double precision   timer_read
 155       character          class
 156       logical            verified
 157       double precision   zeta_verify_value, epsilon, err
 158
 159 c---------------------------------------------------------------------
 160 c  Explicit interface for conj_grad, due to coarray args
 161 c---------------------------------------------------------------------
 162       interface
 163
 164       subroutine conj_grad ( colidx,
 165      >                       rowstr,
 166      >                       x,
 167      >                       z,
 168      >                       a,
 169      >                       p,
 170      >                       q,
 171      >                       r,
 172      >                       w,
 173      >                       rnorm,
 174      >                       l2npcols,
 175      >                       reduce_exch_proc,
 176      >                       reduce_send_starts,
 177      >                       reduce_send_lengths,
 178      >                       reduce_recv_starts,
 179      >                       reduce_recv_lengths,
 180      >                       reduce_rrecv_starts )
 181
 182       common / partit_size  /  naa, nzz,
 183      >                         npcols, nprows,
 184      >                         proc_col, proc_row,
 185      >                         firstrow,
 186      >                         lastrow,
 187      >                         firstcol,
 188      >                         lastcol,
 189      >                         exch_proc,
 190      >                         exch_recv_length,
 191      >                         send_start,
 192      >                         send_len
 193
 194       integer                  naa, nzz,
 195      >                         npcols, nprows,
 196      >                         proc_col, proc_row,
 197      >                         firstrow,
 198      >                         lastrow,
 199      >                         firstcol,
 200      >                         lastcol,
 201      >                         exch_proc,
 202      >                         exch_recv_length,
 203      >                         send_start,
 204      >                         send_len
 205
 206       double precision   x(*),
 207      >                   z(*),
 208      >                   a(nzz)
 209       integer            colidx(nzz), rowstr(naa+1)
 210
 211       double precision   p(*),
 212      >                   q(*)[0:*],
 213      >                   r(*)[0:*],
 214      >                   w(*)[0:*]        ! used as work temporary
 215
 216       integer   l2npcols
 217       integer   reduce_exch_proc(l2npcols)
 218       integer   reduce_send_starts(l2npcols)
 219       integer   reduce_send_lengths(l2npcols)
 220       integer   reduce_recv_starts(l2npcols)[0:*]
 221       integer   reduce_recv_lengths(l2npcols)
 222       integer   reduce_rrecv_starts(l2npcols)
 223
 224       double precision   rnorm
 225
 226       end subroutine
 227
 228       end interface
 229
 230 c---------------------------------------------------------------------
 231 c  The call to the conjugate gradient routine:
 232 c---------------------------------------------------------------------
 233          call conj_grad ( colidx,
 234      >                    rowstr,
 235      >                    x,
 236      >                    z,
 237      >                    a,
 238      >                    p,
 239      >                    q,
 240      >                    r,
 241      >                    w,
 242      >                    rnorm,
 243      >                    l2npcols,
 244      >                    reduce_exch_proc,
 245      >                    reduce_send_starts,
 246      >                    reduce_send_lengths,
 247      >                    reduce_recv_starts,
 248      >                    reduce_recv_lengths,
 249      >                    reduce_rrecv_starts )
 250
 251
 252       sync all
 253
 254       end                              ! end main
 255
 256 c---------------------------------------------------------------------
 257 c---------------------------------------------------------------------
 258       subroutine conj_grad ( colidx,
 259      >                       rowstr,
 260      >                       x,
 261      >                       z,
 262      >                       a,
 263      >                       p,
 264      >                       q,
 265      >                       r,
 266      >                       w,
 267      >                       rnorm,
 268      >                       l2npcols,
 269      >                       reduce_exch_proc,
 270      >                       reduce_send_starts,
 271      >                       reduce_send_lengths,
 272      >                       reduce_recv_starts,
 273      >                       reduce_recv_lengths,
 274      >                       reduce_rrecv_starts )
 275 c---------------------------------------------------------------------
 276 c---------------------------------------------------------------------
 277
 278 c---------------------------------------------------------------------
 279 c  Floaging point arrays here are named as in NPB1 spec discussion of
 280 c  CG algorithm
 281 c---------------------------------------------------------------------
 282
 283       implicit none
 284
 285 c      include 'cafnpb.h'
 286
 287       common / partit_size  /  naa, nzz,
 288      >                         npcols, nprows,
 289      >                         proc_col, proc_row,
 290      >                         firstrow,
 291      >                         lastrow,
 292      >                         firstcol,
 293      >                         lastcol,
 294      >                         exch_proc,
 295      >                         exch_recv_length,
 296      >                         send_start,
 297      >                         send_len
 298       integer                  naa, nzz,
 299      >                         npcols, nprows,
 300      >                         proc_col, proc_row,
 301      >                         firstrow,
 302      >                         lastrow,
 303      >                         firstcol,
 304      >                         lastcol,
 305      >                         exch_proc,
 306      >                         exch_recv_length,
 307      >                         send_start,
 308      >                         send_len
 309
 310
 311
 312       double precision   x(*),
 313      >                   z(*),
 314      >                   a(nzz)
 315       integer            colidx(nzz), rowstr(naa+1)
 316
 317       double precision   p(*),
 318      >                   q(*)[0:*],
 319      >                   r(*)[0:*],
 320      >                   w(*)[0:*]        ! used as work temporary
 321
 322       integer   l2npcols
 323       integer   reduce_exch_proc(l2npcols)
 324       integer   reduce_send_starts(l2npcols)
 325       integer   reduce_send_lengths(l2npcols)
 326       integer   reduce_recv_starts(l2npcols)[0:*]
 327       integer   reduce_recv_lengths(l2npcols)
 328       integer   reduce_rrecv_starts(l2npcols)
 329
 330       integer   recv_start_idx, recv_end_idx, send_start_idx,
 331      >          send_end_idx, recv_length
 332
 333       integer   i, j, k, ierr
 334       integer   cgit, cgitmax
 335
 336       double precision, save :: d[0:*], rho[0:*]
 337       double precision   sum, rho0, alpha, beta, rnorm
 338
 339       external         timer_read
 340       double precision timer_read
 341
 342       data      cgitmax / 25 /
 343
 344
 345       return
 346       end                       ! end of routine conj_grad
 347