!*******************************************************************************
!>  @file compression.f
!>  @brief Contains module @ref compression.
!
!  Note separating the Doxygen comment block here so detailed decription is
!  found in the Module not the file.
!
!>  Defines the base class of the type @ref compression_class. This class
!>  contains the code and buffers to hold compressed and uncompressed data. 2D
!>  matrix data is compressed using a singular value decomposition. See
!>  del-Castillo-Negrete et. al. doi:10.1016/j.jcp.2006.07.022.
!*******************************************************************************

      MODULE compression
      USE stel_kinds
      USE mpi_inc

      IMPLICIT NONE

!*******************************************************************************
!  reconstruction module parameters
!*******************************************************************************
!>  Maximum compressed size before uncompressed buffers are stored.
      REAL (rprec), PARAMETER :: compression_max_percentage = 100.0

!>  Postfix for the data buffer.
      CHARACTER (len=*), PARAMETER ::                                          &
     &   compression_data_buffer_post = "data_buffer"
!>  Postfix for the data buffer.
      CHARACTER (len=*), PARAMETER ::                                          &
     &   compression_u_buffer_post = "u_buffer"
!>  Postfix for the data buffer.
      CHARACTER (len=*), PARAMETER ::                                          &
     &   compression_wvt_buffer_post = "wvt_buffer"
!>  Postfix for the data buffer.
      CHARACTER (len=*), PARAMETER ::                                          &
     &   compression_data_dim_post = "data_dim"

!*******************************************************************************
!  DERIVED-TYPE DECLARATIONS
!  1) compression base class
!
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  Base class containing buffers for compressed and uncompressed data.
!-------------------------------------------------------------------------------
      TYPE compression_class
!  Uncompressed buffer
         REAL (rprec), DIMENSION(:,:), POINTER :: data_buffer => null()

!  Singular Value U buffer
         REAL (rprec), DIMENSION(:,:), POINTER :: u_buffer => null()
!  Singular Value V transpose buffer
         REAL (rprec), DIMENSION(:,:), POINTER :: wvt_buffer => null()

!  Dimensions of the data buffer. This is used in the special case that the
!  orginal data buffer is all zeros. Otherwise it remains unallocated.
         INTEGER, DIMENSION(:), POINTER        :: data_dim => null()
      END TYPE

!-------------------------------------------------------------------------------
!>  Pointer to a compression object. Used for creating arrays of compression
!>  pointers. This is needed because fortran does not allow arrays of pointers
!>  directly.
!-------------------------------------------------------------------------------
      TYPE compression_pointer
         TYPE (compression_class), POINTER :: p => null()
      END TYPE

!*******************************************************************************
!  INTERFACE BLOCKS
!*******************************************************************************
      INTERFACE compression_construct
         MODULE PROCEDURE compression_construct_new,                           &
     &                    compression_construct_netcdf
      END INTERFACE

      CONTAINS
!*******************************************************************************
!  CONSTRUCTION SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Construct a @ref compression_class object.
!>
!>  Constructs compression object and compresses the data buffer if compression
!>  meets the specified criteria.
!>
!>  @param[in] data_in     Data buffer to compress. This gets copied to the
!>                         internal storage buffer.
!>  @param[in] svn_cut_off Cutoff value for determining the number of singular
!>                         values to use for compression.
!>  @returns A pointer to a constructed @ref compression_class object.
!-------------------------------------------------------------------------------
      FUNCTION compression_construct_new(data_in, svd_cut_off)
      USE v3_utilities

      IMPLICIT NONE

!  Declare Arguments
      TYPE (compression_class), POINTER :: compression_construct_new
      REAL (rprec), DIMENSION(:,:), INTENT(in) :: data_in
      REAL (rprec), INTENT(in)                 :: svd_cut_off

!  local arguments
      INTEGER                                  :: m, n, i
      REAL (rprec), DIMENSION(:), ALLOCATABLE  :: w_svd
      REAL (rprec), DIMENSION(:), ALLOCATABLE  :: svd_work
      INTEGER                                  :: work_size
      INTEGER                                  :: status
      REAL (rprec)                             :: e_zero
      REAL (rprec)                             :: e_r

!  Start of executable code
      ALLOCATE(compression_construct_new)

!  Special case if all the data is zero, there is no need to retain any singular
!  values. This will be detected in the uncompress by having the data_dim array
!  allocated.
      IF (ALL(data_in .eq. 0.0)) THEN
         ALLOCATE(compression_construct_new%data_dim(2))
         compression_construct_new%data_dim = SHAPE(data_in)
         RETURN
      END IF

      m = SIZE(data_in, 1)
      n = SIZE(data_in, 2)
      ALLOCATE(compression_construct_new%data_buffer(m,n))
      compression_construct_new%data_buffer = data_in

      IF (svd_cut_off .eq. 0.0) THEN
         RETURN
      END iF

      ALLOCATE(compression_construct_new%wvt_buffer(n,n))
      ALLOCATE(compression_construct_new%u_buffer(m,m))
      ALLOCATE(svd_work(1))
      ALLOCATE(w_svd(MIN(m,n)))

      compression_construct_new%wvt_buffer = 0.0
      compression_construct_new%u_buffer = 0.0
      w_svd = 0.0
      svd_work = 0.0

!  Find the optimal work size.
      CALL dgesvd('All', 'All', m, n,                                          &
     &            compression_construct_new%data_buffer, m,                    &
     &            w_svd, compression_construct_new%u_buffer, m,                &
     &            compression_construct_new%wvt_buffer, n, svd_work, -1,       &
     &            status)
      work_size = INT(svd_work(1))
      DEALLOCATE(svd_work)
      ALLOCATE(svd_work(work_size))
      svd_work = 0.0

!  Factor the matrix to M = U * W * V^T
      CALL dgesvd('All', 'All', m, n,                                          &
     &            compression_construct_new%data_buffer, m,                    &
     &            w_svd, compression_construct_new%u_buffer, m,                &
     &            compression_construct_new%wvt_buffer, n, svd_work,           &
     &            work_size, status)
      CALL assert_eq(0, status, 'dgesvd problem when compressing ' //          &
     &                          'buffer')

      DEALLOCATE(svd_work)

!  Determine the number of singular values to keep. If the number of singular
!  values is greater than half, do not compress the buffer. First start by
!  setting any negative values to zero.
      WHERE (w_svd .lt. 0.0)
         w_svd = 0.0
      END WHERE

!  Find the minimum number of singular values to keep based on
!  1 - n(r) = svd_cut_off where n(r) is equation (7) in del-Castillo-Negrete
!  et. al. doi:10.1016/j.jcp.2006.07.022
      e_zero = DOT_PRODUCT(w_svd, w_svd)

      e_r = 0.0
!  We only need to check up to one more than half the number of singular values.
!  Anymore than that will use more data storage. Store the number of singular
!  values retained in the work_size.
      DO i = 1, SIZE(w_svd)/2 + 1
         e_r = e_r + w_svd(i)*w_svd(i)
         work_size = i
         IF ((1.0 - e_r/e_zero) .le. svd_cut_off) THEN
            EXIT
         END IF
      END DO

!  Check the compression percentage. The compression is defined as the
!  percentage of the orginal data size. The compression percentage is defined as
!
!    compressed_size/uncompressed_size*100.0                                 (1)
!
!  where
!
!    compressed_size = r + r*m + r*n                                         (2)
!
!  and
!
!    uncompressed_size = n*m                                                 (3)
!
!  n and m are the dimensions of the orginal matrix and r is the number of
!  singular values retained.
!
!  However you can gain even more storage space. The compressed data is '
!  uncompressed reconstructing the matrix from U.W.V^T. By precomputing W.V^T
!  and storing that buffer instead instead of the W and V^T buffers separately,
!  the an array the size of the number of signular values is eliminiated. This
!  also has the added benifit of speed when uncompressing the data. The new
!  compressed size becomes
!
!    compressed_size = r*m + r*n                                             (4)
!
!  Barrow the e_ variables to compute th compression
!  percentage. Use e_r for the compressed size and e_zero of the uncompressed
!  size.

      e_r = work_size*m + work_size*n
      e_zero = n*m

      IF (100.0*e_r/e_zero .ge. compression_max_percentage) THEN
!  Use the uncompressed buffers.
         compression_construct_new%data_buffer = data_in

         DEALLOCATE(compression_construct_new%u_buffer)
         compression_construct_new%u_buffer => null()

         DEALLOCATE(compression_construct_new%wvt_buffer)
         compression_construct_new%wvt_buffer => null()
      ELSE
!  Use the compressed buffers. Barrow the data_buffer as temp buffer for
!  resizing the storage buffers.
         DEALLOCATE(compression_construct_new%data_buffer)

!  Store the U buffer. The reduced U buffer now only needs m x r storage space.
         ALLOCATE(compression_construct_new%data_buffer(m,work_size))
         compression_construct_new%data_buffer =                               &
     &      compression_construct_new%u_buffer(:,1:work_size)
         DEALLOCATE(compression_construct_new%u_buffer)
         ALLOCATE(compression_construct_new%u_buffer(m,work_size))
         compression_construct_new%u_buffer =                                  &
     &      compression_construct_new%data_buffer
         DEALLOCATE(compression_construct_new%data_buffer)

!  Store the VT buffer. The reduced VT buffer now only needs r x n storage
!  space.
         ALLOCATE(compression_construct_new%data_buffer(work_size,n))
         compression_construct_new%data_buffer =                               &
     &      compression_construct_new%wvt_buffer(1:work_size,:)
         DEALLOCATE(compression_construct_new%wvt_buffer)
         ALLOCATE(compression_construct_new%wvt_buffer(work_size,n))

!  Multiply W.VT and store in the WVT buffer.
         DO i = 1, n
            compression_construct_new%wvt_buffer(:,i) =                        &
     &         w_svd(1:work_size) *                                            &
     &         compression_construct_new%data_buffer(:,i)
         END DO

         DEALLOCATE(compression_construct_new%data_buffer)
         compression_construct_new%data_buffer => null()
      END IF

      DEALLOCATE(w_svd)

      END FUNCTION

!-------------------------------------------------------------------------------
!>  @brief Construct a @ref compression_class object by reading from an netcdf.
!>  file.
!>
!>  Constructs data from a precompressed netcdf file.
!>
!>  @param[in] ncid A netcdf file id.
!>  @param[in] name A netcdf variable name id.
!>  @param[in] name Flag discribing how the data was compressed.
!>  @returns A pointer to a constructed @ref compression_class object.
!-------------------------------------------------------------------------------
      FUNCTION compression_construct_netcdf(ncid, name)
      USE ezcdf

      IMPLICIT NONE

!  Declare Arguments
      TYPE (compression_class), POINTER :: compression_construct_netcdf
      INTEGER, INTENT(in)               :: ncid
      CHARACTER (len=*), INTENT(in)     :: name

!  local variables
      INTEGER, DIMENSION(2)             :: dim_lengths
      INTEGER                           :: error

!  Start of executable code
      ALLOCATE(compression_construct_netcdf)

      dim_lengths = -1

      CALL cdf_inquire(ncid, TRIM(name) // compression_data_buffer_post,       &
     &                 dim_lengths)
      IF (ALL(dim_lengths .gt. 0)) THEN
         ALLOCATE(                                                             &
     &      compression_construct_netcdf%data_buffer(dim_lengths(1),           &
     &                                               dim_lengths(2)))
         CALL cdf_read(ncid,                                                   &
     &                 TRIM(name) // compression_data_buffer_post,             &
     &                 compression_construct_netcdf%data_buffer)
         RETURN
      END IF

      CALL cdf_inquire(ncid, TRIM(name) // compression_u_buffer_post,          &
     &                 dim_lengths)
      IF (ALL(dim_lengths .gt. 0)) THEN
         ALLOCATE(                                                             &
     &      compression_construct_netcdf%u_buffer(dim_lengths(1),              &
     &                                            dim_lengths(2)))
         CALL cdf_read(ncid, TRIM(name) // compression_u_buffer_post,          &
     &                 compression_construct_netcdf%u_buffer)

         CALL cdf_inquire(ncid,                                                &
     &                    TRIM(name) // compression_wvt_buffer_post,           &
     &                    dim_lengths)
         ALLOCATE(                                                             &
     &      compression_construct_netcdf%wvt_buffer(dim_lengths(1),            &
     &                                              dim_lengths(2)))
         CALL cdf_read(ncid, TRIM(name) // compression_wvt_buffer_post,        &
     &                 compression_construct_netcdf%wvt_buffer)
         RETURN
      END IF

      CALL cdf_inquire(ncid, TRIM(name) // compression_data_dim_post,          &
     &                 dim_lengths(1:1))
      ALLOCATE( compression_construct_netcdf%data_dim(dim_lengths(1)))
      CALL cdf_read(ncid, TRIM(name) // compression_data_dim_post,             &
     &              compression_construct_netcdf%data_dim)

      END FUNCTION

!*******************************************************************************
!  DESTRUCTION SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Deconstruct a @ref compression_class object.
!>
!>  Deallocates memory and uninitializes a @ref compression_class object.
!>
!>  @param[inout] this A @ref compression_class instance.
!-------------------------------------------------------------------------------
      SUBROUTINE compression_destruct(this)

      IMPLICIT NONE

!  Declare Arguments
      TYPE (compression_class), POINTER :: this

!  Start of executable code
      IF (ASSOCIATED(this%data_buffer)) THEN
         DEALLOCATE(this%data_buffer)
         this%data_buffer => null()
      END IF

      IF (ASSOCIATED(this%u_buffer)) THEN
         DEALLOCATE(this%u_buffer)
         this%u_buffer => null()
      END IF

      IF (ASSOCIATED(this%wvt_buffer)) THEN
         DEALLOCATE(this%wvt_buffer)
         this%wvt_buffer => null()
      END IF

      DEALLOCATE(this)

      END SUBROUTINE

!*******************************************************************************
!  GETTER SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Get the ith dimension length.
!>
!>  Retrives the uncompressed dimension of the first data buffer index. This
!>  can be used without needing to decompress the data first.
!>
!>  @param[inout] this A @ref compression_class instance.
!>  @returns The size of the ith dimension of the uncompressed data buffer.
!-------------------------------------------------------------------------------
      FUNCTION compression_get_dimension1(this)

      IMPLICIT NONE

