!
!  Copyright (C) 2003, Northwestern University and Argonne National Laboratory
!  See COPYRIGHT notice in top-level directory.
!
!  $Id$

!
! this test case came from Annette Koonts at PNNL
!
! test creates a dataset with several (large) record variables, but also a
! smaller 'time' record variable.
!
! on 64 bit systems or on BlueGene (where MPI_AINT is 32 bits), this test will
! read the smaller time variable OK, but on systems with a 32 bit MPI_AINT, the
! time variable will be garbled.

       INTEGER FUNCTION XTRIM(STRING)
           CHARACTER*(*) STRING
           INTEGER I, N
           N = LEN(STRING)
           DO I = N, 1, -1
              IF (STRING(I:I) .NE. ' ') GOTO 10
           ENDDO
 10        XTRIM = I
       END ! FUNCTION XTRIM

      program main
      implicit none
      include "mpif.h"
      include "pnetcdf.inc"


! error status return
      integer  iret
! netCDF id
      integer  ncid
! dimension ids
      integer  time_dim
      integer  cells_dim
      integer  interfaces_dim
      integer  XTRIM

! dimension lengths
      integer*8  cells_len
      integer  interfaces_len

      parameter (cells_len = 41943042)
      parameter (interfaces_len = 26)

! variable ids
      integer  time_id
      integer  interfaces_id
      integer  pressure_id

      integer (kind=MPI_OFFSET_KIND) :: longlen

      integer (kind=MPI_OFFSET_KIND) :: start1d(1)
      integer (kind=MPI_OFFSET_KIND) :: count1d(1)

! rank (number of dimensions) for each variable
      integer  time_rank
      integer  interfaces_rank
      integer  pressure_rank

      parameter (time_rank = 1)
      parameter (interfaces_rank = 1)
      parameter (pressure_rank = 3)

! variable shapes
      integer  time_dims(time_rank)
      integer  interfaces_dims(interfaces_rank)
      integer  pressure_dims(pressure_rank)

! data variables
      real  interfaces(interfaces_len)

      integer  myid, err, ierr, n, get_args
      integer  numprocs

      integer*8 i8_size

      integer*8 time_start(1), time_count(1)

      double precision  time(4)
!      data time /0., 20., 40., 60./

      data interfaces /2685.8359, 671.81, 495.91, 425.10001, 393.42999,
     + 377.5, 367.59, 360.06, 353.85999, 348.66, 342.5, 336, 328.5, 320,
     + 310, 300, 290, 280, 270, 260, 250, 240, 230, 220, 210, 199.10001/

      character*256 filename, cmd, msg

