!!  Module of FFT based routines using fftw
!!
! This file is part of LIBPFASST.
!
!>  Module for providing FFTs based on fftw
!!  To use this module, fftw must be installed.
!!  This can be done by the libpfasst make system with the command
!!  make fftw3
!!  You also have to specify USE_FFTW=TRUE in Makefile.defaults and
!!  make clean is recommended before remake
module pf_mod_fftpackage
  use pf_mod_dtype
  use pf_mod_utils
  use pf_mod_fft_abs
  use, intrinsic :: iso_c_binding
  implicit none
  include 'fftw3.f03'

  !>  Variables and storage for FFTW
  type,extends(pf_fft_abs_t) :: pf_fft_t
     type(c_ptr) :: ffftw, ifftw         !! fftw pointers
     real(pfdp) :: normfact              !! normalization factor
   contains
     procedure :: fft_setup
     procedure :: fft_destroy
     procedure :: fftf
     procedure :: fftb
     !  Interpolate in spectral space
     procedure , private :: interp_1d,interp_2d, interp_3d,zinterp_1d,zinterp_2d, zinterp_3d
     generic   :: interp =>interp_1d,interp_2d,interp_3d,zinterp_1d,zinterp_2d,zinterp_3d
  end type pf_fft_t

contains

  !> Initialize the package
  subroutine fft_setup(this, grid_shape, ndim, grid_size)
    class(pf_fft_t), intent(inout) :: this
    integer,             intent(in   ) :: ndim
    integer,             intent(in   ) :: grid_shape(ndim)
    real(pfdp), optional, intent(in   ) :: grid_size(ndim)

    integer     :: nx,ny,nz
    integer     :: i,j,k
    integer     :: ierr
    real(pfdp)  :: om
    type(c_ptr) :: wk

    this%ndim=ndim
    nx=grid_SHAPE(1)
    this%nx = nx

    ! Defaults for grid_size
    this%Lx = 1.0_pfdp
    this%Ly = 1.0_pfdp
    this%Lz = 1.0_pfdp

    select case (ndim)
    case (1)
       if(present(grid_size)) this%Lx = grid_size(1)
       this%normfact=REAL(nx,pfdp)
       wk = fftw_alloc_complex(int(nx, c_size_t))
       call c_f_pointer(wk, this%wk_1d, [nx])

       this%ffftw = fftw_plan_dft_1d(nx, &
            this%wk_1d, this%wk_1d, FFTW_FORWARD, FFTW_ESTIMATE)
       this%ifftw = fftw_plan_dft_1d(nx, &
            this%wk_1d, this%wk_1d, FFTW_BACKWARD, FFTW_ESTIMATE)
    case (2)
       if(present(grid_size)) then
          this%Lx = grid_size(1)
          this%Ly = grid_size(2)
       end if

       ny=grid_SHAPE(2)
       this%ny = ny
       this%normfact=REAL(nx*ny,pfdp)
       ! create in-place, complex fft plans
       wk = fftw_alloc_complex(int(nx*ny, c_size_t))
       call c_f_pointer(wk, this%wk_2d, [nx,ny])

       this%ffftw = fftw_plan_dft_2d(nx,ny, &
            this%wk_2d, this%wk_2d, FFTW_FORWARD, FFTW_ESTIMATE)
       this%ifftw = fftw_plan_dft_2d(nx,ny, &
            this%wk_2d, this%wk_2d, FFTW_BACKWARD, FFTW_ESTIMATE)
    case (3)
       if(present(grid_size))then
          this%Lx = grid_size(1)
          this%Ly = grid_size(2)
          this%Lz = grid_size(3)
       end if

       ny=grid_SHAPE(2)
       nz=grid_SHAPE(3)
       this%ny = ny
       this%nz = nz
       this%normfact=REAL(nx*ny*nz,pfdp)
       wk = fftw_alloc_complex(int(nx*ny*nz, c_size_t))
       call c_f_pointer(wk, this%wk_3d, [nx,ny,nz])
       this%ffftw = fftw_plan_dft_3d(nx,ny,nz, &
            this%wk_3d, this%wk_3d, FFTW_FORWARD, FFTW_ESTIMATE)
       this%ifftw = fftw_plan_dft_3d(nx,ny,nz, &
            this%wk_3d, this%wk_3d, FFTW_BACKWARD, FFTW_ESTIMATE)
    case DEFAULT
       call pf_stop(__FILE__,__LINE__,'Bad case in SELECT',this%ndim)
    end select

    !  Assign wave numbers
    allocate(this%kx(nx),stat=ierr)
    if (ierr /=0) call pf_stop(__FILE__,__LINE__,'allocate fail, error=',ierr)
    om=two_pi/this%Lx
    do i = 1, nx
       if (i <= nx/2+1) then
          this%kx(i) = om*REAL(i-1,pfdp)
       else
          this%kx(i) = om*REAL(-nx + i - 1,pfdp)
       end if
    end do

    if (ndim > 1) then
       allocate(this%ky(ny),stat=ierr)
       if (ierr /=0) call pf_stop(__FILE__,__LINE__,'allocate fail, error=',ierr)
       om=two_pi/this%Ly
       do j = 1, ny
          if (j <= ny/2+1) then
             this%ky(j) = om*REAL(j-1,pfdp)
          else
             this%ky(j) = om*REAL(-ny + j - 1,pfdp)
          end if
       end do
    end if

    if (ndim > 2) then
       allocate(this%kz(nz),stat=ierr)
       if (ierr /=0) call pf_stop(__FILE__,__LINE__,'allocate fail, error=',ierr)
       om=two_pi / this%Lz
       do k = 1,nz
          if (k <= nz/2+1) then
             this%kz(k) = om*REAL(k-1,pfdp)
          else
             this%kz(k) = om*REAL(-nz + k - 1,pfdp)
          end if
       end do
    end if

  end subroutine fft_setup

  !>  Destroy the package
  subroutine fft_destroy(this)
    class(pf_fft_t), intent(inout) :: this

    type(c_ptr) :: wk
    call fftw_destroy_plan(this%ffftw)
    call fftw_destroy_plan(this%ifftw)
    select case (this%ndim)
    case (1)
       call fftw_free(c_loc(this%wk_1d))
       deallocate(this%kx)
    case (2)
       call fftw_free(c_loc(this%wk_2d))
       !  Deallocate wave number arrays
       deallocate(this%kx)
       deallocate(this%ky)
    case (3)
       call fftw_free(c_loc(this%wk_3d))

       !  Deallocate wave number arrays
       deallocate(this%kx)
       deallocate(this%ky)
       deallocate(this%kz)
    case DEFAULT
       call pf_stop(__FILE__,__LINE__,'Bad case in SELECT',this%ndim)
    end select

  end subroutine fft_destroy

  !>  Routine to take foreward FFT
  subroutine fftf(this)
    class(pf_fft_t), intent(inout) :: this
    select case (this%ndim)
    case (1)
       this%wk_1d=this%wk_1d/this%normfact
       call fftw_execute_dft(this%ffftw, this%wk_1d, this%wk_1d)
    case (2)
       this%wk_2d=this%wk_2d/this%normfact
       call fftw_execute_dft(this%ffftw, this%wk_2d, this%wk_2d)
    case (3)
       this%wk_3d=this%wk_3d/this%normfact
       call fftw_execute_dft(this%ffftw, this%wk_3d, this%wk_3d)
    case DEFAULT
       call pf_stop(__FILE__,__LINE__,'Bad case in SELECT',this%ndim)
    end select
  end subroutine fftf

  !>  Routine to take inverse or backward FFT
  subroutine fftb(this)
    class(pf_fft_t), intent(inout) :: this
    !  Normalize the fft
    select case (this%ndim)
    case (1)
       call fftw_execute_dft(this%ifftw, this%wk_1d, this%wk_1d)
    case (2)
       call fftw_execute_dft(this%ifftw, this%wk_2d, this%wk_2d)
    case (3)
       call fftw_execute_dft(this%ifftw, this%wk_3d, this%wk_3d)
    case DEFAULT
       call pf_stop(__FILE__,__LINE__,'Bad case in SELECT',this%ndim)
    end select
  end subroutine fftb

  subroutine interp_1d(this, yvec_c, fft_f,yvec_f,order)
    class(pf_fft_t), intent(inout) :: this
    real(pfdp), intent(inout),  pointer :: yvec_f(:)
    real(pfdp), intent(in),     pointer :: yvec_c(:)
    type(pf_fft_t),intent(in),  pointer :: fft_f
    integer, intent(in),optional :: order

    complex(pfdp),         pointer :: wk_f(:), wk_c(:)
    integer :: nx_f, nx_c,local_order
    real :: c1,c2,c3
    local_order=0
    if (present(order)) local_order = order

    nx_f = SIZE(yvec_f)
    nx_c = SIZE(yvec_c)
    if (nx_f .eq. nx_c) then
       yvec_f=yvec_c
       return
    end if

   select case (local_order)
   case (0)
      call this%get_wk_ptr(wk_c)
      call fft_f%get_wk_ptr(wk_f)

      wk_c=yvec_c

      call this%fftf()       !  internal forward fft call
      call this%zinterp_1d(wk_c, wk_f)
      call fft_f%fftb()     !  internal inverse fft call

      yvec_f=REAL(wk_f,pfdp)     !  grab the real part
   case (2)  !  This is for 2nd order Finite Difference in periodic domains
      yvec_f(1:nx_f-1:2)=yvec_c
      yvec_f(2:nx_f-2:2)=(yvec_c(1:nx_c-1)+yvec_c(2:nx_c))*0.5_pfdp
      yvec_f(nx_f)=(yvec_f(1) + yvec_f(nx_f-1))*0.5_pfdp
   case (4)
      if (nx_c .lt. 4) call pf_stop(__FILE__,__LINE__,'Coarse grid too small in interp_1d ',nx_c)
      c2=-1.0_pfdp/16.0_pfdp
      c1= 9.0_pfdp/16.0_pfdp
      yvec_f(1:nx_f-1:2)=yvec_c
      yvec_f(2:nx_f:2)=c2*(cshift(yvec_c,-1)+cshift(yvec_c,2))+c1*(yvec_c+cshift(yvec_c,1))
   case (6)
      if (nx_c .lt. 6) call pf_stop(__FILE__,__LINE__,'Coarse grid too small in interp_1d ',nx_c)
      c3=  3.0_pfdp/256.0_pfdp
      c2=-25.0_pfdp/256.0_pfdp
      c1= 75.0_pfdp/128.0_pfdp
      yvec_f(1:nx_f-1:2)=yvec_c
      yvec_f(2:nx_f:2)=c3*(cshift(yvec_c,-2)+cshift(yvec_c,3))+c2*(cshift(yvec_c,-1)+cshift(yvec_c,2))+c1*(yvec_c+cshift(yvec_c,1))
   case DEFAULT
      call pf_stop(__FILE__,__LINE__,'Bad case in SELECT',local_order)
   end select

  end subroutine interp_1d
  subroutine interp_2d(this, yvec_c, fft_f,yvec_f)
    class(pf_fft_t), intent(inout) :: this
    real(pfdp), intent(inout), pointer :: yvec_f(:,:)
    real(pfdp), intent(in), pointer    :: yvec_c(:,:)
    type(pf_fft_t),intent(in), pointer :: fft_f

    complex(pfdp),         pointer :: wk_f(:,:), wk_c(:,:)
    integer :: nx_f(2), nx_c(2)

    nx_f = SHAPE(yvec_f)
    nx_c = SHAPE(yvec_c)

    if (nx_f(1) .eq. nx_c(1) .and. nx_f(2) .eq. nx_c(2)) then
       yvec_f=yvec_c
       return
    end if

    call this%get_wk_ptr(wk_c)
    call fft_f%get_wk_ptr(wk_f)

    wk_c=yvec_c
    call this%fftf()                  !  internal forward fft call
    call this%zinterp_2d(wk_c, wk_f)  !  interpolate in spectral space
    call fft_f%fftb()                 !  internal inverse fft call
    yvec_f=REAL(wk_f,pfdp)                 !  grab the real part

  end subroutine interp_2d
  subroutine interp_3d(this, yvec_c, fft_f,yvec_f)
    class(pf_fft_t), intent(inout) :: this
    real(pfdp), intent(inout),  pointer :: yvec_f(:,:,:)
    real(pfdp), intent(in),  pointer    :: yvec_c(:,:,:)
    type(pf_fft_t), intent(in), pointer :: fft_f

    complex(pfdp),  pointer :: wk_f(:,:,:), wk_c(:,:,:)
    integer :: nx_f(3), nx_c(3)

    nx_f = SHAPE(yvec_f)
    nx_c = SHAPE(yvec_c)

    if (nx_f(1) .eq. nx_c(1) .and. nx_f(2) .eq. nx_c(2) .and. nx_f(3) .eq. nx_c(3)) then
       yvec_f=yvec_c
       return
    end if

    call this%get_wk_ptr(wk_c)
    call fft_f%get_wk_ptr(wk_f)

    wk_c=yvec_c
    call this%fftf()                 !  internal forward fft call
    call this%zinterp_3d(wk_c, wk_f) ! interpolate in spectral space
    call fft_f%fftb()                ! internal inverse fft call
    yvec_f=REAL(wk_f,pfdp)                ! grab the real part

  end subroutine interp_3d

  !>  Interpolate from coarse  level to fine in spectral space
  subroutine zinterp_1d(this, yhat_c, yhat_f)
    class(pf_fft_t), intent(inout) :: this
    complex(pfdp),   pointer,intent(inout) :: yhat_f(:)
    complex(pfdp),   pointer,intent(in) :: yhat_c(:)
    integer :: nx_f, nx_c

    nx_f = SIZE(yhat_f)
    nx_c = SIZE(yhat_c)
    if (nx_f .eq. nx_c) then
       yhat_f=yhat_c
       return
    end if

    yhat_f = 0.0_pfdp
    yhat_f(1:nx_c/2) = yhat_c(1:nx_c/2)
    yhat_f(nx_f-nx_c/2+2:nx_f) = yhat_c(nx_c/2+2:nx_c)
    yhat_f(nx_c/2+1) = yhat_c(nx_c/2+1)*0.5_pfdp
    yhat_f(nx_f-nx_c/2+1) = yhat_c(nx_c/2+1)*0.5_pfdp

  end subroutine zinterp_1d
  subroutine zinterp_2d(this, yhat_c, yhat_f)
    class(pf_fft_t), intent(inout) :: this
    complex(pfdp),   pointer,intent(inout) :: yhat_f(:,:)
    complex(pfdp),   pointer,intent(in) :: yhat_c(:,:)

    integer :: nf1,nf2,nc1,nc2
    integer :: nx_f(2), nx_c(2)

    nx_f = SHAPE(yhat_f)
    nx_c = SHAPE(yhat_c)
    if (nx_f(1) .eq. nx_c(1) .and. nx_f(2) .eq. nx_c(2)) then
       yhat_f=yhat_c
       return
    end if

    nf1=nx_f(1)-nx_c(1)/2+2
    nf2=nx_f(2)-nx_c(2)/2+2
    nc1=nx_c(1)/2+2
    nc2=nx_c(2)/2+2

    yhat_f = 0.0_pfdp
    yhat_f(1:nx_c(1)/2,1:nx_c(2)/2) = yhat_c(1:nx_c(1)/2,1:nx_c(2)/2)
    yhat_f(nf1:nx_f(1),1:nx_c(2)/2) = yhat_c(nc1:nx_c(1),1:nx_c(2)/2)
    yhat_f(1:nx_c(1)/2,nf2:nx_f(2)) = yhat_c(1:nx_c(1)/2,nc2:nx_c(2))
    yhat_f(nf1:nx_f(1),nf2:nx_f(2)) = yhat_c(nc1:nx_c(1),nc2:nx_c(2))

  end subroutine zinterp_2d

  subroutine zinterp_3d(this, yhat_c, yhat_f)
    class(pf_fft_t), intent(inout) :: this
    complex(pfdp),   pointer,intent(inout) :: yhat_f(:,:,:)
    complex(pfdp),   pointer,intent(in) :: yhat_c(:,:,:)

    integer :: nf1,nf2,nf3,nc1,nc2,nc3
    integer :: nx_f(3), nx_c(3)

    nx_f = SHAPE(yhat_f)
    nx_c = SHAPE(yhat_c)
    if (nx_f(1) .eq. nx_c(1) .and. nx_f(2) .eq. nx_c(2) .and. nx_f(3) .eq. nx_c(3))  then
       yhat_f=yhat_c
       return
    end if

    yhat_f = 0.0_pfdp

    nx_f = SHAPE(yhat_f)
    nx_c = SHAPE(yhat_c)

    nf1=nx_f(1)-nx_c(1)/2+2
    nf2=nx_f(2)-nx_c(2)/2+2
    nf3=nx_f(3)-nx_c(3)/2+2
    nc1=nx_c(1)/2+2
    nc2=nx_c(2)/2+2
    nc3=nx_c(3)/2+2

    yhat_f = 0.0_pfdp
    yhat_f(1:nx_c(1)/2,1:nx_c(2)/2,1:nx_c(3)/2) = yhat_c(1:nx_c(1)/2,1:nx_c(2)/2,1:nx_c(3)/2)
    yhat_f(nf1:nx_f(1),1:nx_c(2)/2,1:nx_c(3)/2) = yhat_c(nc1:nx_c(1),1:nx_c(2)/2,1:nx_c(3)/2)
    yhat_f(1:nx_c(1)/2,nf2:nx_f(2),1:nx_c(3)/2) = yhat_c(1:nx_c(1)/2,nc2:nx_c(2),1:nx_c(3)/2)
    yhat_f(nf1:nx_f(1),nf2:nx_f(2),1:nx_c(3)/2) = yhat_c(nc1:nx_c(1),nc2:nx_c(2),1:nx_c(3)/2)

    yhat_f(1:nx_c(1)/2,1:nx_c(2)/2,nf3:nx_f(3)) = yhat_c(1:nx_c(1)/2,1:nx_c(2)/2,nc3:nx_c(3))
    yhat_f(nf1:nx_f(1),1:nx_c(2)/2,nf3:nx_f(3)) = yhat_c(nc1:nx_c(1),1:nx_c(2)/2,nc3:nx_c(3))
    yhat_f(1:nx_c(1)/2,nf2:nx_f(2),nf3:nx_f(3)) = yhat_c(1:nx_c(1)/2,nc2:nx_c(2),nc3:nx_c(3))
    yhat_f(nf1:nx_f(1),nf2:nx_f(2),nf3:nx_f(3)) = yhat_c(nc1:nx_c(1),nc2:nx_c(2),nc3:nx_c(3))

  end subroutine zinterp_3d

