program real_test
  use flips
  use rand
  use flipstest

  ! This program tests single and double precision reals in FLIPS

  implicit none

  !integer, parameter :: sp = kind(1.0E0)
  !integer, parameter :: dp = kind(1.0D0)

  real(dp) :: t,f,merr
  integer :: sstart,send,sstep,bmin,bmax,bstep,loopcnt,order, prec,mem,&
       matmode, bsize, csize
  integer :: oa,ob,oc,ia,ib,ic, i, j, bs,h
  logical :: flag = .FALSE.,use_files
  real(sp) :: flns

  write(*,*) 'Give precision:'
  write(*,*) '1. Single'
  write(*,*) '2. Double'
  write(*,*) 'Anything else terminates'
  read(*,*) prec
  if (.NOT.(prec==1 .OR. prec==2)) then
     write(*,*) 'Bye!'
     stop
  end if

  write(*,*) 'Give direct theory matrix mode:'
  write(*,*) '1. Full random'
  write(*,*) '2. Band random'
  write(*,*) '3. Band random with common variables'
  write(*,*) '4. Random sparse'
  write(*,*) 'Anything else terminates'
  read(*,*) matmode
  if (.NOT.(matmode==1 .OR. matmode==2 .OR. matmode==3 .OR. matmode==4)) then
     write(*,*) 'Bye!'
     stop
  end if

  write(*,*) 'Memory or binary files:'
  write(*,*) '1. Memory'
  write(*,*) '2. Binary files'
  write(*,*) 'Anything else terminates'
  read(*,*) mem
  if (.NOT.(mem==1 .OR. mem==2)) then
     write(*,*) 'Bye!'
     stop
  end if

  if (mem==1) then
     use_files=.FALSE.
  else
     use_files=.TRUE.
  end if

  write(*,*) 'Give start size, end size, step'
  read(*,*) sstart,send,sstep

  if (matmode==1) then
     bsize = -1
     csize = -1
  end if

  if (matmode==2) then
     write(*,*) 'Give maximum band size'
     read(*,*) bsize
     csize = -1
  end if

  if (matmode==3) then
     write(*,*) 'Give maximum band size'
     read(*,*) bsize
     write(*,*) 'Give number od common variables'
     read(*,*) csize
  end if

  if (matmode==4) then
     write(*,*) 'Give fullness of the sparse matrix'
     read(*,*) flns
     bsize = -1
     csize = floor(flns*100)
  end if

  if (sstep==0) sstep=1
  write(*,*) 'Give buffer min size, max size, step'
  read(*,*) bmin,bmax,bstep
  if (bstep==0) bstep=1

  write(*,*) 'Give order:'
  write(*,*) '1. By buffer size'
  write(*,*) '2. By matrix size'
  write(*,*) 'Anything else terminates'
  read(*,*) order

  select case (order)

  case(1)
     do i = bmin,bmax,bstep
        do j = sstart,send,sstep

           loopcnt = floor(max(1.0,1100*exp(-0.01*j)+1))

           if (i==0) then
              if (prec==1) then
                 call test_run_s(j,1,bsize,csize,loopcnt,use_files,t,f,merr)
              else
                 call test_run_d(j,1,bsize,csize,loopcnt,use_files,t,f,merr)
              end if
              bs = 1
           else

              if (prec==1) then
                 call test_run_s(j,i,bsize,csize,loopcnt,use_files,t,f,merr)
              else
                 call test_run_d(j,i,bsize,csize,loopcnt,use_files,t,f,merr)
              end if
              bs = i
           end if

	       write(*,'(i6,i6,f15.8,f6.3,f15.8)') j,bs,t,f/t/1.0D9,real(merr,8)

        end do
     end do

  case(2)
     do i = sstart,send,sstep
        do j = bmin,bmax,bstep

           loopcnt = floor(max(1.0,1100*exp(-0.01*i)+1))

           if (j==0) then
              if (prec==1) then
                 call test_run_s(i,1,bsize,csize,loopcnt,use_files,t,f,merr)
              else
                 call test_run_d(i,1,bsize,csize,loopcnt,use_files,t,f,merr)
              end if
              bs = 1
           else

              if (prec==1) then
                 call test_run_s(i,j,bsize,csize,loopcnt,use_files,t,f,merr)
              else
                 call test_run_d(i,j,bsize,csize,loopcnt,use_files,t,f,merr)
              end if
              bs = j
           end if

           write(*,'(i6,i6,f15.8,f6.3,f15.8)') i,bs,t,f/t/1.0D9,real(merr,8)

        end do
     end do
  case default
     write(*,*) 'Bye!'
     stop
  end select

contains

  subroutine test_run_s(size,buffer,bsize,csize,loops,files,time,flops,maxerr)
    implicit none

    integer, intent(in) :: size, buffer, bsize, csize, loops
    logical :: files
    real(dp), intent(out) :: time, flops,maxerr

    type(flips_s) :: gs
    real(dp) :: ts,te,total
    real(sp), dimension(:,:), allocatable :: amat
    real(sp), dimension(:,:), allocatable :: mvec,sol
    real(sp), dimension(:), allocatable :: a, m
    integer :: n, ss,bb,cc

    allocate(amat(size,size),mvec(size,1),a(size*size),m(size),sol(size,1))

    !sol = 1.0

    call random_number(sol)
    write(*,*) 'sol constructed'

    time = 0.0D0
    flops = 0.0D0

    ! Make data
!write(*,*) 'Construct data'
    ss = size
    bb = bsize
    cc = csize
    call construct_mat_s(ss,bb,cc,amat)
write(*,*) 'theory matrix constructed'
    mvec = matmul(amat,sol)
write(*,*) 'measurement constructed'
    !call nrand(mvec)
!write(*,*) 'Data constructed'

    ! Start clock
    call cpu_time(ts)
!write(*,*) 'FLIPS Start'
    ! Loop
    do n = 1,loops

       ! Initialize flips object
       if (files) then
          call flips_init(gs,size,1,idnum=100,buffersize=buffer)
       else
          call flips_init(gs,size,1,buffersize=buffer,bandwidth=1,common=cc)
       end if

       do h = 1,size
          a((h-1)*size +1 : h*size) = amat(h,:)
          m(h) = mvec(h,1)
       end do

       ! Feed the data
       !do h = 1,size
          call flips_add(gs,size,a,m)
       !end do
       ! Solve
       call flips_solve(gs)

       ! Update flops
       flops = flops + gs%fc

       ! Check result
       maxerr = maxval(sol(:,1) - gs%solmat)

       ! Kill fob
       call flips_kill(gs,.FALSE.)

    end do

    ! Stop clock
    call cpu_time(te)
!write(*,*) 'FLIPS Stop'
    !  time
    time = (te-ts)/loops
    ! flops
    flops = flops/loops

    deallocate(amat,mvec)

  end subroutine test_run_s

  subroutine test_run_d(size,buffer,bsize,csize,loops,files,time,flops,maxerr)
    implicit none

    integer, intent(in) :: size, buffer, bsize, csize, loops
    logical :: files
    real(dp), intent(out) :: time, flops,maxerr

    type(flips_d) :: gs
    real(dp) :: ts,te,total
    real(dp), dimension(:,:), allocatable :: amat
    real(dp), dimension(:,:), allocatable :: mvec,sol
    real(dp), dimension(:), allocatable :: a,m
    integer :: n,ss,bb,cc

    allocate(amat(size,size),mvec(size,1),a(size*size),m(size),sol(size,1))

    !sol = 1.0

    call random_number(sol)
    write(*,*) 'sol constructed'

    time = 0.0D0
    flops = 0.0D0

    ! Make data
    ss = size
    bb = bsize
    cc = csize
    call construct_mat_d(ss,bb,cc,amat)

    !write(*,*) 'Theory matrix constructed'

    !call nrand(mvec)
    mvec = matmul(amat,sol)

    ! Start clock
    call cpu_time(ts)

    ! Loop
    do n = 1,loops

       ! Initialize flips object
       if (files) then
          call flips_init(gs,size,1,idnum=100,buffersize=buffer)
          !write(*,*) 'FLIPS initialized'
       else
          call flips_init(gs,size,1,buffersize=buffer,bandwidth=1,common=cc)
       end if

       do h = 1,size
          a((h-1)*size +1 : h*size) = amat(h,:)
          m(h) = mvec(h,1)
       end do

       ! Feed the data
       !do h = 1,size
          call flips_add(gs,size,a,m)
          !write(*,*) 'Data added'
       !end do
       ! Solve
       call flips_solve(gs)
       !write(*,*) 'Solved'

       ! Update flops
       flops = flops + gs%fc

       if (files) then
          allocate(gs%solmat(size))
          call flips_get('solu',gs,gs%solmat)
       end if

       ! Check result
       maxerr = maxval(sol(:,1) - gs%solmat)

       ! Kill fob
       call flips_kill(gs,.FALSE.)

    end do

    ! Stop clock
    call cpu_time(te)

    !  time
    time = (te-ts)/loops
    ! flops
    flops = flops/loops

    deallocate(amat,mvec)

  end subroutine test_run_d

subroutine construct_mat_s(size,bsize,csize,mat)
  implicit none

  integer, intent(inout) :: size, bsize, csize
  real(sp), dimension(:,:), intent(out) :: mat

  if (bsize==-1 .AND. csize==-1) then
     call nrand(mat)
     csize=0
     return
  end if

  if (bsize==-1 .AND. csize>0) then
     call random_sparse_matrix(real(csize/100.0),mat)
     csize = 0
     return
  end if

  if(bsize>0 .AND. csize==-1) then
     call random_band_matrix(bsize,mat)
     csize = 0
     return
  end if

  if (bsize>0 .AND. csize>0) then
     call random_band_matrix_with_common(bsize,csize,mat)
     return
  end if

end subroutine construct_mat_s

subroutine construct_mat_d(size,bsize,csize,mat)
  implicit none

  integer, intent(inout) :: size, bsize, csize
  real(dp), dimension(:,:), intent(out) :: mat

  if (bsize==-1 .AND. csize==-1) then
     call nrand(mat)
     csize = 0
     return
  end if

  if (bsize==-1 .AND. csize>0) then
     call random_sparse_matrix(real(csize/100.0,dp),mat)
     csize = 0
     return
  end if

  if(bsize>0 .AND. csize==-1) then
     call random_band_matrix(bsize,mat)
     csize = 0
     return
  end if

  if (bsize>0 .AND. csize>0) then
     call random_band_matrix_with_common(bsize,csize,mat)
     return
  end if

end subroutine construct_mat_d

end program real_test


      DOUBLE PRECISION FUNCTION DVMIN(N,DX)
*     .. Scalar Arguments ..
      INTEGER N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION DX(*)
*     ..
*
*  Purpose
*  =======
**
*     Return the minimum element in a vector.
*     FORTRAN-90 has an intrinsic for this,
*     but not FORTRAN-77 (and not in BLAS).
*     Alex Stivala 05July2008.
*     $Id: dvmin.F 2969 2009-11-22 01:29:39Z astivala $
*
*     .. Parameters ..
      DOUBLE PRECISION INFTY
      PARAMETER (INFTY=1.79769d+308)
*     .. Local Scalars ..
      INTEGER I
      DOUBLE PRECISION MINVAL
*     ..
*
      MINVAL = INFTY
      DO 10 I = 1,N
         IF (DX(I) .LT. MINVAL) THEN
            MINVAL = DX(I)
         ENDIF
   10 CONTINUE
      DVMIN = MINVAL
      RETURN
      END


      SUBROUTINE DERIV1(X,F,DFDX,N,NS)
      IMPLICIT REAL*4 (A-H,O-Z)
C     ASSUMES THAT ANY ZERO IN X OCCURS AT A ENDPOINT
      DIMENSION X(N),F(N),DFDX(N)
      DFDX(1)=(F(2)-F(1))/(X(2)-X(1))
      N1=N-1
      DFDX(N)=(F(N)-F(N1))/(X(N)-X(N1))
      IF(N.EQ.2)RETURN
      S=ABS(X(2)-X(1))/(X(2)-X(1))
      DO 1 J=MAX(2,NS),N1
       SCALE=AMAX1(ABS(F(J-1)),ABS(F(J)),ABS(F(J+1)))/ABS(X(J))
       IF(SCALE.EQ.0.)SCALE=1.
       D1=(F(J+1)-F(J))/(X(J+1)-X(J))/SCALE
       D=(F(J)-F(J-1))/(X(J)-X(J-1))/SCALE
       TAN1=D1/(S*SQRT(1.+D1**2)+1.)
       TAN=D/(S*SQRT(1.+D**2)+1.)
    1 DFDX(J)=(TAN1+TAN)/(1.-TAN1*TAN)*SCALE
      RETURN
      END