! attribute vectors
! enter define mode
!      iret = nf_create('pressure_19010101_000000.nc', OR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)

      call MPI_INIT(ierr)
      call MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
      call MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr)

      if (myid .EQ. 0) then
          filename = "testfile.nc"
          err = get_args(cmd, filename)
      endif
      call MPI_Bcast(err, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
      if (err .EQ. 0) goto 999

      call MPI_Bcast(filename, 256, MPI_CHARACTER, 0, MPI_COMM_WORLD,
     +               ierr)
      call MPI_Bcast(cmd,      256, MPI_CHARACTER, 0, MPI_COMM_WORLD,
     +               ierr)

      iret = nfmpi_create( MPI_COMM_WORLD, filename,
     +                       IOR(NF_CLOBBER,NF_64BIT_DATA),
     +                       MPI_INFO_NULL, ncid)

        call check_err(cmd,"nfmpi_create(): ", iret)

! define dimensions

        iret = nfmpi_def_dim(ncid, 'time', NFMPI_UNLIMITED, time_dim)
        call check_err(cmd,"nfmpi_def_dim(): time ", iret)

        i8_size = 41943042

        iret = nfmpi_def_dim(ncid, 'cells', i8_size, cells_dim)
        call check_err(cmd,"nfmpi_def_dim(): cells ", iret)

        i8_size = 26
        iret = nfmpi_def_dim(ncid, 'interfaces',
     +                       i8_size, interfaces_dim)
        call check_err(cmd,"nfmpi_def_dim(): interfaces ", iret)
! define variables
        time_dims(1) = time_dim

        iret = nfmpi_def_var(ncid, 'time', NF_DOUBLE,
     +                       time_rank, time_dims,
     +                       time_id)
        call check_err(cmd,"nfmpi_def_var(): time ", iret)
        interfaces_dims(1) = interfaces_dim

        iret = nfmpi_def_var(ncid, 'interfaces', NF_REAL,
     +                       interfaces_rank,
     +                       interfaces_dims, interfaces_id)
        call check_err(cmd,"nfmpi_def_var(): interfaces ", iret)

        pressure_dims(3) = time_dim
        pressure_dims(2) = cells_dim
        pressure_dims(1) = interfaces_dim
        iret = nfmpi_def_var(ncid,
     +                     'pressure',
     +                     NF_REAL,
     +                     pressure_rank,
     +                     pressure_dims,
     +                     pressure_id)

        call check_err(cmd,"nfmpi_def_var(): pressure ", iret)
! assign attributes

        longlen = 4
        iret = nfmpi_put_att_text(ncid, time_id, 'long_name',
     +                            longlen, 'Time')
        call check_err(cmd,"nfmpi_put_att_text(): long_name ", iret)
        longlen = 21
        iret = nfmpi_put_att_text(ncid, time_id, 'units',
     +                            longlen,
     +                           'days since 1901-01-01')
        call check_err(cmd,"nfmpi_put_att_text(): units ", iret)

        longlen = 41
        iret = nfmpi_put_att_text(ncid, interfaces_id, 'long_name',
     +                            longlen,
     +                     'Vertical interfaces, in terms of pressure')
        call check_err(cmd,"nfmpi_put_att_text(): long_name ", iret)

        longlen = 2
        iret = nfmpi_put_att_text(ncid, interfaces_id, 'units',
     +                            longlen, 'Pa')
        call check_err(cmd,"nfmpi_put_att_text(): units ", iret)

        longlen = 8
        iret = nfmpi_put_att_text(ncid, pressure_id, 'long_name',
     +                            longlen,
     1                       'Pressure')
        call check_err(cmd,"nfmpi_put_att_text(): ", iret)

        longlen = 2
        iret = nfmpi_put_att_text(ncid, pressure_id, 'units',
     +                            longlen, 'Pa')
        call check_err(cmd,"nfmpi_put_att_text(): units ", iret)

! leave define mode
        iret = nfmpi_enddef(ncid)
        call check_err(cmd,"nfmpi_enddef(): ", iret)

        start1d(1) = 1
        count1d(1) = 26
        if (myid .GT. 0) count1d = 0

! store interfaces
        iret = nfmpi_put_vara_real_all(ncid, interfaces_id,
     +                                 start1d, count1d, interfaces)
        call check_err(cmd,"nfmpi_put_vara_real_all(): ", iret)

        time(1) = 0.0
        time(2) = 20.0
        time(3) = 40.0
        time(4) = 60.0

! this test is tricky because it writes out the time variable one at a time.
! This element-at-a-time workload does not actually exercise the tricky 32 bit
! MPI_AINT problem, so the issue only shows up at read time.

        do n = 1, 4
          time_start(1) = n
          if(myid .eq. 0) then
            time_count(1) = 1
          else
            time_count(1) = 0
          endif

          iret = nfmpi_put_vara_double_all(ncid, time_id,
     +                                     time_start, time_count,
     +                                     time(n))
          call check_err(cmd,"nfmpi_put_vara_double_all(): ", iret)
        enddo

        iret = nfmpi_close(ncid)

        call MPI_Barrier (MPI_COMM_WORLD, iret)

! todo: insert code to re-open dataset, read time variable all at once
!
      iret = nfmpi_open ( MPI_COMM_SELF,
     +                   filename,
     +                   IOR(NF_CLOBBER,NF_64BIT_DATA),
     +                   MPI_INFO_NULL,
     +                   ncid)
      call check_err(cmd,"nfmpi_open(): ", iret)

      iret = nfmpi_inq_varid(ncid, 'time', time_id);
      call check_err(cmd,"nfmpi_inq_varid(): time ", iret)

      ! deliberately want all processes to end up with the full time array
      time_start(1) = 1
      time_count(1) = 4
      iret = nfmpi_get_vara_double_all(ncid, time_id,
     +                               time_start, time_count, time);
      call check_err(cmd,"nfmpi_get_vara_double_all(): ", iret)

      iret = nfmpi_close(ncid)
      call check_err(cmd,"nfmpi_close(): ", iret)

!     write(6,*) "Time array: ", time
!      if ( (time(1) .eq. 0) .and. (time(2) .eq. 20.0)
!     &             .and. (time(3) .eq. 40.0) .and. (time(4) .eq. 60))
!           write(6,*) " No Errors"
!      else
!           write(6,*) "Error: time array was ", time
!      endif

      msg = '*** TESTING F77 '//cmd(1:XTRIM(cmd))//' for NF_64BIT_DATA'
      if (myid .eq. 0) call pass_fail(0, msg)

 999  call MPI_FINALIZE(ierr)
      end ! program main

      subroutine writerecs(cmd,ncid,time_id)

      implicit none
      include "mpif.h"
      include "pnetcdf.inc"

      character*(*) cmd
! netCDF id
      integer  ncid
! variable ids
      integer  time_id

! error status return
      integer  iret
      integer  n

! netCDF dimension sizes for dimensions used with record variables
      integer  cells_len
      parameter (cells_len = 41943042)
      integer  interfaces_len
      parameter (interfaces_len = 26)

! rank (number of dimensions) for each variable
      integer  time_rank
      integer  pressure_rank
      parameter (time_rank = 1)
      parameter (pressure_rank = 3)
! starts and counts for array sections of record variables
      integer*8 time_start(1), time_count(1)

! data variables

      integer  time_nr
      parameter (time_nr = 4)

      integer  pressure_nr
      parameter (pressure_nr = 1)
!      real  pressure(interfaces_len, cells_len, pressure_nr)

      double precision  time(time_nr)
      data time /0., 20., 40., 60./


!      pressure = NF_FILL_FLOAT

! store time

      do n = 1, 4
        time_start(1) = n
        time_count(1) = 1
        iret = nfmpi_put_vara_double_all(ncid, time_id,
     +                                   time_start, time_count,
     +                                   time)

        call check_err(cmd,"nfmpi_put_vara_double_all(): ", iret)
      enddo

      end ! subroutine writerecs

      subroutine check_err(cmd, msg, iret)

      include "pnetcdf.inc"

      character*(*) cmd, msg
      integer iret
      integer  XTRIM

      if (iret .ne. NF_NOERR) then
          print *, msg, nfmpi_strerror(iret)
          msg = '*** TESTING F77 '//cmd(1:XTRIM(cmd))//
     +          ' for NF_64BIT_DATA'
          call pass_fail(1, msg)
          stop 2
      endif
      end ! subroutine check_err
