MODULE FlexEFT1D
  use BIO_rhs
  implicit none

  private

  public FlexEFT1D_main

  character(LEN=2), public, parameter :: Stn = 'S1'

  ! Model options:
  integer,          public, parameter :: Model_ID = EFTdiscrete

contains

subroutine FlexEFT1D_main
  implicit none

!  namelist /model_setup/    Stn,hmax,thetaS,dtsec,Model_ID,maxD
!  namelist /input_data/     Input_dir,N_NO3,N_Temp,N_Aks
!  namelist /output_data/    Output_dir

  ! Input files
!  character(LEN=22), parameter :: Input_dir = '~/Working/FlexEFT1D/S1'

  character(LEN=20)  :: Tempfile,PARfile,Aksfile,NO3file

  real(8), parameter :: hmax = 2.5d2, &   ! Total water depth
                       thetaS= 2d0  , &   ! surface stretching parameter
                       dtsec = 3D2  , &   ! time step in seconds
                     d_per_s = 864d2, &   ! how many seconds in one day
                       Yup   = 0d0,   &
                       Ydw   = 0d0

                        !how many seconds of one year
  integer, parameter :: y_per_s = INT(d_per_s*360), &
                        !Number of vertical points of NO3,Temp, and Aks profile
                        N_NO3   = 14,               &
                        N_Temp  = 24,               &
                        N_Aks   = 40,               &
                        nsave   = INT(d_per_s)/INT(dtsec), &! Timesteps to save
                        maxD    = 360,              &  ! Number of days to run
                        maxN    = maxD*INT(d_per_s)/INT(dtsec)  ! Number of time steps

  real(8),parameter  :: cnpar = 6d-1

  real(8) :: Z_r(1:nlev), Z_w(0:nlev), Hz(nlev),  &  ! Grid variables
             obs_NO3(N_NO3  , 2),                 &
             obs_PAR(1      ,13),                 &
             obs_Temp(N_Temp,13),                 &
             obs_Aks(N_Aks  ,13),                 &
             obs_time(12), &                ! observation time indices
             time, I_0(1), Aks(0:nlev),           &
             NO3(nlev,1),                         &
             VTemp(nlev,12), VAks(0:nlev,12)

  integer :: i, it, k, j, time_day

  character(LEN=20)    :: outfile

  character(LEN=1)     :: YN
  ! New calculated state variables
  real(8), allocatable :: NewVars(:,:), ww(:,:)
  real(8)              :: t1, t2, cff

  logical, parameter   :: savefile = .FALSE.

!  call CPU_Time(t1)

  ! Data input files:
  Tempfile = trim(Stn)//'_Temp.dat'
  PARfile  = trim(Stn)//'_par.dat'
  Aksfile  = trim(Stn)//'_Aks.dat'
  NO3file  = trim(Stn)//'_NO3.dat'

  !the fraction of a time step in one day
  dtdays   = dtsec/d_per_s

  ! Select biological model
  call choose_model(Model_ID)

  allocate(NewVars(NVAR,nlev))
 ! Sinking rate
  allocate(ww(0:nlev,NVsinkterms))

  ! Setup grid
  call setup_grid(thetaS, nlev, hmax, Z_r, Z_w, Hz)

  ! Initialize state variables
  call Readcsv(NO3file, N_NO3,  2, obs_NO3)

  ! Interpolate initial NO3:
  call gridinterpol(N_NO3,1,obs_NO3(:,1),obs_NO3(:,2),   &
                    nlev, Z_r, NO3(:,1))

  ! Initialize initial NO3:
  Vars(iNO3,:) = NO3(:,1)

  ! Initialize other variables:
  do k = 1,nlev
     do i = 1,NPHY
        Vars(iPHY(i), k) = 1D-3
     enddo
     Vars(iZOO,k) = 1D-2
     Vars(iDET,k) = 1D-2
  enddo

  ! Initialize output data:
  Varout(:,:) = 1D-3
  do i = 1,NVAR
     do k = 1,nlev
        Varout(i,k)= Vars(i,k)
     enddo
  enddo

  ! Give obs. time indices in seconds:
  do i = 1, 12
     obs_time(i) = (float(i-1)+0.5)*30.*d_per_s
  enddo

  ! Read external PAR data:
  call Readcsv(PARfile, 1,      13,obs_PAR)

  ! Read external Temp data:
  call Readcsv(Tempfile,N_Temp, 13,obs_Temp)

  ! Interpolate external Temp data:
  call gridinterpol(N_Temp,12,obs_Temp(:,1),obs_Temp(:,2:13),   &
                       nlev, Z_r, VTemp(:,:))

  ! Interpolate external Aks data:
  call Readcsv(Aksfile, N_Aks ,   13,obs_Aks)

  ! Interpolate external Aks data:
  call gridinterpol(N_Aks,12,obs_Aks(:,1), obs_Aks(:,2:13),   &
                       nlev+1, Z_w, VAks(:,:))

  ! Create output files:
  if (savefile .eq. .true.) then
     do i = 1, Nout
        outfile = trim(Labelout(i))//'.out'

        ! Create data out file
        open (9+i, file = outfile, status = 'replace')

        if (i .eq. oAks) then
           write(9+i, 3) 'Timestep','Days',Z_w
        else
           write(9+i, 1) 'Timestep','Days',Z_r
        endif
     enddo
  endif

1 format(A10,1x,A7, <nlev  >(2x,F12.5))
2 format(I10,1x,I7, <nlev  >(2x,F12.5))
3 format(A10,1x,A7, <nlev+1>(2x,F12.5))
4 format(I10,1x,I7, <nlev+1>(2x,F12.5))

  ! For each time step, read in external environmental data
  ! 'START TIME STEPPING'

  DO it = 1, maxN+1

    !  write(6,*) 'Continue?'
    !  read(6,*)  YN

    !  if (YN .eq. 'N') stop
  ! Calculate current timing (zero is starting time):
     time = float(it-1)*dtsec

  ! Interpolate Temp data throughout the water column:
     call time_interp(int(time), 12, nlev, obs_time, VTemp, Temp)

  ! Interpolate temporal PAR data:
     call time_interp(int(time), 12, 1, obs_time,obs_PAR(1,2:13), I_0)

  ! Convert the unit of par to W m-2:
     cff = I_0(1)/4d-1

  ! Calculate light field:
     call Calculate_PAR(cff, nlev, Hz, Varout(oCHLt,:), PAR)

  ! Interpolate Aks data throughout the water column:
     call time_interp(int(time), 12, nlev+1, obs_time, VAks, Aks)

  ! Save data to output files:
  if (mod(it, nsave) .eq. 1) then
  ! Calculate model time in days:
     time_day=int(time/d_per_s)

!     write(6,*) '----------------------------------------'
!     write(6,*) 'Day ', time_day
!     write(6,5) 'Surface NO3 =',Vars(iNO3,nlev)
!     write(6,5) 'Surface ZOO =',Vars(iZOO,nlev)
!     write(6,5) 'Surface DET =',Vars(iDET,nlev)
!     write(6,5) 'Surface CHLA=',Varout(oCHLt,nlev)
!     write(6,5) 'Surface muNet(3) =',Varout(omuNet(3),nlev)/dtdays
!5    format(A15, 1x, F10.5)

  ! Save Temp data into the output file:
     write(9+oTemp, 2) it, time_day, Temp

  ! Save PAR data into the output file:
     write(9+oPAR, 2) it, time_day, PAR

  ! Save Aks data into the output file:
     write(9+oAks, 4) it, time_day, Aks

  ! Save state variables and diagnostics:
     do i=4,Nout+3
        write(9+i, 2) it, time_day, Varout(i-3,:)
     enddo

  endif  !==> End of saving results

   ! Biological rhs:
  selectcase(Model_ID)

    case(EFTdiscrete)
      call FLEXEFT_DISC

    case(EFTcont)
      call FLEXEFT_CONT

    case(Geiderdisc)
      write(6,*) 'Not coded yet. Quit.'
      stop
    case(Geidercont)
      write(6,*) 'Not coded yet. Quit.'
      stop

    case(EFTsimple)
      write(6,*) 'Not coded yet. Quit.'
      stop

    case(Geidersimple)
      write(6,*) 'Not coded yet. Quit.'
      stop

    case default
      write(6,*) 'Error in choosing biological models! Quit.'
      stop
  endselect

  ! Pass the new state variables to Vars
  do j = 1,NVAR
     Vars(j,:)=Varout(j,:)
  enddo

  ! Diffusion:

  do j = 1,NVAR

     call diff_center(nlev,dtsec,cnpar,1,Hz,Aks,Vars(j,:),NewVars(j,:))

     ! Save diffusion fluxes (normalized to per day)
     Varout(oD_NO3+j-1,:) = (NewVars(j,:) - Vars(j,:))/dtdays

     ! Update the state variables:
     Vars(j,:)=NewVars(j,:)

  enddo

  ! Sinking:
  ! Initialize sinking rate:
  ww(0,   :) = 0.0
  ww(nlev,:) = 0.0

  do k = 1,nlev-1
     do i=1,NPHY
        ww(k,i) = -Varout(ow_p(i),k)         !Phytoplankton sinking rate
     enddo
     ww(k,NPHY+1) = -Params(iwDET)             !Detritus      sinking rate
  enddo

!subroutine adv_center(N,dt,h,ho,ww,Bcup,Bcdw,Yup,Ydw,method,mode,Y)
  do j = 1,NVsinkterms
     call adv_center(nlev,dtdays,Hz,Hz,ww(:,j),  &
                     1,1,Yup,Ydw,6,1,Vars(Windex(j),:))
  enddo

  ! Check whether the values are valid:
  do j = 1,NVAR
     do k=1,nlev
        if( (Vars(j,k) .ne. Vars(j,k)) .OR. (Vars(j,k) .le. 0.) ) then
            write(6,*) 'At time step ',it
            write(6,*) 'The variable ',trim(Labelout(j+3)), ' is invalid at depth ',Z_r(k)
            stop
        endif
     enddo
  enddo

  ENDDO    ! ==> End of time stepping

  ! Close files:
  if (savefile .eq. .true.) then
     do i = 1, Nout
        close (unit=9+i)
     enddo
  endif

!  ! Release memory:
  deallocate(Vars)
  deallocate(NewVars)
  deallocate(ww)
  deallocate(Varout)
  deallocate(params)
  deallocate(iPHY)
  deallocate(Labelout)
  deallocate(Windex)
  deallocate(oPHY)
  deallocate(oTheta)
  deallocate(oQN)
  deallocate(omuNET)
  deallocate(oGraz)
  deallocate(ow_p)
  deallocate(oSI)
  deallocate(oLno3)
  deallocate(oTheHat)
  deallocate(oD_PHY)

!  call CPU_Time(t2)
!
!  write(6,7) 'Model run finishes. CPU time:  ',t2-t1,' seconds'
7 format(A30,F8.1,A8)

END subroutine
!========================================================
! !ROUTINE: Interpolate from time-series observation to model time
subroutine time_interp(time, N, nrow, obs_time, obs_data, mod_data)
  ! time: model time
  !    N: number of time-series observations in observational data
  ! nrow: number of vertical points in observation data
  ! obs_time: time of observational data, should be a vector of length N
  ! obs_data: observational data, should be a vector of length N
  ! mod_data: model data as output
  implicit none
  integer, intent(in)    :: N, time, nrow
  real(8), intent(in)    :: obs_time(N), obs_data(nrow,N)
  real(8), intent(out)   :: mod_data(nrow)

  integer, parameter     :: y_per_s = 31104000
  integer                :: i,j
  real(8)                :: timeMOD, rat

! Get time of the year (mod):
   timeMOD = float(mod(time,y_per_s))