end module pf_mod_fftpackage


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!*********************************************************!!
!! Objetivo: Fazer um programa que calcule a inversa de    !!
!!                    uma matriz NxN                       !!
!! Aluna: Laura Simonassi Raso de Paiva                    !!
!! Matrícula: 180021885                                    !!
!! Data: 03/09/2019                                        !!
!!*********************************************************!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module vg

integer:: N !Variável que representa a dimensão da matriz
integer :: i,j !Variáveis de auxílio que descrevem elementos da matriz
real(kind=8),allocatable :: A(:,:) !Matriz lida no arquivo de entrada
real(kind=8),allocatable :: B(:,:) !Matriz Intermediára
real(kind=8),allocatable :: C(:,:) !Matriz inversa da matriz lida
real(kind=8),allocatable :: D(:,:) !Matriz Identidade

      end module vg

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!***********************************************!!
!! Programa que efetua a inversão da matriz      !!
!!***********************************************!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      program matrizinversa

      call leitura_matriz
      call calcula_inversa
      call escreve_resultados

      end program matrizinversa

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!****************************************************!!
!! Subrotina que lê a matriz em um arquivo de entrada !!
!!****************************************************!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine leitura_matriz
use vg

!No arquivo de entrada devem estar escritas a dimensão da matriz e a matriz, respectivamente.
 open(unit=1,file="dados.in",status="old")
   read(unit=1,fmt=*) N
   allocate(A(N,N))
   allocate(B(N,N))
   allocate(C(N,N))
   allocate(D(N,N))
     do i = 1, N
       read(1,*)(A(i,j),j=1,N)
     end do
 close(unit=1)

   B=A !Escrevemos a matriz intermediária igual a matriz lida, para que ela auxilie na formação da matriz inversa sem ser destruída.

   return
