text:
MODULE ezcdf_GenPut
   USE ezcdf_opncls
   USE ezcdf_inqvar

   ! Generic Interface to Write netcdf data Variables
   ! 03/10/99 C. Ludescher
   ! C. Ludescher/A. Pletzer Tue Apr  4 10:11:33 EDT 2000
   ! + support for complex numbers (ap) Wed May 16 15:18:05 EDT 2001
   ! added support for logicals (sph) Oct 1, 2002
   IMPLICIT NONE
!DEC$ IF DEFINED (NETCDF)

   !
   ! C. Ludescher/A. Pletzer Tue Apr  4 10:11:33 EDT 2000
   !
   ! added support (ap) Wed May 16 15:06:34 EDT 2001
   PUBLIC :: cdfw_3i, cdfw_3l, cdfw_3d, cdfw_3c16, cdfw_3f, cdfw_3c8,  &
        & cdfw_2i, cdfw_2l, cdfw_2d, cdfw_2c16, cdfw_2f, cdfw_2c8, cdfw_2c, &
        & cdfw_1i, cdfw_1l, cdfw_1d, cdfw_1c16, cdfw_1f, cdfw_1c8, cdfw_1c, &
        & cdfw_0i, cdfw_0l, cdfw_0d, cdfw_0c16, cdfw_0f, cdfw_0c8,          &
        & cdfPutVar, cdf_write

   ! cdf_write is an alias of cdfPutVar (required by ifc compiler)
   INTERFACE cdf_write
      MODULE PROCEDURE cdfw_3i, cdfw_3l, cdfw_3d, cdfw_3c16, cdfw_3f, cdfw_3c8, &
         cdfw_2i, cdfw_2l, cdfw_2d, cdfw_2c16, cdfw_2f, cdfw_2c8, cdfw_2c, &
         cdfw_1i, cdfw_1l, cdfw_1d, cdfw_1c16, cdfw_1f, cdfw_1c8, cdfw_1c, &
         cdfw_0i, cdfw_0l, cdfw_0d, cdfw_0c16, cdfw_0f, cdfw_0c8
   END INTERFACE

   ! same as above (Intel compiler does not handle well aliases)
   INTERFACE cdfPutVar
      MODULE PROCEDURE cdfw_3i, cdfw_3l, cdfw_3d, cdfw_3c16, cdfw_3f, cdfw_3c8, &
         cdfw_2i, cdfw_2l, cdfw_2d, cdfw_2c16, cdfw_2f, cdfw_2c8, cdfw_2c, &
         cdfw_1i, cdfw_1l, cdfw_1d, cdfw_1c16, cdfw_1f, cdfw_1c8, cdfw_1c, &
         cdfw_0i, cdfw_0l, cdfw_0d, cdfw_0c16, cdfw_0f, cdfw_0c8
   END INTERFACE

   PUBLIC :: cdfDefVar, cdf_define,                                          &
        & cdfd_3i, cdfd_3l, cdfd_3d, cdfd_3c16, cdfd_3f, cdfd_3c8,          &
        & cdfd_2i, cdfd_2l, cdfd_2d, cdfd_2c16, cdfd_2f, cdfd_2c8, cdfd_2c, &
        & cdfd_1i, cdfd_1l, cdfd_1d, cdfd_1c16, cdfd_1f, cdfd_1c8, cdfd_1c, &
        & cdfd_0i, cdfd_0l, cdfd_0d, cdfd_0c16, cdfd_0f, cdfd_0c8

   INTERFACE cdf_define
      MODULE PROCEDURE cdfDefVar, &
         cdfd_3i, cdfd_3l, cdfd_3d, cdfd_3c16, cdfd_3f, cdfd_3c8, &
         cdfd_2i, cdfd_2l, cdfd_2d, cdfd_2c16, cdfd_2f, cdfd_2c8, cdfd_2c, &
         cdfd_1i, cdfd_1l, cdfd_1d, cdfd_1c16, cdfd_1f, cdfd_1c8, cdfd_1c, &
         cdfd_0i, cdfd_0l, cdfd_0d, cdfd_0c16, cdfd_0f, cdfd_0c8
   END INTERFACE

   PRIVATE
   include "netcdf.inc"

   INTEGER, PARAMETER :: r4 = SELECTED_REAL_KIND(6, 37)
   INTEGER, PARAMETER :: r8 = SELECTED_REAL_KIND(12, 100)
   CHARACTER*13, parameter :: cmplx_name = '__CmPlx_Re_Im'

   CHARACTER(len=nf_max_name)  :: varnam_noalpha
   PRIVATE :: r4, r8, cmplx_name, varnam_noalpha

   EXTERNAL handle_err