#include "real.h"
module mod_density
use mod_grid
use mod_params, only : m_rho, m_K
implicit none

! Parameters.
real(kind=8), private, parameter :: g = 9.81d0

contains

   subroutine density_initialize(dg,nlon,nlat)
      type(data_grids), target, intent(inout) :: dg
      integer(kind=4), intent(in) :: nlon, nlat

      real(kind=REAL_BYTE), pointer, dimension(:,:) :: hz, dz, m_rhoC
      integer(kind=4) :: i, j

      hz     => dg%wave_field%hz
      dz     => dg%depth_field%dz
      m_rhoC => dg%wave_field%m_rhoC

!$omp parallel do private(i)
      do j = 1, nlat
         do i = 1, nlon
            m_rhoC(i,j) = (1.0d0 + m_rho*dz(i,j)*g/(2.0d0*m_K)) &
                        / (1.0d0 + m_rho*dz(i,j)*g/m_K)
         end do
      end do

      return
   end subroutine density_initialize

end module mod_density


module Mod_sup_Kdiscont
contains
   subroutine sup_Kdiscont(e,cshock,auxtens,visac,lambda,chale,grsig,grsigRPO,grsigRP,grvel,vnorm,freq3,kdisc)
      use typre
      use Mod_Element
      implicit none
      class(FiniteElement) :: e
      integer(ip), intent(in)    :: auxtens
      real(rp),    intent(in)    :: grsig(auxtens,e%ndime),grsigRPO(auxtens,e%ndime),grvel(e%ndime,e%ndime),grsigRP(auxtens,e%ndime)
      real(rp),    intent(in)    :: visac,lambda,cshock(2)
      real(rp),    intent(in)    :: vnorm,chale(2)
      real(rp),    intent(out)   :: kdisc

      real(rp)                   :: freq1,freq2,freq3,freqT,gradnorm,gradnormRPO,gradnormV,delta,gradnormRP,freq21,freq22,c1,c2
      integer(ip)                :: idime,jdime,expo

   !Initialization
   freq1=0.0_rp
   freq2=0.0_rp
   freq3=0.0_rp
   delta=1e-8
   expo=1

   !second invariant of velocity gradient
      gradnormV=0.0_rp
      gradnorm=0.0_rp
      gradnormRPO=0.0_rp
      gradnormRP=0.0_rp

      do idime=1,e%ndime
         do jdime=1,e%ndime
            gradnormV=gradnormV + grvel(idime,jdime)&
             *(grvel(idime,jdime))
         end do
      end do
      gradnormV=0.5_rp*(gradnormV)**(0.5_rp)

      do idime=1,auxtens
         do jdime=1,e%ndime
            gradnorm=gradnorm + grsig(idime,jdime)&
             *(grsig(idime,jdime))
         end do
      end do

      do idime=1,auxtens
         do jdime=1,e%ndime
            gradnormRP=gradnormRP + grsigRP(idime,jdime)&
             *(grsigRP(idime,jdime))
         end do
      end do

      do idime=1,auxtens
         do jdime=1,e%ndime
            gradnormRPO=gradnormRPO + grsigRPO(idime,jdime)&
             *(grsigRPO(idime,jdime))
         end do
      end do

      gradnorm=0.5_rp*(gradnorm)**(0.5_rp)
      gradnormRP=0.5_rp*(gradnormRP)**(0.5_rp)
      gradnormRPO=0.5_rp*(gradnormRPO)**(0.5_rp)

      c1=cshock(2)
      c2=cshock(1)

      !antes chale(2)= chale(2)/npol

      freq21=c1*vnorm*chale(2)
      freq22=c2*gradnormV*chale(2)*chale(2)
      ! Characteristic velocity
      freq1 = lambda/(2.0_rp*visac)
      freq2 = (freq21 + freq22)
      freq3 = gradnormRPO/(gradnorm + delta)
      freqT = freq1*freq2*freq3
      !initialization
      kdisc=0.0_rp

      !Compute the stability parameter
      kdisc=freqT

   end subroutine
end module


C
C $Id: phi4dp.f,v 1.5 2008-07-27 00:17:10 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE PHI4DP (ECCNTS,E0,E1,E2,E3,A,B,C,PHI)
C
C SUBROUTINE TO COMPUTE LATITUDE ANGLE (PHI-4).
C
      IMPLICIT DOUBLE PRECISION (A-Z)
      INTEGER II,NIT
      COMMON /ERRMZ0/ IERR
        INTEGER IERR
      SAVE   /ERRMZ0/
      COMMON /PRINZ0/ IPEMSG,IPELUN,IPPARM,IPPLUN
        INTEGER IPEMSG,IPELUN,IPPARM,IPPLUN
      SAVE   /PRINZ0/
      DATA ONE,TWO,FOUR,SIX /1.0D0,2.0D0,4.0D0,6.0D0/
      DATA TOL,NIT /1.0D-10,15/
C
      PHI = A
      DO 020 II = 1,NIT
      SINPHI = SIN (PHI)
      TANPHI = TAN (PHI)
      C = TANPHI * SQRT (ONE - ECCNTS * SINPHI * SINPHI)
      SIN2PH = SIN (TWO * PHI)
      ML = E0 * PHI - E1 * SIN2PH + E2 * SIN (FOUR * PHI)
     .      - E3 * SIN (SIX * PHI)
      MLP = E0 - TWO * E1 * COS (TWO * PHI) + FOUR * E2 *
     .      COS (FOUR * PHI) - SIX * E3 * COS (SIX * PHI)
      CON1 = TWO * ML + C * (ML * ML + B) - TWO * A *
     .       (C * ML + ONE)
      CON2 = ECCNTS * SIN2PH * (ML * ML + B - TWO * A * ML) / (TWO * C)
      CON3 = TWO * (A - ML) * (C * MLP - TWO / SIN2PH) - TWO * MLP
      DPHI = CON1 / (CON2 + CON3)
      PHI = PHI + DPHI
      IF (ABS(DPHI) .GT. TOL) GO TO 020
      RETURN
  020 CONTINUE
C
      IF (IPEMSG .EQ. 0) WRITE (IPELUN,2000) NIT,E0,E1,E2,E3,A,B,C,
     . ECCNTS
 2000 FORMAT (/' ERROR PHI4DP' /
     .         ' LATITUDE FAILED TO CONVERGE AFTER',I3,' ITERATIONS'/
     .         ' E0 =',E25.16,'   E1 =',E25.16/
     .         ' E2 =',E25.16,'   E3 =',E25.16/
     .         ' A  =',E25.16,'   B  =',E25.16/
     .         ' C  =',E25.16/
     .         ' ECCENTRICITY SQUARE =',E25.16)
      IERR = 004
      RETURN
C
      END


      real*8 function secant(f,x00)
      implicit real*8(a-h,o-z)
      logical flag
      x0=x00
      f0=f(x0)
      x1=x0+x0/100.0d0
      f1=f(x1)
      flag=.true.
      do i=1,100
        x=x1-f1*(x1-x0)/(f1-f0)
        if(abs(x-x1).le.1e-4) then
          flag=.false.
          exit
        end if
        x0=x1
        f0=f1
        x1=x
        f1=f(x)
      end do
      if (flag) print *, 'No convergence'
      secant=x
      end


c
c
c
c     =====================================================
       subroutine qinit(maxmx,maxmy,meqn,mbc,mx,my,xlower,ylower,
     &                   dx,dy,q,maux,aux)
c     =====================================================
c
c     # Set initial conditions for q.
c     # Sample scalar equation with data that is piecewise constant with
c     # q = 1.0  if  0.1 < x < 0.6   and   0.1 < y < 0.6
c     #     0.1  otherwise
c
       implicit double precision (a-h,o-z)
       dimension q(1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc, meqn)
c
       do 20 i=1,mx
          xi = xlower + (i-0.5d0)*dx
          do 20 j=1,my
             yj = ylower + (j-0.5d0)*dy
             if (xi.gt.0.1d0 .and. xi.lt.0.6d0 .and.
     &           yj.gt.0.1d0 .and. yj.lt.0.6d0) then
                     q(i,j,1) = 1.d0
                   else
                     q(i,j,1) = 0.1d0
                   endif
  20         continue
       return
       end


      subroutine newnot ( break, coef, l, k, brknew, lnew, coefg )
c  from  * a practical guide to splines *  by c. de boor
c  this is a fake version of  n e w n o t  , of use in example 3 of
c  chapter xiv .
c  returns  lnew+1  knots in  brknew  which are equidistributed on (a,b)
c  = (break(1),break(l+1)) .
c
      integer k,l,lnew,   i
      real break(1),brknew(1),coef(k,l),coefg(2,l),   step
c******  i n p u t ******
c  break, coef, l, k.....contains the pp-representation of a certain
c	 function  f  of order	k . specifically,
c	 d**(k-1)f(x) = coef(k,i)  for	break(i).le. x .lt.break(i+1)
c  lnew.....number of intervals into which the interval (a,b) is to be
c	 sectioned by the new breakpoint sequence  brknew .
c
c******  o u t p u t  ******
c  brknew.....array of length  lnew+1  containing the new breakpoint se-
c	 quence
c  coefg.....the coefficient part of the pp-repr.  break, coefg, l, 2
c	 for the monotone p.linear function  g	wrto which  brknew  will
c	 be equidistributed.
c
      brknew(1) = break(1)
      brknew(lnew+1) = break(l+1)
      step = (break(l+1) - break(1))/float(lnew)
      do 93 i=2,lnew
   93	 brknew(i) = break(1) + float(i-1)*step
					return
      end


subroutine logcldch_to_cldch(logcldch,cldch)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    logcldch_to_cldch  tlm for logcldch to cldch
!   prgmmr: pondeca               org: np20            date: 2015-07-10
!
! abstract: get cloud ceiling height cldch  from logarithm of cldch
!
! program history log:
!   2015-07-10  pondeca
!
!   input argument list:
!      logcldch
!
!   output argument list:
!      cldch
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$
  use kinds, only: r_kind,i_kind
  use gridmod, only: lat2,lon2
  use derivsmod, only: dcldchdlog

  implicit none
  real(r_kind),intent(in   ) :: logcldch(lat2,lon2)
  real(r_kind),intent(  out) :: cldch(lat2,lon2)

  integer(i_kind) i,j

  do j=1,lon2
     do i=1,lat2
        cldch(i,j)=dcldchdlog(i,j)*logcldch(i,j)
     end do
  end do
end subroutine logcldch_to_cldch

subroutine logcldch_to_cldch_ad(logcldch,cldch)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    logcldch_to_cldch_ad  adjoint of logcldch_to_cldch
!   prgmmr: zhu               org: np20                date: 2011-06-30
!
! abstract: adjoint of logcldch_to_cldch
!
! program history log:
!   2015-07-10  pondeca
!
!   input argument list:
!      logcldch
!      cldch
!
!   output argument list:
!      logcldch
!      cldch
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$
  use kinds, only: r_kind,i_kind
  use constants, only: zero
  use gridmod, only: lat2,lon2
  use derivsmod, only: dcldchdlog

  implicit none
  real(r_kind),intent(inout) :: logcldch(lat2,lon2)
  real(r_kind),intent(inout) :: cldch(lat2,lon2)

  integer(i_kind) i,j

  do j=1,lon2
     do i=1,lat2
        logcldch(i,j)=logcldch(i,j)+dcldchdlog(i,j)*cldch(i,j)
        cldch(i,j)=zero
     end do
  end do
end subroutine logcldch_to_cldch_ad


C NCLFORTSTART
      subroutine spigamd (ntim, pp, pmsg, nrun, index)
      implicit none
      integer ntim, nrun
      double precision pp(ntim), index(ntim), pmsg