end subroutine leitura_matriz

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!****************************************************!!
!! Subrotina que efetua o cálculo da matriz inversa   !!
!!****************************************************!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine calcula_inversa
use vg
implicit none
integer:: linha, k, m
real(kind=8):: pivot, l

!Definimos inicialmente uma matriz identidade, a ser transformada:
 do i=1,N
   do j=1,N
    C(i,j)=0.0
   end do
   C(i,i)=1.0
 end do

!Definindo que o melhor pivot.

 do i=1,N
   pivot=B(i,i)
   do j=1,N
   if (B(j,i)>pivot) then
    pivot=B(j,i)
    linha=j
   end if
 end do

!Efetuação das trocas das linhas e alocação na matriz que será a inversa.
 if (pivot>B(i,i)) then
   do k=1,N
      l=B(i,k)
      B(i,k)=B(linha,k)
      B(linha,k)=l

      l=C(i,k)
      C(i,k)=C(linha,k)
      C(linha,k)=l
    end do
 end if

!Método de Gauss-Jordan
!Divisão pelo variável de auxílio para obter as matrizes que, multiplicadas, resultarão na matriz identidade.

  l=B(i,i)
  do j=1,N
   B(i,j)=B(i,j)/l
   C(i,j)=C(i,j)/l
  end do

  do j=i+1,N
  l=B(j,i)
   do k=1,N
    B(j,k)=B(j,k)-l*B(i,k)
    C(j,k)=C(j,k)-l*C(i,k)
   end do
  end do