! Deal with the case between two years:
   IF ((timeMOD .lt. obs_time(1))) THEN

      rat = (timeMOD    -obs_time(N)+float(y_per_s))   &
          / (obs_time(1)-obs_time(N)+float(y_per_s))

      do i=1,nrow
         mod_data(i)=obs_data(i,N)*(1d0-rat)+obs_data(i,1)*rat
      enddo

   ELSEIF (timeMOD .ge. obs_time(N)) THEN

      rat = (timeMOD    -obs_time(N))   &
          / (obs_time(1)-obs_time(N)+float(y_per_s))

      do i=1,nrow
         mod_data(i)=obs_data(i,N)*(1d0-rat)+obs_data(i,1)*rat
      enddo

   ELSE

      do j = 1, N-1
         if ((timeMOD.lt.obs_time(j+1)) .and. (timeMOD.GE.obs_time(j))) then

            rat=(timeMOD-obs_time(j))/(obs_time(j+1)-obs_time(j))

            do i=1,nrow
               mod_data(i)=obs_data(i,j)*(1d0-rat)+obs_data(i,j+1)*rat
            enddo
            exit
         endif
      enddo

   ENDIF
   return
end subroutine
!========================================================
! !ROUTINE: Interpolate from observation space to model grid
!
! !INTERFACE:
subroutine gridinterpol(N,cols,obs_z,obs_prof,nlev,model_z,model_prof)
!
! !DESCRIPTION:
!
!  This is a utility subroutine in which observational data, which might
!  be given on an arbitrary, but structured grid, are linearly interpolated and
!  extrapolated to the actual (moving) model grid.
!
! !USES:
   IMPLICIT NONE
!
! !INPUT PARAMETERS:
   !N    : number of vertical layers in observation data
   !cols : number of profiles in obs. data
   integer,  intent(in)                :: N,cols
   REAL(8),  intent(in)                :: obs_z(N),obs_prof(N,cols)
   integer,  intent(in)                :: nlev
   REAL(8),  intent(in)                :: model_z(nlev)
!
! !OUTPUT PARAMETERS:
   REAL(8),  intent(out)               :: model_prof(nlev,cols)
!
! !REVISION HISTORY:
!  Original author(s): Karsten Bolding & Hans Burchard
!
!EOP
!
! !LOCAL VARIABLES:
   integer                   :: i,j,ii
   REAL(8)                   :: rat
!-----------------------------------------------------------------------
!BOC
!  Set surface values to uppermost input value
   do i=nlev,1,-1
      if(model_z(i) .ge. obs_z(N)) then
         do j=1,cols
            model_prof(i,j) = obs_prof(N,j)
         end do
      end if
   end do

!  Set bottom values to lowest input value
   do i=1,nlev
      if(model_z(i) .le. obs_z(1)) then
         do j=1,cols
            model_prof(i,j) = obs_prof(1,j)
         end do
      end if
   end do

!  Interpolate inner values linearly
   do i=1,nlev
         !write(*,*) 'i = ',i
      if ((model_z(i) .lt. obs_z(N)) .and. (model_z(i) .gt. obs_z(1))) then
         ii=0
224      ii=ii+1
         if (obs_z(ii) .le. model_z(i)) goto 224
         ! Debug:
         !write(*,*) 'ii = ', ii
         !write(*,*) 'model_z = ',model_z(i)
         !write(*,*) '  obs_z = ',  obs_z(ii)
         !write(*,*) '  obs_z(ii-1) = ',  obs_z(ii-1)

         rat=(model_z(i)-obs_z(ii-1))/(obs_z(ii)-obs_z(ii-1))

         do j=1,cols
            model_prof(i,j)=(1-rat)*obs_prof(ii-1,j)+rat*obs_prof(ii,j)
         !write(*,*) 'obs_prof(ii-1) = ',obs_prof(ii-1,j)
         !write(*,*) 'obs_prof(ii)   = ',obs_prof(ii  ,j)
         !write(*,*) 'rat            = ',rat
         !write(*,*) 'model_prof(i)  = ',model_prof(i,j)

         end do
      end if
   end do

   return
end subroutine
!EOC

!========================================================
subroutine setup_grid(thetaS, nlev, hmax, Z_r, Z_w, Hz)
  implicit none
  integer, intent(in)    :: nlev
  real(8), intent(in)    :: thetaS, hmax
  real(8), intent(out)   :: Z_r(1:nlev), Z_w(0:nlev), Hz(1:nlev)

  ! Local scratch variable:
  integer                :: i
  real(8)                :: sc_r, C_sig

  Z_w(0) = -hmax

  !Following Song and Haidvogel (1994). sinh is the hyperbolic sin function
  do i   = 1,nlev
      sc_r  = (float(i-nlev) - 0.5)/float(nlev)
     C_sig  = sinh(thetaS*sc_r)/sinh(thetaS)      ! -1 < C_sig < 0
     Z_r(i) = C_sig*hmax
      sc_r  = (float(i-nlev))/float(nlev)
     C_sig  = sinh(thetaS*sc_r)/sinh(thetaS)      ! -1 < C_sig < 0
     Z_w(i) = C_sig*hmax
      Hz(i) = Z_w(i) - Z_w(i-1)
  enddo
  return
end subroutine

!===========
subroutine Calculate_PAR(I_0, nlev, Hz, Chl, PAR)
  !top level is nlev, bottom layer is 1, following ROMS convention
  implicit none
  real(8), intent(in) :: I_0
  integer, intent(in) :: nlev    ! Total number of vertical layers
  real(8), intent(in) :: Hz(nlev), Chl(nlev)
  real(8), intent(out):: PAR(nlev)
  integer             :: i
  real(8)             :: par0, attn    ! Scratch variable
  real(8), parameter  :: kw = 0.04, kc = 0.025

  par0 = I_0   !Light at the grid surface
  do i = nlev,1,-1
     attn   = exp(-0.5*Hz(i)*(kw + kc*Chl(i)))
     PAR(i) = par0*attn
     par0   = PAR(i)*attn
  enddo

end subroutine Calculate_PAR
!===========
! !ROUTINE: Advection schemes --- grid centers\label{sec:advectionMean}
subroutine adv_center(N,dt,h,ho,ww,Bcup,Bcdw,Yup,Ydw,method,mode,Y)
   IMPLICIT NONE
! !INPUT PARAMETERS:
!  number of vertical layers
   integer,  intent(in)                :: N
!  time step (s)
   real(8), intent(in)                 :: dt
!  layer thickness (m)
   real(8), intent(in)                 :: h(N)

!  old layer thickness (m)
   real(8), intent(in)                 :: ho(N)

!  vertical advection speed
   real(8), intent(in)                 :: ww(0:N)

!  type of upper BC
   integer,  intent(in)                :: Bcup

!  type of lower BC
   integer,  intent(in)                :: Bcdw

!  value of upper BC
   real(8), intent(in)                 :: Yup

!  value of lower BC
   real(8), intent(in)                 :: Ydw

!  type of advection scheme
   integer,  intent(in)                :: method

!  advection mode (0: non-conservative, 1: conservative)
   integer,  intent(in)                :: mode
!
! !INPUT/OUTPUT PARAMETERS:
   real(8),  intent(inout)             :: Y(N)
!
! !DEFINED PARAMETERS:
   real(8),      parameter             :: one6th=1.0d0/6.0d0
   integer,      parameter             :: itmax=100

!  type of advection scheme
   integer,parameter                    :: UPSTREAM       = 1
   integer,parameter                    :: P1             = 2
   integer,parameter                    :: P2             = 3
   integer,parameter                    :: Superbee       = 4
   integer,parameter                    :: MUSCL          = 5
   integer,parameter                    :: P2_PDM         = 6

!  boundary condition type
!  for advection schemes
   integer,parameter                    :: flux           = 1
   integer,parameter                    :: value          = 2
   integer,parameter                    :: oneSided       = 3
   integer,parameter                    :: zeroDivergence = 4

! !LOCAL VARIABLES:
   integer                             :: i,k,it
   real(8)                             :: x,r,Phi,limit
   real(8)                             :: Yu,Yc,Yd
   real(8)                             :: c,cmax
   real(8)                             :: cu(0:N)
!-----------------------------------------------------------------------
!  initialize interface fluxes with zero
   cu   = 0.0

!  initialize maximum Courant number
   cmax = 0.0

!  compute maximum Courant number
   do k = 1,N-1
      c = abs(ww(k))*dt/(0.5*(h(k)+h(k+1)))
      if (c .gt. cmax) cmax=c
   enddo

   it   = min(itmax,int(cmax)+1)

!#ifdef DEBUG
   if (it .gt. 1) then
      write(0,*) 'In adv_center():'
      write(0,*) 'Maximum Courant number is ',cmax
      write(0,*) it,' iterations used for vertical advection'
   endif
!#endif

!  splitting loop
   do i=1,it

!     vertical loop
      do k=1,N-1

!        compute the slope ration
         if (ww(k) .gt. 0.0) then

!           compute Courant number
            c=ww(k)/float(it)*dt/(0.5*(h(k)+h(k+1)))

            if (k .gt. 1) then
               Yu=Y(k-1)                              ! upstream value
            else
               Yu=Y(k)
            end if
            Yc=Y(k  )                                 ! central value
            Yd=Y(k+1)                                 ! downstream value

!           compute slope ratio
            if (abs(Yd-Yc) .gt. 1e-10) then
               r=(Yc-Yu)/(Yd-Yc)
            else
               r=(Yc-Yu)*1.e10
            end if

!        negative speed
         else

!           compute Courant number
            c=-ww(k)/float(it)*dt/(0.5*(h(k)+h(k+1)))

            if (k .lt. N-1) then
               Yu=Y(k+2)                              ! upstream value
            else
               Yu=Y(k+1)
            end if
            Yc=Y(k+1)                                 ! central value
            Yd=Y(k  )                                 ! downstream value

!           compute slope ratio
            if (abs(Yc-Yd) .gt. 1e-10) then
               r=(Yu-Yc)/(Yc-Yd)
            else
               r=(Yu-Yc)*1.e10
            end if

         end if

!        compute the flux-factor phi
         x    =  one6th*(1d0-2d0*c)
         Phi  =  (5d-1+x)+(5d-1-x)*r

!        limit the flux according to different suggestions (Pietrzak 1998)
         select case (method)
            case (UPSTREAM)
               limit= 0.0
            case (P1)
               write(0,*) "Fatal error: P1 advection method not yet implemented, choose other method"
               stop  "adv_center.F90"
            case ((P2),(P2_PDM))
               if (method .eq. P2) then
                  limit=Phi
               else
                  limit=max(0.0,min(Phi,2d0/(1d0-c),2d0*r/(c+1.e-10)))
               end if
            case (Superbee)
               limit=max(0.0, min(1d0, 2.0*r), min(r,2.*1d0) )
            case (MUSCL)
               limit=max(0.0,min(2.*1d0,2.0*r,0.5*(1.0+r)))
            case default
               write(0,*) method
               write(0,*) 'Fatal error: unkown advection method in adv_center()'
               stop
          end select

!        compute the limited flux
         cu(k)=ww(k)*(Yc+0.5*limit*(1-c)*(Yd-Yc))

      end do

!     do the upper boundary conditions
      select case (Bcup)
      case (flux)
         cu(N) = - Yup              ! flux into the domain is positive
      case (value)
         cu(N) =  ww(N)*Yup
      case (oneSided)
         if (ww(N).ge.0.0) then
            cu(N) =  ww(N)*Y(N)
         else
            cu(N) = 0.0
         end if
      case (zeroDivergence)
         cu(N) = cu(N-1)
      case default
         write(0,*) 'Fatal error: unkown upper boundary condition type in adv_center()'
         stop
      end select

!     do the lower boundary conditions
      select case (Bcdw)
      case (flux)
         cu(0) =   Ydw               ! flux into the domain is positive
      case (value)
         cu(0) =  ww(0)*Ydw
      case (oneSided)
         if(ww(0).le.0.0) then
            cu(0) =  ww(0)*Y(1)
         else
            cu(0) = 0.0
         end if
      case (zeroDivergence)
         cu(0) = cu(1)
      case default
         write(0,*) 'Fatal error: unkown lower boundary condition type in adv_center()'
         stop
      end select