!  Declare Aruments
      INTEGER                           :: compression_get_dimension1
      TYPE (compression_class), POINTER :: this

!  Start of executable code
      IF (ASSOCIATED(this%data_buffer)) THEN
         compression_get_dimension1 = SIZE(this%data_buffer, 1)
      ELSE IF (ASSOCIATED(this%u_buffer)) THEN
         compression_get_dimension1 = SIZE(this%u_buffer, 1)
      ELSE IF (ASSOCIATED(this%data_dim)) THEN
         compression_get_dimension1 = this%data_dim(1)
      ELSE
         compression_get_dimension1 = 0
      END IF

      END FUNCTION

!-------------------------------------------------------------------------------
!>  @brief Get the jth dimension length.
!>
!>  Retrives the uncompressed dimension of the second data buffer index. This
!>  can be used without needing to decompress the data first.
!>
!>  @param[inout] this A @ref compression_class instance.
!>  @returns The size of the jth dimension of the uncompressed data buffer.
!-------------------------------------------------------------------------------
      FUNCTION compression_get_dimension2(this)

      IMPLICIT NONE

!  Declare Aruments
      INTEGER                           :: compression_get_dimension2
      TYPE (compression_class), POINTER :: this

!  Start of executable code
      IF (ASSOCIATED(this%data_buffer)) THEN
         compression_get_dimension2 = SIZE(this%data_buffer, 2)
      ELSE IF (ASSOCIATED(this%u_buffer)) THEN
         compression_get_dimension2 = SIZE(this%wvt_buffer, 2)
      ELSE IF (ASSOCIATED(this%data_dim)) THEN
         compression_get_dimension2 = this%data_dim(2)
      ELSE
         compression_get_dimension2 = 0
      END IF

      END FUNCTION

!*******************************************************************************
!  UTILITY SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Decompress the data.
!>
!>  Checks if the U and WVT arrays are allocated. If they are not the
!>  data_buffer was left uncompressed. If the data dimensions is also
!>  unallocated, then the orginal data buffer was all zeros otherwise data is
!>  uncompressed by matrix a multiplication.
!>
!>  @param[inout] this A @ref compression_class instance.
!-------------------------------------------------------------------------------
      SUBROUTINE compression_decompress(this)

      IMPLICIT NONE

!  Declare Arguments
      TYPE (compression_class), POINTER :: this

!  Start of executable code
      IF (ASSOCIATED(this%data_buffer)) THEN
!  Data is stored uncompressed. No need to do anything.
         RETURN
      END IF

      IF (ASSOCIATED(this%data_dim)) THEN
!  Data is all zeros. Allocate the data_buffer and set to zero.
         ALLOCATE(this%data_buffer(this%data_dim(1),this%data_dim(2)))
         this%data_buffer = 0.0
         RETURN
      END IF

!  If control has reached this point, the data is compressed. Uncompress it by
!  U.WVT.
      ALLOCATE(this%data_buffer(SIZE(this%u_buffer, 1),                        &
     &                          SIZE(this%wvt_buffer, 2)))

      this%data_buffer = MATMUL(this%u_buffer, this%wvt_buffer)

      END SUBROUTINE

!-------------------------------------------------------------------------------
!>  @brief Cleanup decompressed data.
!>
!>  If the data dimensions arrays or the U and WVT is allocated, then delete the
!>  data buffer. Otherwise the data is stored uncompressed.
!>
!>  @param[inout] this A @ref compression_class instance.
!-------------------------------------------------------------------------------
      SUBROUTINE compression_cleanup(this)

      IMPLICIT NONE

!  Declare Arguments
      TYPE (compression_class), POINTER :: this

!  Start of executable code
      IF (ASSOCIATED(this%data_dim) .or. ASSOCIATED(this%u_buffer)) THEN
         DEALLOCATE(this%data_buffer)
         this%data_buffer => null()
      END IF

      END SUBROUTINE

!*******************************************************************************
!  NETCDF SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Define variables for the compressed data.
!>
!>  Defines the netcdf variables for writting compressed data to a netcdf file.
!>
!>  @param[in] this A @ref compression_class instance.
!>  @param[in] ncid Netcdf file id.
!>  @param[in] name Base name of variables to compress.
!>  @returns The flag indicating which buffer was stored.
!-------------------------------------------------------------------------------
      SUBROUTINE compression_define(this, ncid, name)
      USE ezcdf

      IMPLICIT NONE

!  Declare Arguments
      TYPE (compression_class), INTENT(in) :: this
      INTEGER, INTENT(in)                  :: ncid
      CHARACTER (len=*), INTENT(in)        :: name

!  Start of executable code
      IF (ASSOCIATED(this%data_buffer)) THEN
         CALL cdf_define(ncid,                                                 &
     &                   TRIM(name) // compression_data_buffer_post,           &
     &                   this%data_buffer)
      ELSE IF (ASSOCIATED(this%u_buffer)) THEN
         CALL cdf_define(ncid, TRIM(name) // compression_u_buffer_post,        &
     &                   this%u_buffer)
         CALL cdf_define(ncid,                                                 &
     &                   TRIM(name) // compression_wvt_buffer_post,            &
     &                   this%wvt_buffer)
      ELSE
         CALL cdf_define(ncid, TRIM(name) // compression_data_dim_post,        &
     &                   this%data_dim)
      END IF

      END SUBROUTINE

!-------------------------------------------------------------------------------
!>  @brief Cleanup decompressed data.
!>
!>  If the data dimensions arrays or the U and WVT is allocated, then delete the
!>  data buffer. Otherwise the data is stored uncompressed.
!>
!>  @param[inout] this A @ref compression_class instance.
!-------------------------------------------------------------------------------
      SUBROUTINE compression_write(this, ncid, name)
      USE ezcdf

      IMPLICIT NONE

!  Declare Arguments
      TYPE (compression_class), INTENT(in) :: this
      INTEGER, INTENT(in)                  :: ncid
      CHARACTER (len=*), INTENT(in)        :: name

!  Start of executable code
      IF (ASSOCIATED(this%data_buffer)) THEN

         CALL cdf_write(ncid,                                                  &
     &                  TRIM(name) // compression_data_buffer_post,            &
     &                  this%data_buffer)

      ELSE IF (ASSOCIATED(this%u_buffer)) THEN

         CALL cdf_write(ncid, TRIM(name) // compression_u_buffer_post,         &
     &                  this%u_buffer)
         CALL cdf_write(ncid, TRIM(name) // compression_wvt_buffer_post,       &
     &                  this%wvt_buffer)

      ELSE

         CALL cdf_write(ncid, TRIM(name) // compression_data_dim_post,         &
     &                  this%data_dim)

      END IF

      END SUBROUTINE

      END MODULE


c
c     4/97
c
c     a subroutine for testing all theta derivative subroutines
c     vtses,vtsec,vtsgs,vtsgc
c
c
c     (1) first set a valid vector field (v,w) in terms of x,y,z
c         cartesian coordinates
c
c     (2) analytically compute (vt,wt) from (1)
c
c     (3) compute (vt,wt) using vtses,vtsec,vtsgs,vtsgc and compare with (2)
c
      program tvts
c
c     set dimensions with parameter statements
c
      parameter(nnlat= 25,nnlon= 19, nnt = 3)
      parameter (lleng= 5*nnlat*nnlat*nnlon,llsav= 5*nnlat*nnlat*nnlon)
      dimension work(lleng),wsave(llsav)
      parameter (lldwork = 4*nnlat*nnlat )
      double precision dwork(lldwork)
      dimension br(nnlat,nnlat,nnt),bi(nnlat,nnlat,nnt)
      dimension cr(nnlat,nnlat,nnt),ci(nnlat,nnlat,nnt)
      dimension thetag(nnlat),dtheta(nnlat),dwts(nnlat)
      dimension v(nnlat,nnlon,nnt),w(nnlat,nnlon,nnt)
      dimension vt(nnlat,nnlon,nnt),wt(nnlat,nnlon,nnt)
      dimension vtsav(nnlat,nnlon,nnt),wtsav(nnlat,nnlon,nnt)
      double precision dtheta, dwts
c
c     set dimension variables
c
      nlat = nnlat
      nlon = nnlon
      lwork = lleng
      lsave = llsav
      nt = nnt
      call iout(nlat,4hnlat)
      call iout(nlon,4hnlon)
      call iout(nt,4h  nt)
      ityp = 0
c
c     set equally spaced colatitude and longitude increments
c
      pi = 4.0*atan(1.0)
      dphi = (pi+pi)/nlon
      dlat = pi/(nlat-1)
c
c     compute nlat gaussian points in thetag
c
      ldwork = lldwork
      call gaqd(nlat,dtheta,dwts,dwork,ldwork,ier)
      do  i=1,nlat
	thetag(i) = dtheta(i)
      end do
      call name(4hgaqd)
      call iout(ier,4h ier)
      call vecout(thetag,4hthtg,nlat)
c
c     test all theta derivative subroutines
c
      do icase=1,4
c
c     icase=1 test vtsec
c     icase=2 test vtses
c     icase=3 test vtsgc
c     icase=4 test vtsgs
c
      call name(4h****)
      call name(4h****)
      call iout(icase,4hicas)
c
c
c     set vector field v,w and compute theta derivatives in (vtsav,wtsav)
c
      do k=1,nt
	do j=1,nlon
	  phi = (j-1)*dphi
	  sinp = sin(phi)
	  cosp = cos(phi)
	  do i=1,nlat
	    theta = (i-1)*dlat
	    if (icase.eq.3 .or. icase.eq.4) theta = thetag(i)
	    cost = cos(theta)
	    sint = sin(theta)
c
c    set x,y,z and their theta derivatives at colatitude theta and longitude p
c
	    x = sint*cosp
	    dxdt = cost*cosp
	    y = sint*sinp
	    dydt = cost*sinp
	    z = cost
	    dzdt = -sint
c
c     set (v,w) field corresponding to stream function
c     S = exp(y)+exp(-z) and velocity potential function
c     P = exp(x)+exp(z)
c
	      ex = exp(x)
	      ey = exp(y)
	      ez = exp(z)
	      emz = exp(-z)
	      w(i,j,k) =-ex*sinp+emz*sint+ey*cost*sinp
	      v(i,j,k) =-ey*cosp-ez*sint+ex*cost*cosp
c
c     set theta derivatives differentiating w,v above
c
	     wtsav(i,j,k) = -ex*dxdt*sinp+emz*(-dzdt*sint+cost)
     +                      +ey*sinp*(dydt*cost-sint)
	     vtsav(i,j,k) = -ey*dydt*cosp-ez*(dzdt*sint+cost)
     +                      +ex*cosp*(dxdt*cost-sint)
	  end do
	end do
      end do