end do

  do i=1, N-1
   do j=i+1,N
    l=B(i,j)
     do m=1,N
      B(i,m)=B(i,m)-l*B(j,m)
      C(i,m)=C(i,m)-l*C(j,m)
     end do
    end do
  end do

   D=matmul(C,A) !Matriz Identidade resultará da matriz A lida multiplicada por sua inversa.
return
end subroutine calcula_inversa

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!****************************************************!!
!!    Subrotina que imprimirá os resultados obtidos   !!
!!                  para cada Matriz                  !!
!!****************************************************!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine escreve_resultados
use vg

 open(1,file='resultados.txt',status='new')
   write(1,*) "Matriz lida"
   do i=1,N
    write(1,10)(A(i,j), j=1,N)
   enddo

   write(1,*) "Matriz Inversa"
    do i=1,N
     write(1,10)(C(i,j), j=1,N)
    enddo

   write(1,*) "Matriz Identidade, obtida atraves da multiplicacao de A e de sua inversa C"
     do i=1,N
      write(1,10)(D(i,j), j=1,N)
     enddo

close(1)

 10 format( <N>(f6.2,1x) )
return
end subroutine escreve_resultados


! RUN: %python %S/test_folding.py %s %flang_fc1
! Tests folding of NEAREST() and its relatives
module m1
  real, parameter :: minSubnormal = 1.e-45
  logical, parameter :: test_1 = nearest(0., 1.) == minSubnormal
  logical, parameter :: test_2 = nearest(minSubnormal, -1.) == 0
  logical, parameter :: test_3 = nearest(1., 1.) == 1.0000001
  logical, parameter :: test_4 = nearest(1.0000001, -1.) == 1
  !WARN: warning: NEAREST intrinsic folding overflow
  real, parameter :: inf = nearest(huge(1.), 1.)
  !WARN: warning: NEAREST intrinsic folding: bad argument
  logical, parameter :: test_5 = nearest(inf, 1.) == inf
  !WARN: warning: NEAREST intrinsic folding: bad argument
  logical, parameter :: test_6 = nearest(-inf, -1.) == -inf
  logical, parameter :: test_7 = nearest(1.9999999, 1.) == 2.
  logical, parameter :: test_8 = nearest(2., -1.) == 1.9999999
  logical, parameter :: test_9 = nearest(1.9999999999999999999_10, 1.) == 2._10
  logical, parameter :: test_10 = nearest(-1., 1.) == -.99999994
  logical, parameter :: test_11 = nearest(-1., -2.) == -1.0000001
  real, parameter :: negZero = sign(0., -1.)
  logical, parameter :: test_12 = nearest(negZero, 1.) == minSubnormal
  logical, parameter :: test_13 = nearest(negZero, -1.) == -minSubnormal
  !WARN: warning: NEAREST: S argument is zero
  logical, parameter :: test_14 = nearest(0., negZero) == -minSubnormal
  !WARN: warning: NEAREST: S argument is zero
  logical, parameter :: test_15 = nearest(negZero, 0.) == minSubnormal