CONTAINS
!-----------------------------------------------------------------
!cdfPutVar implementation routines

   SUBROUTINE cdfw_3i(ncid, varnam, varval, ier)
      !     Write 3 dimensional Integer data array
      !     Use cdfDefVar to define the Variable
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      integer, dimension(:, :, :), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer, dimension(3) :: st = (/1, 1, 1/)
      integer, dimension(3) :: dimlens
      integer               :: varid, ndims, sts
      if (PRESENT(ier)) ier = 1
      sts = nf_enddef(ncid)
      call cdfInqV(ncid, varnam, varid, dimlens, ndims, sts)
      if (sts /= 0) return
      if (ndims /= 3) then
         print "('% cdfPutVar_3i: --E-- The variable ',a,               &
              &         ' was defined as',i2,' dimensional')", varnam, ndims
         return
      end if
      sts = nf_put_vara_int(ncid, varid, st, dimlens, varval)
      call handle_err(sts, varnam, 'cdfPutVar_3i', 'nf_put_vara_int')
      if (PRESENT(ier)) ier = sts
   END SUBROUTINE cdfw_3i

   SUBROUTINE cdfw_3l(ncid, varnam, varval, ier)
      !     Write 3 dimensional logical array
      !     Use cdfDefVar to define the Variable
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      logical, dimension(:, :, :), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer                                :: sts
      integer, allocatable, dimension(:, :, :) :: varval_i
      character*11, parameter :: logical_name = '__logical__'

      ALLOCATE (varval_i(size(varval, 1), size(varval, 2), size(varval, 3)), stat=sts)
      if (sts /= 0) stop 'Allocation error in cdf_putvar'

      WHERE (varval)
         varval_i = 1
      ELSEWHERE
         varval_i = 0
      END WHERE

      call cdfw_3i(ncid, trim(varnam)//logical_name, varval_i, ier)

      DEALLOCATE (varval_i)
   END SUBROUTINE cdfw_3l

   SUBROUTINE cdfw_3d(ncid, varnam, varval, ier)
      !     Write 3 dimensional 64-bit Real data array
      !     Use cdfDefVar to define the Variable
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      REAL(KIND=r8), dimension(:, :, :), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer, dimension(3) :: st = (/1, 1, 1/)
      integer, dimension(3) :: dimlens
      integer               :: varid, ndims, sts
      if (PRESENT(ier)) ier = 1
      sts = nf_enddef(ncid)
      call cdfInqV(ncid, varnam, varid, dimlens, ndims, sts)
      if (sts /= 0) return
      if (ndims /= 3) then
         print "('% cdfPutVar_3d: --E-- The variable ',a,               &
              &         ' was defined as',i2,' dimensional')", varnam, ndims
         return
      end if
      sts = nf_put_vara_double(ncid, varid, st, dimlens, varval)
      call handle_err(sts, varnam, 'cdf_3d', 'nf_put_vara_double')
      if (PRESENT(ier)) ier = sts
   END SUBROUTINE cdfw_3d

   SUBROUTINE cdfw_3c16(ncid, varnam, varval, ier)
      !     Write 3 dimensional 128-bit complex data array
      !     Use cdfDefVar to define the Variable
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      COMPLEX(KIND=r8), dimension(:, :, :), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer, dimension(3) :: st = (/1, 1, 1/)
      integer, dimension(3) :: dimlens
      integer               :: varid, ndims, sts

      if (PRESENT(ier)) ier = 1
      sts = nf_enddef(ncid)
      call cdfInqV(ncid, trim(varnam)//cmplx_name, varid, dimlens, ndims, sts)
      if (sts /= 0) return
      if (ndims /= 3) then
         print "('% cdfPutVar_3c16: --E-- The variable ',a,               &
              &         ' was defined as',i2,' dimensional')", varnam, ndims
         return
      end if
      sts = nf_put_vara_double(ncid, varid, st, dimlens, varval)
      call handle_err(sts, varnam, 'cdf_3c16', 'nf_put_vara_double')
      if (PRESENT(ier)) ier = sts
   END SUBROUTINE cdfw_3c16

   SUBROUTINE cdfw_3f(ncid, varnam, varval, ier)
      !     Write 3 dimensional default Real data array
      !     Use cdfDefVar to define the Variable
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      REAL(KIND=r4), dimension(:, :, :), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer, dimension(3) :: st = (/1, 1, 1/)
      integer, dimension(3) :: dimlens
      integer               :: varid, ndims, sts
      if (PRESENT(ier)) ier = 1
      sts = nf_enddef(ncid)
      call cdfInqV(ncid, varnam, varid, dimlens, ndims, sts)
      if (sts /= 0) return
      if (ndims /= 3) then
         print "('% cdfPutVar_3f: --E-- The variable ',a,               &
              &         ' was defined as',i2,' dimensional')", varnam, ndims
         return
      end if
      sts = nf_put_vara_real(ncid, varid, st, dimlens, varval)
      call handle_err(sts, varnam, 'cdf_3f', 'nf_put_vara_real')
      if (PRESENT(ier)) ier = sts
   END SUBROUTINE cdfw_3f

   SUBROUTINE cdfw_3c8(ncid, varnam, varval, ier)
      !     Write 3 dimensional complex*8 data array
      !     Use cdfDefVar to define the Variable
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      COMPLEX(KIND=r4), dimension(:, :, :), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer, dimension(3) :: st = (/1, 1, 1/)
      integer, dimension(3) :: dimlens
      integer               :: varid, ndims, sts

      if (PRESENT(ier)) ier = 1
      sts = nf_enddef(ncid)
      call cdfInqV(ncid, trim(varnam)//cmplx_name, varid, dimlens, ndims, sts)
      if (sts /= 0) return
      if (ndims /= 3) then
         print "('% cdfPutVar_3c8: --E-- The variable ',a,               &
              &         ' was defined as',i2,' dimensional')", varnam, ndims
         return
      end if
      sts = nf_put_vara_real(ncid, varid, st, dimlens, varval)
      call handle_err(sts, varnam, 'cdf_3c8', 'nf_put_vara_real')
      if (PRESENT(ier)) ier = sts
   END SUBROUTINE cdfw_3c8

   SUBROUTINE cdfw_2i(ncid, varnam, varval, ier)
      !     Write 2 dimensional Integer data array
      !     Use cdfDefVar to define the Variable
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      integer, dimension(:, :), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer, dimension(2) :: st = (/1, 1/)
      integer, dimension(2) :: dimlens
      integer               :: varid, ndims, sts
      if (PRESENT(ier)) ier = 1
      sts = nf_enddef(ncid)
      call cdfInqV(ncid, varnam, varid, dimlens, ndims, sts)
      if (sts /= 0) return
      if (ndims /= 2) then
         print "('% cdfPutVar_2i: --E-- The variable ',a,               &
              &         ' was defined as',i2,' dimensional')", varnam, ndims
         return
      end if
      sts = nf_put_vara_int(ncid, varid, st, dimlens, varval)
      call handle_err(sts, varnam, 'cdfPutVar_2i', 'nf_put_vara_int')
      if (PRESENT(ier)) ier = sts
   END SUBROUTINE cdfw_2i

   SUBROUTINE cdfw_2l(ncid, varnam, varval, ier)
      !     Write 2 dimensional logical array
      !     Use cdfDefVar to define the Variable
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      logical, dimension(:, :), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer                              :: sts
      integer, allocatable, dimension(:, :) :: varval_i
      character*11, parameter :: logical_name = '__logical__'

      ALLOCATE (varval_i(size(varval, 1), size(varval, 2)), stat=sts)
      if (sts /= 0) stop 'Allocation error in cdf_putvar'

      WHERE (varval)
         varval_i = 1
      ELSEWHERE
         varval_i = 0
      END WHERE

      call cdfw_2i(ncid, trim(varnam)//logical_name, varval_i, ier)

      DEALLOCATE (varval_i)
   END SUBROUTINE cdfw_2l

   SUBROUTINE cdfw_2d(ncid, varnam, varval, ier)
      !     Write 2 dimensional 64-bit Real data array
      !     Use cdfDefVar to define the Variable
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      REAL(KIND=r8), dimension(:, :), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer, dimension(2) :: st = (/1, 1/)
      integer, dimension(2) :: dimlens
      integer               :: varid, ndims, sts
      if (PRESENT(ier)) ier = 1
      sts = nf_enddef(ncid)
      call cdfInqV(ncid, varnam, varid, dimlens, ndims, sts)
      if (sts /= 0) return
      if (ndims /= 2) then
         print "('% cdfPutVar_2d: --E-- The variable ',a,               &
              &         ' was defined as',i2,' dimensional')", varnam, ndims
         return
      end if
      sts = nf_put_vara_double(ncid, varid, st, dimlens, varval)
      call handle_err(sts, varnam, 'cdf_2d', 'nf_put_vara_double')
      if (PRESENT(ier)) ier = sts
   END SUBROUTINE cdfw_2d

   SUBROUTINE cdfw_2c16(ncid, varnam, varval, ier)
      !     Write 2 dimensional 128-bit complex data array
      !     Use cdfDefVar to define the Variable
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      COMPLEX(KIND=r8), dimension(:, :), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer, dimension(2) :: st = (/1, 1/)
      integer, dimension(2) :: dimlens
      integer               :: varid, ndims, sts

      if (PRESENT(ier)) ier = 1
      sts = nf_enddef(ncid)
      call cdfInqV(ncid, trim(varnam)//cmplx_name, varid, dimlens, ndims, sts)
      if (sts /= 0) return
      if (ndims /= 2) then
         print "('% cdfPutVar_2c16: --E-- The variable ',a,               &
              &         ' was defined as',i2,' dimensional')", varnam, ndims
         return
      end if
      sts = nf_put_vara_double(ncid, varid, st, dimlens, varval)
      call handle_err(sts, varnam, 'cdf_2c16', 'nf_put_vara_double')
      if (PRESENT(ier)) ier = sts
   END SUBROUTINE cdfw_2c16

   SUBROUTINE cdfw_2f(ncid, varnam, varval, ier)
      !     Write 2 dimensional default Real data array
      !     Use cdfDefVar to define the Variable
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      REAL(KIND=r4), dimension(:, :), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer, dimension(2) :: st = (/1, 1/)
      integer, dimension(2) :: dimlens
      integer               :: varid, ndims, sts
      if (PRESENT(ier)) ier = 1
      sts = nf_enddef(ncid)
      call cdfInqV(ncid, varnam, varid, dimlens, ndims, sts)
      if (sts /= 0) return
      if (ndims /= 2) then
         print "('% cdfPutVar_2f: --E-- The variable ',a,               &
              &         ' was defined as',i2,' dimensional')", varnam, ndims
         return
      end if
      sts = nf_put_vara_real(ncid, varid, st, dimlens, varval)
      call handle_err(sts, varnam, 'cdf_2f', 'nf_put_vara_real')
      if (PRESENT(ier)) ier = sts
   END SUBROUTINE cdfw_2f

   SUBROUTINE cdfw_2c8(ncid, varnam, varval, ier)
      !     Write 2 dimensional complex*8 data array
      !     Use cdfDefVar to define the Variable
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      COMPLEX(KIND=r4), dimension(:, :), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer, dimension(2) :: st = (/1, 1/)
      integer, dimension(2) :: dimlens
      integer               :: varid, ndims, sts

      if (PRESENT(ier)) ier = 1
      sts = nf_enddef(ncid)
      call cdfInqV(ncid, trim(varnam)//cmplx_name, varid, dimlens, ndims, sts)
      if (sts /= 0) return
      if (ndims /= 2) then
         print "('% cdfPutVar_2c8: --E-- The variable ',a,               &
              &         ' was defined as',i2,' dimensional')", varnam, ndims
         return
      end if
      sts = nf_put_vara_real(ncid, varid, st, dimlens, varval)
      call handle_err(sts, varnam, 'cdf_2c8', 'nf_put_vara_real')
      if (PRESENT(ier)) ier = sts
   END SUBROUTINE cdfw_2c8

   SUBROUTINE cdfw_2c(ncid, varnam, varval, ier)
      !     Write 2 dimensional character array
      !     Use cdfDefVar to define the Variable
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      character*(*), dimension(:), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer, dimension(2) :: st = (/1, 1/)
      integer, dimension(2) :: dimlens
      integer               :: varid, ndims, sts
      if (PRESENT(ier)) ier = 1
      sts = nf_enddef(ncid)
      call cdfInqV(ncid, varnam, varid, dimlens, ndims, sts)
      if (sts /= 0) return
      if (ndims /= 2) then
         print "('% cdfPutVar_2c: --E-- The variable ',a,               &
              &         ' was defined as',i2,' dimensional')", varnam, ndims
         return
      end if
      sts = nf_put_vara_text(ncid, varid, st, dimlens, varval)
      call handle_err(sts, varnam, 'cdfPutVar_2c', 'nf_put_var_text')
      if (PRESENT(ier)) ier = sts
   END SUBROUTINE cdfw_2c

   SUBROUTINE cdfw_1i(ncid, varnam, varval, ier)
      !     write 1 dimensional Integer array
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      integer, dimension(:), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer, dimension(1) :: dimlens
      integer               :: varid, ndims, sts
      if (PRESENT(ier)) ier = 1
      sts = nf_enddef(ncid)
      call cdfInqV(ncid, varnam, varid, dimlens, ndims, sts)
      if (sts /= 0) return
      if (ndims /= 1) then
         print "('% cdfPutVar_1i: --E-- The variable ',a,               &
              &         ' was defined as',i2,' dimensional')", varnam, ndims
         return
      end if
      sts = nf_put_var_int(ncid, varid, varval)
      call handle_err(sts, varnam, 'cdfPutVar_1i', 'nf_put_var_int')
      if (PRESENT(ier)) ier = sts
   END SUBROUTINE cdfw_1i

   SUBROUTINE cdfw_1l(ncid, varnam, varval, ier)
      !     Write 1 dimensional logical array
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      logical, dimension(:), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer                            :: sts
      integer, allocatable, dimension(:) :: varval_i
      character*11, parameter :: logical_name = '__logical__'

      ALLOCATE (varval_i(size(varval, 1)), stat=sts)
      if (sts /= 0) stop 'Allocation error in cdf_putvar'

      WHERE (varval)
         varval_i = 1
      ELSEWHERE
         varval_i = 0
      END WHERE

      call cdfw_1i(ncid, trim(varnam)//logical_name, varval_i, ier)

      DEALLOCATE (varval_i)
   END SUBROUTINE cdfw_1l

   SUBROUTINE cdfw_1d(ncid, varnam, varval, ier)
      !     Write 1 dimensional 64-bit data array
      !     Use cdfDefVar to define the Variable
      !
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      REAL(KIND=r8), dimension(:), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer, dimension(1) :: dimlens
      integer               :: varid, ndims, sts
      if (PRESENT(ier)) ier = 1
      sts = nf_enddef(ncid)
      call cdfInqV(ncid, varnam, varid, dimlens, ndims, sts)
      if (sts /= 0) return
      if (ndims /= 1) then
         print "('% cdfPutVar_1d: --E-- The variable ',a,               &
              &         ' was defined as',i2,' dimensional')", varnam, ndims
         return
      end if
      sts = nf_put_var_double(ncid, varid, varval)
      call handle_err(sts, varnam, 'cdfPurVar_1d', 'nf_put_var_double')
      if (PRESENT(ier)) ier = sts
   END SUBROUTINE cdfw_1d

   SUBROUTINE cdfw_1c16(ncid, varnam, varval, ier)
      !     Write 1 dimensional 128-bit complex data array
      !     Use cdfDefVar to define the Variable
      !
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      COMPLEX(KIND=r8), dimension(:), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer, dimension(1) :: dimlens
      integer               :: varid, ndims, sts

      if (PRESENT(ier)) ier = 1
      sts = nf_enddef(ncid)
      call cdfInqV(ncid, trim(varnam)//cmplx_name, varid, dimlens, ndims, sts)
      if (sts /= 0) return
      if (ndims /= 1) then
         print "('% cdfPutVar_1c16: --E-- The variable ',a,               &
              &         ' was defined as',i2,' dimensional')", varnam, ndims
         return
      end if
      sts = nf_put_var_double(ncid, varid, varval)
      call handle_err(sts, varnam, 'cdfPurVar_1c16', 'nf_put_var_double')
      if (PRESENT(ier)) ier = sts
   END SUBROUTINE cdfw_1c16

   SUBROUTINE cdfw_1f(ncid, varnam, varval, ier)
      !     Write 1 dimensional default real array
      !     Use cdfDefVar to define the Variable
      !
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      REAL(KIND=r4), dimension(:), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer, dimension(1) :: dimlens
      integer               :: varid, ndims, sts
      if (PRESENT(ier)) ier = 1
      sts = nf_enddef(ncid)
      call cdfInqV(ncid, varnam, varid, dimlens, ndims, sts)
      if (sts /= 0) return
      if (ndims /= 1) then
         print "('% cdfPutVar_1f: --E-- The variable ',a,               &
              &         ' was defined as',i2,' dimensional')", varnam, ndims
         return
      end if
      sts = nf_put_var_real(ncid, varid, varval)
      call handle_err(sts, varnam, 'cdfPurVar_1f', 'nf_put_var_real')
      if (PRESENT(ier)) ier = sts
   END SUBROUTINE cdfw_1f

   SUBROUTINE cdfw_1c8(ncid, varnam, varval, ier)
      !     Write 1 dimensional complex*8 array
      !     Use cdfDefVar to define the Variable
      !
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      COMPLEX(KIND=r4), dimension(:), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer, dimension(1) :: dimlens
      integer               :: varid, ndims, sts

      if (PRESENT(ier)) ier = 1
      sts = nf_enddef(ncid)
      call cdfInqV(ncid, trim(varnam)//cmplx_name, varid, dimlens, ndims, sts)
      if (sts /= 0) return
      if (ndims /= 1) then
         print "('% cdfPutVar_1c8: --E-- The variable ',a,               &
              &         ' was defined as',i2,' dimensional')", varnam, ndims
         return
      end if
      sts = nf_put_var_real(ncid, varid, varval)
      call handle_err(sts, varnam, 'cdfPurVar_1c8', 'nf_put_var_real')
      if (PRESENT(ier)) ier = sts
   END SUBROUTINE cdfw_1c8

   SUBROUTINE cdfw_1c(ncid, varnam, varval, ier)
      !     Write 1 dimensional character data array
      !     Use cdfDefVar to define the Variable
      !
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      character*(*), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer, dimension(1) :: dimlens
      integer               :: varid, ndims, sts
      if (PRESENT(ier)) ier = 1
      sts = nf_enddef(ncid)
      call cdfInqV(ncid, varnam, varid, dimlens, ndims, sts)
      if (sts /= 0) return
      if (ndims /= 1) then
         print "('% cdfPutVar_1c: --E-- The variable ',a,               &
              &         ' was defined as',i2,' dimensional')", varnam, ndims
         return
      end if
      sts = nf_put_var_text(ncid, varid, varval)
      call handle_err(sts, varnam, 'cdfPutVar_1c', 'nf_put_var_text')
      if (PRESENT(ier)) ier = sts
   END SUBROUTINE cdfw_1c

   SUBROUTINE cdfw_0i(ncid, varnam, varval, ier)
      !     write integer scalar
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      integer, intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer, dimension(1) :: dimlens
      integer               :: varid, ndims, sts
      if (PRESENT(ier)) ier = 1
      sts = nf_enddef(ncid)
      call cdfInqV(ncid, varnam, varid, dimlens, ndims, sts)
      if (sts /= 0) return
      if (ndims /= 0) then
         print "('% cdfPutVar_0i: --E-- The variable ',a,               &
              &         ' was defined as',i2,' dimensional')", varnam, ndims
         return
      end if
      sts = nf_put_var_int(ncid, varid, varval)
      call handle_err(sts, varnam, 'cdfPutVar_0i', 'nf_put_var_int')
      if (PRESENT(ier)) ier = sts
   END SUBROUTINE cdfw_0i

   SUBROUTINE cdfw_0l(ncid, varnam, varval, ier)
      !     Write logical scalar
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      logical, intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer                         :: varval_i
      character*11, parameter :: logical_name = '__logical__'

      IF (varval) THEN
         varval_i = 1
      ELSE
         varval_i = 0
      END IF

      call cdfw_0i(ncid, trim(varnam)//logical_name, varval_i, ier)

   END SUBROUTINE cdfw_0l

   SUBROUTINE cdfw_0d(ncid, varnam, varval, ier)
      !     Write Real*8 Scalar
      !
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      REAL(KIND=r8), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer, dimension(1) :: dimlens
      integer               :: varid, ndims, sts
      if (PRESENT(ier)) ier = 1
      sts = nf_enddef(ncid)
      call cdfInqV(ncid, varnam, varid, dimlens, ndims, sts)
      if (sts /= 0) return
      if (ndims /= 0) then
         print "('% cdfPutVar_0d: --E-- The variable ',a,               &
              &         ' was defined as',i2,' dimensional')", varnam, ndims
         return
      end if
      sts = nf_put_var_double(ncid, varid, varval)
      call handle_err(sts, varnam, 'cdfPutVar_0d', 'nf_put_var_double')
      if (PRESENT(ier)) ier = sts
   END SUBROUTINE cdfw_0d

   SUBROUTINE cdfw_0c16(ncid, varnam, varval, ier)
      !     Write Complex*16 Scalar
      !
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      COMPLEX(KIND=r8), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer, dimension(1) :: dimlens
      integer               :: varid, ndims, sts

      if (PRESENT(ier)) ier = 1
      sts = nf_enddef(ncid)
      call cdfInqV(ncid, trim(varnam)//cmplx_name, varid, dimlens, ndims, sts)
      if (sts /= 0) return
      if (ndims /= 1) then ! scalar complex stored as 2 element real array
         print "('% cdfPutVar_0c16: --E-- The variable ',a,               &
              &         ' was defined as',i2,' dimensional')", varnam, ndims
         return
      end if
      sts = nf_put_var_double(ncid, varid, varval)
      call handle_err(sts, varnam, 'cdfPutVar_0c16', 'nf_put_var_double')
      if (PRESENT(ier)) ier = sts
   END SUBROUTINE cdfw_0c16

   SUBROUTINE cdfw_0f(ncid, varnam, varval, ier)
      !     Write default real
      !
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      REAL(KIND=r4), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer, dimension(1) :: dimlens
      integer               :: varid, ndims, sts
      if (PRESENT(ier)) ier = 1
      sts = nf_enddef(ncid)
      call cdfInqV(ncid, varnam, varid, dimlens, ndims, sts)
      if (sts /= 0) return
      if (ndims /= 0) then
         print "('% cdfPutVar_0f: --E-- The variable ',a,               &
              &         ' was defined as',i2,' dimensional')", varnam, ndims
         return
      end if
      sts = nf_put_var_real(ncid, varid, varval)
      call handle_err(sts, varnam, 'cdfPutVar_0f', 'nf_put_var_real')
      if (PRESENT(ier)) ier = sts
   END SUBROUTINE cdfw_0f

   SUBROUTINE cdfw_0c8(ncid, varnam, varval, ier)
      !     Write complex*8
      !
      implicit none
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      complex(KIND=r4), intent(in) :: varval
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer, dimension(1) :: dimlens
      integer               :: varid, ndims, sts

      if (PRESENT(ier)) ier = 1
      sts = nf_enddef(ncid)
      call cdfInqV(ncid, trim(varnam)//cmplx_name, varid, dimlens, ndims, sts)
      if (sts /= 0) return
      if (ndims /= 1) then
         print "('% cdfPutVar_0c8: --E-- The variable ',a,               &
              &         ' was defined as',i2,' dimensional')", varnam, ndims
         return
      end if
      sts = nf_put_var_real(ncid, varid, varval)
      call handle_err(sts, varnam, 'cdfPutVar_0c8', 'nf_put_var_real')
      if (PRESENT(ier)) ier = sts
   END SUBROUTINE cdfw_0c8