C NCLEND
c compute SPI: Standardized Precipitation Index using gamma distribution

c local/dynamic
      integer maxyrs, j, i, im, n, kmsg, k
      double precision tmparr(ntim/12+1), pcon
      double precision alpha(12), beta(12), gamm(12), pzero(12)
      double precision anvnrmd, gamcdfd

      maxyrs = ntim/12
c
c	Initialize index and check for all missing values
c
      kmsg = 0
      do j=1,ntim
         index(j) = pmsg
         if (pp(j).eq.pmsg) then
             kmsg = kmsg+1
         end if
      end do
      if (kmsg.eq.ntim) return
c
c	check for all constant values; can not fit a distribution
c
      do j=1,ntim
         if (pp(j).ne.pmsg) then
             pcon = pp(j)
             go to 13
         end if
      end do
   13 continue

      do j=1,ntim
         if (pp(j).ne.pmsg .and. pp(j).ne.pcon) then
             go to 18
         end if
      end do
      return
   18 continue

      do j=1,12
         beta(j)  = pmsg
         gamm(j)  = pmsg
         alpha(j) = pmsg
         pzero(j) = pmsg
      end do
c
c	Sum nrun precip. values;
c	store them in the appropriate index location.
c	The first nrun-1 index values will be missing.
c
c	If any value is missing; set the sum to missing.
c
      do j=nrun,ntim
         index(j) = 0.0d0
        do i=0,nrun-1
           if (pp(j-i) .ne. pmsg) then
               index(j) = index(j) + pp(j-i)
           else
               index(j) = pmsg
               goto 30
           endif
       end do
  30   continue
      end do
c
c	For nrun<12, the monthly distributions will be substantially
c       different. So we need to compute gamma parameters for
c	each month starting with the (nrun-1)th.
c
      do i=0,11
        n=0
        do j=nrun+i,ntim,12
           if(index(j) .ne. pmsg) then
              n=n+1
              tmparr(n) = index(j)
           endif
        end do
        im = mod (nrun+i-1, 12) + 1
c
c	Here's where we do the fitting.
c
        if (n.gt.0) then
c
c avoid trying to fit a series of constant values
c
            do k=2,n
               if (tmparr(k).ne.tmparr(1)) then
                   call gamfitd(tmparr,n
     +                  ,alpha(im), beta(im), gamm(im), pzero(im))
                   go to 37
               end if
            end do
        end if

   37   continue
      end do
c
c	Replace precip. sums stored in index with SPI's
c
      do j = nrun, ntim
         im = mod (j-1,12) + 1
         if (index(j) .ne. pmsg .and. beta(im).ne.pmsg) then
c
c	Get the probability
c
             index(j) = gamcdfd(beta(im), gamm(im), pzero(im), index(j))
c
c	Convert prob. to z value.
c
             index(j) = anvnrmd(index(j))
         endif
      end do

      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccc
c	input prob; return z.
c	See Abromowitz and Stegun _Handbook of Mathematical Functions_, p. 933
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccc
      double precision function anvnrmd (prob)
      implicit none
      double precision sign, prob, t, c0, c1, c2, d1, d2, d3
      data c0, c1, c2 /2.515517d0, 0.802853d0, 0.010328d0/
      data d1, d2, d3 /1.432788d0, 0.189269d0, 0.001308d0/

      if (prob .gt. 0.5d0) then
          sign = 1.0d0
          prob = 1.0d0 - prob
      else
          sign = -1.0d0
      endif
      if (prob .lt. 0.0d0) then
c c c     write(*, *) 'Error in anvnrmd(). Prob. not in [0,1.0]'
          anvnrmd = 0.0d0
          return
      endif
      if (prob .eq. 0.0d0) then
          anvnrmd = 1.0d37 * sign
          return
      endif
      t       = sqrt(log (1.0d0 / (prob * prob)))
      anvnrmd = (sign * (t - ((((c2 * t) + c1) * t) + c0) /
     1          ((((((d3*t)+d2)*t)+d1)*t)+1.0)))
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c Estimate incomplete gamma parameters.
c
c Input:
c	datarr - data array
c	n - size of datarr
c
c Output:
c	alpha, beta, gamma - gamma paarameters
c	pzero - probability of zero.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine gamfitd (datarr, n, alpha, beta, gamm, pzero)
      implicit none
      integer n
      double precision datarr(*), alpha, beta, gamm, pzero

      integer nact, i
      double precision sum, sumlog, av

      if (n .le. 0) then
          write(*, *) 'Error in gamfitd - empty data array'
          stop
      endif
      sum    = 0.0d0
      sumlog = 0.0d0
      pzero  = 0.0d0
      nact   = 0

c	compute sums
      do 10 i = 1, n
      if (datarr(i) .gt. 0.0d0) then
          sum = sum + datarr(i)
          sumlog = sumlog + log(datarr(i))
          nact = nact + 1
      else
          pzero = pzero + 1
      endif
   10 continue
      pzero = pzero / n
      if (nact .ne. 0) av = sum / nact

c	Bogus data array but do something reasonable
      if(nact .eq. 1) then
         alpha = 0.0d0
         gamm  = 1.0d0
         beta  = av
         return
      endif

c	They were all zeroes.
      if(pzero .eq. 1.0d0) then
         alpha = 0.0d0
         gamm  = 1.0d0
         beta  = av
         return
      endif

c	Use MLE
c       A Note on the Gamma Distribution
c       Thom (1958): Monthly Weather Review, pp 117-122.
c       eqn 22 for gamma; just above eqn 21 "A" => alpha

      alpha = log(av) - sumlog / nact
      gamm  = (1.0d0 + sqrt(1.0d0 + 4.0d0*alpha/ 3.0d0)) /(4.0d0*alpha)
      beta  = av / gamm

      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c Compute probability of a<=x using incomplete gamma parameters.
c
c Input:
c	beta, gamma - gamma parameters
c	pzero - probability of zero.
c	x - value.
c
c Return:
c	Probability a<=x.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      double precision function gamcdfd (beta, gamm, pzero, x)
      implicit none
      double precision beta, gamm, pzero, x
      double precision gammapd

      if(x .le. 0.0d0) then
         gamcdfd = pzero
      else
         gamcdfd = pzero + (1.0d0 - pzero) * gammapd (gamm, x / beta)
      endif

      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c Compute inverse gamma function i.e. return x given p where CDF(x) = p.
c
c Input:
c	beta, gamma - gamma parameters
c	pzero - probability of zero.
c	prob - probability.
c
c Return:
c	x as above.
c
c Method:
c	We use a simple binary search to first bracket out initial
c	guess and then to refine our guesses until two guesses are within
c	tolerance (eps). Is there a better way to do this?
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      double precision function gaminvd (beta, gamm, pzero, prob)
      implicit none
      double precision beta, gamm, pzero, prob

      integer niter
      double precision eps, phigh, thigh, tlow, t, p
      data eps /1.0d-7/
      double precision gamcdfd

c	Check if prob < prob of zero
      if (prob .le. pzero) then
          gaminvd = 0.0d0
          return
      endif

c	Otherwise adjust prob
      prob = (prob - pzero) / (1.0d0 - pzero)

c	Make initial guess. Keep doubling estimate until prob is
c	bracketed.
      thigh = 2.0d0*eps
 10   continue
      phigh = gamcdfd (beta, gamm, pzero, thigh)
      if(phigh .ge. prob) goto 20
      thigh = thigh*2.0d0
      goto 10
 20   continue
      tlow = thigh / 2.0d0
c     Iterate to find root.
      niter = 0
 30   continue
      if((thigh - tlow) .le. eps) goto 40
         niter = niter + 1
         t = (tlow + thigh) / 2.0d0
         p = gamcdfd (beta, gamm, pzero, t)
         if (p .lt. prob) then
             tlow = t
         else
            thigh = t
         endif
      goto 30
 40   continue

      gaminvd = (tlow + thigh) / 2.0d0
      return
      end
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c Functions for the incomplete gamma functions P and Q
c
c	1 /x-ta-1
c P(a,x)=--------| e t dt, a>0
c	Gamma(x)/ 0
c
c Q(a,x)=1-P(a,x)
c
c Reference: Press, Flannery, Teukolsky, and Vetterling,
c	_Numerical Recipes_, pp. 160-163
c
c Thanks to kenny@cs.uiuc.edu
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c Evaluate P(a,x) by its series representation.
c
      double precision function gamserd (a, x)
      implicit none
      double precision a, x

      integer maxitr, n, iwarn
      double precision eps, ap, sum, del, gln
      double precision gammlnd

c     Maximum number of iterations, and bound on error.
      parameter (maxitr=100, eps=3.0d-7)
      data iwarn /0/

      gln = gammlnd (a)

      if (x .eq. 0.0) then
          gamserd = 0.0d0
          return
      endif

      ap  = a
      sum = 1.0d0 / a
      del = sum
      do 10 n = 1, maxitr
         ap  = ap + 1.0d0
         del = del * (x / ap)
         sum = sum + del
         if (abs (del) .lt. eps * abs (sum)) goto 20
   10 continue

      iwarn = iwarn + 1
c djs if (iwarn .lt. 20) then
c djs     write (*, *) 'gamserd(',a,x,'): not converging.'
c djs     write (*, *) 'Approximate value of ',sum,' + /-',del,' used.'
c djs endif
 20   continue

      gamserd= sum*exp(-x+a*log(x)-gln)

      return
      end
c
c	Evaluate P(a,x) in its continued fraction representation.
c
      double precision function gammcfd (a, x)
      implicit none
      double precision a, x

      integer maxitr, nwarn, n
      double precision    eps, gln, gold, a0,a1,b0,b1,fac,an,ana,anf,g
      parameter (maxitr=200, eps=3.0d-7)
      data nwarn / 0 /, g / 0.0d0 /

      double precision gammlnd

      gln  = gammlnd (a)
      gold = 0.0d0
      a0   = 1.0d0
      a1   = x
      b0   = 0.0d0
      b1   = 1.0d0
      fac  = 1.0d0

      do 10 n = 1, maxitr
         an  = n
         ana = an - a
         a0  = (a1 + a0 * ana) * fac
         b0  = (b1 + b0 * ana) * fac
         anf = an * fac
         a1  = x * a0 + anf * a1
         b1  = x * b0 + anf * b1
         if (a1 .ne. 0.0d0) then
             fac = 1.0d0 / a1
             g = b1 * fac
             if (abs((g - gold) / g) .lt. eps) goto 20
             gold = g
         endif
 10   continue

      nwarn = nwarn + 1
c djs if (nwarn .lt. 20) then
c djs     write (*, *) 'gammcfd(',a,x,'): not converging.'
c djs     write (*, *) 'Inaccurate value of ', g, ' +/- ',
c djs1	  abs(g - gold), ' used.'
c djs endif
 20   continue

      gammcfd= g*exp(-x+a*log(x)-gln)
      return
      end
c
c	Evaluate the incomplete gamma function P(a,x), choosing the most
c	appropriate representation.
c
      double precision function gammapd (a, x)
      implicit none
      double precision a, x
      double precision gamserd, gammcfd

      if (x .lt. a + 1.0d0) then
          gammapd = gamserd (a, x)
      else
          gammapd = 1.0d0 - gammcfd (a, x)
      endif

      return
      end
c
c	Evaluate the incomplete gamma function Q(a,x), choosing the most
c	appropriate representation.
c
      double precision function gammaqd (a, x)
      implicit none
      double precision a, x
      double precision gamserd, gammcfd

      if (x .lt. a + 1.0d0) then
          gammaqd = 1.0d0 - gamserd (a, x)
      else
          gammaqd = gammcfd (a, x)
      endif
      return
      end
c
c	For those who don't have a ln(gamma) function.
c
      double precision function gammlnd(xx)
      implicit none
      double precision xx

      integer j
      double precision cof(6), x, tmp, ser
      data cof / 76.18009173d0, -86.50532033d0, 24.01409822d0
     +         , -1.231739516d0, 0.120858003d-2, -0.536382d-5/

      x   = xx - 1.0d0
      tmp = x + 5.5d0
      tmp = tmp - (x+0.5d0) * log(tmp)
      ser = 1.0d0

      do 10 j = 1, 5
         x   = x + 1.0d0
         ser = ser + cof(j) / x
 10   continue

      gammlnd = -tmp + log(2.50662827465d0 * ser)

      return
      end


      SUBROUTINE FOUR(DATA,NN,ISIGN)