!     do the vertical advection step which will be used for prescribed
!     vertical flow velocity and for settling of suspended matter.

      if (mode.eq.0) then ! non-conservative, water vertical velocity
         do k=1,N
            Y(k)=Y(k)-1./float(it)*dt*((cu(k)-cu(k-1))/        &
                 h(k)-Y(k)*(ww(k)-ww(k-1))/h(k))
         enddo
      else                ! conservative, for PHY and DET sinking
         do k=1,N
            Y(k)=Y(k)-1./float(it)*dt*((cu(k)-cu(k-1))/h(k))
         enddo
      end if

   end do ! end of the iteration loop
  return
end subroutine adv_center
!EOC
!-----------------------------------------------------------------------
!subroutine diff_center(N,dt,cnpar,posconc,h,Bcup,Bcdw, &
!                       Yup,Ydw,nuY,Lsour,Qsour,Taur,Yobs,Yin,Yout)
subroutine diff_center(N,dt,cnpar,posconc,h,nuY,Yin,Yout)

   IMPLICIT NONE
!
! !INPUT PARAMETERS:
!   integer,parameter                    :: Dirichlet      = 0
!   integer,parameter                    :: Neumann        = 1

!  number of vertical layers
   integer,  intent(in)               :: N

!  time step (s)
   real(8), intent(in)                :: dt

!  "implicitness" parameter
   real(8), intent(in)                :: cnpar

!  1: non-negative concentration, 0: else
   integer, intent(in)                :: posconc

!  layer thickness (m)
   real(8), intent(in)                :: h(N)

!  type of upper BC
!   integer,  intent(in)               :: Bcup

!  type of lower BC
!   integer,  intent(in)               :: Bcdw

!  value of upper BC
!   real(8), intent(in)                :: Yup

!  value of lower BC
!   real(8), intent(in)                :: Ydw

!  diffusivity of Y
   real(8), intent(in)                :: nuY(0:N)

!  linear source term
!  (treated implicitly)
!   real(8), intent(in)                :: Lsour(N)

!  constant source term
!  (treated explicitly)
!   real(8), intent(in)                :: Qsour(N)

!  relaxation time (s)
!   real(8), intent(in)                :: Taur(N)

!  observed value of Y
!   real(8), intent(in)                :: Yobs(N)
!
! !INPUT/OUTPUT PARAMETERS:
   real(8), intent(in)                :: Yin(N)
   real(8), intent(out)               :: Yout(N)

   real(8), dimension(N)              :: au,bu,cu,du
! !REVISION HISTORY:
!  Original author(s): Lars Umlauf
!
!EOP
!
! !LOCAL VARIABLES:
   integer                   :: i
   real(8)                   :: a,c,l
!
!-----------------------------------------------------------------------
!BOC
!
!   Debug:
!   write(6,*) 'Yup    = ',Yup
!   write(6,*) 'Ydw    = ',Ydw

!  Initialize au, bu, cu, du
   au(:) = 0d0; bu(:) = 0d0; cu(:) = 0d0; du(:) = 0d0

!  set up matrix
   do i=2,N-1
      c     = 2.0*dt*nuY(i)  /(h(i)+h(i+1))/h(i)
      a     = 2.0*dt*nuY(i-1)/(h(i)+h(i-1))/h(i)
!      l     =     dt*Lsour(i)

      cu(i) =-cnpar*c
      au(i) =-cnpar*a
     ! bu(i) = 1d0 + cnpar*(a + c) - l
      bu(i) = 1d0 + cnpar*(a + c)

     ! du(i) = (1d0 - (1d0-cnpar)*(a + c))*Yin(i)                  &
     !       + (1d0 - cnpar)*( a*Yin(i-1) + c*Yin(i+1) ) + dt*Qsour(i)

      du(i) = (1d0 - (1d0-cnpar)*(a + c))*Yin(i)                  &
            + (1d0 - cnpar)*( a*Yin(i-1) + c*Yin(i+1) )

   enddo

!   set up upper boundary condition
!   select case(Bcup)
!   case(Neumann)
      a     = 2.0*dt*nuY(N-1)/(h(N)+h(N-1))/h(N)
!      l     = dt*Lsour(N)

      au(N) =-cnpar*a
!      if (posconc .eq. 1 .and. Yup.lt.0d0) then ! Patankar (1980) trick
!         bu(N) =  1d0 - au(N) - l  - dt*Yup/Yin(N)/h(N)
!         du(N) = Yin(N) + dt*Qsour(N)   &
!               + (1d0 - cnpar)*a*(Yin(N-1)-Yin(N))
!      else
!       bu(N) =  1d0 - au(N) - l
       bu(N) = 1d0 - au(N)
!       du(N) = Yin(N) + dt*(Qsour(N)+Yup/h(N))   &
!             + (1d0 - cnpar)*a*(Yin(N-1)-Yin(N))
       du(N) = Yin(N) + (1d0 - cnpar)*a*(Yin(N-1)-Yin(N))
!      end if
!   case(Dirichlet)
!      au(N) = 0d0
!      bu(N) = 1d0
!      du(N) = Yup
!   case default
!      write(6,*) 'Fatal error: invalid boundary condition type for upper boundary'
!      stop  'diff_center.F90'
!   end select

!   set up lower boundary condition
!   select case(Bcdw)
!   case(Neumann)
      c     = 2.0*dt*nuY(1)/(h(1)+h(2))/h(1)
!      l     = dt*Lsour(1)

      cu(1) =-cnpar*c
     ! if (posconc.eq.1 .and. Ydw.lt.0d0) then ! Patankar (1980) trick
     !    bu(1) = 1d0 - cu(1) - l - dt*Ydw/Yin(1)/h(1)
     !    du(1) = Yin(1) + dt*(Qsour(1))   &
     !          + (1d0 - cnpar)*c*(Yin(2)-Yin(1))
     ! else
     !    bu(1) = 1d0 - cu(1) - l
     !    du(1) = Yin(1) + dt*(Qsour(1)+Ydw/h(1))   &
     !          + (1d0 - cnpar)*c*(Yin(2)-Yin(1))

         bu(1) = 1d0 - cu(1)
         du(1) = Yin(1) + (1d0 - cnpar)*c*(Yin(2)-Yin(1))

     ! endif
!   case(Dirichlet)
!      cu(1) = 0d0
!      bu(1) = 1d0
!      du(1) = Ydw
!   case default
!      write(6,*) 'Fatal error: invalid boundary condition type for lower boundary'
!      stop  'diff_center.F90'
!   end select

!  relaxation to observed value
!   if (minval(Taur).lt.1.E10) then
!      do i=1,N
!         bu(i)=bu(i)+dt/Taur(i)
!         du(i)=du(i)+dt/Taur(i)*Yobs(i)
!      end do
!   end if

!  solve linear system
   call tridiagonal(N,au,bu,cu,du,1,N,Yout)

   return
end subroutine diff_center
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
subroutine tridiagonal(N,au,bu,cu,du,fi,lt,value)
!
! !DESCRIPTION:
! A linear equation with tridiagonal matrix structure is solved here. The main
! diagonal is stored on {\tt bu}, the upper diagonal on {\tt au}, and the
! lower diagonal on {\tt cu}, the right hand side is stored on {\tt du}.
! The method used here is the simplified Gauss elimination, also called
! \emph{Thomas algorithm}.
!
! !USES:
   IMPLICIT NONE
!
! !INPUT PARAMETERS:
   integer, intent(in)                 :: N,fi,lt
   real(8), dimension(N), intent(in)   :: au, bu, cu, du
!
! !OUTPUT PARAMETERS:
   real(8), intent(out)                :: value(N)
!
!EOP
!
! !LOCAL VARIABLES:
   integer                             :: i
   real(8), dimension(N)               :: ru, qu
!
!-----------------------------------------------------------------------
!BOC
   ru(lt)=au(lt)/bu(lt)
   qu(lt)=du(lt)/bu(lt)

   do i=lt-1,fi+1,-1
      ru(i)=au(i)/(bu(i)-cu(i)*ru(i+1))
      qu(i)=(du(i)-cu(i)*qu(i+1))/(bu(i)-cu(i)*ru(i+1))
   end do

   qu(fi)=(du(fi)-cu(fi)*qu(fi+1))/(bu(fi)-cu(fi)*ru(fi+1))

   value(fi)=qu(fi)

!   write(6,*) 'fi = ',fi
!   write(6,*) 'value(fi) = ',value(fi)

   do i=fi+1,lt
      value(i)=qu(i)-ru(i)*value(i-1)
   end do

!   write(6,*) 'value(lt) = ',value(lt)

   return
end subroutine tridiagonal
!=======================================================
subroutine  Readcsv(filename,nrow,ncol,dat)
  implicit none
  character(LEN=20),intent(in) :: filename
  character(LEN=10),dimension(ncol) :: header
  integer,          intent(in) :: nrow, ncol
  real(8), dimension(nrow,ncol), intent(out):: dat
  integer    :: err, ix
  integer,parameter :: stdout=6

   dat(:,:) = 0.0
   OPEN(unit=10,file=filename,status='OLD',iostat=err)

   IF (err /= 0) THEN
     write(stdout,*) 'open ', TRIM(filename),' fails'
     stop
     close(10)

   ELSE
     ! write(stdout,*) 'Start reading ',TRIM(filename),' !'
     read(10,*,iostat=err) header  !read the first row
     if (err .ne. 0) then
       write(stdout,*) 'End of file reached at Row 1.',     &
                      'The error is: ', err
       stop
     else
       continue
     endif

     do ix = 1,nrow
       read(10,*,iostat=err) dat(ix,:)
       if (err .ne. 0) then
         write(stdout,*) 'End of file reached at Row: ',ix
         exit
       else
         continue
       endif
     enddo

     ENDIF
     CLOSE(unit=10)
! End reading data
 end subroutine Readcsv
!=======================================================
End MODULE FlexEFT1D


    subroutine rtbis(x1,x2,xacc,out,temper)
!   ---------------------------------------
    implicit none
    integer, parameter :: jmax=80
    double precision f1,f2,xnothing
    double precision dx,xmid,fmid,fxmid

    include 'combine_foam.inc'

    call phfunc(x2,f2,xnothing,temper)
    fmid=f2
    call phfunc(x1,f1,xnothing,temper)
    fsoil=f1
    if(fsoil*fmid.ge.0.) then
        write(6,*)x1,fsoil,x2,fmid
        write(6,*)'root must be bracketed:rtbis'
        stop
    endif
    if(fsoil.lt.0.) then
        out=x1
        dx=x2-x1
    else
        out=x2
        dx=x1-x2
    endif

    do j=1,jmax
        dx=dx*0.5
        xmid=out+dx
        call phfunc(xmid,fxmid,xnothing,temper)
        fmid=fxmid
        if(fmid.le.0.)out=xmid
        if(abs(dx).lt.xacc.or.fmid.eq.0.) return
    end do

    write(6,*) 'too many bisection in rtbis'
    return
    end


      SUBROUTINE MB03RX( JOBV, N, KL, KU, A, LDA, X, LDX, WR, WI,
     $                   DWORK )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To reorder the diagonal blocks of the principal submatrix between