end module

module m2
  use ieee_arithmetic, only: ieee_next_after
  real, parameter :: minSubnormal = 1.e-45
  logical, parameter :: test_0 = ieee_next_after(0., 0.) == 0.
  logical, parameter :: test_1 = ieee_next_after(0., 1.) == minSubnormal
  logical, parameter :: test_2 = ieee_next_after(minSubnormal, -1.) == 0
  logical, parameter :: test_3 = ieee_next_after(1., 2.) == 1.0000001
  logical, parameter :: test_4 = ieee_next_after(1.0000001, -1.) == 1
  !WARN: warning: division by zero
  real, parameter :: inf = 1. / 0.
  logical, parameter :: test_5 = ieee_next_after(inf, inf) == inf
  logical, parameter :: test_6 = ieee_next_after(inf, -inf) == inf
  logical, parameter :: test_7 = ieee_next_after(-inf, inf) == -inf
  logical, parameter :: test_8 = ieee_next_after(-inf, -1.) == -inf
  logical, parameter :: test_9 = ieee_next_after(1.9999999, 3.) == 2.
  logical, parameter :: test_10 = ieee_next_after(2., 1.) == 1.9999999
  logical, parameter :: test_11 = ieee_next_after(1.9999999999999999999_10, 3.) == 2._10
  logical, parameter :: test_12 = ieee_next_after(1., 1.) == 1.
  !WARN: warning: invalid argument on division
  real, parameter :: nan = 0. / 0.
  !WARN: warning: IEEE_NEXT_AFTER intrinsic folding: bad argument
  real, parameter :: x13 = ieee_next_after(nan, nan)
  logical, parameter :: test_13 = .not. (x13 == x13)
  !WARN: warning: IEEE_NEXT_AFTER intrinsic folding: bad argument
  real, parameter :: x14 = ieee_next_after(nan, 0.)
  logical, parameter :: test_14 = .not. (x14 == x14)
end module