C
C     THE COOLEY-TUKEY FAST FOURIER TRANSFORM IN USASI BASIC FORTRAN
C
C     TRANSFORM(K)=SUM(DATA(J)*EXP(ISIGN*2*PI*SQRT(-1)*(K-1)*(J-1)/NN)),
C     SUMMED FOR ALL J, K, BETWEEN 1 AND NN.  DATA IS A COMPLEX ARRAY OF
C     LENGTH NN.  THE REAL AND IMAGINARY PARTS ARE ADJACENT IN STORAGE
C     SUCH AS FORTRAN IV PLACES THEM.  ITS DIMENSION IS A POWER OF TWO
C     (.GE. 1).  IF NECESSARY, APPEND ZEROES TO THE DATA TO GET A POWER
C     OF TWO.   ISIGN IS +1 OR -1.  IF A -1 TRANSFORM IS FOLLOWED BY A
C     +1 (OR A +1 BY A -1) THE ORIGINAL DATA REAPPEAR, MULTIPLIED BY NN.
C     TRANSFORM VALUES ARE RETURNED IN ARRAY DATA, REPLACING THE INPUT.
C     WRITTEN BY NORMAN BRENNER FROM THE BASIC PROGRAM OF CHARLES RADER.
C     RALPH ALTER SUGGESTED THE METHOD OF BIT REVERSAL. MIT LINCOLN
C     LABORATORY, AUGUST 1967.
C     SEE-- IEEE AUDIO TRANSACTIONS (JUNE 1967), SPECIAL ISSUE ON FFT.
C
      DIMENSION DATA(1)
      DATA TWOPI /6.283185/
      NTOT=2*NN
C
      NP1=2
      N=NN
      NP2=NP1*N
      IF(N-1)700,600,100
C
C     SHUFFLE DATA BY BIT REVERSAL, SINCE N=2**K.  AS THE SHUFFLING
C     CAN BE DONE BY SIMPLE INTERCHANGE, NO WORKING ARRAY IS NEEDED
C
100   NP2HF=NP2/2
      J=1
      DO 160 I2=1,NP2,NP1
      IF(J-I2)110,130,130
110   I1MAX=I2+NP1-2
      DO 120 I1=I2,I1MAX,2
      DO 120 I3=I1,NTOT,NP2
      J3=J+I3-I2
      TEMPR=DATA(I3)
      TEMPI=DATA(I3+1)
      DATA(I3)=DATA(J3)
      DATA(I3+1)=DATA(J3+1)
      DATA(J3)=TEMPR
120   DATA(J3+1)=TEMPI
130   M=NP2HF
140   IF(J-M)160,160,150
150   J=J-M
      M=M/2
      IF(M-NP1)160,140,140
160   J=J+M
C
C     MAIN LOOP.  PERFORM FOURIER TRANSFORMS OF LENGTH FOUR, WITH ONE OF
C     LENGTH TWO IF NEEDED.  THE TWIDDLE FACTOR W=EXP(ISIGN*2*PI*
C     SQRT(-1)*M/(4*MMAX)).  CHECK FOR THE SPECIAL CASE W=ISIGN*SQRT(-1)
C     AND REPEAT FOR W=ISIGN*SQRT(-1)*CONJUGATE(W).
C
      NP1TW=NP1+NP1
      IPAR=N
310   IF(IPAR-2)350,330,320
320   IPAR=IPAR/4
      GO TO 310
330   DO 340 I1=1,NP1,2
      DO 340 K1=I1,NTOT,NP1TW
      K2=K1+NP1
      TEMPR=DATA(K2)
      TEMPI=DATA(K2+1)
      DATA(K2)=DATA(K1)-TEMPR
      DATA(K2+1)=DATA(K1+1)-TEMPI
      DATA(K1)=DATA(K1)+TEMPR
340   DATA(K1+1)=DATA(K1+1)+TEMPI
350   MMAX=NP1
360   IF(MMAX-NP2HF)370,600,600
370   LMAX=MAX0(NP1TW,MMAX/2)
      IF(MMAX-NP1)405,405,380
380   THETA=-TWOPI*FLOAT(NP1)/FLOAT(4*MMAX)
      IF(ISIGN)400,390,390
390   THETA=-THETA
400   WR=COS(THETA)
      WI=SIN(THETA)
      WSTPR=-2.*WI*WI
      WSTPI=2.*WR*WI
405   DO 570 L=NP1,LMAX,NP1TW
      M=L
      IF(MMAX-NP1)420,420,410
410   W2R=WR*WR-WI*WI
      W2I=2.*WR*WI
      W3R=W2R*WR-W2I*WI
      W3I=W2R*WI+W2I*WR
420   DO 530 I1=1,NP1,2
      KMIN=IPAR*M+I1
      IF(MMAX-NP1)430,430,440
430   KMIN=I1
440   KDIF=IPAR*MMAX
450   KSTEP=4*KDIF
      DO 520 K1=KMIN,NTOT,KSTEP
      K2=K1+KDIF
      K3=K2+KDIF
      K4=K3+KDIF
      IF(MMAX-NP1)460,460,480
460   U1R=DATA(K1)+DATA(K2)
      U1I=DATA(K1+1)+DATA(K2+1)
      U2R=DATA(K3)+DATA(K4)
      U2I=DATA(K3+1)+DATA(K4+1)
      U3R=DATA(K1)-DATA(K2)
      U3I=DATA(K1+1)-DATA(K2+1)
      IF(ISIGN)470,475,475
470   U4R=DATA(K3+1)-DATA(K4+1)
      U4I=DATA(K4)-DATA(K3)
      GO TO 510
475   U4R=DATA(K4+1)-DATA(K3+1)
      U4I=DATA(K3)-DATA(K4)
      GO TO 510
480   T2R=W2R*DATA(K2)-W2I*DATA(K2+1)
      T2I=W2R*DATA(K2+1)+W2I*DATA(K2)
      T3R=WR*DATA(K3)-WI*DATA(K3+1)
      T3I=WR*DATA(K3+1)+WI*DATA(K3)
      T4R=W3R*DATA(K4)-W3I*DATA(K4+1)
      T4I=W3R*DATA(K4+1)+W3I*DATA(K4)
      U1R=DATA(K1)+T2R
      U1I=DATA(K1+1)+T2I
      U2R=T3R+T4R
      U2I=T3I+T4I
      U3R=DATA(K1)-T2R
      U3I=DATA(K1+1)-T2I
      IF(ISIGN)490,500,500
490   U4R=T3I-T4I
      U4I=T4R-T3R
      GO TO 510
500   U4R=T4I-T3I
      U4I=T3R-T4R
510   DATA(K1)=U1R+U2R
      DATA(K1+1)=U1I+U2I
      DATA(K2)=U3R+U4R
      DATA(K2+1)=U3I+U4I
      DATA(K3)=U1R-U2R
      DATA(K3+1)=U1I-U2I
      DATA(K4)=U3R-U4R
520   DATA(K4+1)=U3I-U4I
      KMIN=4*(KMIN-I1)+I1
      KDIF=KSTEP
      IF(KDIF-NP2)450,530,530
530   CONTINUE
      M=MMAX-M
      IF(MMAX-NP1) 580,580,535
535   CONTINUE
      IF(ISIGN)540,550,550
540   TEMPR=WR
      WR=-WI
      WI=-TEMPR
      GO TO 560
550   TEMPR=WR
      WR=WI
      WI=TEMPR
560   IF(M-LMAX)565,565,410
565   TEMPR=WR
      WR=WR*WSTPR-WI*WSTPI+WR
570   WI=WI*WSTPR+TEMPR*WSTPI+WI
580   CONTINUE
      IPAR=3-IPAR
      MMAX=MMAX+MMAX
      GO TO 360
C
C     END OF LOOP OVER EACH DIMENSION
C
600   NP1=NP2
700   RETURN
      END


! Program to test the eoshift intrinsic
program intrinsic_eoshift
   integer, dimension(3, 3) :: a
   integer, dimension(3, 3, 2) :: b
   integer, dimension(3) :: bo, sh

   ! Scalar shift and scalar bound.
   a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
   a = eoshift (a, 1, 99, 1)
   if (any (a .ne. reshape ((/2, 3, 99, 5, 6, 99, 8, 9, 99/), (/3, 3/)))) &
      call abort

   a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
   a = eoshift (a, 9999, 99, 1)
   if (any (a .ne. 99)) call abort

   a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
   a = eoshift (a, -2, dim = 2)
   if (any (a .ne. reshape ((/0, 0, 0, 0, 0, 0, 1, 2, 3/), (/3, 3/)))) &
      call abort

   a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
   a = eoshift (a, -9999, 99, 1)
   if (any (a .ne. 99)) call abort

   ! Array shift and scalar bound.
   a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
   a = eoshift (a, (/1, 0, -1/), 99, 1)
   if (any (a .ne. reshape ((/2, 3, 99, 4, 5, 6, 99, 7, 8/), (/3, 3/)))) &
      call abort

   a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
   a = eoshift (a, (/9999, 0, -9999/), 99, 1)
   if (any (a .ne. reshape ((/99, 99, 99, 4, 5, 6, 99, 99, 99/), (/3, 3/)))) &
      call abort

   a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
   a = eoshift (a, (/2, -2, 0/), dim = 2)
   if (any (a .ne. reshape ((/7, 0, 3, 0, 0, 6, 0, 2, 9/), (/3, 3/)))) &
      call abort

   ! Scalar shift and array bound.
   a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
   a = eoshift (a, 1, (/99, -1, 42/), 1)
   if (any (a .ne. reshape ((/2, 3, 99, 5, 6, -1, 8, 9, 42/), (/3, 3/)))) &
      call abort

   a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
   a = eoshift (a, 9999, (/99, -1, 42/), 1)
   if (any (a .ne. reshape ((/99, 99, 99, -1, -1, -1, 42, 42, 42/), &
	(/3, 3/)))) call abort

   a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
   a = eoshift (a, -9999, (/99, -1, 42/), 1)
   if (any (a .ne. reshape ((/99, 99, 99, -1, -1, -1, 42, 42, 42/), &
	(/3, 3/)))) call abort

   a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
   a = eoshift (a, -2, (/99, -1, 42/), 2)
   if (any (a .ne. reshape ((/99, -1, 42, 99, -1, 42, 1, 2, 3/), (/3, 3/)))) &
      call abort

   a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
   bo = (/99, -1, 42/)
   a = eoshift (a, -2, bo, 2)
   if (any (a .ne. reshape ((/99, -1, 42, 99, -1, 42, 1, 2, 3/), (/3, 3/)))) &
      call abort

   ! Array shift and array bound.
   a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
   a = eoshift (a, (/1, 0, -1/), (/99, -1, 42/), 1)
   if (any (a .ne. reshape ((/2, 3, 99, 4, 5, 6, 42, 7, 8/), (/3, 3/)))) &
      call abort

   a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
   a = eoshift (a, (/2, -2, 0/), (/99, -1, 42/), 2)
   if (any (a .ne. reshape ((/7, -1, 3, 99, -1, 6, 99, 2, 9/), (/3, 3/)))) &
      call abort

   a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
   sh = (/ 3, -1, -3 /)
   bo = (/-999, -99, -9 /)
   a = eoshift(a, shift=sh, boundary=bo)
   if (any (a .ne. reshape ((/ -999, -999, -999, -99, 4, 5, -9, -9, -9 /), &
        shape(a)))) call abort

   a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
   a = eoshift (a, (/9999, -9999, 0/), (/99, -1, 42/), 2)
   if (any (a .ne. reshape ((/99, -1, 3, 99, -1, 6, 99, -1, 9/), (/3, 3/)))) &
      call abort

   ! Test arrays > rank 2
   b(:, :, 1) = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
   b(:, :, 2) = 10 + reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))
   b = eoshift (b, 1, 99, 1)
   if (any (b(:, :, 1) .ne. reshape ((/2, 3, 99, 5, 6, 99, 8, 9, 99/), (/3, 3/)))) &
      call abort
   if (any (b(:, :, 2) .ne. reshape ((/12, 13, 99, 15, 16, 99, 18, 19, 99/), (/3, 3/)))) &
      call abort

   ! TODO: Test array sections