C     the indices KL and KU (KU >= KL) of a real Schur form matrix A
C     together with their eigenvalues, using orthogonal similarity
C     transformations, such that the block specified by KU is moved in
C     the position KL. The transformations are optionally postmultiplied
C     in a given matrix X.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBV    CHARACTER*1
C             Specifies whether or not the transformations are
C             accumulated, as follows:
C             = 'N':  The transformations are not accumulated;
C             = 'V':  The transformations are accumulated in X (the
C                     given matrix X is updated).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A and X.  N >= 0.
C
C     KL      (input) INTEGER
C             The lower boundary index for the rows and columns of the
C             principal submatrix of A whose diagonal blocks are to be
C             reordered, and also the target position for the block to
C             be moved.  1 <= KL <= KU <= N.
C
C     KU      (input/output) INTEGER
C             On entry, KU specifies the upper boundary index for the
C             rows and columns of the principal submatrix of A whose
C             diagonal blocks are to be reordered, and also the original
C             position for the block to be moved.  1 <= KL <= KU <= N.
C             On exit, KU specifies the upper boundary index for the
C             rows and columns of the principal submatrix of A whose
C             diagonal blocks have been reordered. The given value will
C             be increased by 1 if the moved block was 2-by-2 and it has
C             been replaced by two 1-by-1 blocks. Otherwise, its input
C             value is preserved.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A in real Schur canonical form.
C             On exit, the leading N-by-N part of this array contains
C             the ordered real Schur canonical form.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)
C             On entry, if JOBV = 'V', the leading N-by-N part of this
C             array must contain a given matrix X.
C             On exit, if JOBV = 'V', the leading N-by-N part of this
C             array contains the product of the given matrix X and the
C             transformation matrix that performed the reordering of A.
C             If JOBV = 'N', this array is not referenced.
C
C     LDX     INTEGER
C             The leading dimension of array X.
C             LDX >= 1,        if JOBV = 'N';
C             LDX >= MAX(1,N), if JOBV = 'V'.
C
C     WR,     (input/output) DOUBLE PRECISION arrays, dimension (N)
C     WI      On entry, these arrays must contain the real and imaginary
C             parts, respectively, of the eigenvalues of the matrix A.
C             On exit, these arrays contain the real and imaginary
C             parts, respectively, of the eigenvalues of the matrix A,
C             possibly reordered.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (N)
C
C     METHOD
C
C     An attempt is made to move the block in the position (KU,KU) to
C     the position (KL,KL) by a sequence of orthogonal similarity
C     transformations, each swapping two consecutive blocks. The
C     standard algorithm [1], [2] usually succeeds to perform this
C     reordering. A failure of this algorithm means that two consecutive
C     blocks (one of them being the desired block possibly moved) are
C     too close to swap. In such a case, the leading block of the two
C     is tried to be moved in the position (KL,KL) and the procedure is
C     repeated.
C
C     REFERENCES
C
C     [1] Stewart, G.W.
C         HQR3 and EXCHQZ: FORTRAN subroutines for calculating and
C         ordering the eigenvalues of a real upper Hessenberg matrix.
C         ACM TOMS, 2, pp. 275-280, 1976.
C
C     [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
C         Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
C         Ostrouchov, S., and Sorensen, D.
C         LAPACK Users' Guide: Second Edition.
C         SIAM, Philadelphia, 1995.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically stable. If some eigenvalues are
C     ill-conditioned, their returned values could differ much from
C     their input values.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, June 1998.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Eigenvalue, orthogonal transformation, real Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOBV
      INTEGER           KL, KU, LDA, LDX, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), DWORK(*), WI(*), WR(*), X(LDX,*)
C     .. Local Scalars ..
      INTEGER           IERR, IFST, ILST, L
C     .. External Subroutines ..
      EXTERNAL          DTREXC
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, SQRT
C     .. Executable Statements ..
C
      IF ( KU.GT.KL ) THEN
C
C        Try to move the block in position (KU,KU) to position (KL,KL).
C
         IFST = KU
C        REPEAT
   10    CONTINUE
         ILST = KL
         CALL DTREXC( JOBV, N, A, LDA, X, LDX, IFST, ILST, DWORK, IERR )
         IF ( IERR.NE.0 ) THEN
C
C           During calculations, two adjacent blocks were too close
C           to swap; the desired block cannot be moved further, but the
C           block above it is suitable and is tried for moving. The
C           number of repeat cycles is usually 1, and at most the number
C           of blocks between the current position and the position KL.
C
            IFST = ILST - 1
            IF ( IFST.GT.1 ) THEN
               IF ( A(IFST,IFST-1).NE.ZERO )
     $            IFST = ILST - 2
            END IF
            IF ( ILST.GT.KL )
     $         GO TO 10
         END IF
C        UNTIL ( ILST.EQ.KL on output from DTREXC )
C
C        Recompute the eigenvalues for the modified part of A.
C        Note that KU must be incremented if the moved block was 2-by-2
C        and it has been replaced by two 1-by-1 blocks.
C
         IF ( WI(KU).NE.ZERO ) THEN
            IF ( A(KU+1,KU).EQ.ZERO )
     $         KU = KU + 1
         END IF
C
         L = KL
C        WHILE ( L.LT.KU .OR. ( L.EQ.KU .AND. L.LT.N ) ) DO
   20    IF ( L.LT.KU .OR. ( L.EQ.KU .AND. L.LT.N ) ) THEN
            IF ( A(L+1,L).NE.ZERO ) THEN
C
C              A 2x2 block.
C
               WR(L)   =  A(L,L)
               WR(L+1) =  WR(L)
               WI(L)   =  SQRT( ABS( A(L,L+1) ) )*
     $                    SQRT( ABS( A(L+1,L) ) )
               WI(L+1) = -WI(L)
               L = L + 2
            ELSE
C
C              An 1x1 block.
C
               WR(L) = A(L,L)
               WI(L) = ZERO
               L = L + 1
            END IF
            GO TO 20
         ELSE IF ( L.EQ.N ) THEN
            WR(L) = A(L,L)
            WI(L) = ZERO
         END IF
C        END WHILE 20
      END IF
C
      RETURN
C *** Last line of MB03RX ***
      END


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!  This file contains code for constructing nonoscillatory phase functions which
!  represent the solutions of a modified form of Jacobi's differential equation.  The
!  phase and amplitude functions are themselves represented via piecewise chebyshev
!  expansions.  The routines here are somewhat low level and not intended for direct
!  use by users.
!
!  More precisely, for a given triple of parameters (dnu,da,db) the subroutines
!  in this file construct a nonoscillatory amplitude function a(t) and a
!  nonoscillatoryphase function psi(t) such that a(t) cos( psi(t) ) is
!
!      (da,db)                    (da,db)
!     P        ( cos(t) )  r(t)  C                                                        (1)
!      dnu                        dnu
!
!  where  P_dnu^(da,db) is the Jacobi polynomial of the first kind,
!
!     r(t) = cos(t/2) ^(db+1/2) sin(t/2) ^(da+1/2),
!
!  and  C_dnu^(da,db) is a normalization constant.   In fact, these routines
!  actually store a modified version of the phase function
!
!    psi(t)/dnu - t
!
!  because it is somewhat easier to represent than psi(t) using  piecewise
!  polynomial expansions.
!
!  The normalization constant is chosen so that (1) and the associated "Q" function
!  of the second kind  will have Wronskian 1.  The L^2 normalized Jacobi polynomials
!  are obtained by  multiplying (1) by the constant
!
!       (2*dnu+da+db+1)/pi.
!
!  The following are the principal subroutines in this file:
!
!    jacobi_phase - construct the nonoscillatory phase and amplitude functions
!      representing (1)
!
!    jacobi_phase_disc - return a discretization scheme used to represent
!      the amplitude and phase functions
!
!    jacobi_phase_eval - evaluate the phase and amplitude functions at a user-specified
!      collection of points using the data generated by jacobi_phase
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine jacobi_phase(chebdata,dnu,da,db,nints,ab,avals,psivals)
use chebyshev
implicit double precision (a-h,o-z)

double precision, intent(in)              :: dnu,da,db
type(chebexps_data)                       :: chebdata
double precision, intent(in)              :: ab(2,nints)
double precision, intent(out)             :: avals(chebdata%k,nints)
double precision, intent(out)             :: psivals(chebdata%k,nints)

!
!  Construct the phase and amplitude functions for specified values
!  of the parameters.  This routine is a thin wrapper around jacobi_phase_solve.
!
!  Input parameters:
!    chebdata - a chebexps_data structure containing the information needed to
!       manipulate function represented by k-point Chebyshev expansions
!    (dnu,da,db) - the values of the parameters in Jacobi's equation
!    (nints,ab) - the discretization scheme returned by jacobi_phase_disc
!
!  Output parameters:
!    avals - an array of lengh k * nints specifying the values or coefficients
!      of the amplitude function
!    psivals - an array of length k*nints specifying the values of coefficients
!      of the modified phase function
!

data  pi        / 3.14159265358979323846264338327950288d0 /
data  piovertwo / 1.57079632679489661923132169163975144d0 /

call jacobi_phase_solve(chebdata%k,nints,ab,chebdata%xs,                       &
  chebdata%aintr,chebdata%aintr2,chebdata%aintr3,                              &
  chebdata%aintl,chebdata%aintl2,chebdata%aintl3,chebdata%u,                   &
  dnu,da,db,psivals,avals)

end subroutine

subroutine jacobi_phase_disc(nints,ab)
implicit double precision (a-h,o-z)

integer, intent(in)                           :: nints
double precision, intent(out)                 :: ab(2,nints)

!
!  Construct the list of the intervals used to discretize the phase functions.
!
!  Input parameters:
!    nints - the total number of intervals -- this parameter must be even
!
!     IT IS RECOMMENDED THAT THIS BE SET TO 50 IN ORDER TO USE 20th ORDER CHEBYSHEV
!     EXPANSIONS TO REPRESENT PHASE FUNCTIONS
!
!  Output parameters:
!    ab - a (2,nints) array specifying the endpoints of each interval
!

data  pi        / 3.14159265358979323846264338327950288d0 /
data  piovertwo / 1.57079632679489661923132169163975144d0 /

nints0  = nints/2
dd      = 2.0d0

do int=1,nints0
ab(1,int) = dd**(-nints0+int-1)
ab(2,int) = dd**(-nints0+int)
end do

ab = pi/2*ab

do int=1,nints0
ab(1,nints-int+1) = pi - ab(2,int)
ab(2,nints-int+1) = pi - ab(1,int)
end do

end subroutine

subroutine jacobi_phase_solve(k,nints,ab,xscheb,aintr,aintr2,aintr3, &
  aintl,aintl2,aintl3,u,dnu,da,db,psivals,avals)
use chebyshev
implicit double precision (a-h,o-z)

integer                        :: nints
double precision               :: ab(2,nints),avals(k,nints),psivals(k,nints),u(k,k)
double precision               :: xscheb(k),aintr(k,k),aintr2(k,k),aintr3(k,k)
double precision               :: aintl(k,k),aintl2(k,k),aintl3(k,k)

!
!  Construct the nonoscillatory phase and amplitude functions for Jacobi's differential
!  equation.  These functions are represented via piecewise Chebyshev expansions given
!  on a collection of intervals.
!

double precision      :: valsmp(k,nints),valsmpp(k,nints),alphap(k,nints)

data  pi        / 3.14159265358979323846264338327950288d0 /
data  piovertwo / 1.57079632679489661923132169163975144d0 /

p    = dnu + (da+db+1)/2

!
!  Handle the case of large p by evaluating square of the amplitude function
!  and its first two derivatives at the point pi/8 and solving forward and
!  backwards from there
!
if (dnu .gt. 100) then

int0 = nints/2-2
call jacobi_asym_amp(dnu,da,db,c3_0,c2_0,c1_0)

!
!  Solve the ODE backwards, starting from pi/8
!

c1 = c1_0
c2 = c2_0
c3 = c3_0

do int=int0,1,-1
a = ab(1,int)
b = ab(2,int)
call jacobi_solve_back(dnu,da,db,a,b,k,xscheb,aintl,aintl2,aintl3, &
  aintr,aintr2,aintr3,c1,c2,c3,avals(1,int),valsmp(1,int),valsmpp(1,int))
c1 = valsmpp(1,int)
c2 = valsmp(1,int)
c3 = avals(1,int)
end do

!
!  Solve it going forward from pi/8
!

c1 = c1_0
c2 = c2_0
c3 = c3_0

do int=int0+1,nints
a = ab(1,int)
b = ab(2,int)
call jacobi_solve_forward(dnu,da,db,a,b,k,xscheb,aintl,aintl2,aintl3, &
  aintr,aintr2,aintr3,c1,c2,c3,avals(1,int),valsmp(1,int),valsmpp(1,int))
c1 = valsmpp(k,int)
c2 = valsmp(k,int)
c3 = avals(k,int)
end do

else

!
!  For p < 100 use Taylor expansions to evaluate M and its first two derivatives
!  at pi/64
!