module m3
  use ieee_arithmetic, only: ieee_next_up, ieee_next_down
  real(kind(0.d0)), parameter :: minSubnormal = 5.d-324
  logical, parameter :: test_1 = ieee_next_up(0.d0) == minSubnormal
  logical, parameter :: test_2 = ieee_next_down(0.d0) == -minSubnormal
  logical, parameter :: test_3 = ieee_next_up(1.d0) == 1.0000000000000002d0
  logical, parameter :: test_4 = ieee_next_down(1.0000000000000002d0) == 1.d0
  !WARN: warning: division by zero
  real(kind(0.d0)), parameter :: inf = 1.d0 / 0.d0
  !WARN: warning: IEEE_NEXT_UP intrinsic folding overflow
  logical, parameter :: test_5 = ieee_next_up(huge(0.d0)) == inf
  !WARN: warning: IEEE_NEXT_DOWN intrinsic folding overflow
  logical, parameter :: test_6 = ieee_next_down(-huge(0.d0)) == -inf
  !WARN: warning: IEEE_NEXT_UP intrinsic folding: bad argument
  logical, parameter :: test_7 = ieee_next_up(inf) == inf
  !WARN: warning: IEEE_NEXT_DOWN intrinsic folding: bad argument
  logical, parameter :: test_8 = ieee_next_down(inf) == inf
  !WARN: warning: IEEE_NEXT_UP intrinsic folding: bad argument
  logical, parameter :: test_9 = ieee_next_up(-inf) == -inf
  !WARN: warning: IEEE_NEXT_DOWN intrinsic folding: bad argument
  logical, parameter :: test_10 = ieee_next_down(-inf) == -inf
  logical, parameter :: test_11 = ieee_next_up(1.9999999999999997d0) == 2.d0
  logical, parameter :: test_12 = ieee_next_down(2.d0) == 1.9999999999999997d0
  !WARN: warning: invalid argument on division
  real(kind(0.d0)), parameter :: nan = 0.d0 / 0.d0
  !WARN: warning: IEEE_NEXT_UP intrinsic folding: bad argument
  real(kind(0.d0)), parameter :: x13 = ieee_next_up(nan)
  logical, parameter :: test_13 = .not. (x13 == x13)
  !WARN: warning: IEEE_NEXT_DOWN intrinsic folding: bad argument
  real(kind(0.d0)), parameter :: x14 = ieee_next_down(nan)
  logical, parameter :: test_14 = .not. (x14 == x14)
end module


module fftpack
  implicit none
  private
  public cfft1
  public cfft2

  real, allocatable :: wsave(:)
  real, allocatable :: work(:)
  integer :: lensav, lenwrk, n = 0

contains
  subroutine cfft1(s, norm, err)
    complex, intent(inout) :: s(:)
    character(1), intent(in) :: norm
    integer, intent(out) :: err
    integer, save :: l = 0

    if(n /= 1 .or. l /= size(s)) then
      n = 1
      if(allocated(wsave)) deallocate(wsave)
      l = size(s)
      lensav = 2 * l + int(log(real(l)) / log(2.)) + 4
      allocate(wsave(lensav))
      call cfft1i(l, wsave, lensav, err)
      if(err /= 0) return
    end if
    lenwrk = 2 * l
    allocate(work(lenwrk))
    if(norm == 'b') then
      call cfft1b(l, 1, s, l, wsave, lensav, work, lenwrk, err)
    else if(norm == 'f') then
      call cfft1f(l, 1, s, l, wsave, lensav, work, lenwrk, err)
    else
      err = 1
    end if
    deallocate(work)
    s = s * l
  end subroutine

  subroutine cfft2(s, norm, err)
    complex, intent(inout) :: s(:, :)
    character(1), intent(in) :: norm
    integer, intent(out) :: err
    integer, save :: l = 0, m = 0

    if(n /= 2 .or. l /= size(s, 1) .or. m /= size(s, 2)) then
      n = 2
      if(allocated(wsave)) deallocate(wsave)
      l = size(s, 1)
      m = size(s, 2)
      lensav = 2 * (l + m)&
        + int(log(real(l)) / log(2.))&
        + int(log(real(m)) / log(2.))&
        + 8
      allocate(wsave(lensav))
      call cfft2i(l, m, wsave, lensav, err)
      if(err /= 0) return
    end if
    lenwrk = 2 * l * m
    allocate(work(lenwrk))
    if(norm == 'b') then
      call cfft2b(l, l, m, s, wsave, lensav, work, lenwrk, err)
    else if(norm == 'f') then
      call cfft2f(l, l, m, s, wsave, lensav, work, lenwrk, err)
    else
      err = 1
    end if
    deallocate(work)
  end subroutine
end module


module Mod_plcd_IsotropConstitutiveTensor
   use typre
   use Mod_plcd_ConstitutiveTensor
   use Mod_Listen
   implicit none
   private
   public IsotropCT

   type, extends(ConstitutiveTensor) :: IsotropCT

      real(rp) :: E
      real(rp) :: nu
      real(rp) :: invK,CNorm
      real(rp) :: C(6,6),CSph(6,6),CDev(6,6)

contains
      procedure :: ReadData => RDIsotrop
      procedure :: ScatterData => SPIsotrop
      procedure :: CheckData => CheckData
      procedure :: Build => BuildIsotrop
      procedure :: GetPointerToC => GetPointerToCIsotrop
      procedure :: GetPointerToCDeviatoric => GetPointerToCDeviatoricIsotrop
      procedure :: GetPointerToCSpherical => GetPointerToCSphericalIsotrop
      procedure :: GetYoungModulusEquiv => GetYoungModulusEquivIsotrop

      procedure :: GetInverseVolumetricDeformationModulus
      procedure :: GetCNorm
      procedure :: ComputeStressNorm
      procedure :: ComputeMeanStress
      procedure :: GetYoungModulusForDirection
      procedure :: GetPoissonRatio
      procedure :: GetYoungModulus

   end type