end program


        subroutine idd_qmatvec(iftranspose,m,n,a,krank,v)
c
c       applies to a single vector the Q matrix (or its transpose)
c       which the routine iddp_qrpiv or iddr_qrpiv has stored
c       in a triangle of the matrix it produces (stored, incidentally,
c       as data for applying a bunch of Householder reflections).
c       Use the routine qmatmat to apply the Q matrix
c       (or its transpose)
c       to a bunch of vectors collected together as a matrix,
c       if you're concerned about efficiency.
c
c       input:
c       iftranspose -- set to 0 for applying Q;
c                      set to 1 for applying the transpose of Q
c       m -- first dimension of a and length of v
c       n -- second dimension of a
c       a -- data describing the qr decomposition of a matrix,
c            as produced by iddp_qrpiv or iddr_qrpiv
c       krank -- numerical rank
c       v -- vector to which Q (or its transpose) is to be applied
c
c       output:
c       v -- vector to which Q (or its transpose) has been applied
c
        implicit none
        save
        integer m,n,krank,k,ifrescal,mm,iftranspose
        real*8 a(m,n),v(m),scal
c
c
        ifrescal = 1
c
c
        if(iftranspose .eq. 0) then
c
          do k = krank,1,-1
            mm = m-k+1
            if(k .lt. m)
     1       call idd_houseapp(mm,a(k+1,k),v(k),ifrescal,scal,v(k))
          enddo ! k
c
        endif
c
c
        if(iftranspose .eq. 1) then
c
          do k = 1,krank
            mm = m-k+1
            if(k .lt. m)
     1       call idd_houseapp(mm,a(k+1,k),v(k),ifrescal,scal,v(k))
          enddo ! k
c
        endif
c
c
        return
        end
c
c
c
c


module mod_constants

 !===================================================================================85
 !---------------------------- DESCRIPTION ------------------------------------------85
 !
 !
 !
 !          Module  name:
 !                         'mod_constants'
 !
 !          Purpose:
 !                    Collection of various library constants
 !
 !
 !          History:
 !                        Date: 11-08-2017
 !                        Time: 09:48 GMT+2
 !
 !          Version:
 !
 !                      Major: 1
 !                      Minor: 0
 !                      Micro: 0
 !
 !          Author:  Bernard Gingold
 !
 !
 !
 !
 !
 !          E-mail:
 !
 !                      beniekg@gmail.com
 !==================================================================================85

 ! Tab:5 col - Type and etc.. definitions
 ! Tab:10,11 col - Type , function and subroutine code blocks.
    implicit none
    use module_kinds

    !=====================================================59
    !  File and module information:
    !  version,creation and build date, author,description
    !=====================================================59

    ! Major version
    integer(I32P), parameter, public :: MOD_CONSTANTS_MAJOR = 1

    ! Minor version
    integer(I32P), parameter, public :: MOD_CONSTANTS_MINOR = 0

    ! Micro version
    integer(I32P), parameter, public :: MOD_CONSTANTS_MICRO = 0

    ! Module/file full version
    integer(I32P), parameter, public :: MOD_CONSTANTS_FULLVER = 1000*MOD_CONSTANTS_MAJOR+100*MOD_CONSTANTS_MINOR + &
                                                                10*MOD_CONSTANTS_MICRO

    ! Module creation date
    character(*),  parameter, public :: MOD_CONSTANTS_CREATION_DATE = "11-08-2017 11:21 +00200 (FRI 11 AUG 2017 GMT+2)"

    ! Module build date (should be set after every succesfful build)
    character(*),  parameter, public :: MOD_CONSTANTS_BUILD_DATE = " "

    ! Module author info
    character(*),  parameter, public :: MOD_CONSTANTS_AUTHOR = "Programmer: Bernard Gingold e-mail: beniekg@gmail.com"

    ! Module short description
    character(*),  parameter, public :: MOD_CONSTANTS_DESCRIPT = " Collection of various math and phys constants."

    !======================================================60
    !         Definition of various constants
    !   @Remark:
    !            Encoding is: LAM_constant_name
    !======================================================60

    ! Signals minimal number of samples
    integer(I32P), parameter, public :: LAM_MINSAMP    = 32

    ! Signal minimum frequency
    real(R64P),    parameter, public :: LAM_MINFREQ    = 1.0e+7_R64P

    ! One nano-second
    real(R64P),    parameter, public :: LAM_NS         = 0.000000001_R64P

    ! Ohm resistenace for propagating wave
    real(R64P),    parameter, public :: LAM_WRES       = 377.0_R64P

    ! Signal smallest time-step i.e. 1/2^-16
    real(R64P),    parameter, public :: LAM_SMALLTS    = 0.0000152587890625_R64P

    ! Speed of light
    real(R64P),    parameter, public :: LAM_c          = 299792458._R64P

    ! Gravitational constant
    real(R64P),    parameter, public :: LAM_g          = 9.81.R64P

    ! Gas constant dry air i.e 287.04 m^2*s^-2*K^-1
    real(R64P),    parameter, public :: LAM_R          = 287.04_R64P

    ! Surface refractivity
    real(R64P),    parameter, public :: LAM_N          = 313._R64P

    ! Refractivity constant C'd  i.e. 77.6 K mbar^-1
    real(R64P),    parameter, public :: LAM_Cd         = 77.6_R64P

    ! Refractivity constant C'w1 i.e. 71.6 K mbar^-1
    real(R64P),    parameter, public :: LAM_Cw1 = 71.6_R64P

    ! Refractivity constant C'w2 i.e. 3.7x10^5 K^2 mbar^-1
    real(R64P),    parameter, public :: LAM_Cw2 = 370000._R64P

    ! Number of molecule per unit volume Nv0 i.e. 2.6873x10^25 m^-3
    real(R64P),    parameter, public :: LAM_Nv0 = 26873000000000000000000000._R64P

    ! Inverse SRTQ of 2 i.e 1/SQRT(2)
    real(R64P),    parameter, public :: LAM_ISQRT2 = 0.7071067811865475488016887242097_R64P

    ! Null-valued complex constant
    complex(R64P), parameter, public :: LAM_ZC = DCMPLX(0._R64P,0._R64P)

    ! SQRT(2)
    real(R64P),    parameter, public :: LAM_SQRT2 =  1.414213562373095_R64P

    ! Earth mean radius i.e. 6371.0 km
    real(R64P),    parameter, public :: LAM_EMR = 6371._R64P

    ! Value of PI
    real(R64P),    parameter, public :: LAM_PI =  3.1415926535897932384626433832795_R64P

    ! Value of 2PI
    real(R64P),    parameter, public :: LAM_2PI =  6.283185307179586476925286766559_R64P

    ! Value of 4PI
    real(R64P),    parameter, public :: LAM_4PI =  12.566370614359172953850573533118_R64P

    ! Value of 8PI
    real(R64P),    parameter, public :: LAM_8PI =  25.132741228718345907701147066236_R64P

    ! Value of half PI
    real(R64P),    parameter, public :: LAM_HPI = 1.5707963267948966192313216916398_R64P

    ! Value of quarter PI
    real(R64P),    parameter, public :: LAM_QPI =  0.78539816339744830961566084581988_R64P

    ! Value of PI**2
    real(R64P),    parameter, public :: LAM_PIE2 =  9.8696044010893586188344909998762_R64P

    ! Value of PI**3
    real(R64P),    parameter, public :: LAM_PIE3 =  31.006276680299820175476315067101_R64P

    ! Value of PI**4
    real(R64P),    parameter, public :: LAM_PIE4 =  97.409091034002437236440332688705_R64P

    ! Value of PI**5
    real(R64P),    parameter, public :: LAM_PIE5 =  306.01968478528145326274131004344_R64P

    ! Value of SQRT(PI)
    real(R64P),    parameter, public :: LAM_SQRTPI =  1.7724538509055160272981674833411_R64P

    ! Value of SQRT(2PI)
    real(R64P),    parameter, public :: LAM_SQRT2PI =  2.506628274631000502415765284811_R64P

    ! Value of SQRT(4PI)
    real(R64P),    parameter, public :: LAM_SQRT4PI =  3.5449077018110320545963349666823_R64P

    ! Value of 1/SQRT(2PI)
    real(R64P),    parameter, public :: LAM_ISQRT2PI =  0.39894228040143267793994605993439_R64P

    ! Value of 1/SQRT(4PI)
    real(R64P),    parameter, public :: LAM_ISQRT4PI =  0.07957747154594766788444188168626_R64P

    ! Value of Ln(2)
    real(R64P),    parameter, public :: LAM_Ln2     =   0.69314718055994530941723212145818_R64P

    ! Value of Ln(4)
    real(R64P),    parameter, public :: LAM_Ln4     =   1.3862943611198906188344642429164_R64P

    ! Shift by 1000
    real(R64P),    parameter, public  :: LAM_SHIFT1000 = 1000.0_R64P

    ! Very small constant
    real(R64P), parameter,    public :: LAM_SMALL =   0.0000000000000001_R64P

    ! Smallest repreesentable number
    real(R64P), parameter,    public :: LAM_SMALLEST = TINY(LAM_SMALL)

    ! Prevent potential sliding towards denormal numbers
    real(R64P), parameter,    public :: LAM_TINY = LAM_SHIFT1000 * LAM_SMALLEST

    ! Define smallest allowed numeric value of Pressure Field
    real(R64P), parameter,    public :: LAM_TINYPRESS = LAM_TINY

    ! Very large constant
    real(R64P), parameter,    public :: LAM_LARGE = 1.0E+35_R64P

    real(R64P), parameter,    public :: LAM_LARGEST = HUGE(LAM_LARGE)

    ! Minimum number of Sawtooth approximation series waveform (sinusoids)
    integer(I32P), parameter, public :: LAM_MINK = 24

    ! Initialize by zero constant.
    real(R64P), parameter,    public :: LAM_ZINIT = 0._R64P

    real(R64P), parameter,    public :: LAM_ZR8 = 0._R64P

    ! Integral 1 (64-bit)
    integer(I64P), parameter, public :: LAM_IONE8 = 1_I64P

    ! Integral 0 (64-bit)
    integer(I64P), parameter, public :: LAM_IZER8 = 0_I64P

    ! Integral 0 (32-bit)
    integer(I32P), parameter, public :: LAM_IZER4 = 0_I32P

    ! Machine epsilon (64-bit)
    real(R64P),    parameter, public :: LAM_MEPS8 =  0.00000000000000022204460492503131_R64P
    ! Standard tolerance (for statistical calculations)
    real(R64P),    parameter, public :: LAM_STATOL  = 0.0000000000001_R64P

    real(R64P),    parameter, public :: LAM_ONER8 = 1.0_R64P

    real(R64P),    parameter, public :: LAM_QR64P = 0.25_R64P

    real(R64P),    parameter, public :: LAM_HR64P = 0.5_R64P

    real(R64P),    parameter, public :: LAM_PINF   = IEEE_VALUE(1._R64P,IEEE_POSITIVE_INF)

    ! Coefficeints for Gibson function of ice Ih

    ! Coeff G00 i.e. 632020.233335886_R64P J kg^-1 (real part)
    real(R64P),    parameter, public :: LAM_G00  =  -632020.233335886_R64P

    ! Coeff G01  i.e. 0.655022213658955_R64P J kg^-1  (real part)
    real(R64P),    parameter, public :: LAM_G01  =  0.655022213658955_R64P

    ! Coeff G02  i.e. -0.0000000189369929326131 J kg^-1  (real part)
    real(R64P),    parameter, public :: LAM_G02  = -0.0000000189369929326131_R64P

    ! Coeff G03  i.e  0.00000000000000339746123271053 J kg^-1
    real(R64P),    parameter, public :: LAM_G03  =  0.00000000000000339746123271053_R64P

    ! Coeff G04  i.e -5.56464869058991e-22 J kg^-1
    real(R64P),    parameter, public :: LAM_G04  =  -5.56464869058991e-22_R64P

    ! Coeff Sn0 (absolute)
    real(R64P),    parameter, public :: LAM_Sn0  =   189.13_R64P