int0 = nints/2-5
t    = ab(2,int0)
!t    = pi/64
call jacobi_taylor_m(dnu,da,db,t,c3_0,c2_0,c1_0)

!
!  Solve the ODE backwards
!

c1 = c1_0
c2 = c2_0
c3 = c3_0

do int=int0,1,-1
a = ab(1,int)
b = ab(2,int)
call jacobi_solve_back(dnu,da,db,a,b,k,xscheb,aintl,aintl2,aintl3, &
  aintr,aintr2,aintr3,c1,c2,c3,avals(1,int),valsmp(1,int),valsmpp(1,int))
c1 = valsmpp(1,int)
c2 = valsmp(1,int)
c3 = avals(1,int)
end do

!
!  Solve it going forward from pi/8
!

c1 = c1_0
c2 = c2_0
c3 = c3_0

do int=int0+1,nints
a = ab(1,int)
b = ab(2,int)
call jacobi_solve_forward(dnu,da,db,a,b,k,xscheb,aintl,aintl2,aintl3, &
  aintr,aintr2,aintr3,c1,c2,c3,avals(1,int),valsmp(1,int),valsmpp(1,int))
c1 = valsmpp(k,int)
c2 = valsmp(k,int)
c3 = avals(k,int)
end do

endif

!
!  Construct the phase function via integration
!

alphap = 1.0d0/avals
c1     = 0
do int=1,nints
a              = ab(1,int)
b              = ab(2,int)
psivals(:,int) = c1 + matmul((b-a)/2*aintl,alphap(:,int))
c1             = psivals(k,int)
end do

!
!  Translate the phase appropriately using Taylor and asymptotic expansions near 0
!

a2     = 0

if (dnu .le. 100) then
t      = 0.01d0
call jacobi_taylor_p(dnu,da,db,t,valp,derp,der2p)
call jacobi_taylor_q(dnu,da,db,t,valq,derq,der2q)
call chebpw_eval(nints,ab,k,xscheb,psivals,t,psival)
a2 = atan2(valq,valp)-psival

else

t    = 1/dnu
call jacobi_asym_pder(dnu,da,db,t,valp,derp)
!call jacobi_asym0(dnu,da,db,t,valp,derp)

y  = valp
yp = derp

call chebpw_eval(nints,ab,k,xscheb,avals,t,valm)
call chebpw_eval(nints,ab,k,xscheb,valsmp,t,valmp)
call chebpw_eval(nints,ab,k,xscheb,valsmpp,t,valmpp)
call chebpw_eval(nints,ab,k,xscheb,psivals,t,psival)

apval   = 1/valm
appval  = -valmp/valm**2
apppval = 2*valmp/valm**3 - valmpp/valm**2

c1 = y*sqrt(apval)
c2 = yp/sqrt(apval)+y*appval/(2*apval**(1.5d0))

a1  = sqrt(c1**2+c2**2)
a2  = atan2(c1,c2)

if(a2 .gt. pi) then
a1 = -a1
a2 = a2-pi
endif

if(a2 .le. 0) then
a1 = -a1
a2 = a2 + pi
endif
a2 = a2 - pi/2
a2 = a2 - psival

endif

psivals = psivals + a2
avals   = sqrt(avals)

!
!  Subtract dnu*t and divide by dnu
!

do int=1,nints
a = ab(1,int)
b = ab(2,int)
psivals(:,int) = psivals(:,int)/dnu    -  (xscheb*(b-a)/2+(b+a)/2)
end do

!
!  Convert to coefficient expansions
!

! do int=1,nints
! psivals(:,int) = matmul(u,psivals(:,int))
! avals(:,int)   = matmul(u,avals(:,int))
! end do

end subroutine

subroutine jacobi_solve_back(dnu,da,db,a,b,k,xs,aintl,atinl2,aintl3, &
  aintr,aintr2,aintr3,c1,c2,c3,valsm,valsmp,valsmpp)
implicit double precision (a-h,o-z)

double precision       :: aintr(k,k),aintr2(k,k),aintr3(k,k),xs(k)
double precision       :: aintl(k,k),aintl2(k,k),aintl3(k,k)
double precision       :: valsm(k),valsmp(k),valsmpp(k)

double precision :: qvals(k),qpvals(k),amatr(k,k),xx(k),xx2(k)
double precision :: sigma(k)

!
!  Solve the terminal value problem
!
!      M'''(t) 4 Q(t) M'(t) +  2 Q'(t) M(t) = 0
!      M(b) = c3,  M'(b) = c2, M''(b) = c1
!
!  on the interval (a,b).  The square of the amplitude function satisfies
!  this equation.
!

data  pi        / 3.14159265358979323846264338327950288d0 /
data  piovertwo / 1.57079632679489661923132169163975144d0 /

dd   = (b-a)/2
xx = xs*(b-a)/2 + (a-b)/2
xx2 = 0.125d0 * (a-b)**2 * (xs-1)**2

!
!  Evaluate Q and its derivative at the specified points
!

do i=1,k
t         = (b-a)/2 * xs(i) + (b+a)/2

qvals(i)  = dnu*(1+da+db+dnu)+((1+da+db-1.d0*(-da+  &
db)*Cos(t))*1/sin(t)**2)/2.d0-((1+da+db)*cos(t)/sin(t)-1.d0*(-da+db)*&
  1/sin(t))**2/4.d0

qpvals(i) = (((-2+4.d0*da**2+4.d0*db**2)*Cos(t)+(da-1.d0*db)*(da  &
+db)*(3+Cos(2.d0*t)))*1/sin(t)**3)/4.d0
end do

!
!  Form the linear system to solve ...
!

do i=1,k
amatr(i,:) = 4*qvals(i) *aintr2(i,:)*dd**2 + 2 * qpvals(i) * aintr3(i,:)*dd**3
end do
do i=1,k
amatr(i,i) = amatr(i,i)+ 1.0d0
end do

sigma = -4*qvals * ( c2 + c1 * xx ) - 2 * qpvals * (c3 + c2 * xx + c1 * xx2)

!
!  ... and solve it
!

call jacobi_phase_qrsolv(amatr,k,sigma)

valsmpp = c1 + matmul(aintr*dd,sigma)
valsmp  = c2 + matmul(aintr*dd,valsmpp)
valsm   = c3 + matmul(aintr*dd,valsmp)

end subroutine

subroutine jacobi_solve_forward(dnu,da,db,a,b,k,xs,aintl,aintl2,aintl3, &
  aintr,aintr2,aintr3,c1,c2,c3,valsm,valsmp,valsmpp)
implicit double precision (a-h,o-z)

double precision       :: aintl(k,k),aintl2(k,k),aintl3(k,k),xs(k)
double precision       :: aintr(k,k),aintr2(k,k),aintr3(k,k)
double precision       :: valsm(k),valsmp(k),valsmpp(k)

double precision       :: qvals(k),qpvals(k),amatr(k,k),xx(k),xx2(k)
double precision       :: sigma(k)

!
!  Solve the initial value problem
!
!      M'''(t) + 4 Q(t) M'(t) +  2 Q'(t) M(t) = 0
!      M(a) = c3,  M'(a) = c2, M''(a) = c1
!
!  on the interval (a,b).  The square of the amplitude function satisfies
!  this equation.
!

;double precision :: ones(k)

data  pi        / 3.14159265358979323846264338327950288d0 /
data  piovertwo / 1.57079632679489661923132169163975144d0 /

dd   = (b-a)/2

! ones = 1
! xx   = matmul(dd*aintl,ones)
! xx2   = matmul(dd*aintl,xx)

xx  = xs*(b-a)/2 + (b-a)/2
xx2 = 0.125d0 * (a-b)**2 * (xs+1)**2

!
!  Evaluate Q and its derivative at the specified points
!

do i=1,k
t         = (b-a)/2 * xs(i) + (b+a)/2

qvals(i)  = dnu*(1+da+db+dnu)+((1+da+db-1.d0*(-da+  &
db)*Cos(t))*1/sin(t)**2)/2.d0-((1+da+db)*cos(t)/sin(t)-1.d0*(-da+db)*&
  1/sin(t))**2/4.d0

qpvals(i) = (((-2+4.d0*da**2+4.d0*db**2)*Cos(t)+(da-1.d0*db)*(da  &
+db)*(3+Cos(2.d0*t)))*1/sin(t)**3)/4.d0

end do

!
!  Form the linear system to solve ...
!

do i=1,k
amatr(i,:) = 4*qvals(i) *aintl2(i,:)*dd**2 + 2 * qpvals(i) * aintl3(i,:)*dd**3
end do
do i=1,k
amatr(i,i) = amatr(i,i)+ 1.0d0
end do

sigma = -4*qvals * ( c2 + c1 * xx ) - 2 * qpvals * (c3 + c2 * xx + c1 * xx2)

!
!  ... and solve it
!

call jacobi_phase_qrsolv(amatr,k,sigma)

valsmpp = c1 + matmul(aintl*dd,sigma)
valsmp  = c2 + matmul(aintl*dd,valsmpp)
valsm   = c3 + matmul(aintl*dd,valsmp)

end subroutine

subroutine jacobi_phase_eval(chebdata,dnu,da,db,nints,ab,avals,psivals,nts,ts,avals0,psivals0)
use chebyshev
implicit double precision (a-h,o-z)

type(chebexps_data)                         :: chebdata
integer, intent(in)                         :: nints,nts
double precision, intent(in)                :: ab(2,nints),ts(nts)
double precision, intent(in)                :: avals(chebdata%k,nints)
double precision, intent(in)                :: psivals(chebdata%k,nints)
double precision, intent(out)               :: avals0(nts),psivals0(nts)

!
!  Evaluate the phase and amplitude functions associated with the data
!  generated by the jacobi_phase subroutine at a user-specified collection
!  of points in the interval (0,\pi).
!
!  IMPORTANT WARNING: the list of points must be sorted in INCREASING ORDER
!
!  Input parameters:
!    chebdata - a chebexps_data structure containing the information needed to
!       manipulate function represented by k-point Chebyshev expansions
!    (nints,ab) - the discretization scheme for the phase functions
!    (avals,psivals) - the representations of the phase and amplitude functions
!       generated by jacobi_phase
!
!    nts - the number of points at which to evaluate the Jacobi function
!     of the first kind
!    ts - a list of the points at which to evaluate the Jacobi function;
!     THESE MUST BE IN INCREASING ORDER
!
!  Output parameters:
!    avals - a user-supplied vector of length nts which will contain
!     the values of the amplitude function on return
!    psivals - a user-supplied vector of length nts which will contain
!     the values of the phase function on return
!

double precision, allocatable :: ts0(:)
data  pi        / 3.14159265358979323846264338327950288d0 /
data  piovertwo / 1.57079632679489661923132169163975144d0 /
data  log2      / 0.69314718055994530941723212145817657d0 /

p    = dnu + (da+db+1)/2
eps0 = epsilon(0.0d0)

! L^2 normalization
dconst  = sqrt( (2*dnu+da+db+1)/pi )

! Wronskian normalization
!dconst = 1

int0 = 1
k    = chebdata%k

do j=1,nts
t   = ts(j)

! u   = (t - 1.0d-7)/(pi/2-1.0d-7)
! ii  = log(u)/log2
! int = (phase%nints+ii)

do int=int0,nints-1
b = ab(2,int)
if (t .lt. b) exit
end do

a    = ab(1,int)
b    = ab(2,int)
int0 = int

! call chebeval(a,b,k,chebdata%xs,avals(:,int),t,aval)
! call chebeval(a,b,k,chebdata%xs,psivals(:,int),t,psival)

xx   = (2*t - (b+a) ) /(b-a)
sum1 = 0
sum2 = 0
sum3 = 0

dd1 = 1.0d0
do i=1,k
dd=1.0d0
if (i .eq. 1 .OR. i .eq. k) dd = 0.5d0
diff = xx-chebdata%xs(i)
!
!  Handle the case in which the target node coincides with one of
!  the Chebyshev nodes.
!