!------------------------------------------------------------------
! cdfDefVar implementation routines

   subroutine cdfDefVar(ncid, varnam, dimlens, xtype, ier, dimname)
      ! Define a Variable and its dimensions
      ! 03/08/99 C. Ludescher
      ! C. Ludescher/A. Pletzer Tue Apr  4 10:11:33 EDT 2000
      ! added support for complex types (ap) Wed May 16 15:06:34 EDT 2001
      ! added support for logical type Oct 1 2002 (SPH)

      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in)  :: ncid
      character*(*), intent(in)  :: varnam
      integer, dimension(:), intent(in)  :: dimlens
      character*(*), intent(in)  :: xtype
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      integer                 :: ndims, varid, vartype, maxdims
      integer                 :: i, n, status
      integer, dimension(3)   :: dimids
      character*(nf_max_name) :: dimnams(3)
      character*(5)           :: zdim
      character*(9)           :: zdim1
      character*(*), parameter :: cmplx_name = '__CmPlx_Re_Im'
      character*(*), parameter :: logical_name = '__logical__'
      logical :: is_complex, is_logical

      integer dims(3)
      integer flag

      is_complex = .FALSE.
      is_logical = .FALSE.

      if (PRESENT(ier)) ier = 1
      status = 0

      dims = dimlens
      if (xtype == 'R8' .or. xtype == 'r8') then
         vartype = nf_double
      else if (xtype == 'C16' .or. xtype == 'c16') then
         ! complex array = real array with double leading length
         vartype = nf_double
         is_complex = .TRUE.
         dims(1) = 2 * abs(dimlens(1))
      else if (xtype == 'INT' .or. xtype == 'int') then
         vartype = nf_int
      else if (xtype == 'LOG' .or. xtype == 'log' .or. xtype == 'BOOL' .or. xtype == 'bool') then
         vartype = nf_int !if nf_byte, MUST use integer*1
         is_logical = .TRUE.
      else if (xtype == 'R4' .or. xtype == 'r4') then
         vartype = nf_float
      else if (xtype == 'C8' .or. xtype == 'c8') then
         ! complex array = real array with double leading length
         vartype = nf_float
         is_complex = .TRUE.
         dims(1) = 2 * abs(dimlens(1))
      else if (xtype == 'CHAR' .or. xtype == 'char') then
         vartype = nf_char
      end if

      ! The normal behavior is to decrement the rank if all
      ! sizes to the right are 1. However, in some cases it
      ! may be desirable to keep this dimension, in which the
      ! user needs to pass -1 as dimension.

      ndims = size(dims)
      n = ndims
      flag = 1
      do i = n, 1, -1
         if ((dims(i) == 1 .or. dims(i) == 0) .and. flag == 1) then
            ndims = i - 1
         else
            flag = 0
         end if
         dims(i) = abs(dims(i))
      end do

      ! Check ndims <= maxdims
      if (xtype == 'CHAR' .or. xtype == 'char') then
         maxdims = 2
      else
         maxdims = 3
      end if
      if (ndims > maxdims) then
         WRITE (*, 10) ndims, xtype