end module mod_constants


true;
if false then true else false;

(\x:Bool->Bool.x false) (\x:Bool.x) ;
(\x:Bool.x) true;
iszero (pred (succ 2));

let projx = (\r:{x:Nat,y:Nat,z:Nat}.r.x) in projx {x=2,y=4,z=1} ;
(\x:String.x) "hoge";

case <some=1> as <some:Nat,none:Unit> of <some=a> => succ a | <none=y> => 0;
let g = (\x:Nat.succ x) in g 1;
let f = (\x : <some:Nat,none:Unit>. case x of <some=a> => succ a | <none=y> => 0) in
f (<some=1> as <some:Nat,none:Unit>) ;

X = Nat;
(\x:X.succ x) 1;
Y = X -> X;
s = (\x:X.succ x);
double = \f:Y.\x:X.f(f x);
double s 1;

ff = \ie:Nat->Bool.
        \x:Nat.
        if iszero x then true
        else if iszero (pred x) then false
        else ie (pred (pred x));

iseven = fix ff;

iseven 7;

a = ref 0;
incr = ( \a:(Ref Nat). a := succ( !a ) );

!a ;
incr a ;
!a ;


C
C $Id: tsfndp.f,v 1.5 2008-07-27 00:17:12 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      DOUBLE PRECISION FUNCTION TSFNDP (ECCENT,PHI,SINPHI)
C
C FUNCTION TO COMPUTE CONSTANT (SMALL T).
C
      IMPLICIT DOUBLE PRECISION (A-Z)
      DATA HALF,ONE /0.5D0,1.0D0/
      DATA HALFPI /1.5707963267948966D0/
C
      CON = ECCENT * SINPHI
      COM = HALF * ECCENT
      CON = ((ONE - CON) / (ONE + CON)) ** COM
      TSFNDP = TAN (HALF * (HALFPI - PHI)) / CON
C
      RETURN
      END


      subroutine qlbox16(Y,musq,Ires)
      implicit none

C I_4^(4-2\e)(m_2^2,\pd^2,\pt^2,m_4^2;s_{12},s_{23};0,m_2^2,m_3^2,m_4^2)

c  [                              m3sq-s12                    ]
c  [0       ,      0         ,    --------    ,        0      ]
c  [                                 2                        ]
c  [                                                          ]
c  [                          -p2sq+m3sq+m2sq   -s23+m4sq+m2sq]
c  [0       ,        m2sq    ,----------------, --------------]
c  [                                 2               2        ]
c  [                                                          ]
c  [m3sq-s12  -p2sq+m3sq+m2sq                  -p3sq+m4sq+m3sq]
c  [--------, ---------------,     m3sq       ,---------------]
c  [   2                2                              2      ]
c  [                                                          ]
c  [          -s23+m4sq+m2sq   -p3sq+m4sq+m3sq                ]
c  [0       , -------------- , ---------------,      m4sq     ]
c  [                  2                    2                  ]
c  [                                                          ]

C----Implementation of Bennakker-Denner Eq.2.9
C----\bibitem{Beenakker:1988jr}
C----W.~Beenakker and A.~Denner,
C----%``INFRARED DIVERGENT SCALAR BOX INTEGRALS WITH APPLICATIONS IN THE
C----%ELECTROWEAK STANDARD MODEL,''
C----Nucl.\ Phys.\  B {\bf 338}, 349 (1990).

      include 'qlconstants.f'
      integer iep
      logical qlzero
      double precision Y(4,4),m2sq,m3sq,m4sq,musq,m2,m3,m4,
     . si,tabar,ieps,iep2,iep3,mp2sq,mp3sq,mean,rexs,imxs
      double complex fac,cxs(3),cx2(3),cx3(3),
     . xs,Ires(-2:0),qllnrat,xlog,cln,qlcLi2omx2,qlcLi2omx3

      m2sq=Y(2,2)
      m3sq=Y(3,3)
      m4sq=Y(4,4)
C-----Assign s and t so as to agree with notation of BD
      tabar=2d0*Y(1,3)
      si=2d0*Y(2,4)-Y(2,2)-Y(4,4)
      mp2sq=2d0*Y(2,3)-m3sq-m2sq
      mp3sq=2d0*Y(3,4)-m3sq-m4sq
      m2=sqrt(m2sq)
      m3=sqrt(m3sq)
      m4=sqrt(m4sq)
      mean=sqrt(m3sq*musq)

C     iepsi gives the sign of the imaginary part of K
      call qlkfn(cxs,ieps,-si,m2,m4)
      call qlkfn(cx2,iep2,-mp2sq,m2,m3)
      call qlkfn(cx3,iep3,-mp3sq,m3,m4)

      xs=cxs(1)
      rexs=dreal(xs)
      imxs=dimag(xs)
      if ((qlzero(rexs-1d0)) .and. (qlzero(imxs))) then
      fac=dcmplx(-half/(m2*m4*tabar))
      Ires(-2)=czip
      Ires(-1)=cone

      Ires(0)=2d0*qllnrat(mean,tabar)-dcmplx(2d0)
C     special case x2=x3=1
      if ( qlzero(dreal(cx2(1)-cx3(1))) .and.
     .     qlzero(dimag(cx2(1)-cx3(1))) .and.
     .     qlzero(dreal(cx2(1))-1d0) .and.
     .     qlzero(dimag(cx2(1)))) then
      Ires(0) = Ires(0) + dcmplx(4d0)
C     special case x2=x3 /= 1
      elseif (qlzero(dreal(cx2(1)-cx3(1))) .and.
     .     qlzero(dimag(cx2(1)-cx3(1)))) then
      Ires(0) = Ires(0) + ctwo
     .+2d0*(cx2(1)**2+cone)*cln(cx2(1),iep2)/(cx2(1)**2-cone)
      else
      Ires(0)=Ires(0)
     . -(cone+cx2(1)*cx3(1))/(cone-cx2(1)*cx3(1))
     . *(cln(cx2(1),iep2)+cln(cx3(1),iep3))
     . -(cone+cx2(1)/cx3(1))/(cone-cx2(1)/cx3(1))
     . *(cln(cx2(1),iep2)-cln(cx3(1),iep3))
      endif

      else
      fac=dcmplx(-1d0/(m2*m4*tabar))*cxs(1)/(cone-cxs(1)**2)
      xlog=cln(xs,ieps)
      Ires(-2)=czip
      Ires(-1)=-xlog
      Ires(0)=-2d0*xlog*qllnrat(mean,tabar)
     . +cln(cx2(1),iep2)**2 +cln(cx3(1),iep3)**2
     . -qlcLi2omx2(xs,xs,ieps,ieps)
     . +qlcLi2omx3(cxs(1),cx2(1),cx3(1),ieps,iep2,iep3)
     . +qlcLi2omx3(cxs(1),cone/cx2(1),cone/cx3(1),ieps,-iep2,-iep3)
     . +qlcLi2omx3(cxs(1),cx2(1),cone/cx3(1),ieps,iep2,-iep3)
     . +qlcLi2omx3(cxs(1),cone/cx2(1),cx3(1),ieps,-iep2,iep3)
      endif

      do iep=-2,0
      Ires(iep)=Ires(iep)*fac
      enddo
      return
      end


      SUBROUTINE MB03AD( SHFT, K, N, AMAP, S, SINV, A, LDA1, LDA2, C1,
     $                   S1, C2, S2 )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute two Givens rotations (C1,S1) and (C2,S2)
C     such that the orthogonal matrix
C
C                [  C1  S1  0 ]   [ 1  0   0  ]
C           Q =  [ -S1  C1  0 ] * [ 0  C2  S2 ]
C                [  0   0   1 ]   [ 0 -S2  C2 ]
C
C     makes the first column of the real Wilkinson single/double shift
C     polynomial of the general product of matrices, stored in the
C     array A, parallel to the first unit vector.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     SHFT    CHARACTER*1
C             Specifies the number of shifts employed by the shift
C             polynomial, as follows:
C             = 'D':  two real shifts;
C             = 'S':  one real shift.
C
C     Input/Output Parameters
C
C     K       (input)  INTEGER
C             The number of factors.  K >= 1.
C
C     N       (input)  INTEGER
C             The order of the factors in the array A.  N >= 3.
C
C     AMAP    (input) INTEGER array, dimension (K)
C             The map for accessing the factors, i.e., if AMAP(I) = J,
C             then the factor A_I is stored at the J-th position in A.
C
C     S       (input)  INTEGER array, dimension (K)
C             The signature array. Each entry of S must be 1 or -1.
C
C     SINV    (input) INTEGER
C             Signature multiplier. Entries of S are virtually
C             multiplied by SINV.
C
C     A       (input)  DOUBLE PRECISION array, dimension (LDA1,LDA2,K)
C             On entry, the leading N-by-N-by-K part of this array must
C             contain a n-by-n product (implicitly represented by its K
C             factors) in upper Hessenberg form.
C
C     LDA1    INTEGER
C             The first leading dimension of the array A.  LDA1 >= N.
C
C     LDA2    INTEGER
C             The second leading dimension of the array A.  LDA2 >= N.
C
C     C1      (output)  DOUBLE PRECISION
C     S1      (output)  DOUBLE PRECISION
C             On exit, C1 and S1 contain the parameters for the first
C             Givens rotation.
C
C     C2      (output)  DOUBLE PRECISION
C     S2      (output)  DOUBLE PRECISION
C             On exit, if SHFT = 'D', C2 and S2 contain the parameters
C             for the second Givens rotation.
C
C     METHOD
C
C     Two Givens rotations are properly computed and applied.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Berlin, Germany, June 2001.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     July 2009, SLICOT Library version of the routine PLASHF.
C
C     KEYWORDS
C
C     Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal
C     transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TWO
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         SHFT
      INTEGER           K, LDA1, LDA2, N, SINV
      DOUBLE PRECISION  C1, S1, C2, S2
C     .. Array Arguments ..
      INTEGER           AMAP(*), S(*)
      DOUBLE PRECISION  A(LDA1,LDA2,*)
C     .. Local Scalars ..
      LOGICAL           SGLE
      INTEGER           AI, I
      DOUBLE PRECISION  ALPHA, BETA, C3, DELTA, GAMMA, S3, TEMP
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DLARTG
C     .. Intrinsic Functions ..
      INTRINSIC         SQRT
C
C     .. Executable Statements ..
C
      SGLE = LSAME( SHFT, 'S' )
      C1 = ONE
      S1 = ZERO
      C2 = 1/SQRT( TWO )
      S2 = C2
C
      DO 10  I = K, 2, -1
         AI = AMAP(I)
         IF ( S(AI).EQ.SINV ) THEN
            ALPHA = C2 * A(1,1,AI)
            GAMMA = S2 * A(N,N,AI)
            BETA  = S2 * A(N-1,N,AI)
            BETA  = C1 * BETA + S1 * A(N-1,N-1,AI)
            CALL DLARTG( ALPHA, GAMMA, C2, S2, TEMP )
            TEMP = C1 * TEMP
            CALL DLARTG( TEMP, BETA, C1, S1, ALPHA )
         ELSE
            TEMP  = A(1,1,AI)
            BETA  = S2 * TEMP
            TEMP  = C2 * TEMP
            ALPHA = S1 * TEMP
            GAMMA = A(N,N,AI)
            DELTA = C2 * GAMMA
            GAMMA = S2 * GAMMA
            CALL DLARTG( DELTA, BETA, C2, S2, C3 )
            DELTA = C1 * A(N-1,N,AI) - S1 * GAMMA
            ALPHA = C2 * ALPHA - S2 * DELTA
            GAMMA = C1 * A(N-1,N-1,AI)
            CALL DLARTG( GAMMA, ALPHA, C1, S1, TEMP )
         END IF
   10 CONTINUE
C
      AI = AMAP(1)
      ALPHA = A(1,1,AI) * C2 - A(N,N,AI) * S2
      BETA  = C1 * ( C2 * A(2,1,AI) )
      GAMMA = C1 * ( S2 * A(N-1,N,AI) ) + S1 * A(N-1,N-1,AI)
      ALPHA = ALPHA * C1 - A(N,N-1,AI) * S1
      CALL DLARTG( ALPHA, BETA, C1, S1, TEMP )