if(abs(diff) .le. eps0) then
aval   = avals(i,int)
psival = psivals(i,int)
goto 1000
endif

!
!  Otherwise, construct the sums.
!

dd   = (dd1*dd)/diff
dd1  = - dd1
sum1 = sum1+dd*avals(i,int)
sum2 = sum2+dd
sum3 = sum3+dd*psivals(i,int)
dd   = - dd
end do

aval    = sum1/sum2
psival  = sum3/sum2

1000 continue

psivals0(j) = (psival +t )*dnu
avals0(j)   = aval * dconst
end do

end subroutine

subroutine jacobi_phase_qrsolv(a,n,rhs)
implicit double precision (a-h,o-z)

integer            :: n
double precision   :: a(n,n),rhs(n)

!
!  This subroutine uses a version of QR-decomposition to solve the equation
!  A x = b.  The input matrix a is destroyed by this routine.
!
!  Input parameters:
!    a - the (n,n) matrix of coefficients WHICH WILL BE DESTROYED BY THIS
!     ROUTINE
!    n - an integer specifying the size of the system of
!    rhs - a vector of length n speciying the rhs of the system
!
!  Output parameters:
!   rhs - upon return, the solution of the linear system
!

double precision :: aa(2),u(2,2)

!
! transpose the input matrix a
!

size22=0
do i=1,n
do j=1,i
d=a(j,i)
a(j,i)=a(i,j)
a(i,j)=d
size22=size22+a(j,i)**2
size22=size22+a(i,j)**2
end do
end do

!
!  Reduce to upper triangular
!
do i=1,n-1
do j=n,i+1,-1
aa(1)=a(i,j-1)
aa(2)=a(i,j)

u22=-aa(1)
u12=aa(2)
d=u22**2+u12**2
if(d .lt. size22*1.0d-66) then
u(2,2)=1
u(1,2)=0
u(1,1)=1
u(2,1)=0
else
d=sqrt(d)
u(2,2)=u22/d
u(1,2)=u12/d
u(1,1)=-u(2,2)
u(2,1)=u(1,2)
endif

do ii=i,n
d1=u(1,1)*a(ii,j-1)+u(1,2)*a(ii,j)
d2=u(2,1)*a(ii,j-1)+u(2,2)*a(ii,j)
a(ii,j-1)=d1
a(ii,j)=d2
end do

d1=u(1,1)*rhs(j-1)+u(1,2)*rhs(j)
d2=u(2,1)*rhs(j-1)+u(2,2)*rhs(j)
rhs(j-1)=d1
rhs(j)=d2
end do
end do

!
!  Apply the inverse of the triangular matrix
!

rhs(n)=rhs(n)/a(n,n)
do i=n-1,1,-1
d=0
do j=n,i+1,-1
d=d+a(j,i)*rhs(j)
end do
rhs(i)=(rhs(i)-d)/a(i,i)
end do

end subroutine


	subroutine deriva4cuad(eta,deta,n,x)

	include 'PARAMETER'  !solo por kt
	integer n
	real*4 eta(4,4,n), deta(4,4,n), y(kt), dy(kt),x(*)
	integer indi(7),indj(7)
	data indi/1,1,1,1,2,2,3/
	data indj/1,2,3,4,3,4,4/

	do i=1,7
	   do ii=1,n
	      y(ii) = eta(indi(i),indj(i),ii)
	   enddo

	   call derivacuad(y,dy,n,x)

	   do ii=1,n
	      deta(indi(i),indj(i),ii) = dy(ii)
	   enddo
	enddo

	do i=1,n
	   deta(2,2,i) = deta(1,1,i)
	   deta(3,3,i) = deta(1,1,i)
	   deta(4,4,i) = deta(1,1,i)
	   deta(2,1,i) = deta(1,2,i)
	   deta(3,1,i) = deta(1,3,i)
	   deta(4,1,i) = deta(1,4,i)
	   deta(3,2,i) = -deta(2,3,i)
	   deta(4,2,i) = -deta(2,4,i)
	   deta(4,3,i) = -deta(3,4,i)
	enddo

	return
	end


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine gencycsymelemcfd(cs,islav,nslav,imast,nmast,inomat,
     &  nk,co,ne,ipkon,lakon,kon,nkon,ielmat,mi,vold,ielslav,ielmast,
     &  inoslav,inomast,iponoel,inoel)
!
!     creates an additional layer of elements on the slave and the
!     master surface of a cyclic symmetric structure
!
      implicit none
!
      character*8 lakon(*)
!
      integer imast(*),i,j,k,nmast,islav(*),nslav,
     &  nk,ne,ipkon(*),kon(*),nkon,
     &  mi(*),index,nodes,nodem,nope,
     &  ielmat(mi(3),*),indexe,inoslav(*),inomast(*),ielslav(*),
     &  ielmast(*),iponoel(*),inoel(3,*),nodeslav,nodemast,ielemslav,
     &  ielemmast,inomat(*)
!
      real*8 cs(17,*),phibasis,phi,xa(3),xn(3),dd,cphi,sphi,dphi,
     &  c(3,3),xp(3),xq(3),al,co(3,*),vold(0:mi(2),*)
!
!     mcs=1 is assumed
!     phi is the angle of the cyclic basis sector
!
      phibasis=8.d0*datan(1.d0)/cs(1,1)
!
!     xn is an normed vector along the axis
!     xa is a point on the axis
!
      do i=1,3
         xa(i)=cs(5+i,1)
         xn(i)=cs(8+i,1)-xa(i)
      enddo
      dd=dsqrt(xn(1)*xn(1)+xn(2)*xn(2)+xn(3)*xn(3))
      do i=1,3
         xn(i)=xn(i)/dd
      enddo
!
!     new nodes on the master side
!
!     phi is the thickness of the layer in radians
!
      phi=phibasis
      cphi=dcos(phi)
      sphi=dsin(phi)
      dphi=1.d0-cphi
!
!     rotation matrix
!
      c(1,1)=cphi+dphi*xn(1)*xn(1)
      c(1,2)=     dphi*xn(1)*xn(2)-sphi*xn(3)
      c(1,3)=     dphi*xn(1)*xn(3)+sphi*xn(2)
      c(2,1)=     dphi*xn(2)*xn(1)+sphi*xn(3)
      c(2,2)=cphi+dphi*xn(2)*xn(2)
      c(2,3)=     dphi*xn(2)*xn(3)-sphi*xn(1)
      c(3,1)=     dphi*xn(3)*xn(1)-sphi*xn(2)
      c(3,2)=     dphi*xn(3)*xn(2)+sphi*xn(1)
      c(3,3)=cphi+dphi*xn(3)*xn(3)
!
!     new nodes and elements on the master side
!
      do i=1,nmast
!
!        corresponding slave node
!
         nodeslav=inoslav(imast(i))
!
!        loop over all elements to which nodeslav belongs
!
         index=iponoel(nodeslav)
         if(index.eq.0) cycle
!
         do
            ielemslav=inoel(1,index)
            if(ielmast(ielemslav).eq.0) then
               read(lakon(ielemslav)(4:4),'(i1)') nope
               indexe=ipkon(ielemslav)
               do k=1,nope
                  nodes=kon(indexe+k)
                  if(inomast(nodes).eq.0) then
!
!                    generate new node on the master side
!
                     nk=nk+1
                     inomast(nodes)=nk
!
!                    calculating the coordinates of the node
!
                     do j=1,3
                        xp(j)=co(j,nodes)
                     enddo
!
                     al=(xp(1)-xa(1))*xn(1)+
     &                    (xp(2)-xa(2))*xn(2)+
     &                    (xp(3)-xa(3))*xn(3)
!
!                    xq is the orthogonal projection of xp on the axis
!
                     do j=1,3
                        xq(j)=xa(j)+al*xn(j)
                     enddo
!
                     do j=1,3
                        co(j,nk)=xq(j)+c(j,1)*(xp(1)-xq(1))+
     &                       c(j,2)*(xp(2)-xq(2))+
     &                       c(j,3)*(xp(3)-xq(3))
                     enddo
!
!                    initial conditions (global rectangular system)
!
                     do j=0,4
                        vold(j,nk)=vold(j,nodes)
                     enddo
!
!                    assign material to node
!
                     inomat(nk)=inomat(nodes)
!
                  endif
               enddo
!
!              create a new element on the master side
!
               ne=ne+1
               ielmast(ielemslav)=ne
               ipkon(ne)=nkon
               lakon(ne)=lakon(ielemslav)
               ielmat(1,ne)=ielmat(1,ielemslav)
               do j=1,nope
                  kon(nkon+j)=inomast(kon(indexe+j))
               enddo
               nkon=nkon+nope
            endif
!
            index=inoel(3,index)
            if(index.eq.0) exit
         enddo
      enddo
!
!     new nodes on the slave side
!
      phi=-phibasis
      cphi=dcos(phi)
      sphi=dsin(phi)
      dphi=1.d0-cphi
!
!     rotation matrix
!
      c(1,1)=cphi+dphi*xn(1)*xn(1)
      c(1,2)=     dphi*xn(1)*xn(2)-sphi*xn(3)
      c(1,3)=     dphi*xn(1)*xn(3)+sphi*xn(2)
      c(2,1)=     dphi*xn(2)*xn(1)+sphi*xn(3)
      c(2,2)=cphi+dphi*xn(2)*xn(2)
      c(2,3)=     dphi*xn(2)*xn(3)-sphi*xn(1)
      c(3,1)=     dphi*xn(3)*xn(1)-sphi*xn(2)
      c(3,2)=     dphi*xn(3)*xn(2)+sphi*xn(1)
      c(3,3)=cphi+dphi*xn(3)*xn(3)
!
!     new nodes and elements on the slave side
!
      do i=1,nslav
!
!        corresponding slave node
!
         nodemast=inomast(islav(i))
!
!        loop over all elements to which nodeslav belongs
!
         index=iponoel(nodemast)
         if(index.eq.0) cycle
!
         do
            ielemmast=inoel(1,index)
            if(ielslav(ielemmast).eq.0) then
               read(lakon(ielemmast)(4:4),'(i1)') nope
               indexe=ipkon(ielemmast)
               do k=1,nope
                  nodem=kon(indexe+k)
                  if(inoslav(nodem).eq.0) then
!
!                    generate new node on the master side
!
                     nk=nk+1
                     inoslav(nodem)=nk
!
!                    calculating the coordinates of the node
!
                     do j=1,3
                        xp(j)=co(j,nodem)
                     enddo
!
                     al=(xp(1)-xa(1))*xn(1)+
     &                    (xp(2)-xa(2))*xn(2)+
     &                    (xp(3)-xa(3))*xn(3)
!
!                    xq is the orthogonal projection of xp on the axis
!
                     do j=1,3
                        xq(j)=xa(j)+al*xn(j)
                     enddo
!
                     do j=1,3
                        co(j,nk)=xq(j)+c(j,1)*(xp(1)-xq(1))+
     &                       c(j,2)*(xp(2)-xq(2))+
     &                       c(j,3)*(xp(3)-xq(3))
                     enddo
!
!                    initial conditions (global rectangular system)
!
                     do j=0,4
                        vold(j,nk)=vold(j,nodem)
                     enddo
!
!                    assign material to node
!
                     inomat(nk)=inomat(nodem)
!
                  endif
               enddo
!
!              create a new element on the slave side
!
               ne=ne+1
               ielslav(ielemmast)=ne
               ipkon(ne)=nkon
               lakon(ne)=lakon(ielemmast)
               ielmat(1,ne)=ielmat(1,ielemmast)
               do j=1,nope
                  kon(nkon+j)=inoslav(kon(indexe+j))
               enddo
               nkon=nkon+nope
            endif
!
            index=inoel(3,index)
            if(index.eq.0) exit
         enddo
      enddo
!
      return
      end