10       format('% cdfDefVar --E--  Rank', i3, ' not supported for ', a)
         return
      end if

      do i = 1, ndims
         if (dims(i) > 999999999) then
            print *, '% cdfDefVar --E-- dimension >= 1.e9 not supported'
            return
         else if (dims(i) < 100000) then
            write (zdim, '(i5.5)') dims(i)
            dimnams(i) = 'dim_'//zdim
         else
            write (zdim1, '(i9.9)') dims(i)
            dimnams(i) = 'dim_'//zdim1
         end if
         if (PRESENT(dimname)) then
            if (SIZE(dimname) >= i) then
               if (LEN_TRIM(dimname(i)) > 0) dimnams(i) = dimname(i)
            end if
         end if
         status = nf_inq_dimid(ncid, dimnams(i), dimids(i))
         if (status /= nf_noerr) then
            status = nf_def_dim(ncid, dimnams(i), dims(i), dimids(i))
            call handle_err(status, dimnams(i), 'cdfdef', 'nf_def_dim')
         end if
      end do

      if (status /= 0) return

      ! replace any embedded blanks or non-alphanumeric characters with underscores
      varnam_noalpha = varnam
      CALL alpha_numeric(varnam_noalpha)
      ! do some name mangling to keep track of complex and
      ! logical types
      if (is_complex) varnam_noalpha = trim(varnam_noalpha)//cmplx_name
      if (is_logical) varnam_noalpha = trim(varnam_noalpha)//logical_name

      status = nf_def_var(ncid, varnam_noalpha, vartype, ndims, dimids, varid)

      call handle_err(status, varnam, 'cdfDefVar', 'nf_def_var')
      if (PRESENT(ier)) ier = status
   end subroutine cdfDefVar

   SUBROUTINE cdfd_3i(ncid, varnam, varval, ier, dimname)
      !     define 3 dimensional Integer data array
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      integer, dimension(:, :, :), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*3             :: vartype
      integer                 :: dims(3)

      vartype = 'INT'
      dims = -shape(varval)
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_3i

   SUBROUTINE cdfd_2i(ncid, varnam, varval, ier, dimname)
      !     define 2 dimensional Integer data array
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      integer, dimension(:, :), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*3             :: vartype
      integer                 :: dims(3)

      vartype = 'INT'
      dims = (/-shape(varval), 1/)
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_2i

   SUBROUTINE cdfd_1i(ncid, varnam, varval, ier, dimname)
      !     define 1 dimensional Integer data array
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      integer, dimension(:), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*3             :: vartype
      integer                 :: dims(3)

      vartype = 'INT'
      dims = (/-shape(varval), 1, 1/)
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_1i

   SUBROUTINE cdfd_0i(ncid, varnam, varval, ier, dimname)
      !     define scalar Integer
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      integer, intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*3             :: vartype
      integer                 :: dims(3)

      vartype = 'INT'
      dims = 0
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_0i

   SUBROUTINE cdfd_3l(ncid, varnam, varval, ier, dimname)
      !     define 3 dimensional logical array
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      logical, dimension(:, :, :), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*4             :: vartype
      integer                 :: dims(3)

      vartype = 'LOG'
      dims = -shape(varval)
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_3l

   SUBROUTINE cdfd_2l(ncid, varnam, varval, ier, dimname)
      !     define 2 dimensional logical array
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      logical, dimension(:, :), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*3            :: vartype
      integer                 :: dims(3)

      vartype = 'LOG'
      dims = (/-shape(varval), 1/)
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_2l

   SUBROUTINE cdfd_1l(ncid, varnam, varval, ier, dimname)
      !     define 1 dimensional logical array
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      logical, dimension(:), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*3            :: vartype
      integer                 :: dims(3)

      vartype = 'LOG'
      dims = (/-shape(varval), 1, 1/)
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_1l

   SUBROUTINE cdfd_0l(ncid, varnam, varval, ier, dimname)
      !     define scalar logical
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      logical, intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*3            :: vartype
      integer                 :: dims(3)

      vartype = 'LOG'
      dims = 0
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_0l

   SUBROUTINE cdfd_3d(ncid, varnam, varval, ier, dimname)
      !     define 3 dimensional double data array
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      REAL(kind=r8), dimension(:, :, :), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*2             :: vartype
      integer                 :: dims(3)

      vartype = 'R8'
      dims = -shape(varval)
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_3d

   SUBROUTINE cdfd_2d(ncid, varnam, varval, ier, dimname)
      !     define 2 dimensional double data array
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      REAL(kind=r8), dimension(:, :), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*2             :: vartype
      integer                 :: dims(3)

      vartype = 'R8'
      dims = (/-shape(varval), 1/)
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_2d

   SUBROUTINE cdfd_1d(ncid, varnam, varval, ier, dimname)
      !     define 1 dimensional double data array
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      REAL(kind=r8), dimension(:), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*2             :: vartype
      integer                 :: dims(3)

      vartype = 'R8'
      dims = (/-shape(varval), 1, 1/)
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_1d

   SUBROUTINE cdfd_0d(ncid, varnam, varval, ier, dimname)
      !     define scalar double
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      REAL(kind=r8), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*2             :: vartype
      integer                 :: dims(3)

      vartype = 'R8'
      dims = 0
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_0d

   SUBROUTINE cdfd_3f(ncid, varnam, varval, ier, dimname)
      !     define 3 dimensional real data array
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      REAL(kind=r4), dimension(:, :, :), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*2             :: vartype
      integer                 :: dims(3)

      vartype = 'R4'
      dims = -shape(varval)
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_3f

   SUBROUTINE cdfd_2f(ncid, varnam, varval, ier, dimname)
      !     define 2 dimensional real data array
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      REAL(kind=r4), dimension(:, :), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*2             :: vartype
      integer                 :: dims(3)

      vartype = 'R4'
      dims = (/-shape(varval), 1/)
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_2f

   SUBROUTINE cdfd_1f(ncid, varnam, varval, ier, dimname)
      !     define 1 dimensional real data array
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      REAL(kind=r4), dimension(:), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*2             :: vartype
      integer                 :: dims(3)

      vartype = 'R4'
      dims = (/-shape(varval), 1, 1/)
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_1f

   SUBROUTINE cdfd_0f(ncid, varnam, varval, ier, dimname)
      !     define scalar real
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      REAL(kind=r4), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*2             :: vartype
      integer                 :: dims(3)

      vartype = 'R4'
      dims = 0
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_0f

   SUBROUTINE cdfd_3c16(ncid, varnam, varval, ier, dimname)
      !     define 3 dimensional 128-bit complex data array
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      COMPLEX(kind=r8), dimension(:, :, :), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*3             :: vartype
      integer                 :: dims(3)

      vartype = 'C16'
      dims = -shape(varval)
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_3c16

   SUBROUTINE cdfd_2c16(ncid, varnam, varval, ier, dimname)
      !     define 2 dimensional 128-bit complex data array
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      COMPLEX(kind=r8), dimension(:, :), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*3             :: vartype
      integer                 :: dims(3)

      vartype = 'C16'
      dims = (/-shape(varval), 1/)
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_2c16

   SUBROUTINE cdfd_1c16(ncid, varnam, varval, ier, dimname)
      !     define 1 dimensional 128-bit complex data array
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      COMPLEX(kind=r8), dimension(:), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*3             :: vartype
      integer                 :: dims(3)

      vartype = 'C16'
      dims = (/-shape(varval), 1, 1/)
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_1c16

   SUBROUTINE cdfd_0c16(ncid, varnam, varval, ier, dimname)
      !     define scalar 128-bit complex
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      COMPLEX(kind=r8), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*3             :: vartype
      integer                 :: dims(3)

      vartype = 'C16'
      dims = 0
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_0c16

   SUBROUTINE cdfd_3c8(ncid, varnam, varval, ier, dimname)
      !     define 3 dimensional 64-bit complex data array
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      COMPLEX(kind=r4), dimension(:, :, :), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*2             :: vartype
      integer                 :: dims(3)

      vartype = 'C8'
      dims = -shape(varval)
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_3c8

   SUBROUTINE cdfd_2c8(ncid, varnam, varval, ier, dimname)
      !     define 2 dimensional 64-bit complex data array
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      COMPLEX(kind=r4), dimension(:, :), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*2             :: vartype
      integer                 :: dims(3)

      vartype = 'C8'
      dims = (/-shape(varval), 1/)
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_2c8

   SUBROUTINE cdfd_1c8(ncid, varnam, varval, ier, dimname)
      !     define 1 dimensional 64-bit complex data array
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      COMPLEX(kind=r4), dimension(:), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*2             :: vartype
      integer                 :: dims(3)

      vartype = 'C8'
      dims = (/-shape(varval), 1, 1/)
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_1c8

   SUBROUTINE cdfd_0c8(ncid, varnam, varval, ier, dimname)
      !     define scalar 64-bit complex
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      COMPLEX(kind=r4), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*2             :: vartype
      integer                 :: dims(3)

      vartype = 'C8'
      dims = 0
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_0c8

   SUBROUTINE cdfd_2c(ncid, varnam, varval, ier, dimname)
      !     define 2 dimensional character array
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      character*(*), dimension(:), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*4             :: vartype
      integer                 :: dims(3)

      vartype = 'CHAR'
      dims(1) = len(varval(1))
      dims(2) = size(varval); dims(3) = 1
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_2c

   SUBROUTINE cdfd_1c(ncid, varnam, varval, ier, dimname)
      !     define 1 dimensional character array
      implicit none
!!$  include "netcdf.inc"
      ! Input
      integer, intent(in) :: ncid
      character*(*), intent(in) :: varnam
      character*(*), intent(in) :: varval
      character*(*), optional, dimension(:), intent(in) :: dimname
      ! Output
      integer, optional, intent(out) :: ier
      ! Local
      character*4             :: vartype
      integer                 :: dims(3)

      vartype = 'CHAR'
      dims(1) = len(varval); dims(2:3) = 1
      if (dims(1) <= 1) dims(1) = -1
      call cdfDefVar(ncid, varnam, dims, vartype, ier, dimname)

   END SUBROUTINE cdfd_1c
!DEC$ ENDIF
END MODULE ezcdf_GenPut

max_stars_repo_name: AntonioG-Jerez/stella

max_issues_repo_name: AntonioG-Jerez/stella

max_forks_repo_name: AntonioG-Jerez/stella


program main

!*****************************************************************************80
!
!! MAIN is the main program for BUFFON_LAPLACE.
!
!  Discussion:
!
!    This program uses MPI to do a Buffon-Laplace simulation in parallel.
!
!    This is an example of an "embarassingly parallel" computation.  Each
!    processor does the same randomized computation, counting "successes",
!    and returning the number of successes to the master process.
!
!    The particular point made by this example is that each process must
!    use a different stream of random numbers, and that this can be done
!    if each process uses a different seed to initialize the random number
!    generator, and that this, in turn, can be done by simply adding the
!    process's rank to a common seed value.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    26 October 2007
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    William Gropp, Ewing Lusk, Anthony Skjellum,
!    Using MPI: Portable Parallel Programming with the
!    Message-Passing Interface,
!    Second Edition,
!    MIT Press, 1999,
!    ISBN: 0262571323.
!
!    Sudarshan Raghunathan,
!    Making a Supercomputer Do What You Want: High Level Tools for
!    Parallel Programming,
!    Computing in Science and Engineering,
!    Volume 8, Number 5, September/October 2006, pages 70-80.
!

  use mo_kind, only: i4, dp
  use mo_ansi_colors, only: color, c_red, c_green

#ifdef __MPI__
#ifdef __NAG__
  implicit none

  include "mpif.h"
#else
  ! use mpi, only: mpi_init, mpi_success, mpi_finalize, mpi_comm_size, mpi_comm_world, &
  !      mpi_comm_rank, mpi_reduce, mpi_integer, mpi_sum

  implicit none

  include "mpif.h"
#endif
#else
  use mo_mpi_stubs, only: mpi_init, mpi_success, mpi_finalize, mpi_comm_size, mpi_comm_world, &
       mpi_comm_rank, mpi_reduce, mpi_integer, mpi_sum

  implicit none
#endif

  real(dp) :: a = 1.0D+00
  real(dp) :: b = 1.0D+00
  integer(i4) :: buffon_laplace_simulate
  integer(i4):: hit_num
  integer(i4):: hit_total
  integer(i4):: ierr
  real(dp) :: l = 1.0D+00
  integer (kind = 4), parameter :: master = 0
  real(dp) :: pdf_estimate
  real(dp), parameter :: pi = 3.141592653589793238462643D+00
  real(dp) :: pi_error
  real(dp) :: pi_estimate
  integer(i4):: process_num
  integer(i4):: process_rank
  integer(i4):: seed
  integer(i4):: trial_num = 100000
  integer(i4):: trial_total
  real(dp) :: random_value
  integer(i4) :: n = 1