C
C     This is sufficient for single real shifts.
C
      IF ( .NOT.SGLE ) THEN
C
         CALL DLARTG( TEMP, GAMMA, C2, S2, ALPHA )
C
C        Rotation 1 is preserved.
C
         ALPHA = C2
         GAMMA = ( A(N-1,N-1,AI) * C1 ) * C2 + A(N,N-1,AI) * S2
         DELTA = ( A(N-1,N-1,AI) * S1 ) * C2
         CALL DLARTG( GAMMA, DELTA, C3, S3, TEMP )
         CALL DLARTG( ALPHA, TEMP, C2, S2, ALPHA )
C
C        Rotation 3 is preserved throughout the following complete loop.
C
         DO 20  I = K, 2, -1
            AI = AMAP(I)
            IF ( S(AI).EQ.SINV ) THEN
               ALPHA = ( A(1,1,AI) * C1 + A(1,2,AI) * S1 ) * C2
               BETA  = ( A(2,2,AI) * S1 ) * C2
               GAMMA = A(N-1,N-1,AI) * S2
               CALL DLARTG( ALPHA, BETA, C1, S1, TEMP )
               CALL DLARTG( TEMP, GAMMA, C2, S2, ALPHA )
            ELSE
               ALPHA =  C1 * A(1,1,AI)
               GAMMA =  S1 * A(1,1,AI)
               BETA  =  C1 * A(1,2,AI) + S1 * A(2,2,AI)
               DELTA = -S1 * A(1,2,AI) + C1 * A(2,2,AI)
               CALL DLARTG( DELTA, GAMMA, C1, S1, TEMP )
               ALPHA = -ALPHA * S2
               BETA  = -BETA  * S2
               ALPHA = C1 * ALPHA + S1 * BETA
               BETA  = C2 * A(N-1,N-1,AI)
               CALL DLARTG( BETA, ALPHA, C2, S2, TEMP )
               S2 = -S2
            END IF
   20    CONTINUE
C
C        Last step: Let the rotations collap into A.
C
         AI = AMAP(1)
         ALPHA = C1 * A(1,1,AI) + S1 * A(1,2,AI)
         BETA  = C1 * A(2,1,AI) + S1 * A(2,2,AI)
         GAMMA = S1 * A(3,2,AI)
         ALPHA = C2 * ALPHA - S2 * C3
         BETA  = C2 * BETA  - S2 * S3
         GAMMA = C2 * GAMMA
         CALL DLARTG( BETA, GAMMA, C2, S2, TEMP )
         CALL DLARTG( ALPHA, TEMP, C1, S1, BETA )
      END IF
      RETURN
C *** Last line of MB03AD ***
      END


Real Function oobbar(srt)
  Parameter (pimass=0.140, arho=0.77, aomega=0.782)
  Common /ppb1/ene, factr2(6), fsum, ppinnb, s, wtot
  Common /ppmm/pprr, ppee, pppe, rpre, xopoe, rree
  Save
  sppb6p = xppbar(srt)*factr2(6)*ene**4/fsum
  pi2 = (s-4*aomega**2)/4
  oobbar = 4./9.*sppb6p/pi2*wtot
  Return
End Function oobbar


module master_function_mod

  use real_type_mod
  use variables_mod
  use parameters_mod

  implicit none

contains

  subroutine MasterFunction_Derivs(n_sqd, dLdn)

    real(kind=wp), dimension(NFF), intent(in) :: n_sqd
    real(kind=wp), dimension(NFF), intent(out) :: dLdn

    real(kind=wp), dimension(NF) :: n
    real(kind=wp) :: nxy, delta

!!$    Again, this should be generalized
    n = sqrt(n_sqd(1:NF))
!!$    Note that nxy = n_{12}^2 in the code, but we want n_{12}
    nxy = sqrt(n_sqd(NFF))

    delta = sqrt(1.0_wp - (n(1) * n(2) / nxy)**2)

    if (master_function_i .eq. M_FN_GENERIC_PAPER) then

      dLdn(1) = -(1.d0 / nxy**2 / n(1) * &
           (eos_m(1) * nxy**2 + &
            eos_kappa(1) * n(1)**(eos_gamma(1) - 1.d0) * eos_gamma(1) * nxy**2 + &
            eos_kappa_np * n(1)**(eos_sigma(1) - 1.d0) * eos_sigma(1) * n(2)**eos_sigma(2) * nxy**2 - &
            2.d0 * eos_kappa_delta * n(1) * n(2)**2)) / 2.d0

      dLdn(2) = -(1.d0 / nxy**2 / n(2) * &
           (eos_m(2) * nxy**2 + &
            eos_kappa(2) * n(2)**(eos_gamma(2) - 1.d0) * eos_gamma(2) * nxy**2 + &
            eos_kappa_np * n(1)**eos_sigma(1) * n(2)**(eos_sigma(2) - 1.d0) * eos_sigma(2) * nxy**2 - &
            2.d0 * eos_kappa_delta * n(1)**2 * n(2))) / 2.d0

      dLdn(3) = -eos_kappa_delta * n(1)**2 * n(2)**2 / nxy**4

    else

      write(*,*) 'Have not coded this master function case!'
      stop

    end if

  end subroutine MasterFunction_Derivs

  subroutine MasterFunction_SecondDerivs(n_sqd, d2Ldn2, d2Ldn2_2)

    real(kind=wp), dimension(NFF), intent(in) :: n_sqd
    real(kind=wp), intent(out) :: d2Ldn2
    real(kind=wp), dimension(NF), intent(out) :: d2Ldn2_2

    real(kind=wp), dimension(NF) :: n
    real(kind=wp) :: nxy, delta

    integer :: f

!!$    Again, this should be generalized
    n = sqrt(n_sqd(1:NF))
    nxy = sqrt(n_sqd(NFF))

    delta = sqrt(1.0_wp - (n(1) * n(2) / nxy)**2)

!!$    This is the mixed derivative of Lambda wrt n1n2,
!!$    also called dB^x / dn_y^2 in the relativistic two stream paper

    if (master_function_i .eq. M_FN_GENERIC_PAPER) then

      d2Ldn2 = -(1.d0 / nxy**2 / n(1) / n(2) * &
           (eos_kappa_np * n(1)**(eos_sigma(1) - 1.d0) * &
            eos_sigma(1) * n(2)**(eos_sigma(2) - 1.d0) * eos_sigma(2) * nxy**2 - &
            4.d0 * eos_kappa_delta * n(1) * n(2))) / 4.d0

      d2Ldn2_2(1) = -eos_kappa_delta * n(2)**2 / nxy**4
      d2Ldn2_2(2) = -eos_kappa_delta * n(1)**2 / nxy**4

    else

      write(*,*) 'Have not coded this master function case! (Second derivs)'
      stop

    end if

  end subroutine MasterFunction_SecondDerivs

  subroutine force_terms(q, n_up, mu_down, force)

    real(kind=wp), dimension(NEVOLVE), intent(in) :: q
    real(kind=wp), dimension(NF, NV), intent(in) :: n_up, mu_down
    real(kind=wp), dimension(NEVOLVE), intent(out) :: force

    force = 0.0_wp

  end subroutine force_terms

end module master_function_mod


      SUBROUTINE OSCUL(KODE,T,XMU,Y,OE)
C****FOR COMPUTING POSITION AND VELOCITY FROM OSCULATING ELEMENTS
C****(KODE=1),AND VICE VERSA (KODE=2).
C  T = TIME IN UNITS CORRESPONDING TO XMU
C   XMU = GM
C   Y = X,XDOT,Y,YDOT,Z,ZDOT
C   OE(1) = SEMI-MAJOR AXIS
C   OE(2) = ECCENTRICITY
C   OE(3) = MEAN ANOMALY AT EPOCH
C   OE(4) = SIN(INCL)
C   OE(5) = COS(INCL)
C   OE(6) = SIN(PERIGEE)
C   OE(7) = COS(PERIGEE)
C   OE(8) = SIN(NODE)
C   OE(9) = COS(NODE)
C  OE(10)= EPOCH OF ELEMENTS (IF KODE=2 ,OE(10)=T)
C  OE(11)=SIN(E)
C  OE(12)=COS(E)
      DOUBLE PRECISION X(6),Y(6),OE(12),T,XMU,PI,XN,XM,SE,CE,R,SF,CF
     1 ,SU,CU,RD,XK,C,V,G,H,ARCTAN
      DATA PI /3.141592653589793D0/
      GO TO(5,50),KODE
C****POS. AND VEL. FROM ELEMENTS
    5 XN=DSQRT(XMU/OE(1)**3)
      XM=OE(3)+XN*(T-OE(10))
      CALL KEPLER(XM,OE(2),SE,CE)
      OE(11)=SE
      OE(12)=CE
      R=OE(1)*(1.D0-OE(2)*CE)
      SF=OE(1)/R*DSQRT(1.D0-OE(2)**2)*SE
      CF=OE(1)/R*(CE-OE(2))
      SU=OE(6)*CF+OE(7)*SF
      CU=OE(7)*CF-OE(6)*SF
      G=DSQRT(XMU*OE(1)*(1.D0-OE(2)**2))
      H=G*OE(5)
      RD=XMU*OE(2)*SF/G
      XK=G*OE(4)*CU
      X(1)=R*(CU*OE(9)-SU*OE(8)*OE(5))
      X(2)=R*(CU*OE(8)+SU*OE(9)*OE(5))
      X(3)=R*SU*OE(4)
      X(6)=(X(3)*RD+XK)/R
      C=(R-X(3))*(R+X(3))
      XK=XK/C
      H=H/C
      X(4)=(X(1)*RD-XK*X(1)*X(3)-H*X(2)*R)/R
      X(5)=(X(2)*RD-XK*X(2)*X(3)+H*X(1)*R)/R
      DO 10 I=1,3
      Y(I+I-1)=X(I)
   10 Y(I+I)=X(I+3)
      RETURN
C****ELEMENTS FROM POS. AND VEL.
   50 CONTINUE
      DO 55 I=1,3
      X(I)=Y(I+I-1)
   55 X(I+3)=Y(I+I)
      R=DSQRT(X(1)**2+X(2)**2+X(3)**2)
      RD=(X(1)*X(4)+X(2)*X(5)+X(3)*X(6))/R
      V=DSQRT(X(4)*X(4)+X(5)*X(5)+X(6)*X(6))
      OE(1)=1.D0/(2.D0/R-V*V/XMU)
      SE=R*RD/DSQRT(XMU*OE(1))
      CE=1.D0-R/OE(1)
      OE(2)=DSQRT(SE*SE+CE*CE)
      OE(3)=ARCTAN(SE,CE)-SE
      OE(10)=T
      G=DSQRT(XMU*OE(1)*(1.D0-OE(2)**2))
      OE(11)=0.D0
      OE(12)=1.D0
      SF=0.D0
      CF=1.D0
      IF(OE(2).LT.1.D-15) GO TO 60
      OE(11)=SE/OE(2)
      OE(12)=CE/OE(2)
      SF=RD*G/XMU/OE(2)
      CF=OE(1)/R*(CE/OE(2)-OE(2))
   60 CONTINUE
      OE(5)=(X(1)*X(5)-X(2)*X(4))/G
      OE(4)=1.D0-OE(5)**2
      IF(OE(4).LT.0.D0)OE(4)=0.D0
      OE(4)=DSQRT(OE(4))
      SU=SF
      CU=CF
      OE(8)=(X(2)*CU-X(1)*SU)/R
      OE(9)=(X(1)*CU+X(2)*SU)/R
      IF(OE(4).LT.1.D-15) GO TO 70
      SU=X(3)/OE(4)/R
      CU=(R*X(6)-RD*X(3))/OE(4)/G
      C=R*(1.D0-(SU*OE(4))**2)
      OE(8)=(X(2)*CU-X(1)*SU*OE(5))/C
      OE(9)=(X(1)*CU+X(2)*SU*OE(5))/C
   70 CONTINUE
      OE(6)=SU*CF-CU*SF
      OE(7)=CU*CF+SU*SF
      RETURN
      END


      subroutine nut_pminrl2

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine computes p flux between the labile, active mineral
!!    and stable mineral p pools.
!!    this is the alternate phosphorus model described in Vadas and White (2010)
!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Min
!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use basin_module
      use organic_mineral_mass_module
      use hru_module, only : ihru
      use output_landscape_module, only : hnb_d
      use soil_module
      use time_module

      implicit none

      integer :: j                      !none          |HRU number
      integer :: l                      !none          |counter
      real :: rto                       !              |
      real :: rmp1                      !kg P/ha       |amount of phosphorus moving from the solution
                                        !              |mineral to the active mineral pool in the soil layer
      real :: roc                       !kg P/ha       |amount of phosphorus moving from the active
                                        !              |mineral to the stable mineral pool in the soil layer
      real :: wetness                   !              |
      real :: base                      !              |
      real :: vara                      !		       |Intermediate Variable
      real :: varb                      !    	       |Intermediate Variable
      real :: varc                      !    	       |Intermediate Variable
      real :: as_p_coeff                !              |
      real :: solp                      !mg/kg	       |Solution pool phosphorous content
      real :: actpp                     !mg/kg	       |Active pool phosphorous content
      real :: stap                      !mg/kg	       |Stable pool phosphorous content
      real :: arate                     !			   |Intermediate Variable
      real :: ssp                       !              |

      j = ihru

      hnb_d(j)%lab_min_p = 0.
      hnb_d(j)%act_sta_p = 0.
      do l = 1, soil(j)%nly !! loop through soil layers in this HRU
	!! make sure that no zero or negative pool values come in
	if (soil1(j)%mp(l)%lab <= 1.e-6) soil1(j)%mp(l)%lab = 1.e-6
	if (soil1(j)%mp(l)%act <= 1.e-6) soil1(j)%mp(l)%act = 1.e-6
      if (soil1(j)%mp(l)%sta <= 1.e-6) soil1(j)%mp(l)%sta = 1.e-6