C SUBROUTINE CHIFIT.F
C
C SOURCE
C   BEVINGTON, PAGES 228-231.
C
C PURPOSE
C   MAKE A LEAST-SQUARES FIT TO A NON-LINEAR FUNCTION
C      WITH A PARABOLIC EXPANSION OF CHI SQUARE
C
C USAGE
C   CALL CHIFIT (X, Y, SIGMAY, NPTS, NTERMS, MODE, A, DELTAA,
C      SIGMAA, YFIT, CHISQR)
C
C DESCRIPTION OF PARAMETERS
C   X      - ARRAY OF DATA POINTS FOR INDEPENDENT VARIABLE
C   Y      - ARRAY OF DATA POINTS FOR DEPENDENT VARIABLE
C   SIGMAY - ARRAY OF STANDARD DEVIATIONS FOR Y DATA POINTS
C   NPTS   - NUMBER OF PAIRS OF DATA POINTS
C   NTERMS - NUMBER OF PARAMETERS
C   MODE   - DETERMINES METHOD OF WEIGHTING LEAST-SQUARES FIT
C            +1 (INSTRUMENTAL) WEIGHT(I) = 1./SIGMAY(I)**2
C             0 (NO WEIGHTING) WEIGHT(I) = 1.
C            -1 (STATISTICAL)  WEIGHT(I) = 1./Y(I)
C   A      - ARRAY OF PARAMETERS
C   DELTAA - ARRAY OF INCREMENTS FOR PARAMETERS A
C   SIGMAA - ARRAY OF STANDARD DEVIATIONS FOR PARAMETERS A
C   YFIT   - ARRAY OF CALCULATED VALUES OF Y
C   CHISQR - REDUCED CHI SQUARE FOR FIT
C
C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C   FUNCTN (X, I, A)
C      EVALUATES THE FITTING FUNCTION FOR THE ITH TERM
C   FCHISQ (Y, SIGMAY, NPTS, NFREE, MODE, YFIT)
C      EVALUATES REDUCED CHI SQUARED FOR FIT TO DATA
C   MATINV (ARRAY, NTERMS, DET)
C      INVERTS A SYMMETRIC TWO-DIMENSIONAL MATRIX OF DEGREE NTERMS
C      AND CALCULATES ITS DETERMINANT
C
C COMMENTS
C   DIMENSION STATEMENT VALID FOR NTERMS UP TO 10
C
      SUBROUTINE CHIFIT (X,Y,SIGMAY,NPTS,NTERMS,MODE,A,DELTAA,
     *SIGMAA,YFIT,CHISQR)
      DOUBLE PRECISION ALPHA
      DIMENSION X(1),Y(1),SIGMAY(1),A(1),DELTAA(1),SIGMAA(1),
     *YFIT(1)
      DIMENSION ALPHA(10,10),BETA(10),DA(10)
      REAL FUNCTN
      EXTERNAL FUNCTN
C
11    NFREE=NPTS-NTERMS
      FREE=NFREE
      IF (NFREE) 14,14,16
14    CHISQR=0.
      GOTO 120
16    DO 17 I=1,NPTS
17    YFIT(I)=FUNCTN (X,I,A)
      CHISQ1=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT)
C
C EVALUATE ALPHA AND BETA MATRICES
C
20    DO 60 J=1,NTERMS
C
C A(J) + DELTAA(J)
C
21    AJ=A(J)
      A(J)=AJ+DELTAA(J)
      DO 24 I=1,NPTS
24    YFIT(I)=FUNCTN (X,I,A)
      CHISQ2=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT)
      ALPHA(J,J)=CHISQ2-2.*CHISQ1
      BETA(J)=-CHISQ2
31    DO 50 K=1,NTERMS
      IF (K-J) 33,50,36
33    ALPHA(K,J)=(ALPHA(K,J)-CHISQ2)/2.
      ALPHA(J,K)=ALPHA(K,J)
      GOTO 50
36    ALPHA(J,K)=CHISQ1-CHISQ2
C
C A(J) + DELTAA(J) AND A(K) + DELTAA(K)
C
41    AK=A(K)
      A(K)=AK+DELTAA(K)
      DO 44 I=1,NPTS
44    YFIT(I)=FUNCTN (X,I,A)
      CHISQ3=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT)
      ALPHA(J,K)=ALPHA(J,K)+CHISQ3
      A(K)=AK
50    CONTINUE
C
C A(J) - DELTAA(J)
C
51    A(J)=AJ-DELTAA(J)
      DO 53 I=1,NPTS
53    YFIT(I)=FUNCTN (X,I,A)
      CHISQ3=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT)
      A(J)=AJ
      ALPHA(J,J)=(ALPHA(J,J)+CHISQ3)/2.
      BETA(J)=(BETA(J)+CHISQ3)/4.
60    CONTINUE
C
C ELIMINATE NEGATIVE CURVATURE
C
61    DO 70 J=1,NTERMS
      IF (ALPHA(J,J)) 63,65,70
63    ALPHA(J,J)=-ALPHA(J,J)
      GOTO 66
65    ALPHA(J,J)=0.01
C Changed from DO 70
66    DO 700 K=1,NTERMS
C Changed from 68, 70, 68
      IF (K-J) 68,700,68
68    ALPHA(J,K)=0.
      ALPHA(K,J)=0.
C New continuation statement
700   CONTINUE
70    CONTINUE
C
C INVERT MATRIX AND EVALUATE PARAMETER INCREMENTS
C
71    CALL MATINV (ALPHA,NTERMS,DET)
      DO 76 J=1,NTERMS
      DA(J)=0.
74    DO 75 K=1,NTERMS
75    DA(J)=DA(J)+BETA(K)*ALPHA(J,K)
76    DA(J)=0.2*DA(J)*DELTAA(J)
C
C MAKE SURE CHI SQUARE DECREASES
C
81    DO 82 J=1,NTERMS
82    A(J)=A(J)+DA(J)
83    DO 84 I=1,NPTS
84    YFIT(I)=FUNCTN (X,I,A)
      CHISQ2=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT)
      IF (CHISQ1-CHISQ2) 87,91,91
87    DO 89 J=1,NTERMS
      DA(J)=DA(J)/2.
89    A(J)=A(J)-DA(J)
      GOTO 83
C
C INCREMENT PARAMETERS UNTIL CHI SQUARE STARTS TO INCREASE
C
91    DO 92 J=1,NTERMS
92    A(J)=A(J)+DA(J)
      DO 94 I=1,NPTS
94    YFIT(I)=FUNCTN (X,I,A)
      CHISQ3=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT)
      IF (CHISQ3-CHISQ2) 97,101,101
97    CHISQ1=CHISQ2
      CHISQ2=CHISQ3
99    GOTO 91
C
C FIND MINIMUM OF PARABOLA DEFINED BY LAST THREE POINTS
C
101   DELTA=1./(1.+(CHISQ1-CHISQ2)/(CHISQ3-CHISQ2))+0.5
      DO 104 J=1,NTERMS
      A(J)=A(J)-DELTA*DA(J)
104   SIGMAA(J)=DELTAA(J)*SQRT(FREE*ALPHA(J,J))
      DO 106 I=1,NPTS
106   YFIT(I)=FUNCTN (X,I,A)
      CHISQR=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT)
111   IF (CHISQ2-CHISQR) 112,120,120
112   DO 113 J=1,NTERMS
113   A(J)=A(J)+(DELTA-1.)*DA(J)
      DO 115 I=1,NPTS
115   YFIT(I)=FUNCTN (X,I,A)
      CHISQR=CHISQ2
120   RETURN
      END


	SUBROUTINE RU_WIND  ( field, wnknot, dir, spd, iret )
C************************************************************************
C* RU_WIND								*
C*									*
C* This subroutine decodes a wind field in the form ddfff where dd	*
C* is the direction in tens of degrees and fff is the wind speed.	*
C* The units value of the direction rounded to the nearest 5 degrees	*
C* has been multiplied by 100 and added to fff.				*
C*									*
C* RU_WIND  ( FIELD, WNKNOT, DIR, SPD, IRET )				*
C*									*
C* Input parameters:							*
C*	FIELD		CHAR*		Encoded field			*
C*	WNKNOT		LOGICAL		Speed in knots flag		*
C*									*
C* Output parameters:							*
C*	DIR		REAL		Direction			*
C*	SPD		REAL		Speed in meters/sec		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 2/86						*
C* D. Kidwell/NCEP	 3/01	Added check for '31313'                 *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	field
	LOGICAL		wnknot
C------------------------------------------------------------------------
	iret = 0
C*
	dir = RMISSD
	spd = RMISSD
C
C*	The tens and hundreds of the wind direction is encoded in the
C*	first two digits.  Skip processing if direction is missing.
C
	CALL ST_INTG  ( field (1:2), idir, ier )
	IF  ( ier .ne. 0 )  THEN
	    RETURN
	  ELSE
	    idir = idir * 10
	END IF
C
C*	The wind speed is encoded in the last three digits.
C
	CALL ST_INTG  ( field (3:5), ispd, ier )
	IF  ( ier .ne. 0 )  THEN
	    RETURN
	  ELSE
C
C*	    The units value of the direction rounded to 0 or 5 is
C*	    multiplied by 100 and added to the wind speed.
C
	    IF  ( ispd .ge. 500 )  THEN
		ispd = ispd - 500
		idir = idir + 5
	    END IF
	END IF
C
C*	Set the output values.  Return missing data if direction is
C*	greater than 360 or field is '31313'.
C
	IF ( ( idir .le. 360 ) .and. ( field (1:5) .ne. '31313' ) ) THEN
	    spd = FLOAT ( ispd )
	    IF ( wnknot ) spd = PR_KNMS ( spd )
	    dir = FLOAT ( idir )
	    IF  ( dir .eq. 360. ) dir = 0.
	END IF
C*
	RETURN
	END


      subroutine fftdf(a,n,nskip,mtrn,mskip,isign,fac,
     >                 irev,btrv,ierr,ireal)
      double precision a(1), fac(1)
      integer          btrv(1), n, nskip, mtrn, mskip, isign
      integer          irev, ierr, ireal
c
c     fftdf performs multiple complex-complex or real-complex fast
c     fourier transforms by decimation in frequency. initialization is
c     performed by calling fftdf with isign = 0.  Note that the fortran
c     version does not actually use the btrv array.
c
c     a            double precision complex n + 1, real 2*(n+1)
c                  the array of transforms.
c
c     nskip        skip between adjacent points of a transform (complex)
c
c     mtrn         number of transforms to do.
c
c     mskip        skip between starting elements of adjacent transforms
c
c     isign        sign (+/-1) of exponent/direction of transform
c                  forward = -1, back = +1
c
c     fac          array of exponential factors of length 6*n calculated
c                  during the initialization call (isign=0)
c
c     irev         1 to do the bitreverse, 0 to skip it
c
c     btrv         index array for bitreverse on length n
c
c     ierr         return error condition
c
c     ireal        0 = complex-complex, 1 = real-complex
c
c
c
c
c     fourier-space representation
c
c     real-complex
c
c     for a real array of length n, an array of length n+2 (n/2+1
c     complex numbers) is needed in fourier space
c
c         k:      0  1   2  ...   n/2-1  n/2
c         index:  1  2   3  ...   n/2    n/2+1
c
c     complex-complex:
c
c         k:      0   1   2  ...  n/2-1  +-n/2  -(n/2-1) ...  -2   -1
c         index:  1   2   3  ...  n/2    n/2+1   n/2+2   ...  n-1   n
c
c     the index n/2+1 in the complex-complex fft corresponds to the
c     aliased (+/-)n/2 mode and should be ignored (set to zero)
c
c
c
c     Things to be kept in mind:
c
c     1. To transform from Physical-Fourier space, use isign = -1,
c        which corresponds to a negative exponent exp(-i*pi*n/N).
c
c     2. After the forward and back transforms, the data must be div-
c        ided through by N for the complex-complex routines and 4*N
c        for the real-complex routines.
c
c=====================================================================
c
      if (isign.eq.0) then
         call facinit(fac,n)
         return
      endif
      if (ireal.eq.1) then
         call fealft(a,n,nskip,mtrn,mskip,isign,fac,
     >               irev,btrv,ierr)
      else
         call ftsdf(a,n,nskip,mtrn,mskip,isign,fac,
     >              irev,btrv,ierr)
      endif
      return
      end