!
!  Initialize MPI.
!

  call MPI_Init ( ierr )

  if ( ierr /= MPI_SUCCESS ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'BUFFON_LAPLACE: Warning!'
    write ( *, '(a,i8)' ) '  MPI_INIT returns IERR = ', ierr
    call MPI_Finalize ( ierr )
    stop
  end if
!
!  Get the number of processes.
!
  call MPI_Comm_size ( MPI_COMM_WORLD, process_num, ierr )
!
!  Get the rank of this processor.
!
  call MPI_Comm_rank ( MPI_COMM_WORLD, process_rank, ierr )
!
!  The master process sets the value of the parameters,
!  and broadcasts them.
!
  if ( process_rank == master ) then
#ifdef __MPI__
     write ( *, '(a)' ) 'Using mpi'
#else
     write ( *, '(a)' ) 'Using mo_mpi_stubs'
#endif
  endif

  if ( process_rank == master ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'BUFFON_LAPLACE - Master process:'
    write ( *, '(a)' ) '  FORTRAN90 version'
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  An MPI example program to estimate PI'
    write ( *, '(a)' ) '  using the Buffon-Laplace needle experiment.'
    write ( *, '(a)' ) '  On a grid of cells of  width A and height B,'
    write ( *, '(a)' ) '  a needle of length L is dropped at random.'
    write ( *, '(a)' ) '  We count the number of times it crosses'
    write ( *, '(a)' ) '  at least one grid line, and use this to estimate '
    write ( *, '(a)' ) '  the value of PI.'
    write ( *, '(a)' ) ' '
    write ( *, '(a,i8)' ) '  The number of processes is ', process_num
    write ( *, '(a)' ) ' '
    write ( *, '(a,f14.6)' ) '  Cell width A =    ', a
    write ( *, '(a,f14.6)' ) '  Cell height B =   ', b
    write ( *, '(a,f14.6)' ) '  Needle length L = ', l
  end if
!
!  Each process sets a random number seed.
!
  seed = 123456789 + process_rank * 100
!
!  The process of setting the random number seed in FORTRAN90 is,
!  at least, uniformly specified by the language,
!  but lamentably Byzantine and cumbersome.
!
!  I put all this rigmarole in a subroutine.
!
  call random_initialize ( seed )
!
!  Just to make sure that we're all doing different things, have each
!  process print out its rank, seed value, and a first test random value.
!
  call random_number ( harvest = random_value )

  write ( *, '(2x,i8,2x,i12,2x,g14.6)' ) process_rank, seed, random_value
!
!  Each process now carries out TRIAL_NUM trials, and then
!  sends the value back to the master process.
!
  hit_num = buffon_laplace_simulate ( a, b, l, trial_num )

  call MPI_Reduce ( hit_num, hit_total, n, MPI_INTEGER, MPI_SUM, master, &
    MPI_COMM_WORLD, ierr )
!
!  The master process can now estimate PI.
!
  if ( process_rank == master ) then

    trial_total = trial_num * process_num

    pdf_estimate = real ( hit_total, kind = 8 ) / real ( trial_total, kind = 8 )

    if ( hit_total == 0 ) then

      pi_estimate = huge ( pi_estimate )

    else

      pi_estimate = l * ( 2.0D+00 * ( a + b ) - l ) / ( a * b * pdf_estimate )

    end if

    pi_error = abs ( pi - pi_estimate )

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '    Trials      Hits    Estimated PDF  ' // &
      '     Estimated Pi         Error'
    write ( *, '(a)' ) ' '
    write ( *, '(2x,i8,2x,i8,2x,g20.12,2x,g20.12,2x,g20.12)' ) &
         trial_total, hit_total, pdf_estimate, pi_estimate, pi_error

    if (pi_error < 0.1_dp) then
       write(*,*) 'mo_mpi_stubs ', color('o.k.', c_green)
    else
       write(*,*) 'mo_mpi_stubs ', color('failed!', c_red)
    endif

  end if
!
!  Terminate MPI.
!
  call MPI_Finalize ( ierr )
!
!  Terminate.
!
  if ( process_rank == master ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'BUFFON_LAPLACE - Master process:'
    write ( *, '(a)' ) '  Normal end of execution.'
  end if

end program main

function buffon_laplace_simulate ( a, b, l, trial_num )

!*****************************************************************************80
!
!! BUFFON_LAPLACE_SIMULATE simulates a Buffon-Laplace needle experiment.
!
!  Discussion:
!
!    In the Buffon-Laplace needle experiment, we suppose that the plane has been
!    tiled into a grid of rectangles of width A and height B, and that a
!    needle of length L is dropped "at random" onto this grid.
!
!    We may assume that one end, the "eye" of the needle falls at the point
!    (X1,Y1), taken uniformly at random in the cell [0,A]x[0,B].
!
!    ANGLE, the angle that the needle makes is taken to be uniformly random.
!    The point of the needle, (X2,Y2), therefore lies at
!
!      (X2,Y2) = ( X1+L*cos(ANGLE), Y1+L*sin(ANGLE) )
!
!    The needle will have crossed at least one grid line if any of the
!    following are true:
!
!      X2 <= 0, A <= X2, Y2 <= 0, B <= Y2.
!
!    This routine simulates the tossing of the needle, and returns the number
!    of times that the needle crossed at least one grid line.
!
!    If L is larger than sqrt ( A*A + B*B ), then the needle will
!    cross every time, and the computation is uninteresting.  However, if
!    L is smaller than this limit, then the probability of a crossing on
!    a single trial is
!
!      P(L,A,B) = ( 2 * L * ( A + B ) - L * L ) / ( PI * A * B )
!
!    and therefore, a record of the number of hits for a given number of
!    trials can be used as a very roundabout way of estimating PI.
!    (Particularly roundabout, since we actually will use a good value of
!    PI in order to pick the random angles!)
!
!    Note that this routine will try to generate 5 * TRIAL_NUM random
!    double precision values at one time, using automatic arrays.
!    When I tried this with TRIAL_NUM = 1,000,000, the program failed,
!    because of internal system limits on such arrays.
!
!    Such a problem could be avoided by using a DO loop running through
!    each trial individually, but this tend to run much more slowly than
!    necessary.
!
!    Since this routine invokes the FORTRAN90 random number generator,
!    the user should initialize the random number generator, particularly
!    if it is desired to control whether the sequence is to be varied
!    or repeated.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    26 February 2007
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Sudarshan Raghunathan,
!    Making a Supercomputer Do What You Want: High Level Tools for
!    Parallel Programming,
!    Computing in Science and Engineering,
!    Volume 8, Number 5, September/October 2006, pages 70-80.
!
!  Parameters:
!
!    Input, real(dp) A, B, the horizontal and vertical dimensions
!    of each cell of the grid.  0 <= A, 0 <= B.
!
!    Input, real(dp) L, the length of the needle.
!    0 <= L <= min ( A, B ).
!
!    Input, integer TRIAL_NUM, the number of times the needle is
!    to be dropped onto the grid.
!
!    Output, integer BUFFON_LAPLACE_SIMULATE, the number of times the needle
!    crossed at least one line of the grid of cells.
!
!  Local Parameters:
!
!    Local, integer BATCH_SIZE, specifies the number of trials to be done
!    in a single batch.  Setting BATCH_SIZE to 1 will be very slow.
!    Replacing it by TRIAL_NUM would be fine except that your system
!    may have a limit on the size of automatic arrays.  We have set a default
!    value of 10,000 here which should be large enough to be efficient
!    but small enough not to annoy the system.
!
  use mo_kind, only: i4, dp

  implicit none

  integer(i4), parameter :: batch_size = 10000
  integer(i4) :: trial_num

  real(dp) :: a
  real(dp) :: angle(batch_size)
  real(dp) :: b
  integer(i4) :: batch
  integer(i4) :: buffon_laplace_simulate
  integer(i4) :: hits
  real(dp) :: l
  integer(i4) :: n
  real(dp), parameter :: pi = 3.141592653589793238462643D+00
  real(dp) :: x1(batch_size)
  real(dp) :: x2(batch_size)
  real(dp) :: y1(batch_size)
  real(dp) :: y2(batch_size)

  hits = 0

  do batch = 1, trial_num, batch_size

    n = min ( batch_size, trial_num + 1 - batch )
!
!  Randomly choose the location of the eye of the needle in [0,0]x[A,B],
!  and the angle the needle makes.
!
    call random_number ( harvest = x1(1:n) )
    call random_number ( harvest = y1(1:n) )
    call random_number ( harvest = angle(1:n) )

    x1(1:n) = a * x1(1:n)
    y1(1:n) = b * y1(1:n)
    angle(1:n) = 2.0D+00 * pi * angle(1:n)
!
!  Compute the location of the point of the needle.
!
    x2(1:n) = x1(1:n) + l * cos ( angle(1:n) )
    y2(1:n) = y1(1:n) + l * sin ( angle(1:n) )
!
!  Count the end locations that lie outside the cell.
!
    hits = hits + count (      x2(1:n) <= 0.0 .or. &
                          a <= x2(1:n)        .or. &
                               y2(1:n) <= 0.0 .or. &
                          b <= y2(1:n) )

  end do

  buffon_laplace_simulate = hits

  return
end function buffon_laplace_simulate

subroutine random_initialize ( seed_input )

!*****************************************************************************80
!
!! RANDOM_INITIALIZE initializes the FORTRAN90 random number seed.
!
!  Discussion:
!
!    If you don't initialize the FORTRAN90 random number generator
!    routine RANDOM_NUMBER, which is used by calls like
!
!      call random_number ( harvest = x )
!
!    then its behavior is not specified.  That may be OK for you.  But
!    you may want to be able to force the same sequence to be generated
!    each time, or to force a different sequence.
!
!    To control the sequence of random numbers, you need to set the seed.
!    In FORTRAN90, this is done by calling the RANDOM+SEED routine.
!    You can call it with no arguments, in fact.  But if you call
!    it with no arguments:
!
!      call random_seed ( )
!
!    then its behavior (or more particularly, the behavior of RANDOM_NUMBER)
!    is still not specified.  You might hope that the system will go out
!    and pick a nice random seed for you, but there's no guarantee.
!
!
!    For example, on the DEC ALPHA, if you compile a program that calls
!    RANDOM_NUMBER, then every time you run it, you get the same sequence
!    of "random" values.  If you compile a program that calls RANDOM_SEED
!    with no arguments, and then calls RANDOM_NUMBER, you still get the
!    same sequence each time you run the program.
!
!    In order to actually try to scramble up the random number generator
!    a bit, this routine goes through the tedious process of getting the
!    size of the random number seed, making up values based on the current
!    time, and setting the random number seed.
!
!    Unfortunately, the RANDOM_SEED routine has a very elastic definition.
!    It does not use a single scalar integer SEED.  Instead, it communicates
!    with the user through an integer vector whose size is not specified.
!    You actually have to "ask" the routine to tell you the size of this
!    vector.  Then you can fill up the vector with values to be used to
!    influence the seeding of the random number routine.  The details of
!    how the seed affects the sequence are also unspecified, but the only
!    thing we are reasonably confident about is that specifying the same
!    seed should result in the same sequence, and specifying different
!    seeds should result in different sequences!
!
!    I assume this is far more than you wanted to know.  (It's certainly
!    more than I wanted to know!)
!
!    The argument SEED is an input quantity only, so it is legal
!    to type
!
!      call random_initialize ( 0 )
!
!    or
!
!      call random_initialize ( 18867 )
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    21 February 2006
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer SEED_INPUT, the user's "suggestion" for a seed.
!    However, if the input value is 0, the routine will come up with
!    its own "suggestion", based on the system clock.
!
  use mo_kind, only: i4, dp

  implicit none

  integer(i4) :: count
  integer(i4) :: count_max
  integer(i4) :: count_rate
  logical, parameter :: debug = .false.
  integer(i4) :: i
  integer(i4) :: seed
  integer(i4) :: seed_input
  integer(i4), allocatable :: seed_vector(:)
  integer(i4) :: seed_size
  real(dp) :: t
  integer(i4), parameter :: warm_up = 100

  seed = seed_input
!
!  Initialize the random seed routine.
!
  call random_seed ( )
!
!  Determine the size of the random number seed vector.
!
  call random_seed ( size = seed_size )
!
!  Allocate a vector of the right size to be used as a random seed.
!
  allocate ( seed_vector(seed_size) )
!
!  If the user supplied a SEED value, use that.
!
!  Otherwise, use the system clock value to make up a value that is
!  likely to change based on when this routine is called.
!
  if ( seed /= 0 ) then

    if ( debug ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'RANDOM_INITIALIZE'
      write ( *, '(a,i20)' ) '  Initialize RANDOM_NUMBER, user SEED = ', seed
    end if

  else

    call system_clock ( count, count_rate, count_max )

    seed = count

    if ( debug ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'RANDOM_INITIALIZE'
      write ( *, '(a,i20)' ) '  Initialize RANDOM_NUMBER, arbitrary SEED = ', &
        seed
    end if

  end if
!
!  Set the seed vector.  We don't know the significance of the
!  individual entries of the internal seed vector, so we'll just set
!  all entries to SEED.
!
  seed_vector(1:seed_size) = seed
!
!  Now call RANDOM_SEED, and tell it to use this seed vector.
!
  call random_seed ( put = seed_vector(1:seed_size) )
!
!  Free up the seed space.
!
  deallocate ( seed_vector )
!
!  Call the random number routine a bunch of times just to "warm it up".
!
  do i = 1, warm_up
    call random_number ( harvest = t )
  end do

  return
end subroutine random_initialize


text:
! ifort -O2 test_ksl_cme.f90 tt_ksl.o expokit.o explib.o normest.o dlacn1.o zlacn1.o dlarpc.o dlapst.o mytt.a -o test_ksl_cme -mkl

program test_eigb_f
 use tt_lib
 use ttaux_lib
 use ttop_lib
 use ttio_lib
 use time_lib
 use dyn_tt
 implicit none

 double precision,parameter :: tpi=6.28318530717958647692528676655900577d0

 type(ztt) :: A,u
 integer :: i, r1,j,r2, d, sz, info, Nt
 integer, allocatable :: n(:), ra(:), ru(:)
 double precision :: tol,t1,t2, tau, T
 double complex, allocatable :: crU(:), crA(:)
 character(len=40) :: Anam, unam, unam_res

  INTEGER :: i_, n_, clock_
  INTEGER, DIMENSION(:), ALLOCATABLE :: seed_

  CALL RANDOM_SEED(size = n_)
  ALLOCATE(seed_(n_))
  CALL SYSTEM_CLOCK(COUNT=clock_)
  seed_ = clock_ + 37 * (/ (i_ - 1, i_ = 1, n_) /)
  CALL RANDOM_SEED(PUT = seed_)
  DEALLOCATE(seed_)

  open(10,file='test_ksl_cme.inp')
  read (10,*) Anam
  read (10,*) unam
  read (10,*) unam_res
  read (10,*) T
  read (10,*) Nt
  close(10)

  tau = T/Nt

  call OMP_SET_NUM_THREADS(1)

! Read dtt data
  call ztt_read(A,Anam,info)
  if(info.ne.0)then;write(*,*) 'read fails: ',info;stop;endif
  call say(A)

  call ztt_read(u,unam,info)
  if(info.ne.0)then;write(*,*) 'read fails: ',info;stop;endif
  call say(u)

  d = u%m - u%l + 1
  print *, 'd=', d

! Convert into the linear storage
  sz = sum(A%r(0:d-1)*A%n(1:d)*A%r(1:d))
  allocate(crA(sz))
  sz = 0
  do i=1,d
    forall(r1=1:A%r(i-1),j=1:A%n(i),r2=1:A%r(i)) crA(sz+r1+(j-1)*A%r(i-1)+(r2-1)*A%r(i-1)*A%n(i))=A%u(i)%p(r1,j,r2)
    sz=sz+A%r(i-1)*A%n(i)*A%r(i)
  end do

  sz = sum(u%r(0:d-1)*u%n(1:d)*u%r(1:d))
  allocate(crU(sz))
  sz = 0
  do i=1,d
    forall(r1=1:u%r(i-1),j=1:u%n(i),r2=1:u%r(i)) crU(sz+r1+(j-1)*u%r(i-1)+(r2-1)*u%r(i-1)*u%n(i))=u%u(i)%p(r1,j,r2)
    sz=sz+u%r(i-1)*u%n(i)*u%r(i)
  end do

 allocate (n(d), ra(d+1), ru(d+1))
 ra(1) = 1
 ra(d+1) = 1
 do i=1,d
   n(i) = nint(sqrt(real(A%n(i))))
   ra(i+1) = A%r(i)
   ru(i+1) = u%r(i)
 end do
 ru(1) = 1

! Run the solver and measure the time
 t1=timef()
 do i=1,Nt
  call ztt_ksl(d,n,n,ra,crA, crU, ru, tau, 500)
!   call tt_ksl(d,n,n,ra,crA, crU, ru, tau, 500)
  call zcopy(sum(ru(1:d)*n(1:d)*ru(2:d+1)), zresult_core, 1, crU, 1)
  print *, 'step ', i, 'done'
 end do
 t2=timef()-t1

 print *, ru(1:d+1)
 print *, 'Wall Time = ', t2

  open(10,file='test_ksl_cme.out')
  do i=1,sum(ru(1:d)*n(1:d)*ru(2:d+1))
  write (10,*) zresult_core(i)
  end do
  close(10)

 ! Cast result_core back into dtt and save
  call dealloc(u)
  u%l = 1
  u%m = d
  u%r(0)=1
  do i=1,d
    u%n(i)=n(i)
    u%r(i)=ru(i+1)
  end do
  call alloc(u)
  sz = 0
  do i=1,d
    forall(r1=1:u%r(i-1),j=1:u%n(i),r2=1:u%r(i)) u%u(i)%p(r1,j,r2) = zresult_core(sz+r1+(j-1)*u%r(i-1)+(r2-1)*u%r(i-1)*u%n(i))
    sz=sz+u%r(i-1)*u%n(i)*u%r(i)
  end do

! deallocate result_core
 call deallocate_result

 call ztt_write(u,unam_res,info)
 if(info.ne.0)then;write(*,*) 'write fails: ',info;stop;endif

 call dealloc(u)

 deallocate (crA, crU, ra, ru, n)
end

max_stars_repo_name: dimpase/tt-fort

max_issues_repo_name: dimpase/tt-fort

max_forks_repo_name: dimpase/tt-fort


!!<summary>Kind descriptors for the precision of integer and real values.</summary>
MODULE num_types
implicit none
private
public dp, sp, si, li
!!<member name="dp">Double precision kind for decimal precision of at least 15
!!digits, a decimal exponent range of at least 307.</member>
!!<member name="sp">Single precision kind for decimal precision of at least 6
!!digits, a decimal exponent range of at least 37.</member>
!!<member name="si">Short kind for integers that can represent all
!!values ranging from -10^1 (exclusive) to 10^1 (exclusive).</member>
!!<member name="li">Long kind for integers that can represent all
!!values ranging from -10^18 (exclusive) to 10^18 (exclusive).</member>
integer, parameter:: dp=selected_real_kind(15,307)
integer, parameter:: sp=selected_real_kind(6,37)
integer, parameter:: si=selected_int_kind(1)
integer, parameter:: li=selected_int_kind(18)
END MODULE


text:
Name: Barbara Brady

Office: UC Davis Administrative and Resource Management, Director of Communication

Phone Number: (530) 7540323

Email: bebrady@ucdavis.edu

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!

program t
integer,pointer::xptr(:)
integer,target::x(1:5)
integer result,expect

x = 7
xptr=>x
!xptr=>x(2:4)
namelist/xx/ xptr

namelist/xx/ xptr
open(11, file='out', action='write')
write(11, '(A)') "    &xx xptr(3)=1/"
close(11)

open(17,file='out', action='read')
read(17, nml=xx)

expect=1
result=xptr(3)
call check(expect,result, 1)

end

max_stars_repo_name: abrahamtovarmob/flang

max_issues_repo_name: abrahamtovarmob/flang

max_forks_repo_name: abrahamtovarmob/flang


text:
!
! This file is released under terms of BSD license
! See LICENSE file for more information
!

module mod5
end module mod5

max_stars_repo_name: peclatj/claw-compiler

max_issues_repo_name: peclatj/claw-compiler

max_forks_repo_name: peclatj/claw-compiler


text:
!----------------------------------------------------------------
! (c) Copyright, 2016 by the Regents of the University of California.
! DriftTubeclass: Drift space beam line element class
!             in Lattice module of APPLICATION layer.
! Version: 1.0
! Author: Ji Qiang
! Description: This class defines the linear transfer map and field
!              for the drift space beam line elment.
! Comments:
!----------------------------------------------------------------
      module DriftTubeclass
        use PhysConstclass
        use Dataclass
        integer, private, parameter :: Nparam = 2
        type DriftTube
          !Itype = 0
          integer :: Nseg,Mapstp,Itype
          double precision :: Length
          double precision, dimension(Nparam) :: Param
          ! Param(1) : zedge
          !      (2) : radius
        end type DriftTube
        interface getparam_DriftTube
          module procedure getparam1_DriftTube,  &
                          getparam2_DriftTube,   &
                          getparam3_DriftTube
        end interface
        interface setparam_DriftTube
          module procedure setparam1_DriftTube,  &
                          setparam2_DriftTube, setparam3_DriftTube
        end interface
      contains
        subroutine construct_DriftTube(this,numseg,nmpstp,type,blength)
        implicit none
        type (DriftTube), intent(out) :: this
        integer, intent(in) :: numseg,nmpstp,type
        double precision, intent(in) :: blength

        this%Nseg = numseg
        this%Mapstp = nmpstp
        this%Itype = type
        this%Length = blength

        this%Param = 0.0

        end subroutine construct_DriftTube

        subroutine setparam1_DriftTube(this,i,value)
        implicit none
        type (DriftTube), intent(inout) :: this
        integer, intent(in) :: i
        double precision, intent(in) :: value

        this%Param(i) = value

        end subroutine setparam1_DriftTube

        subroutine setparam2_DriftTube(this,values)
        implicit none
        type (DriftTube), intent(inout) :: this
        double precision, dimension(:), intent(in) :: values

        this%Param = values

        end subroutine setparam2_DriftTube

        subroutine setparam3_DriftTube(this,numseg,nmpstp,type,blength)
        implicit none
        type (DriftTube), intent(inout) :: this
        integer, intent(in) :: numseg,nmpstp,type
        double precision, intent(in) :: blength

        this%Nseg = numseg
        this%Mapstp = nmpstp
        this%Itype = type
        this%Length = blength

        end subroutine setparam3_DriftTube

        subroutine getparam1_DriftTube(this,i,blparam)
        implicit none
        type (DriftTube), intent(in) :: this
        integer, intent(in) :: i
        double precision, intent(out) :: blparam

        blparam = this%Param(i)

        end subroutine getparam1_DriftTube

        subroutine getparam2_DriftTube(this,blparams)
        implicit none
        type (DriftTube), intent(in) :: this
        double precision, dimension(:), intent(out) :: blparams

        blparams = this%Param

        end subroutine getparam2_DriftTube

        subroutine getparam3_DriftTube(this,blength,bnseg,bmapstp,&
                                       btype)
        implicit none
        type (DriftTube), intent(in) :: this
        double precision, intent(out) :: blength
        integer, intent(out) :: bnseg,bmapstp,btype

        blength = this%Length
        bnseg = this%Nseg
        bmapstp = this%Mapstp
        btype = this%Itype

        end subroutine getparam3_DriftTube

        subroutine maplinear_DriftTube(t,tau,xm,this,refpt,Bchg,Bmass)
        implicit none
        include 'mpif.h'
        double precision, intent(in) :: t,tau,Bchg,Bmass
        double precision, dimension(6,6), intent(out) :: xm
        double precision, dimension(6), intent(inout) :: refpt
        type (DriftTube), intent(in) :: this
        double precision, dimension(18) :: y
        double precision :: h,t0,gi,betai,ui,squi,sqi3
        double precision :: dlti,thli,gf,betaf,uf,squf,sqf3
        double precision :: dltf,thlf,zedge,tfin
        integer :: mpstp

        xm = 0.0

        zedge = this%Param(1)
        mpstp = this%Mapstp

        y(1)=0.0
        y(2)=0.0
        y(3)=0.0
        y(4)=0.0
        y(5)=refpt(5)
        y(6)=refpt(6)
        y(7)=1.0
        y(8)=0.0
        y(9)=0.0
        y(10)=1.0
        y(11)=1.0
        y(12)=0.0
        y(13)=0.0
        y(14)=1.0
        y(15)=1.0
        y(16)=0.0
        y(17)=0.0
        y(18)=1.0
        h=tau/mpstp
        t0=t
        gi=-refpt(6)
        betai=sqrt(gi**2-1.)/gi
        ui=gi*betai
        squi=sqrt(ui)
        sqi3=sqrt(ui)**3

        dlti=0.0
        thli=0.0

        call rk6i_DriftTube(h,mpstp,t0,y,18,this,Bchg,Bmass)

        refpt(5)=y(5)
        refpt(6)=y(6)
        gf=-refpt(6)
        betaf=sqrt(gf**2-1.)/gf
        uf=gf*betaf
        squf=sqrt(uf)
        sqf3=sqrt(uf)**3

        tfin = t + tau

        dltf = 0.0
        thlf = 0.0

        xm(1,1)= y(7)*squi/squf+y(9)*squi/squf*dlti
        xm(2,1)=(y(8)-y(7)*dltf)*squi*squf+(y(10)-y(9)*dltf)*squi*squf*&
                 dlti
        xm(1,2)= y(9)/(squi*squf)
        xm(2,2)=(y(10)-y(9)*dltf)*squf/squi
        xm(3,3)= y(11)*squi/squf+y(13)*squi/squf*dlti
        xm(4,3)= &
        (y(12)-y(11)*dltf)*squi*squf+(y(14)-y(13)*dltf)*squi*squf*dlti
        xm(3,4)= y(13)/(squi*squf)
        xm(4,4)=(y(14)-y(13)*dltf)*squf/squi
        xm(5,5)= y(15)*sqi3/sqf3+y(17)*sqi3/sqf3*thli
        xm(6,5)= &
        (y(16)-y(15)*thlf)*sqi3*sqf3+(y(18)-y(17)*thlf)*sqi3*sqf3*thli
        xm(5,6)= y(17)/(sqi3*sqf3)
        xm(6,6)=(y(18)-y(17)*thlf)*sqf3/sqi3

        end subroutine maplinear_DriftTube

        subroutine rk6i_DriftTube(h,ns,t,y,nvar,this,Bchg,Bmass)
        implicit none
        include 'mpif.h'
        integer, intent(in) :: ns,nvar
        double precision, intent(inout) :: t
        double precision, intent(in) :: h,Bchg,Bmass
        double precision, dimension(nvar), intent(inout) :: y
        type (DriftTube), intent(in) :: this
        double precision, dimension(nvar) :: yt,a,b,c,d,e,f,g,o,p
        double precision:: tint,tt
        integer :: i
        tint=t
        do i=1,ns
          call intfunc1_DriftTube(t,y,f,this,Bchg,Bmass)
          a=h*f
          yt=y+a/9.d0
          tt=t+h/9.d0
          call intfunc1_DriftTube(tt,yt,f,this,Bchg,Bmass)
          b=h*f
          yt=y + (a + 3.d0*b)/24.d0
          tt=t+h/6.d0
          call intfunc1_DriftTube(tt,yt,f,this,Bchg,Bmass)
          c=h*f
          yt=y+(a-3.d0*b+4.d0*c)/6.d0
          tt=t+h/3.d0
          call intfunc1_DriftTube(tt,yt,f,this,Bchg,Bmass)
          d=h*f
          yt=y + (278.d0*a - 945.d0*b + 840.d0*c + 99.d0*d)/544.d0
          tt=t+.5d0*h
          call intfunc1_DriftTube(tt,yt,f,this,Bchg,Bmass)
          e=h*f
          yt=y + (-106.d0*a+273.d0*b-104.d0*c-107.d0*d+48.d0*e)/6.d0
          tt = t+2.d0*h/3.d0
          call intfunc1_DriftTube(tt,yt,f,this,Bchg,Bmass)
          g=h*f
          yt = y+(110974.d0*a-236799.d0*b+68376.d0*c+ &
                  103803.d0*d-10240.d0*e + 1926.d0*g)/45648.d0
          tt = t + 5.d0*h/6.d0
          call intfunc1_DriftTube(tt,yt,f,this,Bchg,Bmass)
          o=h*f
          yt = y+(-101195.d0*a+222534.d0*b-71988.d0*c-  &
                  26109.d0*d-2.d4*e-72.d0*g+22824.d0*o)/25994.d0
          tt = t + h
          call intfunc1_DriftTube(tt,yt,f,this,Bchg,Bmass)
          p=h*f
          y = y+(41.d0*a+216.d0*c+27.d0*d+ &
                 272.d0*e+27.d0*g+216.d0*o+41.d0*p)/840.d0
          t=tint+i*h
        enddo

        end subroutine rk6i_DriftTube

        subroutine intfunc1_DriftTube(t,y,f,this,Bchg,Bmass)
        implicit none
        include 'mpif.h'
        double precision, intent(in) :: t,Bchg,Bmass
        double precision, dimension(:), intent(in) :: y
        double precision, dimension(:), intent(out) :: f
        type (DriftTube), intent(in) :: this
        double precision :: gamma0,beta0,gbet
        double precision :: zedge,s11,s33,s55

        zedge = this%Param(1)

        f(1) = 0.0
        f(2) = 0.0
        f(3) = 0.0
        f(4) = 0.0

        ! synchronous particle:
        gamma0=-y(6)
        beta0=sqrt(gamma0**2-1.)/gamma0
        gbet=sqrt((gamma0-1.0)*(gamma0+1.0))

        f(5)=1.0/(beta0*Scxl)
        f(6)=0.0

        ! matrix elements
        s11=0.0
        s33=0.0
        s55=  0.0

        f(7)=y(8)/Scxl
        f(8)=-s11*y(7)
        f(9)=y(10)/Scxl
        f(10)=-s11*y(9)
        f(11)=y(12)/Scxl
        f(12)=-s33*y(11)
        f(13)=y(14)/Scxl
        f(14)=-s33*y(13)
        f(15)=y(16)/Scxl
        f(16)=-s55*y(15)
        f(17)=y(18)/Scxl
        f(18)=-s55*y(17)

        end subroutine intfunc1_DriftTube

        subroutine  getfld_DriftTube(pos,extfld,this)
        implicit none
        include 'mpif.h'
        double precision, dimension(4), intent(in) :: pos
        type (DriftTube), intent(in) :: this
        double precision, dimension(6), intent(out) :: extfld
        double precision:: zz,bgrad,zedge

        extfld(1) = 0.0
        extfld(2) = 0.0
        extfld(3) = 0.0
        extfld(4) = 0.0
        extfld(5) = 0.0
        extfld(6) = 0.0

        end subroutine getfld_DriftTube

      end module DriftTubeclass

max_stars_repo_name: hhslepicka/IMPACT-Z

max_issues_repo_name: hhslepicka/IMPACT-Z

max_forks_repo_name: hhslepicka/IMPACT-Z


text:
! ###########################################################
! #                                                         #
! #                    THE LIDORT FAMILY                    #
! #                                                         #
! #      (LInearized Discrete Ordinate Radiative Transfer)  #
! #       --         -        -        -         -          #
! #                                                         #
! ###########################################################

! ###########################################################
! #                                                         #
! #  Author :      Robert. J. D. Spurr                      #
! #                                                         #
! #  Address :     RT Solutions, Inc.                       #
! #                9 Channing Street                        #
! #                Cambridge, MA 02138, USA                 #
! #                                                         #
! #  Tel:          (617) 492 1183                           #
! #  Email :        rtsolutions@verizon.net                 #
! #                                                         #
! #  This Version :   3.7 F90                               #
! #  Release Date :   June 2014                             #
! #                                                         #
! #       NEW: THERMAL SUPPLEMENT INCLUDED    (3.2)         #
! #       NEW: OUTGOING SPHERICITY CORRECTION (3.2)         #
! #       NEW: TOTAL COLUMN JACOBIANS         (3.3)         #
! #       VLIDORT COMPATIBILITY               (3.4)         #
! #       THREADED/OPTIMIZED F90 code         (3.5)         #
! #       EXTERNAL SS / NEW I/O STRUCTURES    (3.6)         #
! #                                                         #
! #       Surface-leaving, BRDF Albedo-scaling     (3.7)    #
! #       Taylor series, BBF Jacobians, ThreadSafe (3.7)    #
! #                                                         #
! ###########################################################

!    #####################################################
!    #                                                   #
!    #   This Version of LIDORT comes with a GNU-style   #
!    #   license. Please read the license carefully.     #
!    #                                                   #
!    #####################################################

      module LIDORT_LinInputs_def

!  Version 3.7, Internal threading removed, 02 May 2014

!  This Module contains the following LIDORT Input Structures, with Intents :

!          LIDORT_Fixed_LinControl    nested in LIDORT_Fixed_LinInputs
!          LIDORT_Fixed_LinOptical    nested in LIDORT_Fixed_LinInputs
!           LIDORT_Fixed_LinInputs    Intent(In)

      use LIDORT_PARS, only : fpk, MAXMOMENTS_INPUT, MAXLAYERS, MAX_ATMOSWFS

      implicit none

! #####################################################################
! #####################################################################

      TYPE LIDORT_Fixed_LinControl

!  Control linearization

      LOGICAL  :: TS_DO_COLUMN_LINEARIZATION
      LOGICAL  :: TS_DO_PROFILE_LINEARIZATION
      LOGICAL  :: TS_DO_SURFACE_LINEARIZATION

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!@@@ Addition of SLEAVE WF stuff, R. Spurr, 22 August 2012 @@@@@@@@@
!  Total number of Sleave Jacobians
      LOGICAL  :: TS_DO_SLEAVE_WFS
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

!  Control for atmospheric linearizations, layer by layer

      LOGICAL, dimension(MAXLAYERS)  :: TS_LAYER_VARY_FLAG
      INTEGER, dimension(MAXLAYERS)  :: TS_LAYER_VARY_NUMBER

!  Total number of column Jacobians

      INTEGER  :: TS_N_TOTALCOLUMN_WFS

!  Total number of Surface Jacobians

      INTEGER  :: TS_N_SURFACE_WFS

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!@@@ Addition of SLEAVE WF stuff, R. Spurr, 22 August 2012 @@@@@@@@@
!  Total number of Sleave Jacobians
      INTEGER  :: TS_N_SLEAVE_WFS
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

!  BlackBody Jacobian Flags, Introduced March 18th 2014

      LOGICAL  :: TS_DO_ATMOS_LBBF
      LOGICAL  :: TS_DO_SURFACE_LBBF

      END TYPE LIDORT_Fixed_LinControl

! #####################################################################
! #####################################################################

      TYPE LIDORT_Fixed_LinOptical

!  Optical property linearizations
!  Layer linearization (bulk property variation) input
!  Layer linearization (phase function variation) input

      REAL(fpk), dimension(MAX_ATMOSWFS,MAXLAYERS) :: TS_L_DELTAU_VERT_INPUT
      REAL(fpk), dimension(MAX_ATMOSWFS,MAXLAYERS) :: TS_L_OMEGA_TOTAL_INPUT
      REAL(fpk), dimension(MAX_ATMOSWFS,0:MAXMOMENTS_INPUT,MAXLAYERS) :: TS_L_PHASMOMS_TOTAL_INPUT

      END TYPE LIDORT_Fixed_LinOptical

! #####################################################################
! #####################################################################

      TYPE LIDORT_Fixed_LinInputs

      TYPE(LIDORT_Fixed_LinControl)    :: Cont
      TYPE(LIDORT_Fixed_LinOptical)    :: Optical

      END TYPE LIDORT_Fixed_LinInputs

! #####################################################################
! #####################################################################

      !Note: This type structure not currently used.
      !      Placeholder for possible future variables.

      TYPE LIDORT_Modified_LinInputs

      INTEGER :: Dummy
      !TYPE(LIDORT_Modified_LinControl)    :: MCont

      END TYPE LIDORT_Modified_LinInputs

! #####################################################################
! #####################################################################

!  EVERYTHING PUBLIC HERE

      PRIVATE
      PUBLIC :: LIDORT_Fixed_LinControl, &
                LIDORT_Fixed_LinOptical, &
                LIDORT_Fixed_LinInputs,&
                LIDORT_Modified_LinInputs

      end module LIDORT_LinInputs_def

max_stars_repo_name: GEOS-ESM/AeroApps

max_issues_repo_name: GEOS-ESM/AeroApps

max_forks_repo_name: GEOS-ESM/AeroApps


text:
      SUBROUTINE INTENS(BRIGHT,NCOLOR)
C
C          ------------------------------------------------
C          ROUTINE NO. (  60)   VERSION (A7.2)    12:OCT:95
C          ------------------------------------------------
C
C          THIS SETS A COLOUR TABLE ENTRY TO AN INTENSITY LEVEL.
C
C
C          <BRIGHT>  GIVES THE INTENSITY LEVEL.
C          <NCOLOR>  IS THE COLOUR NUMBER.
C
C
      REAL    RDATA(4)
      INTEGER IDATA(1)
C
      COMMON /T0KTAB/ REDCO0(255),GRNCO0(255),BLUCO0(255),NCOLS0
      COMMON /T0KTFL/ NCFLG0(255)
      COMMON /T0TRAC/ IPRINT
      COMMON /T0TRAR/ RTRAC1,RTRAC2,RTRAC3,RTRAC4
      COMMON /T3NBYR/ NBYTR
C
      DATA IDATA /0/
C
C
      CALL G3INIT(2)
C
      RTRAC1= BRIGHT
      RTRAC2= NCOLOR
      IF (IPRINT.EQ.1) CALL G0MESG(37,2)
C
      IF (NCOLOR.LT.1.OR.NCOLOR.GT.255) RETURN
      BRILL= BRIGHT
      IF (BRILL.LT.0.0) BRILL= 0.0
      IF (BRILL.GT.1.0) BRILL= 1.0
C
      IF (NCOLS0.LT.NCOLOR) NCOLS0= NCOLOR
      REDCO0(NCOLOR)= BRILL
      GRNCO0(NCOLOR)= BRILL
      BLUCO0(NCOLOR)= BRILL
      NCFLG0(NCOLOR)= 1
C
      RDATA(1)= NCOLOR
      RDATA(2)= BRILL
      RDATA(3)= BRILL
      RDATA(4)= BRILL
      CALL G3LINK(5,1,4*NBYTR,IDATA,RDATA)
      RETURN
      END

max_stars_repo_name: ZedThree/GHOST

max_issues_repo_name: ZedThree/GHOST

max_forks_repo_name: ZedThree/GHOST


text:
      program hpftest09
      integer g(10)
      integer j,k,l,m,n
CHPF$ TEMPLATE t(10)
CHPF$ ALIGN g(I) with t(I)
CHPF$ PROCESSORS p(2)
CHPF$ DISTRIBUTE t(block) ONTO p
      k=1
      j=g(k)+1
      l=g(g(j)+2)+3
      m=j+k+l
      n=0
      end


text:
! { dg-do compile }
! { dg-options "-std=f95" }

! Parsing of finalizer procedure definitions.
! While ALLOCATABLE scalars are not implemented, this even used to ICE.
! Thanks Tobias Burnus for the test!

integer, allocatable :: x ! { dg-error "may not be ALLOCATABLE" }

end

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
integer(C_INT) function spral_random_matrix_generate(cstate, matrix_type, m, &
     n, nnz, ptr, row, cval, flags) bind(C)
  use iso_c_binding
  use spral_random, only: random_state, random_get_seed, random_set_seed
  use spral_random_matrix, only: random_matrix_generate
  implicit none

  integer(C_INT), intent(inout) :: cstate
  integer(C_INT), value :: matrix_type
  integer(C_INT), value :: m
  integer(C_INT), value :: n
  integer(C_INT), value :: nnz
  integer(C_INT), dimension(n+1), intent(out) :: ptr
  integer(C_INT), dimension(nnz), intent(out) :: row
  type(C_PTR), value :: cval
  integer(C_INT), value :: flags

  integer, parameter :: wp = C_DOUBLE
  integer, parameter :: SPRAL_RANDOM_MATRIX_FINDEX       = 1
  integer, parameter :: SPRAL_RANDOM_MATRIX_NONSINGULAR  = 2
  integer, parameter :: SPRAL_RANDOM_MATRIX_SORT         = 4

  type(random_state) :: fstate
  real(wp), dimension(:), pointer, contiguous :: fval
  logical :: findex, nonsingular, sort

  ! Set random generator state
  call random_set_seed(fstate, cstate)

  ! Decipher flags
  findex      = (iand(flags, SPRAL_RANDOM_MATRIX_FINDEX)      .ne. 0)
  nonsingular = (iand(flags, SPRAL_RANDOM_MATRIX_NONSINGULAR) .ne. 0)
  sort        = (iand(flags, SPRAL_RANDOM_MATRIX_SORT)        .ne. 0)

  ! Check if we have a val vector
  if (C_ASSOCIATED(cval)) then
     call C_F_POINTER(cval, fval, shape = (/ nnz /))
  else
     nullify(fval)
  end if

  if (ASSOCIATED(fval)) then
     call random_matrix_generate(fstate, matrix_type, m, n, nnz, ptr, row, &
          spral_random_matrix_generate, nonsingular=nonsingular, sort=sort, &
          val=fval)
  else
     call random_matrix_generate(fstate, matrix_type, m, n, nnz, ptr, row, &
          spral_random_matrix_generate, nonsingular=nonsingular, sort=sort)
  end if

  ! Convert to C indexing if required
  if (.not. findex) then
     ptr(:) = ptr(:) - 1
     row(:) = row(:) - 1
  end if

  ! Recover new random genenerator state
  cstate = random_get_seed(fstate)
end function spral_random_matrix_generate

integer(C_INT) function spral_random_matrix_generate_long(cstate, matrix_type, &
     m, n, nnz, ptr, row, cval, flags) bind(C)
  use iso_c_binding
  use spral_random, only: random_state, random_get_seed, random_set_seed
  use spral_random_matrix, only: random_matrix_generate
  implicit none

  integer(C_INT), intent(inout) :: cstate
  integer(C_INT), value :: matrix_type
  integer(C_INT), value :: m
  integer(C_INT), value :: n
  integer(C_LONG_LONG), value :: nnz
  integer(C_LONG_LONG), dimension(n+1), intent(out) :: ptr
  integer(C_INT), dimension(nnz), intent(out) :: row
  type(C_PTR), value :: cval
  integer(C_INT), value :: flags

  integer, parameter :: wp = C_DOUBLE
  integer, parameter :: SPRAL_RANDOM_MATRIX_FINDEX       = 1
  integer, parameter :: SPRAL_RANDOM_MATRIX_NONSINGULAR  = 2
  integer, parameter :: SPRAL_RANDOM_MATRIX_SORT         = 4

  type(random_state) :: fstate
  real(wp), dimension(:), pointer, contiguous :: fval
  logical :: findex, nonsingular, sort

  ! Set random generator state
  call random_set_seed(fstate, cstate)

  ! Decipher flags
  findex      = (iand(flags, SPRAL_RANDOM_MATRIX_FINDEX)      .ne. 0)
  nonsingular = (iand(flags, SPRAL_RANDOM_MATRIX_NONSINGULAR) .ne. 0)
  sort        = (iand(flags, SPRAL_RANDOM_MATRIX_SORT)        .ne. 0)

  ! Check if we have a val vector
  if (C_ASSOCIATED(cval)) then
     call C_F_POINTER(cval, fval, shape = (/ nnz /))
  else
     nullify(fval)
  end if

  if (ASSOCIATED(fval)) then
     call random_matrix_generate(fstate, matrix_type, m, n, nnz, ptr, row, &
          spral_random_matrix_generate_long, nonsingular=nonsingular, sort=sort,&
          val=fval)
  else
     call random_matrix_generate(fstate, matrix_type, m, n, nnz, ptr, row, &
          spral_random_matrix_generate_long, nonsingular=nonsingular, sort=sort)
  end if

  ! Convert to C indexing if required
  if (.not. findex) then
     ptr(:) = ptr(:) - 1
     row(:) = row(:) - 1
  end if

  ! Recover new random genenerator state
  cstate = random_get_seed(fstate)
end function spral_random_matrix_generate_long

max_stars_repo_name: mjacobse/spral

max_issues_repo_name: mjacobse/spral

max_forks_repo_name: mjacobse/spral


text:
program main
  PARAMETER (nsize=10000)
  real a(nsize, nsize), b(nsize, nsize), c(nsize, nsize)
  integer *8 i,j
  integer *4, dimension(8) :: values, values1

  do i=1,nsize
    do j=1,nsize
      a(i,j) = 0
      b(i,j) = i+j
      c(i,j) = 10
    end do
  end do

  call date_and_time(VALUES=values)
  call foo(a,b,c)
  call date_and_time(VALUES=values1)
  print *,"Time Sec=" , ((values1(6)-values(6))*60*1000 + (values1(7)-values(7)) * 1000+(values1(8)-values(8))) *.001
  write(6,*)"a(1,1)=", a(1,1), "    a(2,2)=", a(2,2)
  if (a(1,1).ne.21 .or. a(2,2).ne.42) then
    stop "ERROR: wrong answers"
  endif
  return
end
subroutine foo(a,b,c)
  PARAMETER (nsize=10000)
  real a(nsize,nsize), b(nsize,nsize), c(nsize,nsize)
  integer i,j,k,omp_get_num_threads,omp_get_thread_num,omp_get_max_threads
!$omp target teams distribute parallel do simd map(from:a) map(to:b,c) private(i,j,k)
  do k=1,20
   do i=1,nsize-1
    do j=1,nsize-1
      a(i,j) = b(i,j) * c(i,j) + i
    end do
   end do
  end do
!$omp end target teams distribute parallel do
  return
end

max_stars_repo_name: raramakr/aomp

max_issues_repo_name: raramakr/aomp

max_forks_repo_name: raramakr/aomp


text: #redirect The California Aggie