c     call a3out(wtsav,4hwtsv,nlat,nlon,nt)
c     call a3out(vtsav,4hvtsv,nlat,nlon,nt)

      if (icase.eq.1) then

      call name(4h**ec)

      call vhaeci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name(4hvhai)
      call iout(ierror,4hierr)

      call vhaec(nlat,nlon,ityp,nt,v,w,nlat,nlon,br,bi,cr,ci,nlat,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name(4hvha )
      call iout(ierror,4hierr)

c
c     now compute theta derivatives of v,w
c
      call vtseci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)

      call name(4hvtsi)
      call iout(ierror,4hierr)

      call vtsec(nlat,nlon,ityp,nt,vt,wt,nlat,nlon,br,bi,cr,ci,nlat,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name(4hvts )
      call iout(ierror,4hierr)

      else if (icase.eq.2) then

      call name(4h**es)

      call vhaesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name(4hvhai)
      call iout(ierror,4hierr)

      call vhaes(nlat,nlon,ityp,nt,v,w,nlat,nlon,br,bi,cr,ci,nlat,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name(4hvha )
      call iout(ierror,4hierr)

      call vtsesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name(4hvtsi)
      call iout(ierror,4hierr)

      call vtses(nlat,nlon,ityp,nt,vt,wt,nlat,nlon,br,bi,cr,ci,nlat,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name(4hvts )
      call iout(ierror,4hierr)

      else if (icase.eq.3) then

      call name(4h**gc)

      call name(4hvhgi)
      call iout(nlat,4hnlat)

      call vhagci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name(4hvhai)
      call iout(ierror,4hierr)

      call vhagc(nlat,nlon,ityp,nt,v,w,nlat,nlon,br,bi,cr,ci,nlat,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name(4hvha )
      call iout(ierror,4hierr)

c
c     now synthesize v,w from br,bi,cr,ci and compare with original
c
      call vtsgci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name(4hvtsi)
      call iout(ierror,4hierr)

      call vtsgc(nlat,nlon,ityp,nt,vt,wt,nlat,nlon,br,bi,cr,ci,nlat,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name(4hvts )
      call iout(ierror,4hierr)

      else if (icase.eq.4) then

      call name(4h**gs)
      call vhagsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name(4hvhai)
      call iout(ierror,4hierr)

      call vhags(nlat,nlon,ityp,nt,v,w,nlat,nlon,br,bi,cr,ci,nlat,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name(4hvha )
      call iout(ierror,4hierr)

      call vtsgsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name(4hvtsi)
      call iout(ierror,4hierr)

      call vtsgs(nlat,nlon,ityp,nt,vt,wt,nlat,nlon,br,bi,cr,ci,nlat,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name(4hvts )
      call iout(ierror,4hierr)

      end if

c     call a3out(wt,4hwt  ,nlat,nlon,nt)
c     call a3out(vt,4hvt  ,nlat,nlon,nt)

c
c     compute "error" in vt,wt
c
      err2v = 0.0
      err2w = 0.0
      do k=1,nt
	do j=1,nlon
	  do i=1,nlat
	    err2v = err2v + (vt(i,j,k) - vtsav(i,j,k))**2
	    err2w = err2w + (wt(i,j,k) - wtsav(i,j,k))**2
	  end do
	end do
      end do
c
c     set and print least squares error in v,w
c
      err2v = sqrt(err2v/(nt*nlat*nlon))
      err2w = sqrt(err2w/(nt*nlat*nlon))
      call vout(err2v,4herrv)
      call vout(err2w,4herrw)
c
c     end of icase loop
c
      end do
      end
      subroutine iout(ivar,nam)
      real nam
      write(6,10) nam , ivar
   10 format(1h a4, 3h = ,i8)
      return
      end
c
      subroutine vout(var,nam)
      real nam
      write(6,10) nam , var
   10 format(1h a4,3h = ,e12.5)
      return
      end
c
      subroutine name(nam)
      real nam
      write(6,100) nam
  100 format(1h a8)
      return
      end
c
      subroutine vecout(vec,nam,len)
      dimension vec(len)
      real nam
      write(6,109) nam, (vec(l),l=1,len)
  109 format(1h a4,/(1h 8e11.4))
      return
      end


subroutine supf_ExaPreElmdir(a,e,elmat,elrhs)
   use typre
   use Mod_Mesh
   use Mod_SupExacso
   use Mod_ThreeField
   use Mod_SUPFractionalStep
   use Mod_Element
   implicit none
   class(SUPFractionalStepProblem) :: a
   class(FiniteElement) :: e
   type(SupExacso)  :: exacso

   real(rp) :: elmat(1,e%mnode,1,e%mnode), elrhs(1,e%mnode)

   real(rp) :: adiag
   integer(ip) :: inode,ipoin,jnode
   !Exact Values
   real(rp)                   :: exprg(e%ndime)
   real(rp)                   :: expre
   real(rp), pointer          :: coord(:) => NULL()

   real(rp)    :: prepr

   do inode = 1,e%pnode
      ipoin = e%lnods(inode)

      call a%Mesh%GetPointCoord(ipoin,coord)

      !Exact solution
      call exacso%sup_ComputeSolution(e%ndime,coord,a%ctime,a%LogFormulation,a)
      call exacso%sup_GetPressure(e%ndime,expre,exprg)

      prepr = expre

      adiag=elmat(1,inode,1,inode)
      elmat(1,inode,1,1:e%pnode)=0.0_rp
      do jnode = 1,e%pnode
         elrhs(1,jnode) = elrhs(1,jnode)- elmat(1,jnode,1,inode)*prepr
      enddo
      elmat(1,1:e%pnode,1,inode) = 0.0_rp
      elmat(1,inode,1,inode) = adiag
      elrhs(1,inode) = adiag*prepr

   enddo
end subroutine


subroutine modelB_function2(in_val, in_val_copy, out_val)
  ! Only valid if in_val > 2
  real, intent(in) :: in_val
  real, intent(out) :: in_val_copy
  real, intent(out) :: out_val
  in_val_copy = in_val
  out_val = 2 * (in_val**2)
  print *, "modelB_function2(", in_val, ") = ", out_val
end subroutine modelB_function2


c     program DRDPFIT
c>> 1996-06-21 DRDPFIT Krogh Special code for C conversion.
c>> 1996-05-28 DRDPFIT Krogh Added external statement.
c>> 1995-09-15 DRDPFIT Krogh Declare all variables.
c>> 1995-09-15 DRDPFIT Krogh Remove '0' in format (again?)
c>> 1994-10-19 DRDPFIT Krogh  Changes to use M77CON
c>> 1994-08-09 DRDPFIT WVS Remove '0' in format
c>> 1991-11-20 DRDPFIT CLL Edited for Fortran 90
c>> 1987-12-09 DRDPFIT  Lawson  Initial Code.
c--D replaces "?": DR?PFIT, ?PFIT, ?CPVAL
c     Demonstration driver for DPFIT.
c++ Code for .C. is inactive
c%%   long int j;
c++ End
      external DCPVAL
      double precision  X(12),Y(12),P(11),SIGFAC,W(121),DCPVAL
      double precision  SIG(1), R, YFIT
      integer I, M, NDEG, NP3
c
      data X / 2.D0, 4.D0, 6.D0, 8.D0, 10.D0, 12.D0, 14.D0,
     *         16.D0, 18.D0, 20.D0, 22.D0, 24.D0 /
      data Y / 2.2D0, 4.0D0, 5.0D0, 4.6D0, 2.8D0, 2.7D0,
     *         3.8D0, 5.1D0, 6.1D0, 6.3D0, 5.0D0, 2.0D0 /
      data SIG(1) / -1.D0 /
      data M      / 12 /
c
 1001 format(1X/'  I    X       Y       YFIT  R=Y-YFIT'/1X)
 1002 format(1X,I2,F6.0,2F9.3,F10.3)
c
      call DPFIT(M,X,Y,SIG,8, .TRUE. , .TRUE. , .TRUE. ,P,NDEG,SIGFAC,W)
      NP3 = NDEG+3

c++ Code for ~.C. is active
      print
     *'(/'' NDEG ='',I2,10X,''SIGFAC ='',F8.4//
     *'' P(1),P(2) ='',9X,2F15.8//'' P(3),...,P(NDEG+3) ='',3F15.8/
     *(21X,3F15.8))', NDEG,SIGFAC,(P(I),I=1,NP3)
c++ Code for .C. is inactive
c%%   printf(
c%%      "\n NDEG =%2ld          SIGFAC =%8.4f",ndeg,sigfac );
c%%   printf(
c%%   "\n\n P(1),P(2) =         %15.8f%15.5f\n\n P(3),...,P(NDEG+3) =",
c%%   p[0], p[1]);
c%%   for (i = 2; i < (np3); i+=3){
c%%      for (j = i; j < (i < np3-2 ? i+3 : np3); j++)
c%%           printf("%15.8f", p[j] );
c%%           if (i < np3-2) printf("\n                     ");}
c%%   printf( "\n" );
c++ End
      write(*,1001)
      do 20 I = 1,M
        YFIT = DCPVAL(P,NDEG,X(I))
        R = Y(I) - YFIT
        write(*,1002)I,X(I),Y(I),YFIT,R
   20 continue
      stop
      end


      REAL*4 FUNCTION TAND(ARG)

!PURPOSE: Calculate tangent from angle in deg.

      INCLUDE       '../INCLDS/COPYRIGT.FOR'

!CALLING ARGUMENTS:

      REAL*4        ARG                 !Tangent argument in degrees

!INCLUDE STATEMENTS:

!LOCAL VARIABLES:

!FUNCTION DEFINITIONS:

!DATA STATEMENTS:

      DATA  RPD/0.017453292519943/

!CODE:

      TAND = TAN(ARG*RPD)
      RETURN
      END


!!# LIBRARY MODULE <<LIB_xy>>
MODULE LIB_xy

!!## PURPOSE
!! A library of routines for $2D$ computational geometry.

!!## DEPENDENCIES
!! * basic kinds
!! * defined constants (<c_PI>$=\pi$, etc.)
!! * the error function (<Error(X)> is the error number for
!!   the type of <X>
!! * add all computational geometry routines
USE KND_IntrinsicTypes                   !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rdp                    !!((02-A-PAR_Constants_Rdp.f90))
USE FUN_Error                            !!((04-A-FUN_Error.f90))
USE TBX_ComputationalGeometry            !!((09-A-TBX_ComputationalGeometry.f90))
USE FUN_xyAREA                           !!((04-B-FUN_xyAREA.f90))
USE FUN_xySAREA                          !!((03-A-FUN_xySAREA.f90))
USE FUN_Upcase                           !!((03-A-FUN_Upcase.f90))
USE FUN_Default                          !!((04-A-FUN_Default.f90))
USE VAR_ComputationalGeometry            !!((03-A-VAR_ComputationalGeometry.f90))
USE FUN_STR                              !!((05-B-FUN_STR.f90))
USE VAR_Units                            !!((03-A-VAR_Units.f90))
USE FUN_xyROTATE                         !!((05-B-FUN_xyROTATE.f90))
USE FUN_xyTRANSLATE                      !!((05-B-FUN_xyTRANSLATE.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

INTEGER,PARAMETER :: Unit_noisy=86
PRIVATE :: Unit_noisy

!!## PUBLIC ACCESS LIST
PUBLIC :: xyOUTFACES_PgU
PUBLIC :: xyIS_CONVEX_CCW_Pg
PUBLIC :: GNUPLOT_Pg,GNUPLOT_Ls,GNUPLOT_Sli,GNUPLOT_P
PUBLIC :: GNUPLOT_OUTFACES
!! test shapes

!!## CONTAINED PROCEDURES
CONTAINS

SUBROUTINE GNUPLOT_Pg( Unit , N , Pg )
INTEGER       ,INTENT(IN)  :: Unit
INTEGER       ,INTENT(IN)  :: N
REAL(KIND_Rdp),INTENT(IN)  :: Pg(2,N)
REAL(KIND_Rdp) :: P1(2),P2(2)
INTEGER :: i1,i2
!!--begin--

i1 = N
i2 = 1
DO

 P1 = Pg(:,i1)
 P2 = Pg(:,i2)

 WRITE(Unit,*)P1
 WRITE(Unit,*)P2
 WRITE(Unit,*)

 i1 = MOD(i1,N)+1
 i2 = i2 + 1

 IF( i2>N )THEN
  EXIT
 END IF

END DO
WRITE(Unit,*)

!!--end--
END SUBROUTINE

SUBROUTINE GNUPLOT_Sli( Unit , N , Sli )
INTEGER       ,INTENT(IN)  :: Unit
INTEGER       ,INTENT(IN)  :: N
REAL(KIND_Rdp),INTENT(IN)  :: Sli(3,N)
REAL(KIND_Rdp)  :: Qp(2,4)
INTEGER :: i

!!--begin--

DO i=1,N-1
 !get the parallelogram
 Qp(:,1) = (/ Sli(1,i  ),Sli(2,i)   /)
 Qp(:,2) = (/ Sli(1,i+1),Sli(2,i+1) /)
 Qp(:,3) = (/ Sli(1,i+1),Sli(3,i+1) /)
 Qp(:,4) = (/ Sli(1,i  ),Sli(3,i)   /)

 CALL GNUPLOT_Pg( Unit , 4 , Qp )
END DO

!!--end--
END SUBROUTINE

SUBROUTINE GNUPLOT_P( Unit , P )
INTEGER       ,INTENT(IN)  :: Unit
REAL(KIND_Rdp),INTENT(IN)  :: P(2)
!!--begin--

WRITE(Unit,*)P
WRITE(Unit,*)
WRITE(Unit,*)

!!--end--
END SUBROUTINE

SUBROUTINE GNUPLOT_Ls( Unit , Ls )
INTEGER       ,INTENT(IN)  :: Unit
REAL(KIND_Rdp),INTENT(IN)  :: Ls(2,2)
!!--begin--

WRITE(Unit,*)Ls(:,1)
WRITE(Unit,*)Ls(:,2)
WRITE(Unit,*)
WRITE(Unit,*)

!!--end--
END SUBROUTINE

SUBROUTINE GNUPLOT_U( Unit , U )
INTEGER       ,INTENT(IN)  :: Unit
REAL(KIND_Rdp),INTENT(IN)  :: U(2)
!!--begin--

WRITE(Unit,*)(/0._KIND_Rdp,0._KIND_Rdp/)
WRITE(Unit,*)U
WRITE(Unit,*)
WRITE(Unit,*)

!!--end--
END SUBROUTINE

SUBROUTINE GNUPLOT_OutFaces( N , Pg , U )
USE KND_IntrinsicTypes                   !!((01-A-KND_IntrinsicTypes.f90))
USE FUN_xyLINESEGMENT                    !!((05-B-FUN_xyLINESEGMENT.f90))
USE PAR_Constants_Rdp                    !!((02-A-PAR_Constants_Rdp.f90))
USE FUN_NewFile                          !!((05-B-FUN_NewFile.f90))
INTEGER :: N
REAL(KIND_Rdp) :: Pg(2,N),U(2)
REAL(KIND_Rdp) :: Ls(2,N)
INTEGER :: i,i1,i2
INTEGER :: Unit_outface,Unit_inface,Unit_outverts,Unit_inverts
LOGICAL :: OUTFACES(N),OUTVERTS(N)

!!--begin--

Unit_outface = NewFile("outface")
Unit_inface = NewFile("inface")
Unit_outverts = NewFile("outverts")
Unit_inverts = NewFile("inverts")

OUTFACES = xyOUTFACES_PgU( N , Pg , U , OUTVERTS )

DO i=1,N

 !get indices
 i1 = i
 i2 = MOD(i,N) + 1

 Ls = xyLINESEGMENT_PP( Pg(:,i1) , Pg(:,i2) )

 IF( OUTFACES(i) )THEN
  CALL GNUPLOT_Ls( Unit_outface , Ls )
 ELSE
  CALL GNUPLOT_Ls( Unit_inface , Ls )
 END IF

 IF( OUTVERTS(i) )THEN
  CALL GNUPLOT_P( Unit_outverts , Pg(:,i) )
 ELSE
  CALL GNUPLOT_P( Unit_inverts , Pg(:,i) )
 END IF

END DO

!!--end--
END SUBROUTINE

FUNCTION xyOUTFACES_PgU( N , Pg , U , OUTVERTS ) RESULT(OUTFACES)
USE KND_IntrinsicTypes                   !!((01-A-KND_IntrinsicTypes.f90))
USE FUN_xyROTATE                         !!((05-B-FUN_xyROTATE.f90))
USE FUN_xyDIRECTION                      !!((04-B-FUN_xyDIRECTION.f90))
USE FUN_xyVECTOR                         !!((03-A-FUN_xyVECTOR.f90))
USE FUN_xyDOT                            !!((03-A-FUN_xyDOT.f90))
USE PAR_Constants_Rdp                    !!((02-A-PAR_Constants_Rdp.f90))

INTEGER,INTENT(IN) :: N
REAL(KIND_Rdp),INTENT(IN) :: Pg(2,N)
LOGICAL,OPTIONAL,INTENT(OUT) :: OUTVERTS(N)
LOGICAL :: OUTFACES(N)
INTEGER :: i,i1,i2
REAL(KIND_Rdp) :: D(2),U(2)

!!--begin--

DO i=1,N

 !get indices
 i1 = i
 i2 = MOD(i,N) + 1

 !get outward normal <D> of face from <i1> to <i2>
 D = xyROTATE_U( &
       xyDIRECTION_V( &
         xyVECTOR_PP( Pg(:,i1) , Pg(:,i2) ) &
       ) , -c_PI_by_2 )

 !check outward normal for positive direction
 !with respect to <U>
 OUTFACES(i) = xyDOT_VV( D , U )>=0._KIND_Rdp

END DO

IF( PRESENT(OUTVERTS) )THEN
 i1=N
 i2=1
 DO i=1,N
  OUTVERTS(i) = OUTFACES(i1) .AND. OUTFACES(i2)
  i1 = i
  i2 = MOD(i,N) + 1
 END DO
END IF

!!--end--
END FUNCTION

FUNCTION xyIS_CONVEX_CCW_Pg(n,pg,angle,each_pass) RESULT(pass)
INTEGER :: n
REAL(8) :: pg(2,n)
LOGICAL :: pass
REAL(8),INTENT(OUT),OPTIONAL :: angle(n)
LOGICAL,INTENT(OUT),OPTIONAL :: each_pass(n)
REAL(8) :: dx1,dx2,dy1,dy2,r1,r2
REAL(8) :: c,d,tol_
LOGICAL :: this_pass
LOGICAL,PARAMETER :: VERBOSE=.FALSE.
INTEGER :: i,next,last
pass=.TRUE.
tol_=sqrt(epsilon(1.d0))
i=n
next=1
dx1=pg(1,next)-pg(1,i)
dy1=pg(2,next)-pg(2,i)
r1=sqrt(dx1**2+dy1**2)
DO i=1,n
    next=MOD(i,n)+1
    dx2=pg(1,next)-pg(1,i)
    dy2=pg(2,next)-pg(2,i)
    r2=sqrt(dx2**2+dy2**2)
    c=dx1*dy2-dx2*dy1
    d=c/(r1*r2)
    this_pass=(d>=-tol_)
    pass=pass.AND.this_pass
    IF( PRESENT(angle) .OR. PRESENT(each_pass) )THEN
        IF( PRESENT(angle) )THEN
            angle(i)=ASIN(d)
        END IF
        IF( PRESENT(each_pass) )THEN
            each_pass(i)=this_pass
        END IF
    END IF
    IF( VERBOSE )THEN
        last=i-1
        IF( last==0 )THEN
            last=n
        END IF
        WRITE(*,'(a,i4,a,i4,a,es21.12,a,l3)')'from side=',last,' to side=',i,' angle=',ASIN(d),' pass=',this_pass
    END IF
    IF( .NOT.(PRESENT(angle).OR.PRESENT(each_pass)) .AND. (.NOT.pass) )THEN
        RETURN
    END IF
    dx1=dx2
    dy1=dy2
    r1=r2
END DO

END FUNCTION xyIS_CONVEX_CCW_Pg

END MODULE


! gfortran -O3 code_01_flop.f90 -o code_01_flop.x
! ./code_01_flop.x | tee benchmark_times.txt

program calc_mflops

  use iso_fortran_env, only: int64

  implicit none

  integer, parameter               :: dp = kind(1.0d0)
  integer(int64)                   :: M, N, R
  real(dp), allocatable            :: A(:), B(:), C(:), D(:)
  real(dp)                         :: S, E, MFLOPS
  integer                          :: i, j

  R = 100

  do M = 10, 28

    N = 2**M

    allocate(A(1:N), B(1:N), C(1:N), D(1:N))

    do i = 1, N
      A(i) = 0.0d0
      B(i) = 1.0d0
      C(i) = 2.0d0
      D(i) = 3.0d0
    enddo

    call get_walltime(S)

    do j = 1, R
      do i = 1, N
        A(i) = B(i) + C(i) * D(i)
      enddo
    enddo

    call get_walltime(E)

    MFLOPS = R * N * 2d0 / ((E-S) * 1.0d6)

    deallocate(A, B, C, D)

    write(*,'(e16.8,a,e16.8)') real(N,dp), ',', MFLOPS

  enddo

end program calc_mflops

subroutine get_walltime(wctime)

  use iso_fortran_env, only: int64

  implicit none

  integer, parameter :: dp = kind(1.0d0)
  real(dp)           :: wctime
  integer(int64)     :: tcount, trate

  call system_clock(tcount, trate)

  wctime = real(tcount, dp) / real(trate, dp)

end subroutine get_walltime


! ------------------------------------------------------------------
! Programmer(s): Daniel R. Reynolds @ SMU
! ------------------------------------------------------------------
! SUNDIALS Copyright Start
! Copyright (c) 2002-2020, Lawrence Livermore National Security
! and Southern Methodist University.
! All rights reserved.
!
! See the top-level LICENSE and NOTICE files for details.
!
! SPDX-License-Identifier: BSD-3-Clause
! SUNDIALS Copyright End
! ------------------------------------------------------------------
! Example problem for IDA: 2D heat equation, serial, GMRES.
!
! This example solves a discretized 2D heat equation problem.
! This version uses the Krylov solver Spgmr.
!
! The DAE system solved is a spatial discretization of the PDE
!          du/dt = d^2u/dx^2 + d^2u/dy^2
! on the unit square. The boundary condition is u = 0 on all edges.
! Initial conditions are given by u = 16 x (1 - x) y (1 - y). The
! PDE is treated with central differences on a uniform M x M grid.
! The values of u at the interior points satisfy ODEs, and
! equations u = 0 at the boundaries are appended, to form a DAE
! system of size N = M^2. Here M = 10.
!
! The system is solved with IDA using the Krylov linear solver
! SPGMR. The preconditioner uses the diagonal elements of the
! Jacobian only. Routines for preconditioning, required by
! SPGMR, are supplied here. The constraints u >= 0 are posed
! for all components. Output is taken at t = 0, .01, .02, .04,
! ..., 10.24. Two cases are run -- with the Gram-Schmidt type
! being Modified in the first case, and Classical in the second.
! The second run uses IDAReInit.
! ------------------------------------------------------------------

module dae_mod

  !======= Inclusions ===========
  use, intrinsic :: iso_c_binding

  !======= Declarations =========
  implicit none

  integer(c_int),  parameter :: nout  = 11
  integer(c_int),  parameter :: mgrid = 10
  integer(c_long), parameter :: neq   = mgrid*mgrid

  real(c_double) :: dx
  real(c_double) :: coeff
  real(c_double) :: pp(mgrid,mgrid)

contains

  ! ----------------------------------------------------------------
  ! resHeat: The DAE residual function
  !
  ! Return values:
  !    0 = success,
  !    1 = recoverable error,
  !   -1 = non-recoverable error
  ! ----------------------------------------------------------------
  integer(c_int) function resHeat(tres, sunvec_u, sunvec_up, sunvec_r, user_data) &
       result(ierr) bind(C,name='resHeat')

    !======= Inclusions ===========
    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod

    !======= Declarations =========
    implicit none

    ! calling variables
    real(c_double), value :: tres      ! current time
    type(N_Vector)        :: sunvec_u  ! solution N_Vector
    type(N_Vector)        :: sunvec_up ! derivative N_Vector
    type(N_Vector)        :: sunvec_r  ! residual N_Vector
    type(c_ptr),    value :: user_data ! user-defined data

    ! pointers to data in SUNDIALS vectors
    real(c_double), pointer :: u(:,:)
    real(c_double), pointer :: up(:,:)
    real(c_double), pointer :: r(:,:)

    ! local variables
    integer(c_long) :: i, j

    !======= Internals ============

    ! get data arrays from SUNDIALS vectors
    u(1:mgrid, 1:mgrid)  => FN_VGetArrayPointer(sunvec_u)
    up(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_up)
    r(1:mgrid, 1:mgrid)  => FN_VGetArrayPointer(sunvec_r)

    ! Initialize r to u, to take care of boundary equations
    r = u

    ! Loop over interior points; set res = up - (central difference)
    do j = 2,mgrid-1
       do i = 2,mgrid-1
          r(i,j) = up(i,j) - coeff*( u(i-1,j) + u(i+1,j) + u(i,j-1) + u(i,j+1) - 4.d0*u(i,j))
       end do
    end do

    ! return success
    ierr = 0
    return

  end function resHeat

  ! ----------------------------------------------------------------
  ! PsetupHeat: Preconditioner setup routine
  !
  ! Return values:
  !    0 = success,
  !    1 = recoverable error,
  !   -1 = non-recoverable error
  ! ----------------------------------------------------------------
  integer(c_int) function PSetupHeat(t, sunvec_u, sunvec_up, sunvec_r, cj, prec_data) &
       result(ierr) bind(C,name='PSetupHeat')

    !======= Inclusions ===========
    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod
    use fnvector_serial_mod

    !======= Declarations =========
    implicit none

    ! calling variables
    real(c_double), value :: t         ! current time
    real(c_double), value :: cj        ! step size scaling factor
    type(N_Vector)        :: sunvec_u  ! solution N_Vector
    type(N_Vector)        :: sunvec_up ! derivative N_Vector
    type(N_Vector)        :: sunvec_r  ! residual N_Vector
    type(c_ptr),    value :: prec_data ! preconditioner data

    ! local variables
    real(c_double) :: pelinv

    !======= Internals ============

    ! initialize pp to 1
    pp = 1.d0

    ! Compute the inverse of the preconditioner diagonal elements
    pelinv = 1.d0/(cj + 4.d0*coeff)

    ! set the interior points to the correct value for preconditioning
    pp(2:mgrid-1, 2:mgrid-1) = pelinv

    ! return success
    ierr = 0
    return

  end function PSetupHeat

  ! ----------------------------------------------------------------
  ! PsolveHeat: Preconditioner solve routine
  !
  ! Return values:
  !    0 = success,
  !    1 = recoverable error,
  !   -1 = non-recoverable error
  ! ----------------------------------------------------------------
  integer(c_int) function PSolveHeat(t, sunvec_u, sunvec_up, sunvec_r, sunvec_rhs, &
       sunvec_sol, cj, delta, prec_data) result(ierr) bind(C,name='PSolveHeat')

    !======= Inclusions ===========
    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod

    !======= Declarations =========
    implicit none

    ! calling variables
    real(c_double), value :: t          ! current time
    real(c_double), value :: cj         ! step size scaling factor
    real(c_double), value :: delta      ! desired preconditioner solve accuracy
    type(N_Vector)        :: sunvec_u   ! solution N_Vector
    type(N_Vector)        :: sunvec_up  ! derivative N_Vector
    type(N_Vector)        :: sunvec_r   ! residual N_Vector
    type(N_Vector)        :: sunvec_rhs ! rhs N_Vector
    type(N_Vector)        :: sunvec_sol ! solution N_Vector
    type(c_ptr),    value :: prec_data  ! preconditioner data

    ! pointers to data in SUNDIALS vectors
    real(c_double), pointer :: rhs(:,:)
    real(c_double), pointer :: sol(:,:)

    !======= Internals ============

    ! get data arrays from SUNDIALS vectors
    rhs(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_rhs)
    sol(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_sol)

    ! Apply preconditioner to rhs to create sol
    sol = rhs * pp

    ! return success
    ierr = 0
    return

  end function PSolveHeat

end module dae_mod
! ------------------------------------------------------------------

program main
  use, intrinsic :: iso_c_binding
  use fidas_mod                  ! Fortran interface to IDA
  use fnvector_serial_mod        ! Fortran interface to serial N_Vector
  use fsunlinsol_spgmr_mod       ! Fortran interface to spgmr SUNLinearSolver
  use fsundials_matrix_mod       ! Fortran interface to generic SUNMatrix
  use fsundials_nvector_mod      ! Fortran interface to generic N_Vector
  use fsundials_linearsolver_mod ! Fortran interface to generic SUNLinearSolver
  use dae_mod                    ! DAE problem module
  implicit none

  ! Local variables
  real(c_double)  :: rtol, atol, t0, t1, tout, tret(1)
  integer(c_int)  :: retval, iout
  integer(c_long) :: netf(1), ncfn(1), ncfl(1)

  type(N_Vector),        pointer :: sunvec_u     ! sundials solution vector
  type(N_Vector),        pointer :: sunvec_up    ! sundials derivative vector
  type(N_Vector),        pointer :: sunvec_c     ! sundials constraints vector
  type(N_Vector),        pointer :: sunvec_r     ! sundials residual vector
  type(SUNMatrix),       pointer :: sunmat_A     ! sundials matrix (empty)
  type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver
  type(c_ptr)                    :: idas_mem      ! IDA memory

  ! Solution, residual and constraints vectors, mgrid is set in the dae_mod module
  real(c_double), dimension(mgrid,mgrid) :: uu, up, res, constraints

  !======= Internals ============

  ! Assign parameters in dae_mod
  dx = 1.d0/(mgrid-1)
  coeff = 1.d0/(dx * dx)

  ! Create N_Vectors
  sunvec_u => FN_VMake_Serial(neq, uu)
  if (.not. associated(sunvec_u)) then
     print *, 'ERROR: sunvec = NULL'
     stop 1
  end if

  sunvec_up => FN_VMake_Serial(neq, up)
  if (.not. associated(sunvec_up)) then
     print *, 'ERROR: sunvec = NULL'
     stop 1
  end if

  sunvec_r => FN_VMake_Serial(neq, res)
  if (.not. associated(sunvec_r)) then
     print *, 'ERROR: sunvec = NULL'
     stop 1
  end if

  sunvec_c => FN_VMake_Serial(neq, constraints)
  if (.not. associated(sunvec_c)) then
     print *, 'ERROR: sunvec = NULL'
     stop 1
  end if

  ! Initialize solution vectors
  call SetInitialProfile(sunvec_u, sunvec_up, sunvec_r)

  ! Set constraints to all 1's for nonnegative solution values
  constraints = 1.d0

  ! Assign various parameters
  t0   = 0.d0
  t1   = 0.01d0
  rtol = 0.d0
  atol = 1.d-3

  ! Call FIDACreate and FIDAInit to initialize solution
  idas_mem = FIDACreate()
  if (.not. c_associated(idas_mem)) then
     print *, 'ERROR: idas_mem = NULL'
     stop 1
  end if

  retval = FIDASetConstraints(idas_mem, sunvec_c)
  if (retval /= 0) then
     print *, 'Error in FIDASetConstraints, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAInit(idas_mem, c_funloc(resHeat), t0, sunvec_u, sunvec_up)
  if (retval /= 0) then
     print *, 'Error in FIDAInit, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDASStolerances(idas_mem, rtol, atol)
  if (retval /= 0) then
     print *, 'Error in FIDASStolerances, retval = ', retval, '; halting'
     stop 1
  end if

  ! Create the linear solver SUNLinSol_SPGMR with left preconditioning
  ! and the default Krylov dimension
  sunlinsol_LS => FSUNLinSol_SPGMR(sunvec_u, PREC_LEFT, 0)
  if (.not. associated(sunlinsol_LS)) then
     print *, 'ERROR: sunlinsol = NULL'
     stop 1
  end if

  ! IDA recommends allowing up to 5 restarts (default is 0)
  retval = FSUNLinSol_SPGMRSetMaxRestarts(sunlinsol_LS, 5)
  if (retval /= 0) then
     print *, 'Error in FSUNLinSol_SPGMRSetMaxRestarts, retval = ', retval, '; halting'
     stop 1
  end if

  ! Attach the linear solver (will NULL SUNMatrix object)
  sunmat_A => null()
  retval = FIDASetLinearSolver(idas_mem, sunlinsol_LS, sunmat_A)
  if (retval /= 0) then
     print *, 'Error in FIDASetLinearSolver, retval = ', retval, '; halting'
     stop 1
  end if

  ! Set the preconditioner solve and setup functions */
  retval = FIDASetPreconditioner(idas_mem, c_funloc(PsetupHeat), c_funloc(PsolveHeat))
  if (retval /= 0) then
     print *, 'Error in FIDASetPreconditioner, retval = ', retval, '; halting'
     stop 1
  end if

  ! Print output heading
  call PrintHeader(rtol, atol)

  !-------------------------------------
  ! CASE I
  !-------------------------------------

  ! Print case number, output table heading, and initial line of table

  print *, " "
  print *, " "
  print *, "Case 1: gsytpe = MODIFIED_GS"
  print *, " "
  print *, "   Output Summary (umax = max-norm of solution)"
  print *, " "
  print *, "  time     umax       k  nst  nni  nje   nre   nreLS    h      npe nps"
  print *, "----------------------------------------------------------------------"

  ! Loop over output times, call IDASolve, and print results

  tout = t1
  do iout = 1,NOUT
     retval = FIDASolve(idas_mem, tout, tret, sunvec_u, sunvec_up, IDA_NORMAL)
     if (retval < 0) then
        print *, 'Error in FIDASolve, retval = ', retval, '; halting'
        stop 1
     end if
     call PrintOutput(idas_mem, tret(1), uu)
     tout = 2.d0*tout
  end do

  ! Print remaining counters
  retval = FIDAGetNumErrTestFails(idas_mem, netf)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumErrTestFails, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAGetNumNonlinSolvConvFails(idas_mem, ncfn)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumNonlinSolvConvFails, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAGetNumLinConvFails(idas_mem, ncfl)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumLinConvFails, retval = ', retval, '; halting'
     stop 1
  end if

  print *, " "
  print '(a,i1)', "Error test failures            = ", netf
  print '(a,i1)', "Nonlinear convergence failures = ", ncfn
  print '(a,i1)', "Linear convergence failures    = ", ncfl

  !-------------------------------------
  ! CASE II
  !-------------------------------------

  ! Re-initialize uu, up

  call SetInitialProfile(sunvec_u, sunvec_up, sunvec_r)

  ! Re-initialize IDA and SPGMR

  retval = FIDAReInit(idas_mem, t0, sunvec_u, sunvec_up)
  if (retval /= 0) then
     print *, 'Error in FIDAReInit, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FSUNLinSol_SPGMRSetGSType(sunlinsol_LS, CLASSICAL_GS)
  if (retval /= 0) then
     print *, 'Error in FSUNLinSol_SPGMRSetGSType, retval = ', retval, '; halting'
     stop 1
  end if

  ! Print case number, output table heading, and initial line of table

  print *, " "
  print *, " "
  print *, "Case 2: gsytpe = CLASSICAL_GS"
  print *, " "
  print *, "   Output Summary (umax = max-norm of solution)"
  print *, " "
  print *, "  time     umax       k  nst  nni  nje   nre   nreLS    h      npe nps"
  print *, "----------------------------------------------------------------------"

  ! Loop over output times, call IDASolve, and print results
  tout = t1
  do iout = 1,NOUT
     retval = FIDASolve(idas_mem, tout, tret, sunvec_u, sunvec_up, IDA_NORMAL)
     if (retval < 0) then
        print *, 'Error in FIDASolve, retval = ', retval, '; halting'
        stop 1
     end if
     call PrintOutput(idas_mem, tret(1), uu)
     tout = 2.d0*tout
  end do

  ! Print remaining counters

  retval = FIDAGetNumErrTestFails(idas_mem, netf)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumErrTestFails, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAGetNumNonlinSolvConvFails(idas_mem, ncfn)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumNonlinSolvConvFails, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAGetNumLinConvFails(idas_mem, ncfl)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumLinConvFails, retval = ', retval, '; halting'
     stop 1
  end if

  print *, " "
  print '(a,i1)', "Error test failures            = ", netf
  print '(a,i1)', "Nonlinear convergence failures = ", ncfn
  print '(a,i1)', "Linear convergence failures    = ", ncfl

  ! free memory
  call FIDAFree(idas_mem)
  retval = FSUNLinSolFree(sunlinsol_LS)
  call FN_VDestroy(sunvec_u)
  call FN_VDestroy(sunvec_up)
  call FN_VDestroy(sunvec_r)
  call FN_VDestroy(sunvec_c)

end program main

! ----------------------------------------------------------------
! SetInitialProfile: routine to initialize u and up vectors.
! ----------------------------------------------------------------
subroutine SetInitialProfile(sunvec_u, sunvec_up, sunvec_r)

  !======= Inclusions ===========
  use, intrinsic :: iso_c_binding
  use fsundials_nvector_mod
  use fnvector_serial_mod
  use dae_mod

  !======= Declarations =========
  implicit none

  ! calling variables
  type(N_Vector) :: sunvec_u  ! solution N_Vector
  type(N_Vector) :: sunvec_up ! derivative N_Vector
  type(N_Vector) :: sunvec_r  ! residual N_Vector

  ! pointers to data in SUNDIALS vectors
  real(c_double), pointer :: uu(:,:)
  real(c_double), pointer :: up(:,:)
  real(c_double), pointer :: r(:,:)

  ! local variables
  integer(c_long) :: i, j
  real(c_double)  :: xfact, yfact
  integer(c_int)  :: retval

  !======= Internals ============

  ! get data arrays from SUNDIALS vectors
  uu(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_u)
  up(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_up)
  r(1:mgrid, 1:mgrid)  => FN_VGetArrayPointer(sunvec_r)

  !======= Internals ============

  ! Initialize uu on all grid points
  do j = 1,mgrid
     yfact = dx * (j-1)
     do i = 1,mgrid
        xfact = dx * (i-1)
        uu(i,j) = 16.d0 * xfact * (1.d0 - xfact) * yfact * (1.d0 - yfact)
     end do
  end do

  ! Initialize up vector to 0
  up = 0.d0

  ! resHeat sets res to negative of ODE RHS values at interior points
  retval = resHeat(0.d0, sunvec_u, sunvec_up, sunvec_r, C_NULL_PTR)

  ! Copy -r into up to get correct interior initial up values
  up = -r

  ! Set up at boundary points to zero
  up(1,:)     = 0.d0
  up(mgrid,:) = 0.d0
  up(:,1)     = 0.d0
  up(:,mgrid) = 0.d0

  return
end subroutine SetInitialProfile

! ----------------------------------------------------------------
! PrintHeader: prints first lines of output (problem description)
! ----------------------------------------------------------------
subroutine PrintHeader(rtol, atol)

  !======= Inclusions ===========
  use, intrinsic :: iso_c_binding
  use dae_mod

  !======= Declarations =========
  implicit none

  ! calling variable
  real(c_double) :: rtol, atol

  !======= Internals ============

  print *, " "
  print *, "idasHeat2D_kry: Heat equation, serial example problem for IDA"
  print *, "         Discretized heat equation on 2D unit square."
  print *, "         Zero boundary conditions, polynomial initial conditions."
  print '(2(a,i2),a,i3)', "         Mesh dimensions: ", mgrid, " x ", mgrid, &
       "        Total system size: ", neq
  print *, " "
  print '(2(a,f5.3))', "Tolerance parameters:  rtol = ", rtol,"   atol = ", atol
  print *, "Constraints set to force all solution components >= 0."
  print *, "Linear solver: SPGMR, preconditioner using diagonal elements."

  return
end subroutine PrintHeader

! ----------------------------------------------------------------
! PrintOutput
! ----------------------------------------------------------------
subroutine PrintOutput(idas_mem, t, uu)

  !======= Inclusions ===========
  use, intrinsic :: iso_c_binding
  use fidas_mod
  use dae_mod

  !======= Declarations =========
  implicit none

  ! calling variable
  type(c_ptr)    :: idas_mem
  real(c_double) :: t, uu(mgrid,mgrid)

  ! internal variables
  integer(c_int)  :: retval, kused(1)
  integer(c_long) :: nst(1), nni(1), nje(1), nre(1), nreLS(1), nli(1), npe(1), nps(1)
  real(c_double)  :: hused(1), umax

  !======= Internals ============

  umax = maxval(abs(uu))

  retval = FIDAGetLastOrder(idas_mem, kused)
  if (retval /= 0) then
     print *, 'Error in FIDAGetLastOrder, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAGetNumSteps(idas_mem, nst)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumSteps, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAGetNumNonlinSolvIters(idas_mem, nni)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumNonlinSolvIters, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAGetNumResEvals(idas_mem, nre)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumResEvals, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAGetLastStep(idas_mem, hused)
  if (retval /= 0) then
     print *, 'Error in FIDAGetLastStep, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAGetNumJtimesEvals(idas_mem, nje)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumJtimesEvals, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAGetNumLinIters(idas_mem, nli)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumLinIters, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAGetNumLinResEvals(idas_mem, nreLS)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumLinResEvals, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAGetNumPrecEvals(idas_mem, npe)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumPrecEvals, retval = ', retval, '; halting'
     stop 1
  end if

  retval = FIDAGetNumPrecSolves(idas_mem, nps)
  if (retval /= 0) then
     print *, 'Error in FIDAGetNumPrecSolves, retval = ', retval, '; halting'
     stop 1
  end if

  print '(f5.2,1x,es13.5,1x,i1,2x,3(i3,2x),2(i4,2x),es9.2,2x,2(i3,1x))', &
       t, umax, kused, nst, nni, nje, nre, nreLS, hused(1), npe, nps

end subroutine PrintOutput


      PROGRAM T123
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C                    TRAVAIL FLEURY 'T123.FOR'
C                    ~~~~~~~~~~~~~~~~~~~~~~~~~
C 02.01.97  . ajout de commentaires
C           . division en plusieurs fichiers
C           . reponse Travail #1 & 2
C 06.02.97  . debut de reponse Travail #3
C 08.02.97  . correction Travail #3
C           . nettoyage et commentaires
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Var. : IMAX	: Taille du vecteur S
C ~~~~   S	: Vecteur d'allocation dynamique de memoire
C                 (pour plus de details, voir ALLOC.FOR)
C        II	: Vecteur contenant les pos. des tabl. dans S
C        MEMORY	: Memoire libre
C        EPS	: Precision voulue
C        N	: Nbre de variables
C        m	: Nbre de contraintes
C        METH	: Methode d'opti (1 = Steep. des.; 2 = CG)
C        METHD	: Methode primale (0) ou duale (1)
C        NCHECK	: Frequence d'evaluation de l'ASS
C        IASS	: Type de strategie des contraintes actives
C        ICONST : Probleme contraint (1) ou non contraint (0)
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Rem :.Il faut bien distinguer le contenu du fichier *.DAT
C ~~~   charge en memoire et le probleme a resoudre. Par expl.,
C       on peut charger un fichier contenant des contraintes
C       lineaires (matrices C et D) et demander au programme de
C       resoudre le probleme non contraint. Il ignore alors
C       ces matrices.
C      .Si on charge un Hessien non diagonal et qu'on demande
C       une formulation duale, le prog. ignore les elements
C       hors diag.
C      .Il n'y a pas de formulation primale pour des
C       contraintes lineaires
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C     Declaration des variables
C     -------------------------
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER (IMAX=10000)
      CHARACTER*20 Fichier
C
      DIMENSION S(IMAX),II(12)
C
C     Definition des variables (clavier/fichier)
C     ------------------------------------------
      EPS=1.D-06
      MEMORY=IMAX
C
 10   WRITE(*,410)
      READ(*,*)Fichier
      IF(Fichier.NE.'0') THEN
         OPEN(UNIT = 1, ERR=200, FILE = Fichier, STATUS = 'OLD')
         READ(1,*)N,m
 11      WRITE(*,350)N,m
         IF(N.LT.1) GOTO 11
         IERR=0
         CALL ALLOC(N,II,MEMORY,IERR,m)
         IF(IERR.NE.0) STOP
         DO i=1, N*(N+1)/2+2*N+(N+1)*m
            READ(1,*)S(i)
         ENDDO
         READ(1,*)F
         CLOSE(UNIT=1)
      ELSE
         CALL GENDAT(N,S,II,F,MEMORY,m)
      ENDIF
C
C     Choix de la methode d'optimisation (SD - CG)
C     --------------------------------------------
   2  WRITE (*,360)
      READ  (*,*) METH
      IF((METH.LT.0).OR.(METH.GT.1)) GOTO 2
C
C     Choix du type de probleme (contraint - non contraint)
C     -----------------------------------------------------
   3  WRITE (*,370)
      READ  (*,*) ICONST
      IF((ICONST.LT.0).OR.(ICONST.GT.1)) GOTO 3
C
C     Choix de la methode (primale - duale)
C     -------------------------------------
      IF(ICONST.EQ.1) THEN
   4     WRITE (*,380)
         READ  (*,*) METHD
         IF((METHD.LT.0).OR.(METHD.GT.1)) GOTO 4
         IF((METHD.EQ.1).AND.(m.EQ.0)) THEN
            WRITE(*,420)
            METHD=0
         ENDIF
         IF((METHD.EQ.0).AND.(m.NE.0)) WRITE(*,310)
         IF(METHD.EQ.1) THEN
            CALL CHKDUAL(N,A,IERR)
            IF(IERR.EQ.1) WRITE(*,300)
         ENDIF
      ELSE
         METHD=0
      ENDIF
C
C     Choix de la strategie des contraintes actives
C     ---------------------------------------------
      IF(ICONST.EQ.1) THEN
  5      WRITE(*,340)
         READ(*,*)IASS
         IF((IASS.LT.0).OR.(IASS.GT.2)) GOTO 5
         IF(IASS.EQ.2) THEN
            WRITE(*,400)
            READ(*,*)NCHECK
         ENDIF
      ENDIF
C
C     Appel de la routine de minimisation
C     -----------------------------------
      if(METHD.eq.1) then
         CALL TRANSFO(S(II(1)),S(II(2)),S(II(3)),S(II(4)),S(II(5)),
     #                S(II(8)),S(II(9)),S(II(10)),N,m,F2)
         CALL MINIM2 (S(II(8)),S(II(10)),S(II(9)),S(II(7)),S(II(6)),
     #                EPS,F2,m,METH,IASS,NCHECK,ICONST,S(II(11)))
         CALL TRANSF2(S(II(1)),S(II(2)),S(II(3)),S(II(5)),S(II(10)),
     #                N,m)
      ELSE
         CALL MINIM2 (S(II(1)),S(II(5)),S(II(2)),S(II(7)),S(II(6)),
     #                EPS,F,N,METH,IASS,NCHECK,ICONST,S(II(11)))
      ENDIF
C
C     Affiche la solution
C     -------------------
      WRITE(*,320)
      READ(*,*)
      DO i=1,N
         WRITE(*,330)i,S(II(5)+i-1)
      ENDDO
C
      CLOSE(UNIT=1)
      STOP
C
C     Erreur lors de l'ouverture du fichier
C     -------------------------------------
 200  WRITE(*,390)
      GOTO 10
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 300  FORMAT(/' Attention : elements diagonaux du Hessien ignores!'/)
 310  FORMAT(/' Attention : contraintes lineaires ignorees!'/)
 320  FORMAT(/' <ENTER> pour voir la solution'/)
 330  FORMAT('  X(',I3,') = ',D20.10)
 340  FORMAT(' Active set strategy : 0 = evaluation a chaque it.:'/,
     #       '                     : 1 = attendre un pt stat.   :'/,
     #       '                     : 2 = eval. toutes les n it. :')
 350  FORMAT(/' Nbre de variables   :',I3/,
     #        ' Nbre de contraintes :',I3/)
 360  FORMAT( ' Methode  : 0 = STEEPEST DESCENT   :'/,
     #        '          : 1 = CONJUGATE GRADIENT :')
 370  FORMAT( ' Probleme : 0 = NON CONTRAINT      :'/,
     #        '          : 1 = CONTRAINT          :')
 380  FORMAT( ' Methode  : 0 = PRIMALE (Xi>=0)    :'/,
     #        '          : 1 = DUALE (c. lin.)    :')
 390  FORMAT( ' Fichier inexistant !')
 400  FORMAT( ' Entrez n :')
 410  FORMAT( ' Nom du fichier de donnees (0=clavier) :')
 420  FORMAT(/' Attention : Pas de contraintes lin. definies'/,
     #        '   -> Methode primale utilisee avec Xi>=0'/)
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      END


      subroutine subbak ( w, ipivot, nrow, ncol, last, x )
c  carries out backsubstitution for current block.
c
c parameters
c    w, ipivot, nrow, ncol, last  are as on return from factrb.
c    x(1),...,x(ncol)  contains, on input, the right side for the
c	     equations in this block after backsubstitution has been
c	     carried up to but not including equation ipivot(last).
c	     means that x(j) contains the right side of equation ipi-
c	     vot(j) as modified during elimination, j=1,...,last, while
c	     for j .gt. last, x(j) is already a component of the solut-
c	     ion vector.
c    x(1),...,x(ncol) contains, on output, the components of the solut-
c	     ion corresponding to the present block.
c
      integer nrow, ncol
      integer ipivot(nrow),last,  ip,j,k,kp1
      real w(nrow,ncol),x(ncol), sum
      k = last
      ip = ipivot(k)
      sum = 0.
      if (k .eq. ncol)			go to 4
      kp1 = k+1
    2	 do 3 j=kp1,ncol
    3	    sum = w(ip,j)*x(j) + sum
    4	 x(k) = (x(k) - sum)/w(ip,k)
	 if (k .eq. 1)			return
	 kp1 = k
	 k = k-1
	 ip = ipivot(k)
	 sum = 0.
					go to 2
      end


!
!@(#) using non-square viewports, the associated distortion -- and how to fix it
!(LICENSE:PD)
!
        program fdistrt

      use M_draw

        integer BLACK, RED, GREEN, YELLOW, BLUE, MAGENTA, CYAN, WHITE
        parameter(BLACK = 0)
        parameter(RED = 1)
        parameter(GREEN = 2)
        parameter(YELLOW = 3)
        parameter(BLUE = 4)
        parameter(MAGENTA = 5)
        parameter(CYAN = 6)
        parameter(WHITE = 7)
        character(len=50)  :: device
        character(len=120) :: buf
        real    xfact, yfact

        print*,'Enter output device:'
        read(*,'(a)') device

        call vinit(device)

        call color(BLACK)
        call clear

!
! Make the viewport the same size as the screen/window.
!
        call getfactors(xfact, yfact)
        call viewport(-1.0, xfact, -1.0, yfact)

!
! Draw a square. (Looks like a rectangle, if the viewport
! wasn't "accidentally" square)
!
        call color(1)
        call rect(-0.5, -0.5, 0.5, 0.5)

!
! Tell them what it is.
!
        call move2(-1.0, 0.9)
        write(buf,'(''Distorted square (viewport(-1, '', F7.3, '', -1, '', F7.3, ''))'')') xfact, yfact
        call drawstr(buf)

        idum=getkey()

!
! Fix up the distortion (The actual formula to fix
! the distortion is (viewport.xmax * (1 + xfact) / 2.0),
! and similar for the y axis.
!
        call ortho2(-1.0, xfact, -1.0, yfact)

!
! Draw another square (Really is square this time)
!
        call color(3)
        call rect(-0.5, -0.5, 0.5, 0.5)

!
! Tell them what it is.
!
        call move2(-1.0, -0.9)
        write(buf,'(''Fixed up square with ortho2(-1, '', F7.3, '', -1, '', F7.3, '')'')') xfact, yfact
        call drawstr(buf)

        idum=getkey()

!
! Do it with world coords going from 0 - 5, 0 - 5.
! Reset square viewport.
!

        call color(0)
        call clear

        call viewport(-1.0, 1.0, -1.0, 1.0)
        call ortho2(0.0, 5.0, 0.0, 5.0)
        call textsize(0.1, 0.1)

!
! Square from 1 to 3. (Really is square)
!

        call color(2)
        call rect(1.0, 1.0, 3.0, 3.0)

        call move2(0.0, 4.5)
        call drawstr('Square from 0 - 3, 0 - 3')

        idum=getkey()

!
! Distort it with a non-square viewport.
!
        call viewport(-1.0, xfact, -1.0, yfact)

        call color(4)
        call rect(1.0, 1.0, 3.0, 3.0)

        call move2(0.0, 0.5)
        call drawstr('Distorted square from 0 - 3, 0 - 3')

        idum=getkey()

!
! Fix the distortion.
!
        call ortho2(0.0, 5.0 * (1.0 + xfact) / 2.0, 0.0, 5.0 * (1.0 + yfact) / 2.0)

        call color(5)
        call rect(1.0, 1.0, 3.0, 3.0)

        call move2(0.0, 2.5)
        call drawstr('Fixed up  square from 0 - 3, 0 - 3')

        idum=getkey()

        call vexit

        end


PROGRAM random_num

IMPLICIT NONE
real    :: randnum

! ----- variables for portable seed setting -----
INTEGER :: i_seed, i
INTEGER, DIMENSION(:), ALLOCATABLE :: a_seed
INTEGER, DIMENSION(1:8) :: dt_seed
! ----- Set up random seed portably -----
CALL RANDOM_SEED(size=i_seed)
ALLOCATE(a_seed(1:i_seed))
CALL RANDOM_SEED(get=a_seed)
CALL DATE_AND_TIME(values=dt_seed)
a_seed(i_seed)=dt_seed(8); a_seed(1)=dt_seed(8)*dt_seed(7)*dt_seed(6)
CALL RANDOM_SEED(put=a_seed)
DEALLOCATE(a_seed)

CALL RANDOM_NUMBER(randnum)
print *, randnum
STOP
END


MODULE ex3_mod
CONTAINS
ATTRIBUTES(GLOBAL) SUBROUTINE sumation(a,b,d)
IMPLICIT NONE
INTEGER,INTENT(in) :: a(:,:)
INTEGER,INTENT(in) :: b(:,:)
INTEGER,INTENT(out):: d(:,:)
INTEGER :: i,j,nx,ny

i = blockDim%x*(blockIdx%x-1)+threadIdx%x
j = blockDim%y*(blockIdx%y-1)+threadIdx%y
nx=size(a,1) ; ny=size(a,2)
IF ((i<=nx).and.(j<=ny)) THEN
	d(i,j) = a(i,j)+ b(i,j)
END IF
END SUBROUTINE sumation
END MODULE ex3_mod

!!==========================================
PROGRAM ex3_presentation
USE cudafor
USE ex3_mod
IMPLICIT NONE
INTEGER, PARAMETER :: nx=30000000,ny=4
INTEGER :: a(nx,ny),b(nx,ny),d(nx,ny)
INTEGER, device :: a_d(nx,ny),b_d(nx,ny),d_d(nx,ny)
TYPE(dim3) :: gridDim,blockDim
a=10
b=20
blockDim=dim3(512,2,1)
gridDim=dim3(ceiling(real(nx)/blockDim%x),ceiling(real(ny)/blockDim%y),1)

a_d=a ; b_d=b
CALL sumation <<<gridDim,blockDim>>>(a_d,b_d,d_d)
d=d_d
IF(all(d==30)) THEN
      WRITE(* ,*)'**** OK ****'
ELSE
      WRITE(* ,*)'Program Failed'
END IF
END PROGRAM ex3_presentation


program prog_main

    use constants   ! provides constants definitions
    use funhandles  ! the funhandles contains the interface defining the signature of getthepower function

    implicit none

    integer :: i
    integer :: N
    real :: result

    N = 10

    do i = 1, N
        result = getheppower( i )

        if ( i == 1 ) then
            write (*, '("La puissance 1ere du nombre pi est: ",f8.2)') result
        else
            write (*, '("La puissance",i3,"ieme du nombre pi est: ",f8.2)') i, result
        end if

    end do

end program prog_main


!##############   STANDARD  ##############
subroutine make_standard(nside,map,mskv,npixr,mean,var)

implicit none

integer, intent (in) :: nside
Real*8, intent (in) :: mskv
Real*8, intent (inout) :: map(nside,nside)
integer, intent (out) :: npixr
Real*8, intent (out) :: mean,var

integer  i,j

npixr=0
mean=0
do i=1,nside
	do j=1,nside
	  if (map(i,j)/=mskv) then
	    mean=mean+map(i,j)
	    npixr=npixr+1
	  end if
	end do
end do

mean=mean/npixr
map=map-mean

var=0
do i=1,nside
	do j=1,nside
	  if (map(i,j)/=mskv) then
	    var=var+map(i,j)**2
	  end if
	end do
end do
var=sqrt(var/npixr)
map=map/var

end

!##############   Threshold finder  ##############
subroutine thsh_f(rows,columns,d,lt,ut,nt,thsh)
implicit none

integer, intent (in) :: rows,columns
Real*8, intent (in) :: lt,ut
Real*8, intent (in) :: d(rows,columns)
integer, intent (out) :: nt
integer, intent (out) :: thsh(2,rows*columns)

integer  i,j

nt=0

do i=2,rows-1
  do j=2,columns-1
    if(d(i,j)>lt .and. d(i,j)<ut) then
      nt=nt+1
      thsh(1,nt)=i
      thsh(2,nt)=j
    end if
  end do
end do

end

!##############   Peak finder  ##############
subroutine peak_f(rows,columns,d,lt,ut,np,peaks)
implicit none

integer, intent (in) :: rows,columns
Real*8, intent (in) :: lt,ut
Real*8, intent (in) :: d(rows,columns)
integer, intent (out) :: np
integer, intent (out) :: peaks(2,rows*columns)

integer  i,j
Real*8 temp

np=0

do i=2,rows-1
  do j=2,columns-1
    if(d(i,j)>lt .and. d(i,j)<ut) then

      temp=max(d(i+1,j),d(i,j+1),d(i-1,j),d(i,j-1), &
& d(i+1,j+1),d(i+1,j-1),d(i-1,j+1),d(i-1,j-1))
      if (d(i,j)>temp)  then
        np=np+1
        peaks(1,np)=i
        peaks(2,np)=j
      end if
    end if
  end do
end do

end

!##############   Cross finder  ##############
subroutine cross_f(rows,columns,d,lt,ut,nc1,nc2,cr1,cr2)
implicit none

integer, intent (in) :: rows,columns
Real*8, intent (in) :: lt,ut
Real*8, intent (in) :: d(rows,columns)
integer, intent (out) :: nc1,nc2
integer, intent (out) :: cr1(2,rows*columns),cr2(2,rows*columns)

integer  i,j
Real*8 temp

nc1=0; nc2=0

do i=2,rows-1
  do j=2,columns-1

! First Direction
    if(d(i,j)>lt .and. d(i-1,j)<lt) then
	     nc1=nc1+1
	     cr1(1,nc1)=i
	     cr1(2,nc1)=j
		end if
! Second Direction
    if(d(i,j)>lt .and. d(i,j-1)<lt) then
		   nc2=nc2+1
		   cr2(1,nc2)=i
		   cr2(2,nc2)=j
		end if

  end do
end do
end

!##############   Ridge finder  ##############
subroutine ridge_f(rows,columns,d,lt,ut,nr1,nr2,rdg1,rdg2)
implicit none

integer, intent (in) :: rows,columns
Real*8, intent (in) :: lt,ut
Real*8, intent (in) :: d(rows,columns)
integer, intent (out) :: nr1,nr2
integer, intent (out) :: rdg1(2,rows*columns),rdg2(2,rows*columns)

integer  i,j
Real*8 temp

nr1=0; nr2=0

do i=2,rows-1
  do j=2,columns-1

! First Direction
    if(d(i,j)>lt .and. d(i-1,j)<lt) then
			if (d(i,j+1)<d(i,j) .and. d(i,j-1)<d(i,j)) then
		    nr1=nr1+1
		    rdg1(1,nr1)=i
		    rdg1(2,nr1)=j
			end if
    end if

! Second Direction
    if(d(i,j)>lt .and. d(i,j-1)<lt) then
			if (d(i+1,j)<d(i,j) .and. d(i-1,j)<d(i,j)) then
		    nr2=nr2+1
		    rdg2(1,nr2)=i
		    rdg2(2,nr2)=j
			end if
    end if

  end do
end do
end

!##############  Correlation  ##############
subroutine cf(map,l,n_p,mskv,cor,vcor)
implicit none

integer, intent(in) :: l
real*8, intent(in) :: map(l,l)
real*8, intent(in) :: n_p
real*8, intent(in) :: mskv
real*8, intent(out) :: cor(0:l),vcor(0:l)

integer :: i,i1,j1,i2,j2,k,kp,limit
integer :: nu(0:l)
real*8 :: r1,r2,r3,gam
real*8 :: c(0:l,int(3*n_p/l))

limit=int(3*n_p/l)
cor=0
vcor=0
nu=0

i=0
Do while (i<n_p/100)
i=i+1

  call random_number(r1)
  call random_number(r2)
  call random_number(r3)
	r1=floor((l*l-1)*r1)
	r2=floor((l-1)/10.*r2)
	r3=floor((l-1)/10.*r3)
  i1=mod(int(r1),l)+1
  j1=floor(r1/l)+1
  i2=mod(int(i1+r2+1),l)+1
  j2=mod(int(j1+r3+1),l)+1

  if(map(i1,j1)/=mskv.and.map(i2,j2)/=mskv) then
    gam=sqrt( real( (i1-i2)**2 + (j1-j2)**2 ) )
    k=floor(gam)
		if (k<=l .and. nu(k)<limit) then
			nu(k)=nu(k)+1
			kp=nu(k)
			c(k,kp)=map(i1,j1)*map(i2,j2)
		end if
  end if
end do !i

Do while (i<n_p)
i=i+1

  call random_number(r1)
  call random_number(r2)
	r1=floor((l*l-1)*r1)
	r2=floor((l*l-1)*r2)
  i1=mod(int(r1),l)+1
  j1=floor(r1/l)+1
  i2=mod(int(r2),l)+1
  j2=floor(r2/l)+1

  if(map(i1,j1)/=mskv.and.map(i2,j2)/=mskv) then

    gam=sqrt( real( (i1-i2)**2 + (j1-j2)**2 ) )
    k=floor(gam)
		if (k<=l .and. nu(k)<limit) then
			nu(k)=nu(k)+1
			kp=nu(k)
			c(k,kp)=map(i1,j1)*map(i2,j2)
		end if
  end if
end do !i

! mean
  do k=0,l
    kp=nu(k)
    do i=1,kp
      cor(k)=cor(k)+c(k,i)
    end do
    if(kp.ne.0.0) cor(k)=cor(k)/real(kp)
  end do

! error
  do k=0,l
    kp=nu(k)
    do i=1,kp
      vcor(k)=vcor(k)+(c(k,i)-cor(k))**2
    end do
    if(kp.ne.0.0) vcor(k)=sqrt(vcor(k)/real(kp))
  end do

end

!##############  Cross Correlation  ##############
subroutine cross_cf(map1,map2,l1,l2,n_p,mskv,cor,vcor)
implicit none

integer, intent(in) :: l1,l2
real*8, intent(in) :: map1(l1,l2),map2(l1,l2)
real*8, intent(in) :: n_p
real*8, intent(in) :: mskv
real*8, intent(out) :: cor(0:max(l1,l2)),vcor(0:max(l1,l2))

integer :: i,i1,j1,i2,j2,k,kp,limit
integer :: nu(0:max(l1,l2))
real*8 :: r1,r2,r3,gam
real*8 :: c(0:max(l1,l2),int(3*n_p/max(l1,l2)))

limit=int(3*n_p/max(l1,l2))
cor=0
vcor=0
nu=0

i=0
Do while (i<n_p/100)
i=i+1

11 call random_number(r1)
  call random_number(r2)
  call random_number(r3)
	r1=floor((l1*l2-1)*r1)
	r2=floor((l1-1)/10.*r2)
	r3=floor((l2-1)/10.*r3)
  i1=mod(int(r1),l1)+1
  j1=floor(r1/l1)+1
  i2=i1+r2+1
  j2=j1+r3+1

	if (i2>l1 .or. j2>l2) goto 11

  if(map1(i1,j1)/=mskv.and.map2(i2,j2)/=mskv) then
    gam=sqrt( real( (i1-i2)**2 + (j1-j2)**2 ) )
    k=floor(gam)
		if (nu(k)<limit) then
			nu(k)=nu(k)+1
			kp=nu(k)
			c(k,kp)=map1(i1,j1)*map2(i2,j2)
		end if
  end if
end do !i

Do while (i<n_p)
i=i+1

  call random_number(r1)
  call random_number(r2)
	r1=floor((l1*l2-1)*r1)
	r2=floor((l1*l2-1)*r2)
  i1=mod(int(r1),l1)+1
  j1=floor(r1/l1)+1
  i2=mod(int(r2),l1)+1
  j2=floor(r2/l1)+1

  if(map1(i1,j1)/=mskv.and.map2(i2,j2)/=mskv) then

    gam=sqrt( real( (i1-i2)**2 + (j1-j2)**2 ) )
    k=floor(gam)
		if (k<=max(l1,l2) .and. nu(k)<limit) then

			nu(k)=nu(k)+1
			kp=nu(k)
			c(k,kp)=map1(i1,j1)*map2(i2,j2)
		end if

  end if
end do !i

! mean
  do k=0,max(l1,l2)
    kp=nu(k)
    do i=1,kp
      cor(k)=cor(k)+c(k,i)
    end do
    if(kp.ne.0.0) cor(k)=cor(k)/real(kp)
  end do

! error
  do k=0,max(l1,l2)
    kp=nu(k)
    do i=1,kp
      vcor(k)=vcor(k)+(c(k,i)-cor(k))**2
    end do
    if(kp.ne.0.0) vcor(k)=sqrt(vcor(k)/real(kp))
  end do

end

!##############   F-F Correlation  ##############
subroutine   ffcf(ds,sze,fl1,n_pks1,fl2,n_pks2,ksi,vksi,n_sh,mth,lng)

implicit none

integer, intent (in) :: sze,n_pks1,n_pks2,n_sh,mth,lng
Real*8, intent (in) :: ds
integer, intent (in) :: fl1(2,n_pks1)
integer, intent (in) :: fl2(2,n_pks2)
Real*8, intent (out) :: ksi(0:lng),vksi(0:lng)

Integer  i,j,k
Real*8  gam,ran1,ran2
Real*8 DD(0:lng),DR1(0:lng),DR2(0:lng),RR(0:lng)
Integer x_sh(n_sh),y_sh(n_sh)

 call init_random_seed()

ksi=0; vksi=0
dd=0; dr1=0; dr2=0; rr=0

do i=1,n_sh
  call random_number(ran1)
  call random_number(ran2)
  x_sh(i)=int(ran1*dble(sze))
  y_sh(i)=int(ran2*dble(sze))
end do

do i=1,n_pks1
  do j=1,n_pks2
!    if (max(abs(x(i)-x(j)),abs(y(i)-y(j)))>lng )cycle
    gam=sqrt( real( (fl1(1,i)-fl2(1,j))**2 + (fl1(2,i)-fl2(2,j))**2 ) )
    k=floor(gam/ds)
    if (k<=lng) DD(k)=DD(k)+1
  enddo
enddo
DD=1.*DD/(n_pks1*n_pks2)

do i=1,n_pks1
  do j=1,n_sh
!    if (max(abs(x(i)-x_sh(j)),abs(y(i)-y_sh(j)))>lng )cycle
    gam=sqrt( real((fl1(1,i)-x_sh(j))**2 + (fl1(2,i)-y_sh(j))**2) )
    k=floor(gam/ds)
    if (k<=lng) DR1(k)=DR1(k)+1
  end do
end do
DR1=1.*DR1/(n_pks1*n_sh)

do i=1,n_pks2
  do j=1,n_sh
!    if (max(abs(x(i)-x_sh(j)),abs(y(i)-y_sh(j)))>lng )cycle
    gam=sqrt( real((fl2(1,i)-x_sh(j))**2 + (fl2(2,i)-y_sh(j))**2) )
    k=floor(gam/ds)
    if (k<=lng) DR2(k)=DR2(k)+1
  end do
end do
DR2=1.*DR2/(n_pks2*n_sh)

if (mth==2 .or. mth==3) then
print*, "This part is out of service for now!"
!do i=1,n_sh
!  do j=i+1,n_sh
!    gam=sqrt( real( (x_sh(i)-x_sh(j))**2 + (y_sh(i)-y_sh(j))**2 ) )
!    k=floor(gam/ds)
!    if (k<=lng) RR(k)=RR(k)+1
!  end do
!end do
end if

do k=1, lng
  if(DR1(k)+DR2(k).ne.0) then
if (mth==1) ksi(k)=2.*DD(k)/(DR1(k)+DR2(k))-1
!if (mth==2) ksi(k)=4.*(DD(k)*RR(k)*1./DR(k)**2)-1.
!if (mth==3) ksi(k)=(DD(k)*1./RR(k))*(n_sh*1./n_pks)**2-2*(DR(k)*1./RR(k))*(n_sh*1./n_pks) + 3.
vksi(k)=0
!    vksi(k)=2.*(n_sh*1./n_pks)*(  ((1.-2*DD(k)/(n_pks*(n_pks-1)))/DR(k))**2 + &
!	& (DD(k)*(1.-2*DR(k)/n_sh*(n_sh-1))/DR(k)**2)**2  )
  end if
end do

end

!##############   F-F Correlation Without random list  ##############
subroutine   ffcfnr(ds,fl1,n_pks1,fl2,n_pks2,rlist,n_sh,ksi,vksi,mth,lng)

implicit none

integer, intent (in) :: n_pks1,n_pks2,n_sh,mth,lng
Real*8, intent (in) :: ds
integer, intent (in) :: fl1(2,n_pks1)
integer, intent (in) :: fl2(2,n_pks2)
integer, intent (in) :: rlist(2,n_sh)
Real*8, intent (out) :: ksi(0:lng),vksi(0:lng)

Integer  i,j,k
Real*8  gam,ran1,ran2
Real*8 DD(0:lng),DR1(0:lng),DR2(0:lng),RR(0:lng)

 call init_random_seed()

ksi=0; vksi=0
dd=0; dr1=0; dr2=0; rr=0

!do i=1,n_sh
!  call random_number(ran1)
!  call random_number(ran2)
!  x_sh(i)=int(ran1*dble(sze))
!  y_sh(i)=int(ran2*dble(sze))
!end do

do i=1,n_pks1
  do j=1,n_pks2
!    if (max(abs(x(i)-x(j)),abs(y(i)-y(j)))>lng )cycle
    gam=sqrt( real( (fl1(1,i)-fl2(1,j))**2 + (fl1(2,i)-fl2(2,j))**2 ) )
    k=floor(gam/ds)
    if (k<=lng) DD(k)=DD(k)+1
  enddo
enddo
DD=1.*DD/(n_pks1*n_pks2)

do i=1,n_pks1
  do j=1,n_sh
!    if (max(abs(x(i)-x_sh(j)),abs(y(i)-y_sh(j)))>lng )cycle
    gam=sqrt( real((fl1(1,i)-rlist(1,j))**2 + (fl1(2,i)-rlist(2,j))**2) )
    k=floor(gam/ds)
    if (k<=lng) DR1(k)=DR1(k)+1
  end do
end do
DR1=1.*DR1/(n_pks1*n_sh)

do i=1,n_pks2
  do j=1,n_sh
!    if (max(abs(x(i)-x_sh(j)),abs(y(i)-y_sh(j)))>lng )cycle
    gam=sqrt( real((fl2(1,i)-rlist(1,j))**2 + (fl2(2,i)-rlist(2,j))**2) )
    k=floor(gam/ds)
    if (k<=lng) DR2(k)=DR2(k)+1
  end do
end do
DR2=1.*DR2/(n_pks2*n_sh)

if (mth==2 .or. mth==3) then
print*, "This part is out of service for now!"
!do i=1,n_sh
!  do j=i+1,n_sh
!    gam=sqrt( real( (x_sh(i)-x_sh(j))**2 + (y_sh(i)-y_sh(j))**2 ) )
!    k=floor(gam/ds)
!    if (k<=lng) RR(k)=RR(k)+1
!  end do
!end do
end if

do k=1, lng
  if(DR1(k)+DR2(k).ne.0) then
if (mth==1) ksi(k)=2.*DD(k)/(DR1(k)+DR2(k))-1
!if (mth==2) ksi(k)=4.*(DD(k)*RR(k)*1./DR(k)**2)-1.
!if (mth==3) ksi(k)=(DD(k)*1./RR(k))*(n_sh*1./n_pks)**2-2*(DR(k)*1./RR(k))*(n_sh*1./n_pks) + 3.
vksi(k)=0
!    vksi(k)=2.*(n_sh*1./n_pks)*(  ((1.-2*DD(k)/(n_pks*(n_pks-1)))/DR(k))**2 + &
!	& (DD(k)*(1.-2*DR(k)/n_sh*(n_sh-1))/DR(k)**2)**2  )
  end if
end do

end

!##############   RANDOM SEED GERERATOR  ##############
subroutine init_random_seed()
  use iso_fortran_env, only: int64
implicit none
  integer, allocatable :: seed(:)
  integer :: i, n, un, istat, dt(8), pid
  integer(int64) :: t

  call random_seed(size = n)
  allocate(seed(n))
  ! First try if the OS provides a random number generator
  open(newunit=un, file="/dev/urandom", access="stream", &
       form="unformatted", action="read", status="old", iostat=istat)
  if (istat == 0) then
     read(un) seed
     close(un)
  else
     ! Fallback to XOR:ing the current time and pid. The PID is
     ! useful in case one launches multiple instances of the same
     ! program in parallel.
     call system_clock(t)
     if (t == 0) then
        call date_and_time(values=dt)
        t = (dt(1) - 1970) * 365_int64 * 24 * 60 * 60 * 1000 &
   + dt(2) * 31_int64 * 24 * 60 * 60 * 1000 &
   + dt(3) * 24_int64 * 60 * 60 * 1000 &
   + dt(5) * 60 * 60 * 1000 &
   + dt(6) * 60 * 1000 + dt(7) * 1000 &
   + dt(8)
     end if
     pid = getpid()
     t = ieor(t, int(pid, kind(t)))
     do i = 1, n
        seed(i) = lcg(t)
     end do
  end if
  call random_seed(put=seed)
contains
  ! This simple PRNG might not be good enough for Real*8 work, but is
  ! sufficient for seeding a better PRNG.
  function lcg(s)
    integer :: lcg
    integer(int64) :: s
    if (s == 0) then
       s = 104729
    else
       s = mod(s, 4294967296_int64)
    end if
    s = mod(s * 279470273_int64, 4294967291_int64)
    lcg = int(mod(s, int(huge(0), int64)), kind(0))
  end function lcg
end subroutine init_random_seed


   PROGRAM value_delta_R
   IMPLICIT NONE

   INTEGER (KIND=8),PARAMETER::n=27
   INTEGER (KIND=8):: i
   REAL (KIND=8):: Rmin,Rmax,dev_R
   REAL    (KIND=8),DIMENSION(n):: R,pa,delta_R

!!!=======================================================================================
!!!=======================================================================================

   OPEN(unit=11,file='R_L24.txt')
   OPEN(unit=12,file='delta_R_Q005_L24.txt')

   DO i=1,n
      READ(11,*)pa(i),R(i),Rmin,Rmax,dev_R
   END DO

   delta_R(:)=0.
   DO i=1,n-1
      delta_R(i)=(R(i+1)-R(i))/(pa(i+1)-pa(i))
   END DO

   DO i=1,n
      WRITE(12,*)pa(i),delta_R(i)
   END DO

   CLOSE(11)
   CLOSE(12)

   END PROGRAM value_delta_R


module types
implicit none
private
public sp, dp, hp, ivector, dvector, zvector

integer, parameter :: dp=kind(0.d0), &             ! double precision
                      hp=selected_real_kind(15), & ! high precision
                      sp = kind(0.)                ! single precision

type ivector                       ! allocatable integer vector
   integer, pointer :: vec(:) => null()
end type

type dvector                       ! allocatable real double precision vector
   real(dp), pointer :: vec(:) => null()
end type

type zvector                       ! allocatable complex double precision vector
   complex(dp), pointer :: vec(:) => null()
end type

end module


#include "scalar.fpp"

!=====================================================================!
! A particle falling freely under gravity physics. This is a simple
! example of setting up a physical system for analysis within the
! framework.
!
! Author: Komahan Boopathy (komahan@gatech.edu)
!=====================================================================!

module freefall_dynamics_class

  use constants                 , only : WP
  use dynamic_physics_interface , only : dynamics

  implicit none

  private

  public :: freefall

  !-------------------------------------------------------------------!
  ! Type that implements freefall mass damper ODE
  !-------------------------------------------------------------------!

  type, extends(dynamics) :: freefall

     ! Define constants and other parameters needed for residual and
     ! jacobian assembly here

     type(scalar) :: mass
     type(scalar) :: gravity

   contains

     ! Implement deferred procedures from superclasses
     procedure :: add_residual
     procedure :: add_jacobian
     procedure :: get_initial_condition

     ! Destructor
     final :: destruct

  end type freefall

  ! Interface to construct freefall particle system
  interface freefall
     procedure construct
  end interface freefall

contains

  !===================================================================!
  ! Constructor for freefall system
  !===================================================================!

  pure type(freefall) function construct(M, G) &
       & result (this)

    type(scalar), intent(in) :: M, G

    ! Set the number of state variables of FREEFALL system
    call this % set_num_state_vars(1)

    ! Set time order of FREEFALL system
    call this % set_differential_order(2)

    ! Set the system parameters
    this % mass = M
    this % gravity = G

  end function construct

  !===================================================================!
  ! Destructor for freefall system
  !===================================================================!

  pure subroutine destruct(this)

    type(freefall), intent(inout) :: this

  end subroutine destruct

  !===================================================================!
  ! Residual assembly at each time step. This is a mandary function
  ! that the user needs to implement to use the integration
  ! scheme. This is where the differential equations are supplied to
  ! the solver.
  !===================================================================!

  pure subroutine add_residual(this, residual, U, X)

    class(freefall)   , intent(inout) :: this
    type(scalar) , intent(inout) :: residual(:)
    type(scalar) , intent(in)    :: U(:,:)
    type(scalar) , intent(in)    :: X(:,:)

    associate( q => U(1,:), qdot => U(2,:), qddot => U(3,:), &
         & m => this % mass, g => this % gravity)

      residual = residual + m*qddot - m*g

    end associate

  end subroutine add_residual

  !===================================================================!
  ! Jacobian assembly at each time step.
  !
  ! Jacobian is the matrix of partial derivatives. Each row in the
  ! Jacobian matrix arises from differentiating a single
  ! equation. Each column in the Jacobian comes from a variable in the
  ! problem. Note the NEQN should be equal to NVARS for the system to
  ! be solved.
  !
  ! Note: alpha, beta and gamma are scalars that need to be multiplied
  ! with the partial derivatives DRDQ, DRDudot and DRDuddot
  ! respectively.
  !===================================================================!

  pure subroutine add_jacobian(this, jacobian, coeff, U, X)

    class(freefall)   , intent(inout) :: this
    type(scalar) , intent(inout) :: jacobian(:,:)
    type(scalar) , intent(in)    :: coeff(:)
    type(scalar) , intent(in)    :: U(:,:)
    type(scalar) , intent(in)    :: X(:,:)

    associate(&
         & q=>U(1,:), qdot=> U(2,:), qddot=> U(3,:), &
         & M=>this%mass, &
         & alpha=>coeff(1), beta=>coeff(2), gamma=>coeff(3)&
         & )

      jacobian = jacobian + gamma*M

    end associate

  end subroutine add_jacobian

  !===================================================================!
  ! Sets the initial condition for use in the integator. If first order
  ! system just set initial Q, if a second order system set initial Q
  ! and qdot
  !===================================================================!

  pure subroutine get_initial_condition(this, U, X)

    class(freefall)   , intent(in)    :: this
    type(scalar) , intent(inout) :: U(:,:)
    type(scalar) , intent(in)    :: X(:,:)

    U(1,:) = 0.0_WP ! position
    U(2,:) = 1.0_WP ! velocity

  end subroutine get_initial_condition

end module freefall_dynamics_class


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Fortran version kronercker product for coo_matrix
!Author: Leo
!Data: Mar. 11. 2016
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!Kronercker product
!
!Parameters:
!   row1, col1, dat1, row2, col2, dat2, the rows, columns and datas defining the 1st and 2nd coo_matrices.
!   n1, n2, the number of non zero items in 1st and 2nd matrices.
!   nrow2, ncol2, the number of rows and columns of the 2nd matrix.
!
!Return:
!   rown, coln, datn, the row, column and data of the new coo_matrix.
subroutine fkron_coo(row1,col1,dat1,row2,col2,dat2,n1,n2,nrow2,ncol2,rown,coln,datn)
    implicit none
    integer,intent(in) :: n1,n2,nrow2,ncol2
    integer,intent(in) :: row1(n1),col1(n1),row2(n2),col2(n2)
    complex*16,intent(in) :: dat1(n1),dat2(n2)
    integer,intent(out) :: rown(n1*n2),coln(n1*n2)
    complex*16,intent(out) :: datn(n1*n2)
    integer :: op,ed,i

    !f2py intent(in) :: n1,n2,nrow2,ncol2,row1,col1,dat1,row2,col2,dat2
    !f2py intent(out) :: rown,coln,datn

    do i=1,n1
        op=(i-1)*n2+1
        ed=i*n2
        rown(op:ed)=row1(i)*nrow2+row2
        coln(op:ed)=col1(i)*ncol2+col2
        datn(op:ed)=dat1(i)*dat2
    enddo
end subroutine fkron_coo

!Kronercker product for scr matrices.
!
!Parameters:
!   indptr1, indices1, dat1, indptr2, indices2, dat2, the row pointers, columns and datas defining the 1st and 2nd coo_matrices.
!   nrow1, nrow2, the number of non zero items in 1st and 2nd matrices.
!   nnz1, nnz2, the number of non zero elements in 1st and 1nd matrices.
!
!Return:
!   indptrn, indicesn, datn, the row pointers, columns and datas of the new coo_matrix.
subroutine fkron_csr(indptr1,indices1,dat1,indptr2,indices2,dat2,nrow1,nnz1,nrow2,nnz2,indptrn,indicesn,datn,ncol2)
    implicit none
    integer,intent(in) :: nrow1,nnz1,nrow2,nnz2,ncol2
    integer,intent(in) :: indptr1(nrow1+1),indptr2(nrow2+1)
    integer,intent(in) :: indices1(nnz1),indices2(nnz2)
    complex*16,intent(in) :: dat1(nnz1),dat2(nnz2)
    integer,intent(out) :: indptrn(nrow1*nrow2+1),indicesn(nnz1*nnz2)
    complex*16,intent(out) :: datn(nnz1*nnz2)
    integer :: op,ed,i1,i2,jn1,j1,start1,start2,stop1,stop2

    !f2py intent(in) :: nnz1,nnz2,nrow1,nrow2,ncol2,indptr1,indices1,dat1,indptr2,indices2,dat2
    !f2py intent(out) :: indptrn,indicesn,datn

    ed=0
    do i1=1,nrow1
        start1=indptr1(i1)
        stop1=indptr1(i1+1)
        do i2=1,nrow2
            indptrn((i1-1)*nrow2+i2)=ed  !setup indptr
            start2=indptr2(i2)
            stop2=indptr2(i2+1)
            do jn1=1,stop1-start1
                j1=indices1(start1+jn1)
                op=ed+1
                ed=ed+(stop2-start2) !calculate nonzero elements in this row.
                datn(op:ed)=dat1(start1+jn1)*dat2(start2+1:stop2)
                indicesn(op:ed)=j1*ncol2+indices2(start2+1:stop2)
            enddo
        enddo
    enddo
    indptrn(nrow1*nrow2+1)=ed
end subroutine fkron_csr

!Kronercker product for scr matrices, taking rows.
!
!Parameters:
!   indptr1, indices1, dat1, indptr2, indices2, dat2, the row pointers, columns and datas defining the 1st and 2nd coo_matrices.
!   nrow1, nrow2, the number of non zero items in 1st and 2nd matrices.
!   nnz1, nnz2, the number of non zero elements in 1st and 1nd matrices.
!   takerows, 1darray the rows desired.
!   ntake, the number of rows desired
!
!Return:
!   indptrn, indicesn, datn, the row pointers, columns and datas of the new coo_matrix.
subroutine fkron_csr_takerow(indptr1,indices1,dat1,indptr2,indices2,dat2,&
        nrow1,nnz1,nrow2,nnz2,indptrn,indicesn,datn,ncol2,takerows,ntake,nnz)
    implicit none
    integer,intent(in) :: nrow1,nnz1,nrow2,nnz2,ncol2,ntake,nnz
    integer,intent(in) :: indptr1(nrow1+1),indptr2(nrow2+1),takerows(ntake)
    integer,intent(in) :: indices1(nnz1),indices2(nnz2)
    complex*16,intent(in) :: dat1(nnz1),dat2(nnz2)
    integer,intent(out) :: indptrn(ntake+1),indicesn(nnz)
    complex*16,intent(out) :: datn(nnz)
    integer :: op,ed,i1,i2,jn1,j1,start1,start2,stop1,stop2,ii

    !f2py intent(in) :: nnz1,nnz2,nrow1,nrow2,ncol2,indptr1,indices1,dat1,indptr2,indices2,dat2,takerows,ntake,nnz
    !f2py intent(out) :: indptrn,indicesn,datn

    ed=0
    do ii=1,ntake  !iterate over rows.
        !get i1,i2
        i2=takerows(ii)
        i1=i2/nrow2
        i2=i2-nrow2*i1+1
        i1=i1+1

        start1=indptr1(i1)
        stop1=indptr1(i1+1)
        start2=indptr2(i2)
        stop2=indptr2(i2+1)
        indptrn(ii)=ed  !setup indptr

        do jn1=1,stop1-start1
            j1=indices1(start1+jn1)
            op=ed+1
            ed=ed+(stop2-start2) !calculate nonzero elements in this row.
            datn(op:ed)=dat1(start1+jn1)*dat2(start2+1:stop2)
            indicesn(op:ed)=j1*ncol2+indices2(start2+1:stop2)
        enddo
    enddo
    indptrn(ntake+1)=ed
end subroutine fkron_csr_takerow


! 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 i64shft
  integer(8) :: res(4), expect(4), x, y

  x = 1
  y = 32
  res = do_shfts(x, y)

  expect = 4294967296

  call check(res, expect, 4)

  contains

   function do_shfts(x, y) result(r)
     integer(8) :: x, y, r(4)
     integer(8) :: z = ishft(1, 32) ! compile-time

     r(1) = z
     r(2) = ishft(z, 1)
     r(2) = ishft(r(2), -1)
     r(3) = ishft(x,32)
     r(4) = ishft(x,y)
   end function
end program


subroutine binned_map(signal, pixidx, mappixels, hits)
    implicit none

    real(kind=8), dimension(:), intent(in) :: signal
    integer(kind=8), dimension(size(signal)), intent(in) :: pixidx
    real(kind=8), dimension(:), intent(inout) :: mappixels
    integer(kind=8), dimension(size(mappixels)), intent(inout) :: hits

    integer :: i

    mappixels = 0.0
    hits = 0

    do i = 1, size(signal)
        mappixels(pixidx(i) + 1) = mappixels(pixidx(i) + 1) + signal(i)
        hits(pixidx(i) + 1) = hits(pixidx(i) + 1) + 1
    end do

    do i = 1, size(mappixels)
        if (hits(i) .gt. 0) then
            mappixels(i) = mappixels(i) / hits(i)
        end if
    end do

  end subroutine binned_map