c
c=====================================================================
c
c     real-complex decimation-in-frequency
c
      subroutine fealft (data,n,nskip,mtrn,mskip,isign,
     >                   fac,irev,btrv,ierr)
      double precision  data(1)
      double precision  fac (1)
      integer           btrv(1), n, nskip, mtrn, mskip, isign
     >                  irev, ierr
c
c     internal variables
c
      double precision  wr, wi, wpr, wpi, wtemp, theta
      double precision  h1r, h1i, h2r, h2i
      double precision  c1, sfac
      integer           itrn, ib, i, i1, i2, i3, i4, n2p3
c
c     constants
c
      double precision  pi
      parameter (pi=3.141592653589793238463d0)
c
      theta = pi / dble(n)
      c1    = dble(isign)
      if (isign.eq.-1) then
         call ftsdf(data,n,nskip,mtrn,mskip,isign,fac,
     >        irev,btrv,ierr)
      endif
c
c     main loop over transforms
c
      do itrn = 1, mtrn
         wpr  = dcos(theta)
         wpi  = dsin(theta)
         wr   = wpr
         wi   = wpi
         ib   = (itrn-1)*mskip
         n2p3 = n + 2
         do i = 2, ishft(n,-1)
c
            i1  = ishft((i-1)*nskip+ib,1) + 1
            i2  = i1 + 1
            i3  = ishft((n2p3-i-1)*nskip + ib,1) + 1
            i4  = i3 + 1
c
            h1r      =  data(i1) + data(i3)
            h1i      =  data(i2) - data(i4)
            h2r      =  data(i2) + data(i4)
            h2i      =  data(i1) - data(i3)
c
            data(i1) =  h1r - wi * h2i - c1 * wr * h2r
            data(i2) =  h1i - wi * h2r + c1 * wr * h2i
            data(i3) =  h1r + wi * h2i + c1 * wr * h2r
            data(i4) = -h1i - wi * h2r + c1 * wr * h2i
c
            wtemp = wr
            wr    = wr * wpr - wi    * wpi
            wi    = wi * wpr + wtemp * wpi
         enddo
c
         if (isign.eq.-1) then
            i1       = ishft(ib,1) + 1
            i2       = i1 + 1
            i3       = i1 + n*nskip
            i4       = i3 + 1
            h1r      = data(i1)
            h1i      = data(i2)
            data(i1) = 2.d0 * (h1r + h1i)
            data(i2) = 2.d0 * (h1r - h1i)
            data(i3) =  2.d0* data(i3)
            data(i4) = -2.d0* data(i4)
         else
            i1       = ishft(ib,1) + 1
            i2       = i1 + 1
            i3       = i1 + n*nskip
            i4       = i3 + 1
            h1r      = data(i1)
            h1i      = data(i2)
            data(i1) = h1r + h1i
            data(i2) = h1r - h1i
            data(i3) =  2.d0 * data(i3)
            data(i4) = -2.d0 * data(i4)
         endif
      enddo
      if (isign.eq.1) then
            call ftsdf(data,n,nskip,mtrn,mskip,isign,fac,
     >           irev,btrv,ierr)
         endif
      return
      end
c
c
c=====================================================================
c
c     complex-complex decimation-in-frequency
c
      subroutine ftsdf(data,n,nskip,mtrn,mskip,isign,
     >                 fac,irev,btrv,ierr)
      double precision  data(1)
      double precision  fac (1)
      integer           btrv(1), n, nskip, mtrn, mskip, isign
      integer           irev, ierr
c
c     internal variables
c
      double precision  tmpr, tmpi, exr, exi, hr, hi
      integer           itrn, ill, ilog, idexj, iss, i, j, mmax
      integer           istep, ib, m, i1, i2, j1, j2
c
c     constants
c
      double precision  pi, l2
      parameter (pi=3.141592653589793238463d0,
     >           l2=1.442695040888963407359d0)

c
c     calculate log(n)
c
      ilog = int(dlog(dble(n))*l2 + 0.01d0)
c
c     set starting point in exponential factor array
c
      if (isign.eq.1) then
         iss = ishft(n-1,1)
      else
         iss = 0
      endif
c
c     main loop over transforms
c
      do itrn = 1, mtrn
         mmax  = n
         ill   = ilog + 1
         ib    = (itrn-1) * mskip
 101     continue
         ill   = ill - 1
         istep = mmax
         mmax  = ishft(mmax,-1)
         idexj = ishft(2,ill-1) - 1 + iss
         do m  = 1, mmax
            exr  = fac(idexj)
            exi  = fac(idexj+1)
            do i = m, n, istep
c
               j  = i + mmax
               i1 = ishft(ib + (i - 1) * nskip,1) + 1
               i2 = i1 + 1
               j1 = ishft(ib + (j - 1) * nskip,1) + 1
               j2 = j1 + 1
c
               tmpr     = data(i1) - data(j1)
               tmpi     = data(i2) - data(j2)
               data(i1) = data(i1) + data(j1)
               data(i2) = data(i2) + data(j2)
               data(j1) = exr * tmpr - exi * tmpi
               data(j2) = exr * tmpi + exi * tmpr
c
            enddo
            idexj = idexj + 2
         enddo
c
         if(mmax.gt.1) goto 101
c
c     do the bit reverse
c
         if (irev.eq.0) goto 999
         j = 1
         do i = 1, n
            if(j.gt.i)then
               i1       = ishft(ib + (i-1) * nskip,1) + 1
               i2       = i1 + 1
               j1       = ishft(ib + (j-1) * nskip,1) + 1
               j2       = j1 + 1
               tmpr     = data(j1)
               tmpi     = data(j2)
               data(j1) = data(i1)
               data(j2) = data(i2)
               data(i1) = tmpr
               data(i2) = tmpi
            endif
            m = ishft(n,-1)
 888        if((m.ge.2).and.(j.gt.m)) then
               j = j - m
               m = ishft(m,-1)
               go to 888
            endif
            j = j + m
         enddo
 999     continue
      enddo
      return
      end
c
c
c=====================================================================
c
c     precalculate exponential factors
      subroutine facinit (fac, n)
      double precision fac(1)
      integer           n
c
c     internal variables
c
      double precision er,ei,epr,epi,etemp,theta,eps
      integer           nn, inf, isign, mmax, m
c
c     constants
c
      double precision  pi
      parameter (pi=3.141592653589793238463d0)
c
      nn    = ishft(n,1)
      eps   = 9.d-16
      inf   = 1
      isign = -1
 3    continue
      mmax  = 2
 2    if (nn.gt.mmax) then
         theta = 2.d0 * pi / dble(isign*mmax)
         epr   = dcos(theta)
         epi   = dsin(theta)
         er    = 1.d0
         ei    = 0.d0
         do m = 1, mmax, 2
            if (dabs(er).lt.eps) er = 0.0d0
            if (dabs(ei).lt.eps) ei = 0.0d0
            fac(inf)   = er
            fac(inf+1) = ei
            etemp      = er
            er         = er * epr - ei * epi
            ei         = ei * epr + etemp * epi
            inf        = inf + 2
         enddo
         mmax = ishft(mmax,1)
         go to 2
      endif
      if (isign.lt.0) then
         isign = 1
         goto 3
      endif
c
c     this section is to generate the additional factors needed for
c     real-complex
c
      inf   = ishft(n,2)
      isign = -1
 33   continue
      mmax  = nn
      theta = 2.d0 * pi / dble(isign*mmax)
      epr   = dcos(theta)
      epi   = dsin(theta)
      er    = epr
      ei    = epi
      do m = 2, ishft(n,-1)
         if (dabs(er).lt.eps) er = 0.0d0
         if (dabs(ei).lt.eps) ei = 0.0d0
         fac(inf)   = er
         fac(inf+1) = ei
         etemp      = er
         er         = er * epr - ei * epi
         ei         = ei * epr + etemp * epi
         inf        = inf + 2
      enddo
      if (isign.lt.0) then
         isign = 1
         goto 33
      endif
      return
      end


c
c --------------------------------------------------------------
c
      subroutine bdcrse( xleft,xright,ybot,ytop,hx,hy,time,intime,
     1                   level,nvar,lw2,valdub,midub,mjdub,valbig,
     2                   mi2tot,mj2tot,irr,mitot,mjtot)
c
c  bdcrse: first set double the stencil size worth of boundary values,
c          then coarsen them for the giant step integration.
c
      implicit double precision (a-h,o-z)
      include "cirr.i"
      dimension valdub(midub,mjdub,nvar), valbig(mi2tot,mj2tot,nvar),
     1          irr(mitot,mjtot)

c     left boundary

      xl = xleft - lw2*hx
      yb = ybot - lw2*hy
      xr = xleft
      yt = ytop

      call filpc(xl,xr,yb,yt,level,nvar,valdub,time,intime,midub,
     1           mjdub,1,lw2,1,mjdub-lw2,irr,mitot,mjtot)

c     right boundary

      xl = xright
      yb = ybot
      xr = xright + lw2*hx
      yt = ytop + lw2*hy

      call filpc(xl,xr,yb,yt,level,nvar,valdub,time,intime,midub,
     1           mjdub,midub-lw2+1,midub,lw2+1,mjdub,irr,mitot,mjtot)

c     bottom boundary

      xl = xleft
      yb = ybot - lw2*hy
      xr = xright + lw2*hx
      yt = ybot

      call filpc(xl,xr,yb,yt,level,nvar,valdub,time,intime,midub,
     1           mjdub,lw2+1,midub,1,lw2,irr,mitot,mjtot)

c     top boundary

      xl = xleft - lw2*hx
      yb = ytop
      xr = xright
      yt = ytop + lw2*hy

      call filpc(xl,xr,yb,yt,level,nvar,valdub,time,intime,midub,
     1           mjdub,1,midub-lw2,mjdub-lw2+1,mjdub,irr,mitot,mjtot)

c
c now coarsen by 2 in every direction - conservatively, so that
c irregular and exterior cells count appropriately.
c irr array only exists for lwidth, not 2*lwidth sized grid.
c boundary cells not done correctly here.
c
      lwidth = lw2 / 2
      ar(-1) = 0.d0
      do 100 ivar = 1,nvar
      do 100 j = 1, mj2tot
         jfine = 2*(j - 1) + 1
         do 100 i = 1, mi2tot
            ifine = 2*(i - 1) + 1
	    tarea = 0.d0
	    if ((ifine .le. lwidth) .or. (jfine .le. lwidth) .or.
     .          (ifine+1 .gt. midub-lwidth) .or.
     .          (jfine+1 .gt. mjdub-lwidth)) then
	       a11 = 1.d0
	       a21 = 1.d0
	       a12 = 1.d0
	       a22 = 1.d0
	    else
	       ieff = ifine - lwidth
	       jeff = jfine - lwidth
	       a11   = ar(irr(ieff,jeff))
	       a21   = ar(irr(ieff+1,jeff))
	       a12   = ar(irr(ieff,jeff+1))
	       a22   = ar(irr(ieff+1,jeff+1))
	    endif
c
	    tarea = a11+a12+a21+a22
c
            if (tarea .eq. 0.d0) then
	      valbig(i,j,ivar) = valdub(ifine,jfine,ivar)
	    else
              valbig(i,j,ivar)=(valdub(ifine,jfine,ivar)*a11 +
     &                    valdub(ifine+1,jfine,ivar)*a21+
     &                    valdub(ifine,jfine+1,ivar)*a12 +
     &                    valdub(ifine+1,jfine+1,ivar)*a22)/tarea
	    endif
100   continue
c
c  external boundary conditions
c
       lwidth = lw2 / 2
       hx2    = 2.d0*hx
       hy2    = 2.d0*hy
       xl = xleft  - lwidth*hx2
       yb = ybot   - lwidth*hy2
       xr = xright + lwidth*hx2
       yt = ytop   + lwidth*hy2
       call physbd(xl,xr,yb,yt,level,mi2tot,mj2tot,nvar,valbig,
     1             time,hx2,hy2)
c
      return
      end