contains

   subroutine RDIsotrop(a,Listener)
      implicit none
      class(IsotropCT) :: a
      type(ListenFile) :: Listener

      call Listener%Listen('RDIsotrop')
      if (Listener%exists('YOUNG')) a%E = Listener%GetRea('YOUNG',1.0_rp,'Young Modulus')
      call Listener%Listen('RDIsotrop')
      if (Listener%exists('POISS')) a%nu = Listener%GetRea('POISS',0.3_rp,'Poisson Coefficient')

   end subroutine

   subroutine SPIsotrop(a)
      use MPI
      implicit none
      class(IsotropCT) :: a
      integer(ip) :: ierr
      call MPI_BCAST(a%E,1,MPI_REAL8,a%MPIroot,a%MPIcomm,ierr)
      call MPI_BCAST(a%nu,1,MPI_REAL8,a%MPIroot,a%MPIcomm,ierr)

   end subroutine

   subroutine CheckData(a)
      use MPI
      implicit none
      class(IsotropCT) :: a
      if(a%E <= 0.0_rp) call runend('Negative value for the Young Modulus')
      if((a%nu <= -1.0_rp).OR.(a%nu > 0.5_rp)) call runend('Poisson Coefficient out of range (-1 < v <= 0.5)')

   end subroutine

   subroutine BuildIsotrop(a)
      implicit none
      class(IsotropCT) :: a

      real(rp) :: raux
      real(rp) :: Eigenvalues(6)

      !Deviatoric part
      a%CDev(:,1) = a%E/(1+a%nu)*(/ 2.0_rp/3.0_rp,-1.0_rp/3.0_rp,-1.0/3.0_rp,0.0_rp,0.0_rp,0.0_rp /)
      a%CDev(:,2) = a%E/(1+a%nu)*(/ -1.0_rp/3.0_rp,2.0_rp/3.0_rp,-1.0_rp/3.0_rp,0.0_rp,0.0_rp,0.0_rp /)
      a%CDev(:,3) = a%E/(1+a%nu)*(/ -1.0_rp/3.0_rp,-1.0_rp/3.0_rp,2.0_rp/3.0_rp,0.0_rp,0.0_rp,0.0_rp /)
      a%CDev(:,4) = a%E/(1+a%nu)*(/ 0.0_rp,0.0_rp,0.0_rp,1.0_rp/2.0_rp,0.0_rp,0.0_rp /)
      a%CDev(:,5) = a%E/(1+a%nu)*(/ 0.0_rp,0.0_rp,0.0_rp,0.0_rp,1.0_rp/2.0_rp,0.0_rp /)
      a%CDev(:,6) = a%E/(1+a%nu)*(/ 0.0_rp,0.0_rp,0.0_rp,0.0_rp,0.0_rp,1.0_rp/2.0_rp /)

      if (.not. a%OnlyDeviatoricPart) then
         raux = a%nu/(1-2*a%nu)
         a%C(:,1) = a%E/(1+a%nu)*(/ 1.0_rp+raux,raux,raux,0.0_rp,0.0_rp,0.0_rp /)
         a%C(:,2) = a%E/(1+a%nu)*(/ raux,1.0_rp+raux,raux,0.0_rp,0.0_rp,0.0_rp /)
         a%C(:,3) = a%E/(1+a%nu)*(/ raux,raux,1.0_rp+raux,0.0_rp,0.0_rp,0.0_rp /)
         a%C(:,4) = a%E/(1+a%nu)*(/ 0.0_rp,0.0_rp,0.0_rp,1.0_rp/2.0_rp,0.0_rp,0.0_rp /)
         a%C(:,5) = a%E/(1+a%nu)*(/ 0.0_rp,0.0_rp,0.0_rp,0.0_rp,1.0_rp/2.0_rp,0.0_rp /)
         a%C(:,6) = a%E/(1+a%nu)*(/ 0.0_rp,0.0_rp,0.0_rp,0.0_rp,0.0_rp,1.0_rp/2.0_rp /)

      elseif (a%OnlyDeviatoricPart) then
         a%C = a%CDev
      endif

      !Volumetric part
      a%invK = (3*(1-2*a%nu))/a%E
      a%CSph = a%C - a%CDev

      call MatrixEigenValues(6,a%C,Eigenvalues)

      a%CNorm = maxval(abs(Eigenvalues))

   end subroutine

   subroutine GetPointerToCIsotrop(a,C)
      implicit none
      class(IsotropCT), target :: a
      real(rp), pointer :: C(:,:)

      C => a%C
   end subroutine

   subroutine GetPointerToCSphericalIsotrop(a,C)
      implicit none
      class(IsotropCT), target :: a
      real(rp), pointer :: C(:,:)

      C => a%CSph
   end subroutine

   subroutine GetPointerToCDeviatoricIsotrop(a,C)
      implicit none
      class(IsotropCT), target :: a
      real(rp), pointer :: C(:,:)

      C => a%CDev
   end subroutine

   subroutine GetInverseVolumetricDeformationModulus(a,invK)
      implicit none
      class(IsotropCT) :: a
      real(rp) :: invK

      invK  = a%invK

   end subroutine

   subroutine GetCNorm(a,CNorm)
      implicit none
      class(IsotropCT) :: a
      real(rp) :: CNorm

      CNorm = a%CNorm

   end subroutine

   subroutine ComputeStressNorm(a,Stress,StressNorm)
      implicit none
      class(IsotropCT), target :: a
      real(rp) :: Stress(:),StressNorm

      real(rp) :: dot1,dot2

      dot1 = dot_product(Stress(1:3),Stress(1:3))
      dot2 = dot_product(Stress(4:6),Stress(4:6))
      StressNorm = sqrt(dot1+2.0_rp*dot2)

   end subroutine

   subroutine ComputeMeanStress(a,Stress,MeanStress)
      implicit none
      class(IsotropCT), target :: a
      real(rp) :: Stress(:),MeanStress

      meanStress = sum(Stress(1:3))/3.0
   end subroutine

   subroutine GetYoungModulusForDirection(a,Direction,E)
      implicit none
      class(IsotropCT) :: a
      real(rp) :: Direction(:)
      real(rp) :: E

      E = a%E
   end subroutine

   subroutine GetPoissonRatio(a,nu)
      implicit none
      class(IsotropCT) :: a
      real(rp) :: nu

      nu = a%nu
   end subroutine

   subroutine GetYoungModulus(a,E)
      implicit none
      class(IsotropCT) :: a
      real(rp) :: E

      E = a%E
   end subroutine

   subroutine GetYoungModulusEquivIsotrop(a,E)
      implicit none
      class(IsotropCT) :: a
      real(rp) :: E

      E = a%E
   end subroutine