!! Convert kg/ha to ppm so that it is more meaningful to compare between soil layers
	  solp = soil1(j)%mp(l)%lab / soil(j)%phys(l)%conv_wt * 1000000.
	  actpp = soil1(j)%mp(l)%act / soil(j)%phys(l)%conv_wt * 1000000.
	  stap = soil1(j)%mp(l)%sta / soil(j)%phys(l)%conv_wt * 1000000.

!! ***************Soluble - Active Transformations***************

	  !! Dynamic PSP Ratio
	    !!PSP = -0.045*log (% clay) + 0.001*(Solution P, mg kg-1) - 0.035*(% Organic C) + 0.43
	    if (soil(j)%phys(l)%clay > 0.) then
	      bsn_prm%psp = -0.045 * log(soil(j)%phys(l)%clay)+ (0.001 * solp)
	      bsn_prm%psp = bsn_prm%psp - (0.035  * soil1(j)%tot(l)%c) + 0.43
	    else
	      bsn_prm%psp = 0.4
	    end if
		!! Limit PSP range
		if (bsn_prm%psp < .1)  bsn_prm%psp = 0.1 ! limits on PSP
	    if (bsn_prm%psp > 0.7)  bsn_prm%psp = 0.7

        !! Calculate smoothed PSP average
	  if (soil(j)%ly(l)%psp_store > 0.) then
	    bsn_prm%psp = (soil(j)%ly(l)%psp_store * 29. + bsn_prm%psp * 1.)/30
	  end if
        !! Store PSP for tomarrows smoothing calculation
	  soil(j)%ly(l)%psp_store = bsn_prm%psp

!!***************Dynamic Active/Soluble Transformation Coeff******************

	  !! on day 1 just set to a value of zero
      if ((time%day == 1) .and. (time%yrs == 1)) then
        soil(j)%ly(l)%a_days = 0 !! days since P Application
        soil(j)%ly(l)%b_days = 0 !! days since P deficit
      end if

      !! Calculate P balance
      rto = bsn_prm%psp / (1. - bsn_prm%psp)
      rmp1 = soil1(j)%mp(l)%lab - soil1(j)%mp(l)%act * rto !! P imbalance

	  !! Move P between the soluble and active pools based on Vadas et al., 2006
		if (rmp1 >= 0.) then !! Net movement from soluble to active
		  rmp1 = Max(rmp1, (-1 * soil1(j)%mp(l)%lab))
		  !! Calculate Dynamic Coefficant
          vara = 0.918 * (exp(-4.603 * bsn_prm%psp))
		  varb = (-0.238 * ALOG(vara)) - 1.126
		  if (soil(j)%ly(l)%a_days >0) then
		    arate = vara * (soil(j)%ly(l)%a_days ** varb)
		  else
		    arate = vara * (1) ** varb
		  end if
		  !! limit rate coeff from 0.05 to .5 helps on day 1 when a_days is zero
		  if (arate > 0.5) arate  = 0.5
		  if (arate < 0.1) arate  = 0.1
		  rmp1 = arate * rmp1
	      soil(j)%ly(l)%a_days = soil(j)%ly(l)%a_days  + 1 !! add a day to the imbalance counter
	      soil(j)%ly(l)%b_days = 0
        end if

		if (rmp1 < 0.) then !! Net movement from Active to Soluble
		  rmp1 = Min(rmp1, soil1(j)%mp(l)%act)
		  !! Calculate Dynamic Coefficant
		  base = (-1.08 * bsn_prm%psp) + 0.79
		  varc = base * (exp (-0.29))
	       !! limit varc from 0.1 to 1
		  if (varc > 1.0) varc  = 1.0
		  if (varc < 0.1) varc  = 0.1
          rmp1 = rmp1 * varc
		  soil(j)%ly(l)%a_days = 0
		  soil(j)%ly(l)%b_days = soil(j)%ly(l)%b_days  + 1 !! add a day to the imbalance counter
        End if

!!*************** Active - Stable Transformations ******************
        !! Estimate active stable transformation rate coeff
	  !! original value was .0006
		!! based on linear regression rate coeff = 0.005 @ 0% CaCo3 0.05 @ 20% CaCo3
		  as_p_coeff = 0.0023 * soil(j)%ly(l)%cal + 0.005
          if (as_p_coeff > 0.05) as_p_coeff = 0.05
         if (as_p_coeff < 0.002) as_p_coeff = 0.002
        !! Estimate active/stable pool ratio
        !! Generated from sharpley 2003
      	ssp = 25.044 * (actpp + (actpp * rto))** (-0.3833)
	  ! limit ssp to range in measured data
	  if (ssp > 10.) ssp = 10.
	  if (ssp < 0.7) ssp = 0.7

	  ! Smooth ssp, no rapid changes
		 if (soil(j)%ly(l)%ssp_store > 0.) then
		    ssp = (ssp + soil(j)%ly(l)%ssp_store * 99.)/100.
		 end if

         roc = ssp * (soil1(j)%mp(l)%act + soil1(j)%mp(l)%act * rto)
		 roc = roc - soil1(j)%mp(l)%sta
		 roc = as_p_coeff * roc
		 !! Store todays ssp for tomarrows calculation
		 soil(j)%ly(l)%ssp_store = ssp

!! **************** Account for Soil Water content, do not allow movement in dry soil************
         wetness = (soil(j)%phys(l)%st/soil(j)%phys(l)%fc) !! range from 0-1 1 = field cap
		 if (wetness >1.)  wetness = 1.
		 if (wetness <0.25)  wetness = 0.25
		 rmp1 = rmp1 * wetness
		 roc  = roc  * wetness

!! If total P is greater than 10,000 mg/kg do not allow transformations at all
	   If ((solp + actpp + stap) < 10000.) then
	      !! Allow P Transformations
		  soil1(j)%mp(l)%sta = soil1(j)%mp(l)%sta + roc
		  if (soil1(j)%mp(l)%sta < 0.) soil1(j)%mp(l)%sta = 0.
		  soil1(j)%mp(l)%act = soil1(j)%mp(l)%act - roc + rmp1
		  if (soil1(j)%mp(l)%act < 0.) soil1(j)%mp(l)%act = 0.
		  soil1(j)%mp(l)%lab = soil1(j)%mp(l)%lab - rmp1
		  if (soil1(j)%mp(l)%lab < 0.) soil1(j)%mp(l)%lab = 0.
	   end if

!! Add water soluble P pool assume 1:5 ratio based on sharpley 2005 et al
	soil(j)%ly(l)%watp = soil1(j)%mp(l)%lab / 5.

    hnb_d(j)%lab_min_p = hnb_d(j)%lab_min_p + rmp1
    hnb_d(j)%act_sta_p = hnb_d(j)%act_sta_p + roc

      end do
      return
      end subroutine nut_pminrl2


! Economic analysis subroutine
! Lubello: gen 2020

subroutine econanalysis(enExpendComplete,       & ! (I) Electrical energy expenditure for each time step
                        enExpendGasComplete,    & ! (I) Gas expenditure at each time step
                        DataEconAn,             & ! (I) Components,life expectancy, capex exp
                        curveNPV,               & ! (O) NPV curve
                        TotActInvest)             ! (O) Total actualized investment

      USE MODparam, ONLY: NdayYear,NhourDay,NhourYear,Nyears,Nstep,MaxComp,Maxloc,MaxGiorni,MaxHours

      implicit real(8) (a-h,o-z), integer(i-n)

      real(8), dimension(MaxHours),             intent(IN   ):: enExpendComplete,enExpendGasComplete
      real(8), dimension( 13,MaxComp,Maxloc), intent(IN   ):: DataEconAn
      real(8), dimension(0:MaxGiorni),          intent(  OUT):: curveNPV
      real(8),                                  intent(  OUT):: TotActInvest

      real(8), dimension(0:MaxGiorni) :: Expend
      real(8), parameter:: rate   = 0.05d0 ! Interest rate

      ! DataEconAn description
      ! First index:  1- ID component, 2- Number of substitutions, 3- Components CAPEX, 4 to 13- Year in which it will be substituted
      ! Second index: Which component of the location
      ! Third index:  Which location

      ! Daily interest rate

      rateupd = (1.d0+rate)**(1.d0/dble(NdayYear)) - 1.d0    ! rateupd = rate / 365.d0

      ! Calculations

      Expend(0)=0.d0
      do iday=1,Nstep
        Expend(iday) = 0.d0
        do ih=1,NhourDay !24 h/day
        Expend(iday) = Expend(iday)+                                &
                       enExpendComplete   ((iday-1)*NhourDay+ih)+   &
                       enExpendGasComplete((iday-1)*NhourDay+ih) !spesa alla fine del giorno
        enddo
      enddo

      TotActInvest = 0.d0 ! Total actualized investment inizialization

      ! Adding CAPEX costs to the daily expenditure

      do jj=1,Maxloc ! Iterating on the locations
        do ii=1,MaxComp !Iterating on the components

          ID = DataEconAn(1,ii,jj) !tipo del componente

          select case (ID)

          case(0)
            ! Matrix zeros, no action required

          case(1,2)
            ! Component "Demand", no action required

          case(3,4,5,6,7,8,9,10,11,12,13,14)
            ! All other components
            Nsost            = nint(DataEconAn(2,ii,jj))
            CompCapex        =      DataEconAn(3,ii,jj)

            do isost=0,Nsost

              if(isost .eq. 0)then
                iday = 0
              else
                iday=DataEconAn(3+isost,ii,jj)*NdayYear
              endif

              if(iday.ge.Nstep) then
                ! Making sure we are not investing on new components the last day of the last year
              else
                ! Adding CAPEX
                Expend(iday) = Expend(iday) - CompCapex                        ! CAPEX added at the beginning of the day
                TotActInvest = TotActInvest + CompCapex/((1.d0+rateupd)**iday) ! Total actualized investment
              endif

            enddo

          case default
            write(*,*) 'Internal error: missing component ID in econanalysis'
            stop 'Internal error!'
          endselect

        enddo
      enddo

      ! Computing the cumulative curve of energy expend considering int rate

      curveNPV(0) = Expend(0)  ! Starting instant

      do iday=1,Nstep
        curveNPV(iday) = curveNPV(iday-1) + Expend(iday)/((1.d0+rateupd)**iday)
      enddo

      return

end subroutine econanalysis