end module


*DECK SINQF
      SUBROUTINE SINQF (N, X, WSAVE)
C***BEGIN PROLOGUE  SINQF
C***PURPOSE  Compute the forward sine transform with odd wave numbers.
C***LIBRARY   SLATEC (FFTPACK)
C***CATEGORY  J1A3
C***TYPE      SINGLE PRECISION (SINQF-S)
C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***DESCRIPTION
C
C  Subroutine SINQF computes the fast Fourier transform of quarter
C  wave data.  That is, SINQF computes the coefficients in a sine
C  series representation with only odd wave numbers.  The transform
C  is defined below at output parameter X.
C
C  SINQB is the unnormalized inverse of SINQF since a call of SINQF
C  followed by a call of SINQB will multiply the input sequence X
C  by 4*N.
C
C  The array WSAVE which is used by subroutine SINQF must be
C  initialized by calling subroutine SINQI(N,WSAVE).
C
C  Input Parameters
C
C  N       the length of the array X to be transformed.  The method
C          is most efficient when N is a product of small primes.
C
C  X       an array which contains the sequence to be transformed
C
C  WSAVE   a work array which must be dimensioned at least 3*N+15
C          in the program that calls SINQF.  The WSAVE array must be
C          initialized by calling subroutine SINQI(N,WSAVE), and a
C          different WSAVE array must be used for each different
C          value of N.  This initialization does not have to be
C          repeated so long as N remains unchanged.  Thus subsequent
C          transforms can be obtained faster than the first.
C
C  Output Parameters
C
C  X       For I=1,...,N
C
C               X(I) = (-1)**(I-1)*X(N)
C
C                  + the sum from K=1 to K=N-1 of
C
C                  2*X(K)*SIN((2*I-1)*K*PI/(2*N))
C
C               A call of SINQF followed by a call of
C               SINQB will multiply the sequence X by 4*N.
C               Therefore SINQB is the unnormalized inverse
C               of SINQF.
C
C  WSAVE   contains initialization calculations which must not
C          be destroyed between calls of SINQF or SINQB.
C
C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
C                 Computations (G. Rodrigue, ed.), Academic Press,
C                 1982, pp. 51-83.
C***ROUTINES CALLED  COSQF
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           changing dummy array size declarations (1) to (*)
C   861211  REVISION DATE from Version 3.2
C   881128  Modified by Dick Valent to meet prologue standards.
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SINQF
      DIMENSION X(*), WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  SINQF
      IF (N .EQ. 1) RETURN
      NS2 = N/2
      DO 101 K=1,NS2
         KC = N-K
         XHOLD = X(K)
         X(K) = X(KC+1)
         X(KC+1) = XHOLD
  101 CONTINUE
      CALL COSQF (N,X,WSAVE)
      DO 102 K=2,N,2
         X(K) = -X(K)
  102 CONTINUE
      RETURN
      END


MODULE Netradiationequivalentevaporationmod
    IMPLICIT NONE
CONTAINS

    SUBROUTINE model_netradiationequivalentevaporation(lambdaV, &
        netRadiation, &
        netRadiationEquivalentEvaporation)
        IMPLICIT NONE
        REAL, INTENT(IN) :: lambdaV
        REAL, INTENT(IN) :: netRadiation
        REAL, INTENT(OUT) :: netRadiationEquivalentEvaporation
        !- Description:
    !            * Title: NetRadiationEquivalentEvaporation Model
    !            * Author: Pierre Martre
    !            * Reference: Modelling energy balance in the wheat crop model SiriusQuality2:
    !            Evapotranspiration and canopy and soil temperature calculations
    !            * Institution: INRA/LEPSE Montpellier
    !            * Abstract:  It is given by dividing net radiation by latent heat of vaporization of water
        !- inputs:
    !            * name: lambdaV
    !                          ** description : latent heat of vaporization of water
    !                          ** parametercategory : constant
    !                          ** datatype : DOUBLE
    !                          ** default : 2.454
    !                          ** min : 0
    !                          ** max : 10
    !                          ** unit : MJ kg-1
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : parameter
    !            * name: netRadiation
    !                          ** description : net radiation
    !                          ** variablecategory : state
    !                          ** datatype : DOUBLE
    !                          ** default : 1.566
    !                          ** min : 0
    !                          ** max : 5000
    !                          ** unit : MJ m-2 d-1
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : variable
        !- outputs:
    !            * name: netRadiationEquivalentEvaporation
    !                          ** variablecategory : auxiliary
    !                          ** description : net Radiation in Equivalent Evaporation
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 5000
    !                          ** unit : g m-2 d-1
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
        netRadiationEquivalentEvaporation = netRadiation / lambdaV * 1000.0
    END SUBROUTINE model_netradiationequivalentevaporation

END MODULE


program decaimento

    implicit none
    double precision, dimension (0:200) :: nu, t, diff
    double precision :: tal, dt
    real :: cont
    integer :: c

    cont = 0
    nu(0) = 100
    tal = 1
    dt = 0.05

    do c = 1,200
	t(c) = c*dt
	diff(c-1) = -(nu(c-1)/tal)
	nu(c) = diff(c-1)*dt + nu(c-1)
	write(*,*) t(c), nu(c)
    enddo

    open(1,FILE = "dados.txt")

	do c = 0,200
	    write(1,*) t(c), nu(c)
	enddo

    close(1)

end program