c
      program qg1l_dp
c
c -------------------------------
c  Public distribution copy of quasigeostrophic model code used for the calculations described by:
c
c       Samelson, R. M., D. B. Chelton, and M. G. Schlax, 2019.  The ocean mesoscale regime
c         of the reduced-gravity quasi-geostrophic model.  J. Phys. Oceanogr., 49, 2469–2498,
c         DOI: 10.1175/JPO-D-18-0260.1.
c
c   This version adds code for netcdf output files.   RMS  24 Jan 2020
c   Example compile command:
c    gfortran -I/usr/local/include -L/usr/local/lib -lnetcdf -lnetcdff qg1ldp_rf_nc.f ../../fft_src/fft99f.f -o qg1ldp_rf_nc.x
c
c  Copyright 2019, 2020 Roger M. Samelson
c
c Permission is hereby granted, free of charge, to any person obtaining a copy of this software
c  and associated documentation files (the "Software"), to deal in the Software without restriction,
c  including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense,
c  and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so,
c  subject to the following conditions:
c
c The above copyright notice and this permission notice shall be included in all copies or substantial
c  portions of the Software.
c
c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT
c  LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
c  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
c  WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
c  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
c ----------------------
c
c     This code uses the fft99f.f two-dimensional Fast Fourier Transform routine.  The version
c      that has been used for the published calculations with this code was obtained from
c      dsl@ncar.ucar.edu on Monday 9 September 1991 and contains the following history comments:
C      PACKAGE FFT99F HISTORY:
C              THE PACKAGE WAS WRITTEN BY CLIVE TEMPERTON AT ECMWF IN
C              NOVEMBER, 1978.  IT WAS MODIFIED, DOCUMENTED, AND TESTED
C              FOR NCAR BY RUSS REW IN SEPTEMBER, 1980.
c
c -------------------------------
c
c   Code history
c
c    Recent modifications for calculations described in Samelson et al. (2019)
c
c     RMS Dec 2017:  convert to doubly periodic from qg1lc_rf.f
c
c     RMS Oct 2017:  add random forcing
c                    convert to 1-layer model from qg2lc_rf.f
c
c    Original source and previous modifications
c
c     The two-layer quasi-geostrophic model code that is the original source for this code
c      was written by R. M. Samelson to perform the calculations described by:
c       Samelson, R. M., and J. Pedlosky, 1990. Local baroclinic instability of flow over
c         variable topography. Journal of Fluid Mechanics, 221, 411-436.
c       Oh, S. P., J. Pedlosky, and R. M. Samelson, 1993. Linear and finite-amplitude localized
c         baroclinic instability. Journal of the Atmospheric Sciences, 50(16), 2772-2784.
c
c     This version has been modified by Karl Helfrich from
c     the original code written by Roger Samelson.
c     KRH 10/92
c
c	  The Roberts scheme for controlling the saw-tooth
c	  computational instability has been added.
c	  KRH 11-12-92
c
c     This version has friction in the from of
c     a hyperviscosity = -r del^6 psi_n
c     KRH 12-23-93
c
c  N - x, M - y, XK, XL wavenumber constants (= 2 pi/Lx or pi/Ly)
c
      parameter (N=256,M=128)
      real a0(N+2,M+2),a1(N+2,M+2),ap(N+2,M+2)
      real p1(N+2,M+2)
      real fcap0(N/2+1,M/2+1),phi_a(N/2+1,M/2+1,2)
      real force_a(N+2,M+2)
c netcdf file and variable ids
      integer ncid,psi_varid,Fcap0_varid,nrec
      common /dumdif/ ddum((2*N+2)*(2*M+2)+(N+2)*(M+2))
      common /dumjac/ dumj(4*(2*N+2)*(2*M+2))
      common /workft/ work((2*N+1)*2*M),trigs(3*N+1),ifax(13)
      common /workft2/ work2((2*M+1)*2*(N+2)),trigs2(3*M+1),ifax2(13)
c r: del^6; rek: del^2, rpsi: del^0
      common /frict/ ifrict,r,rek,rpsi
      common /parms/ xk,xl,dt,bb,f1,rob,twopi,dtn,c0_rf
c
c     if a continuation run set t=time of restart and icont=1
c
      data nt/5/,np/1/,ki/0/,io/1/,t/0./,icont/0/
c      data nt/50/,np/1/,ki/0/,io/1/,t/0./,icont/0/
c      data nt/400/,np/1/,ki/0/,io/1/,t/0./,icont/0/
c      data nt/2500/,np/1/,ki/0/,io/1/,t/0./,icont/0/
c
c
c --
      dt=0.002
c      j2m=int(1.0/dt+0.05)
      j2m=int(0.5/dt+0.05)
c      j2m=1
c  output file record time step
      dt_out=j2m*np*dt
c
c  beta parameter
      bb=0.616
c  F1=1 (L=L_R)
      f1=1
      xk=1./6.
      xl=2*1./6
c  Robert filter parameter for leapfrog time-stepping
c      rob=0.001
c  Friction parameters
      ifrict=2
      rpsi=0.0216
      rek=0.0
      r0_del6=0.00865
      r=400000*r0_del6/(xk**2*(N/2)**2+xl**2*(M/2)**2)**3
c      r=200000*rpsi/(xk**2*(N/2)**2+xl**2*(M/2)**2)**3
c  Forcing autocorrelation timescale, wavenumbers, and time-step
      tau=0.925
      f_amp=1./sqrt(tau)
      dxkf=1./3.
      xkf=1.0
      c0_rf=0.
      ndt=10
      dtn=dt/ndt
      rcap=(tau-0.5*dtn)/(tau+0.5*dtn)
c
c  Parameter rescaling following Appendix a. Scaling of Samelson et al. (2019).
c  No longer required because normalization of forcing (force_a,fcap0)
c   has been corrected in this version of the code.
c  Default parameter values in code were computed by this rescaling
c   with F_stddev=0.89.
c
c     Acap_F=F_stddev**(2./3.)
c     bb=0.57/Acap_F
c     tau=1.00*Acap_F
c     rpsi=0.020/Acap_F
c     r0_del6=0.008/Acap_F
c
c --
c
      call init(ki,N+2,M+2,a0,a1,ap,icont)
      call rforc_init(N+2,M+2,N/2+1,M/2+1,xkf,dxkf,fcap0,force_a)
c
c
c      write(20,'(1x,2i5,8f10.5)') N,M,DT,XK,XL
c      write(20,'(1x,8e15.5)') BB,F1,rpsi,rek,r
c      write(20,'(1x,4i5,f7.2)') nt,ki,io,np,t
c
      write(22,'(1x,2i5,8f10.5)') N,M,DT,XK,XL
      write(22,'(1x,8e15.5)') BB,F1,rpsi,rek,r
      write(22,'(1x,8e15.5)') f_amp,tau,dxkf,xkf,c0_rf
      write(22,'(1x,4i5,f7.2)') nt,ki,io,np,t
c
c  initialize netcdf file and write initial data
      call out_nc_init(ncid
     .,  bb,f1,xk,xl,dt,ifrict,rpsi,rek,r0_del6,r,tau,f_amp
     .,  dxkf,xkf,c0_rf,ndt,dtn,rcap,dt_out
     .,  N+2,M+2,psi_varid,Fcap0_varid,a0,force_a,p1)
c   netcdf file output record counter
      nrec=1
c
c      if(io.eq.1) call out(N+2,M+2,a0,p1,20)
c      if(io.eq.1) call out(N+2,M+2,force_a,p1,21)
c ***
      call intclc(N+2,M+2,a0,force_a,ep,ek,eq,ef)
      write(22,'(1x,e15.5,8(1x,e15.5))') t,ep,ek,eq,ef
      write( 6,'(1x,e15.5,8(1x,e15.5))') t,ep,ek,eq,ef
c ***
c  Start integration loop
c
c
      do 500 j1=1,nt
       do 400 j2=1,j2m
c  Runge-Kutta step
         call rkstep((N+2)*(M+2),t,a0,a1,ap)
c  Leapfrog time-step
c         call lfstep((N+2)*(M+2),t,a0,a1,ap)
c  Random forcing step
         call rforc_step(N+2,M+2,N/2+1,M/2+1,ndt,rcap,fcap0,phi_a
     .                   ,force_a,f_amp,a0)
400    continue
c ***
       call intclc(N+2,M+2,a0,force_a,ep,ek,eq,ef)
       write(22,'(1x,e15.5,8(1x,e15.5))') t,ep,ek,eq,ef
       write( 6,'(1x,e15.5,8(1x,e15.5))') t,ep,ek,eq,ef
c ***
c  write netcdf file record
      if(io.eq.1.and.((j1/np)*np).eq.j1) nrec=nrec+1
      if(io.eq.1.and.((j1/np)*np).eq.j1) call out_nc(ncid,nrec
     .,  N+2,M+2,psi_varid,Fcap0_varid,a0,force_a,p1)
c
c      if(io.eq.1.and.((j1/np)*np).eq.j1)call out(N+2,M+2,a0,p1,20)
c      if(io.eq.1.and.((j1/np)*np).eq.j1)call out(N+2,M+2,force_a,p1,21)
500   continue
c
c      close(20)
c      close(21)
      close(22)
      stop
      end

      subroutine rforc_init(nn,mm,n2,m2,xkf,dxkf,fcap0,force_a)
c      call with n2=nn/2,m2=mm/2
      real fcap0(n2,m2)
      real force_a(nn,mm)
      common /parms/ xk,xl,dt,bb,f1,rob,twopi,dtn,c0_rf
c
      fcap0sum=0.
      do l=0,m2-1
       k=0
       xkcap2=XK**2*k**2+XL**2*l**2
       fcap0(k+1,l+1)=
     .         max(0.,((xkf+dxkf)**2-xkcap2)*(xkcap2-(xkf-dxkf)**2))
       fcap0sum=fcap0sum+fcap0(k+1,l+1)**2
       k=n2-1
       xkcap2=XK**2*k**2+XL**2*l**2
       fcap0(k+1,l+1)=
     .         max(0.,((xkf+dxkf)**2-xkcap2)*(xkcap2-(xkf-dxkf)**2))
       fcap0sum=fcap0sum+fcap0(k+1,l+1)**2
      enddo
      do k=0,n2-1
       l=0
       xkcap2=XK**2*k**2+XL**2*l**2
       fcap0(k+1,l+1)=
     .         max(0.,((xkf+dxkf)**2-xkcap2)*(xkcap2-(xkf-dxkf)**2))
       fcap0sum=fcap0sum+fcap0(k+1,l+1)**2
       l=m2-1
       xkcap2=XK**2*k**2+XL**2*l**2
       fcap0(k+1,l+1)=
     .         max(0.,((xkf+dxkf)**2-xkcap2)*(xkcap2-(xkf-dxkf)**2))
       fcap0sum=fcap0sum+fcap0(k+1,l+1)**2
      enddo
      fcap0sum=2*fcap0sum
      do l=1,m2-2
        do k=1,n2-2
          xkcap2=XK**2*k**2+XL**2*l**2
          fcap0(k+1,l+1)=
     .         max(0.,((xkf+dxkf)**2-xkcap2)*(xkcap2-(xkf-dxkf)**2))
          fcap0sum=fcap0sum+4.*fcap0(k+1,l+1)**2
        enddo
      enddo
      fcap0norm=1./sqrt(fcap0sum)
      write(6,*) fcap0norm
      do l=1,m2
        do k=1,n2
          fcap0(k,l)=fcap0norm*fcap0(k,l)
        enddo
      enddo
      do l=1,mm
        do k=1,nn
         force_a(k,l)=0.
        enddo
      enddo
      return
      end

      subroutine rforc_step(nn,mm,n2,m2,ndt,rcap,fcap0,phi_a
     .                     ,force_a,f_amp,a0)
c      call with n2=nn/2,m2=mm/2
      real a0(nn,mm)
      real fcap0(n2,m2),phi_a(n2,m2,2)
      real force_a(nn,mm)
      common /parms/ xk,xl,dt,bb,f1,rob,twopi,dtn,c0_rf
c
      do jdt=1,ndt
       force_a(1,1)=0.
       force_a(2,1)=0.
       force_a(1,2)=0.
       force_a(2,2)=0.
       call random_number(phi_a)
       do k=1,n2-1
         l=0
         cp1=cos(twopi*phi_a(k+1,l+1,1))
         sp1=sin(twopi*phi_a(k+1,l+1,1))
         cp2=1.
         force_a(2*k+1,2*l+1)=rcap*force_a(2*k+1,2*l+1)
     .+fcap0(k+1,l+1)*sqrt(1-rcap**2)*cp1*cp2
         force_a(2*k+2,2*l+1)=rcap*force_a(2*k+2,2*l+1)
     .+fcap0(k+1,l+1)*sqrt(1-rcap**2)*sp1*cp2
         l=m2-1
         cp1=cos(twopi*phi_a(k+1,l+1,1))
         sp1=sin(twopi*phi_a(k+1,l+1,1))
         cp2=1.
         force_a(2*k+1,2*l+1)=rcap*force_a(2*k+1,2*l+1)
     .+fcap0(k+1,l+1)*sqrt(1-rcap**2)*cp1*cp2
         force_a(2*k+2,2*l+1)=rcap*force_a(2*k+2,2*l+1)
     .+fcap0(k+1,l+1)*sqrt(1-rcap**2)*sp1*cp2
       enddo
       do l=1,m2-1
         k=0
         cp1=1.
         cp2=cos(twopi*phi_a(k+1,l+1,2))
         sp2=sin(twopi*phi_a(k+1,l+1,2))
         force_a(2*k+1,2*l+1)=rcap*force_a(2*k+1,2*l+1)
     .+fcap0(k+1,l+1)*sqrt(1-rcap**2)*cp1*cp2
         force_a(2*k+1,2*l+2)=rcap*force_a(2*k+1,2*l+2)
     .+fcap0(k+1,l+1)*sqrt(1-rcap**2)*cp1*sp2
         k=n2-1
         cp1=1.
         cp2=cos(twopi*phi_a(k+1,l+1,2))
         sp2=sin(twopi*phi_a(k+1,l+1,2))
         force_a(2*k+1,2*l+1)=rcap*force_a(2*k+1,2*l+1)
     .+fcap0(k+1,l+1)*sqrt(1-rcap**2)*cp1*cp2
         force_a(2*k+1,2*l+2)=rcap*force_a(2*k+1,2*l+2)
     .+fcap0(k+1,l+1)*sqrt(1-rcap**2)*cp1*sp2
       enddo
       do l=1,m2-2
         do k=1,n2-2
            cp1=cos(twopi*phi_a(k+1,l+1,1))
            sp1=sin(twopi*phi_a(k+1,l+1,1))
            cp2=cos(twopi*phi_a(k+1,l+1,2))
            sp2=sin(twopi*phi_a(k+1,l+1,2))
            force_a(2*k+1,2*l+1)=rcap*force_a(2*k+1,2*l+1)
     .+fcap0(k+1,l+1)*sqrt(1-rcap**2)*cp1*cp2
            force_a(2*k+2,2*l+1)=rcap*force_a(2*k+2,2*l+1)
     .+fcap0(k+1,l+1)*sqrt(1-rcap**2)*sp1*cp2
            force_a(2*k+1,2*l+2)=rcap*force_a(2*k+1,2*l+2)
     .+fcap0(k+1,l+1)*sqrt(1-rcap**2)*cp1*sp2
            force_a(2*k+2,2*l+2)=rcap*force_a(2*k+2,2*l+2)
     .+fcap0(k+1,l+1)*sqrt(1-rcap**2)*sp1*sp2
         enddo
       enddo
      enddo

c c  zonal propagation
c        do l=1,m2
c          do k=1,n2
c             cp1=cos(xk*k*c0_rf*dtn)
c             sp1=sin(xk*k*c0_rf*dtn)
c             fa_temp=
c      .    cp1*force_a(2*k+1,2*l+1)+sp1*force_a(2*k+2,2*l+1)
c             force_a(2*k+2,2*l+1)=
c      .   -sp1*force_a(2*k+1,2*l+1)+cp1*force_a(2*k+2,2*l+1)
c             force_a(2*k+1,2*l+1)=fa_temp
c             fa_temp=
c      .    cp1*force_a(2*k+1,2*l+2)+sp1*force_a(2*k+2,2*l+2)
c             force_a(2*k+2,2*l+2)=
c      .   -sp1*force_a(2*k+1,2*l+2)+cp1*force_a(2*k+2,2*l+2)
c             force_a(2*k+1,2*l+2)=fa_temp
c          enddo
c        enddo
c       enddo
c

      do l=0,m2-1
        do k=0,n2-1
          a0(2*k+1,2*l+1)=a0(2*k+1,2*l+1)
     .     -dt*f_amp*force_a(2*k+1,2*l+1)/(XK**2*k**2+XL**2*l**2+F1)
          a0(2*k+2,2*l+1)=a0(2*k+2,2*l+1)
     .     -dt*f_amp*force_a(2*k+2,2*l+1)/(XK**2*k**2+XL**2*l**2+F1)
          a0(2*k+1,2*l+2)=a0(2*k+1,2*l+2)
     .     -dt*f_amp*force_a(2*k+1,2*l+2)/(XK**2*k**2+XL**2*l**2+F1)
          a0(2*k+2,2*l+2)=a0(2*k+2,2*l+2)
     .     -dt*f_amp*force_a(2*k+2,2*l+2)/(XK**2*k**2+XL**2*l**2+F1)
       enddo
      enddo
c
      return
      end

      subroutine lfstep(nm,t,a0,a1,ap)
c  One leapfrog time-step
      parameter (N=256,M=128)
c
      common /parms/ xk,xl,dt,bb,f1,rob,twopi,dtn,c0_rf
c
      real a0(nm),a1(nm),ap(nm)
      call diff(N+2,M+2,t,a1,a0,ap)
      do 40 i=1,(N+2)*(M+2)
       savea=a1(i)
       a1(i)=a0(i)+ap(i)*2.*DT
       a0(i)=savea+rob*(a0(i)+a1(i)-2.*savea)
40    continue
      t=t+DT
      return
      end

      subroutine diff(nn,mm,t,a,a0,ap)
c  Calculate time derivatives of spectral amplitudes
      parameter (N=256,M=128)
      common /dumdif/ c(2*N+2,2*M+2),d(N+2,M+2)
      common /frict/ ifrict,r,rek,rpsi
c
      common /parms/ xk,xl,dt,bb,f1,rob,twopi,dtn,c0_rf
c
      real a(nn,mm),a0(nn,mm)
      real ap(nn,mm)
c
c
c  Single-layer Jacobian
       call jacobc(nn,mm,a,F1,c)
c
c  Friction
c
      if(ifrict.ge.1)then
c  ( dissip = - r*del^6(phi) ) hyperviscosity
        do 500 l=0,M/2
          do 490 k=0,N/2
             d(2*k+1,2*l+1)=r*(XK**2*k**2+XL**2*l**2)**3*a0(2*k+1,2*l+1)
             d(2*k+2,2*l+1)=r*(XK**2*k**2+XL**2*l**2)**3*a0(2*k+2,2*l+1)
             d(2*k+1,2*l+2)=r*(XK**2*k**2+XL**2*l**2)**3*a0(2*k+1,2*l+2)
             d(2*k+2,2*l+2)=r*(XK**2*k**2+XL**2*l**2)**3*a0(2*k+2,2*l+2)
  490     continue
  500   continue
      if(ifrict.eq.2)then
c  add Ekman friction (equal in both layers) and linear psi damping
        do l=0,M/2
          do k=0,N/2
             d(2*k+1,2*l+1)=d(2*k+1,2*l+1)
     .        +(rek*(XK**2*k**2+XL**2*l**2)+rpsi)*a0(2*k+1,2*l+1)
             d(2*k+2,2*l+1)=d(2*k+2,2*l+1)
     .        +(rek*(XK**2*k**2+XL**2*l**2)+rpsi)*a0(2*k+2,2*l+1)
             d(2*k+1,2*l+2)=d(2*k+1,2*l+2)
     .        +(rek*(XK**2*k**2+XL**2*l**2)+rpsi)*a0(2*k+1,2*l+2)
             d(2*k+2,2*l+2)=d(2*k+2,2*l+2)
     .        +(rek*(XK**2*k**2+XL**2*l**2)+rpsi)*a0(2*k+2,2*l+2)
          enddo
	enddo
       endif
      else
c  no friction
        do 540 l=1,M+2
        do 540 k=1,N+2
          d(k,l)=0.0
540     continue
      endif
c
c  Linear parts explicit
c
      do 200 l=0,M/2
       do 100 k=0,N/2
        ap(2*k+1,2*l+1)=
     .(1./(XK**2*k**2+XL**2*l**2+F1))
     .*( -BB*XK*k*a(2*k+2,2*l+1)
     .   +c(2*k+1,2*l+1)-d(2*k+1,2*l+1) )
        ap(2*k+2,2*l+1)=
     .(1./(XK**2*k**2+XL**2*l**2+F1))
     .*( BB*XK*k*a(2*k+1,2*l+1)
     .   +c(2*k+2,2*l+1)-d(2*k+2,2*l+1) )
        ap(2*k+1,2*l+2)=
     .(1./(XK**2*k**2+XL**2*l**2+F1))
     .*( -BB*XK*k*a(2*k+2,2*l+2)
     .   +c(2*k+1,2*l+2)-d(2*k+1,2*l+2) )
        ap(2*k+2,2*l+2)=
     .(1./(XK**2*k**2+XL**2*l**2+F1))
     .*( BB*XK*k*a(2*k+1,2*l+2)
     .   +c(2*k+2,2*l+2)-d(2*k+2,2*l+2) )
100    continue
200   continue

      return
      end
c
      subroutine jacobc(nn,mm,a,fcap,c)
c  Jacobian for psi=sum(Akl*exp(ikx+ily))
      parameter (N=256,M=128)
      real a(nn,mm),c(2*nn-2,2*mm-2)
      common /dumjac/ u(2*N+2,2*M+2),v(2*N+2,2*M+2),qx(2*N+2,2*M+2)
     .,               qy(2*N+2,2*M+2)
      common /workft/ work((2*N+1)*2*M),trigs(3*N+1),ifax(13)
      common /workft2/ work2((2*M+1)*2*(N+2)),trigs2(3*M+1),ifax2(13)
c
      common /parms/ xk,xl,dt,bb,f1,rob,twopi,dtn,c0_rf
c
c  Get u,v,qx,qy wave terms at (k,l)
      do l=0,M/2
       do k=0,N/2
        u(2*k+1,2*l+1)=+XL*l*a(2*k+1,2*l+2)
        u(2*k+1,2*l+2)=-XL*l*a(2*k+1,2*l+1)
        u(2*k+2,2*l+1)=+XL*l*a(2*k+2,2*l+2)
        u(2*k+2,2*l+2)=-XL*l*a(2*k+2,2*l+1)
        v(2*k+1,2*l+1)=-XK*k*a(2*k+2,2*l+1)
        v(2*k+2,2*l+1)=+XK*k*a(2*k+1,2*l+1)
        v(2*k+1,2*l+2)=-XK*k*a(2*k+2,2*l+2)
        v(2*k+2,2*l+2)=+XK*k*a(2*k+1,2*l+2)
        qx(2*k+1,2*l+1)=
     . -XK*k*(-(XK**2*k**2+XL**2*l**2+fcap)*a(2*k+2,2*l+1))
        qx(2*k+2,2*l+1)=
     . +XK*k*(-(XK**2*k**2+XL**2*l**2+fcap)*a(2*k+1,2*l+1))
        qx(2*k+1,2*l+2)=
     . -XK*k*(-(XK**2*k**2+XL**2*l**2+fcap)*a(2*k+2,2*l+2))
        qx(2*k+2,2*l+2)=
     . +XK*k*(-(XK**2*k**2+XL**2*l**2+fcap)*a(2*k+1,2*l+2))
        qy(2*k+1,2*l+1)=
     . -XL*l*(-(XK**2*k**2+XL**2*l**2+fcap)*a(2*k+1,2*l+2))
        qy(2*k+1,2*l+2)=
     . +XL*l*(-(XK**2*k**2+XL**2*l**2+fcap)*a(2*k+1,2*l+1))
        qy(2*k+2,2*l+1)=
     . -XL*l*(-(XK**2*k**2+XL**2*l**2+fcap)*a(2*k+2,2*l+2))
        qy(2*k+2,2*l+2)=
     . +XL*l*(-(XK**2*k**2+XL**2*l**2+fcap)*a(2*k+2,2*l+1))
       enddo
      enddo
      do l=1,M+2
       do k=N+3,2*N+2
        u(k,l)=0.
        v(k,l)=0.
        qx(k,l)=0.
        qy(k,l)=0.
       enddo
      enddo
      do l=M+3,2*M+2
       do k=1,2*N+2
        u(k,l)=0.
        v(k,l)=0.
        qx(k,l)=0.
        qy(k,l)=0.
       enddo
      enddo
c
c
c  Transform from (k,l) to (x,l) and then to (x,y)
      inc=1
      jump=2*N+2
      call fft991(u,work,trigs,ifax,inc,jump,2*N,M+2,+1)
      call fft991(v,work,trigs,ifax,inc,jump,2*N,M+2,+1)
      call fft991(qx,work,trigs,ifax,inc,jump,2*N,M+2,+1)
      call fft991(qy,work,trigs,ifax,inc,jump,2*N,M+2,+1)
      inc=2*N+2
      jump=1
      call fft991(u,work2,trigs2,ifax2,inc,jump,2*M,2*N,+1)
      call fft991(v,work2,trigs2,ifax2,inc,jump,2*M,2*N,+1)
      call fft991(qx,work2,trigs2,ifax2,inc,jump,2*M,2*N,+1)
      call fft991(qy,work2,trigs2,ifax2,inc,jump,2*M,2*N,+1)
c  Compute jacobian on doubled grid
      do l=1,2*M
       do k=1,2*N
        c(k,l)=u(k,l)*qx(k,l)+v(k,l)*qy(k,l)
       enddo
      enddo
c  Transform from (x,y) to (x,l) and then to (k,l)
c   Could repack to avoid transforming zeros at k=2
      inc=2*N+2
      jump=1
      call fft991(c,work2,trigs2,ifax2,inc,jump,2*M,2*N,-1)
      inc=1
      jump=2*N+2
      call fft991(c,work,trigs,ifax,inc,jump,2*N,M+2,-1)

c  Done
      return
      end
c
c
      subroutine out(nn,mm,a,p1,iun)
      parameter (N=256,M=128)
      real a(nn,mm),p1(nn,mm)
      real u(2*N+2,M),v(2*N+2,M),q(2*N+2,M)
      common /workft/ work((2*N+1)*2*M),trigs(3*N+1),ifax(13)
      common /workft2/ work2((2*M+1)*2*(N+2)),trigs2(3*M+1),ifax2(13)
c
      common /parms/ xk,xl,dt,bb,f1,rob,twopi,dtn,c0_rf
c
      do 20 l=1,M+2
       do 10 k=1,N+2
        p1(k,l)=a(k,l)
10     continue
20    continue
c
      call set99(trigs,ifax,N)
      call set99(trigs2,ifax2,M)
      inc=1
      jump=N+2
      call fft991(p1,work,trigs,ifax,inc,jump,N,M,+1)
      inc=N+2
      jump=1
      call fft991(p1,work2,trigs2,ifax2,inc,jump,M,N,+1)
      call set99(trigs,ifax,2*N)
      call set99(trigs2,ifax2,2*M)
c
      Mout=M/16
c      Mout=min(M,22)
      do 40 k=1,N
       do lm=1,Mout
        la=1+(lm-1)*16
	lb=lm*16
        write(iun,'(1x,i5,20(1x,e10.4))') k,(p1(k,l),l=la,lb)
       enddo
40    continue

      write(6,*) p1(N,M)
      return
      end

      subroutine intclc(nn,mm,a,f_a,ep,ek,eq,ef)
c  Calculate integral quantities
c   for psi=sum(Akl*exp(ikx)*sinly)+sum*(A0l*cosly)
c      ep = psi^2
c      ek = K^2 psi^2
c      eq = K^4 psi^2
c      ef = force_a^2
c
      parameter (N=256,M=128)
c
      common /parms/ xk,xl,dt,bb,f1,rob,twopi,dtn,c0_rf
c
      real a(nn,mm),f_a(nn,mm)
c  Calculate spectral sums
      ep=0.
      ek=0.
      eq=0.
      ef=0.
c  Get u,v,qx,qy wave terms at (k,l)
      do l=0,M/2
       do k=0,N/2
        ep=ep+a(2*k+1,2*l+1)**2+a(2*k+1,2*l+2)**2
     .       +a(2*k+2,2*l+1)**2+a(2*k+2,2*l+2)**2
        ek=ek+(XK**2*k**2+XL**2*l**2)
     .        *(a(2*k+1,2*l+1)**2+a(2*k+1,2*l+2)**2
     .         +a(2*k+2,2*l+1)**2+a(2*k+2,2*l+2)**2)
        eq=eq+(XK**2*k**2+XL**2*l**2)**2
     .        *(a(2*k+1,2*l+1)**2+a(2*k+1,2*l+2)**2
     .         +a(2*k+2,2*l+1)**2+a(2*k+2,2*l+2)**2)
        ef=ef+f_a(2*k+1,2*l+1)**2+f_a(2*k+1,2*l+2)**2
     .       +f_a(2*k+2,2*l+1)**2+f_a(2*k+2,2*l+2)**2
       enddo
      enddo

      return
      end

      subroutine init(ki,nn,mm,a0,a1,ap,icont)
c  Initialization
      parameter (N=256,M=128)
      real a0(nn,mm),a1(nn,mm)
      real ap(nn,mm)
      real ca(M),cb(M)
      common /dumdif/ ddum((2*N+2)*(2*M+2)+(N+2)*(M+2))
      common /dumjac/ dumj(4*(2*N+2)*(2*M+2))
      common /workft/ work((2*N+1)*2*M),trigs(3*N+1),ifax(13)
      common /workft2/ work2((2*M+1)*2*(N+2)),trigs2(3*M+1),ifax2(13)
c
      common /parms/ xk,xl,dt,bb,f1,rob,twopi,dtn,c0_rf
c
c
      twopi=8*atan(1.0)
      write(6,*) twopi
c  zero initial stream function arrays
       do l=1,M+2
        do k=1,N+2
         a0(k,l)=0.
         a1(k,l)=0.
        enddo
       enddo
c  single waves
c       a0(2*6+1,2*1+1)=0.05
c       a0(2*6+1,2*3+1)=0.05
c
c  Read input file in (k,l) space
c       Mout=M/16
c      Mout=min(M,22)
c       do k=1,N
c        do lm=1,Mout
c         la=1+(lm-1)*16
c         lb=lm*11
c         read(5,'(1x,i5,20(1x,e10.4))') kk,(a0(k,l),l=la,lb)
c        enddo
c       enddo
c
c
c  Zero arrays
      do i=1,(2*N+2)*(2*M+2)+(N+2)*(M+2)
       ddum(i)=0.
      enddo
      do i=1,4*(2*N+2)*(2*M+2)
       dumj(i)=0.
      enddo
c
c
      call set99(trigs,ifax,2*N)
      call set99(trigs2,ifax2,2*M)
c
c  Disturbance at step -1 for leapfrog
c
c      call diff(N+2,M+2,t,a0,a0,ap)
c      do 90 l=1,M+2
c       do 80 k=1,N+1
c        a1(k,l)=a0(k,l)-ap(k,l)*DT
c80     continue
c      a1(N+2,l)=0.
c90    continue

      return
      end

! ----------------------------------------------------------------
!
      subroutine rkstep(nm,t,a0,a1,ap)
c rkstep:  2nd-order Runge-Kutta step
c   Adapt code from pgom for rk step, using eustpr euler step routine
c  One R-K time-step
      parameter (N=256,M=128)
c
      common /parms/ xk,xl,dt,bb,f1,rob,twopi,dtn,c0_rf
c
      real a0(nm),a1(nm)
      real ap(nm)
c      real al0(nn,mm),al1(nn,mm)
c      real alp(nn,mm)

c Predictor:
      call diff(N+2,M+2,t,a0,a0,ap)
c  predictor step
      call eustep((N+2)*(M+2),dt,a0,a1,ap)

c Corrector:
      call diff(N+2,M+2,t,a1,a0,ap)
c  corrector step
      call eustep((N+2)*(M+2),dt,a0,a0,ap)

c Predictor and corrector steps completed. Now average results:
      do i=1,(N+2)*(M+2)
       a0(i)=0.5*(a0(i)+a1(i))
      enddo

      t=t+dt
      return
      end

      subroutine eustep(nm,dt,a0,a1,ap)
! This routine does a simple Euler timestep
! Input variables: nm,dt,a0,ap
! Variable changed on output: a1
      real a0(nm),a1(nm)
      real ap(nm)
!  Euler time step
      do i=1,nm
       a1(i)=a0(i)+ap(i)*dt
      enddo
      return
      end
!
! ----------------------------------------------------------------

      subroutine out_nc(ncid,nrec,nn,mm,psi_varid,Fcap0_varid
     .,                 a0,force_a,p1)
      implicit none
c   QG spectral model dimensions
      integer N,M
      parameter (N=256,M=128)
      character*(*) FILE_NAME
      parameter (FILE_NAME = 'qg1ldp_rf_out.nc')
      integer ncid,nrec
      integer psi_varid, Fcap0_varid
c
      integer nn,mm
      real a0(nn,mm),force_a(nn,mm),p1(nn,mm)
      common /workft/ work((2*N+1)*2*M),trigs(3*N+1),ifax(13)
      common /workft2/ work2((2*M+1)*2*(N+2)),trigs2(3*M+1),ifax2(13)
      real work,trigs,work2,trigs2
      integer ifax,ifax2
      integer k,l,inc,jump

C   Output is 3D data: an MxN lat-lon grid, for one timestep
      integer NDIMS
      parameter (NDIMS = 3)

      include 'netcdf.inc'
      integer NLATS, NLONS
      parameter (NLATS = M, NLONS = N)

C   The start and count arrays will tell the netCDF library where to
C   write our data.
      integer start(NDIMS), count(NDIMS)
c   Need internal array dimension to match netCDF file record dimension
      common /dumjac/ p1_nc(NLONS,NLATS)
     .,               dumj(4*(2*N+2)*(2*M+2)-NLONS*NLATS)
      real p1_nc,dumj

C   Error handling.
      integer retval

c -----------
      retval = nf_open(FILE_NAME, nf_write, ncid)
      if (retval .ne. nf_noerr) call handle_err(retval)

C   These settings tell netcdf to write one timestep of data. (The
C   setting of start(3) inside the loop below tells netCDF which
C   timestep to write.)
      count(1) = NLONS
      count(2) = NLATS
      count(3) = 1
      start(1) = 1
      start(2) = 1
      start(3) = nrec

C   Write the stream function and forcing arrays.
c   The arrays hold one time step of data.
c
      do l=1,M+2
       do k=1,N+2
        p1(k,l)=a0(k,l)
       enddo
      enddo
c
      call set99(trigs,ifax,N)
      call set99(trigs2,ifax2,M)
      inc=1
      jump=N+2
      call fft991(p1,work,trigs,ifax,inc,jump,N,M,+1)
      inc=N+2
      jump=1
      call fft991(p1,work2,trigs2,ifax2,inc,jump,M,N,+1)
      call set99(trigs,ifax,2*N)
      call set99(trigs2,ifax2,2*M)
c
      do l=1,M
       do k=1,N
        p1_nc(k,l)=p1(k,l)
       enddo
      enddo

      retval = nf_put_vara_real(ncid, psi_varid, start, count, p1_nc)
      if (retval .ne. nf_noerr) call handle_err(retval)

c
      do l=1,M+2
       do k=1,N+2
        p1(k,l)=force_a(k,l)
       enddo
      enddo
c
      call set99(trigs,ifax,N)
      call set99(trigs2,ifax2,M)
      inc=1
      jump=N+2
      call fft991(p1,work,trigs,ifax,inc,jump,N,M,+1)
      inc=N+2
      jump=1
      call fft991(p1,work2,trigs2,ifax2,inc,jump,M,N,+1)
      call set99(trigs,ifax,2*N)
      call set99(trigs2,ifax2,2*M)
c
      do l=1,M
       do k=1,N
        p1_nc(k,l)=p1(k,l)
       enddo
      enddo

      retval = nf_put_vara_real(ncid, Fcap0_varid, start, count, p1_nc)
      if (retval .ne. nf_noerr) call handle_err(retval)

C   Close the file. This causes netCDF to flush all buffers and make
C   sure your data are really written to disk.
      retval = nf_close(ncid)
      if (retval .ne. nf_noerr) call handle_err(retval)

      print *,'*** SUCCESS writing state file ',nrec

      end

! ----------------------------------------------------------------^M

      subroutine out_nc_init(ncid
     .,  bb,f1,xk,xl,dt,ifrict,rpsi,rek,r0_del6,r,tau,f_amp
     .,  dxkf,xkf,c0_rf,ndt,dtn,rcap,dt_out
     .,  nn,mm,psi_varid,Fcap0_varid,a0,force_a,p1)
      implicit none
c   QG spectral model dimensions
      integer N,M
      parameter (N=256,M=128)
C   Specify output file name
      character*(*) FILE_NAME
      parameter (FILE_NAME = 'qg1ldp_rf_out.nc')
      integer ncid
c
      integer nn,mm
      real a0(nn,mm),force_a(nn,mm),p1(nn,mm)
      common /workft/ work((2*N+1)*2*M),trigs(3*N+1),ifax(13)
      common /workft2/ work2((2*M+1)*2*(N+2)),trigs2(3*M+1),ifax2(13)
      real work,trigs,work2,trigs2
      integer ifax,ifax2
      integer k,l,inc,jump

C   Output is 3D data: an MxN lat-lon grid, with 1
C   timestep of initial data; also numerous model parameters.
      integer NDIMS, NRECS
      parameter (NDIMS = 3, NRECS = 1)

      include 'netcdf.inc'
      integer NLATS, NLONS
      parameter (NLATS = M, NLONS = N)
      character*(*) LAT_NAME, LON_NAME, REC_NAME
      parameter (LAT_NAME = 'latitude', LON_NAME = 'longitude')
      parameter (REC_NAME = 'time')
      integer lon_dimid, lat_dimid, rec_dimid

C   The start and count arrays will tell the netCDF library where to
C   write our data.
      integer start(NDIMS), count(NDIMS)

C   These program variables hold the latitudes and longitudes.
      real lats(NLATS), lons(NLONS)
      integer lon_varid, lat_varid
      real twopi
c   Need internal array dimension to match netCDF file record dimension
      common /dumjac/ p1_nc(NLONS,NLATS)
     .,               dumj(4*(2*N+2)*(2*M+2)-NLONS*NLATS)
      real p1_nc,dumj

C   Create netCDF variables for stream function psi and
C   forcing Fcap0 fields.
      character*(*) psi_NAME, Fcap0_NAME
      parameter (psi_NAME='psi')
      parameter (Fcap0_NAME='Fcap0')
      integer psi_varid, Fcap0_varid
      integer dimids(NDIMS)
c   QG spectral model parameters
      real bb,f1,xk,xl,dt,rpsi,rek,r0_del6,r,tau,f_amp
     .,  dxkf,xkf,c0_rf,dtn,rcap,dt_out
      integer ifrict,ndt
C   Create a netCDF variable for each model parameter
      character*(*) bb_NAME, f1_NAME, xk_NAME, xl_NAME, dt_NAME
     ., rpsi_NAME, rek_NAME, r0_del6_NAME, r_NAME, tau_NAME, f_amp_NAME
     ., dxkf_NAME, xkf_NAME, c0_rf_NAME, ndt_NAME, dtn_NAME, rcap_NAME
     ., dt_out_NAME,ifrict_NAME
      parameter (bb_NAME='bb',f1_NAME='f1',xk_NAME='xk',xl_NAME='xl')
      parameter (dt_NAME='dt',rpsi_NAME='rpsi',rek_NAME='rek'
     .,          r0_del6_NAME='r0_del6', r_NAME='r',tau_NAME='tau'
     .,          f_amp_NAME='f_amp',dxkf_NAME='dxkf',xkf_NAME='xkf'
     .,          c0_rf_NAME='c0_rf',ndt_NAME='ndt' ,dtn_NAME='dtn'
     .,          rcap_NAME='rcap',dt_out_NAME='dt_out'
     .,          ifrict_NAME='ifrict')
      integer bb_varid, f1_varid, xk_varid, xl_varid, dt_varid
     .,       rpsi_varid
     .,       rek_varid, r0_del6_varid, r_varid, tau_varid, f_amp_varid
     .,       dxkf_varid, xkf_varid, c0_rf_varid, ndt_varid, dtn_varid
     .,       rcap_varid, dt_out_varid, ifrict_varid

C   Each variable carries a "units" attribute; all are dimensionless.
      character*(*) UNITS
      parameter (UNITS = 'Units')
      character*(*) UNITS_nd
      parameter (UNITS_nd = 'dimensionless')

C   Use these to construct latitude and longitude data
      integer START_LAT, START_LON
      parameter (START_LAT = 0, START_LON = 0)

C   Loop indices.
      integer lat, lon, rec, i

C   Error handling.
      integer retval

c -----------

C   Create the file.
      write(6,*) FILE_NAME
      retval = nf_create(FILE_NAME, nf_clobber, ncid)
      if (retval .ne. nf_noerr) call handle_err(retval)

c   Define parameter variables, assign units attributes.
      write(6,*) bb_NAME
      retval = nf_def_var(ncid, bb_NAME, NF_REAL, 0, 0, bb_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_att_text(ncid, bb_varid, UNITS, len(UNITS_nd)
     .,      UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)
      write(6,*) f1_NAME
      retval = nf_def_var(ncid, f1_NAME, NF_REAL, 0, 0, f1_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_att_text(ncid, f1_varid, UNITS, len(UNITS_nd)
     .,      UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)
      write(6,*) xk_NAME
      retval = nf_def_var(ncid, xk_NAME, NF_REAL, 0, 0, xk_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_att_text(ncid, xk_varid, UNITS, len(UNITS_nd)
     .,      UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)
      write(6,*) xl_NAME
      retval = nf_def_var(ncid, xl_NAME, NF_REAL, 0, 0, xl_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_att_text(ncid, xl_varid, UNITS, len(UNITS_nd)
     .,      UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)
      write(6,*) dt_NAME
      retval = nf_def_var(ncid, dt_NAME, NF_REAL, 0, 0, dt_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_att_text(ncid, dt_varid, UNITS, len(UNITS_nd)
     .,      UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)
      write(6,*) rpsi_NAME
      retval = nf_def_var(ncid, rpsi_NAME, NF_REAL, 0, 0, rpsi_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_att_text(ncid, rpsi_varid, UNITS, len(UNITS_nd)
     .,      UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)
      write(6,*) rek_NAME
      retval = nf_def_var(ncid, rek_NAME, NF_REAL, 0, 0, rek_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_att_text(ncid, rek_varid, UNITS, len(UNITS_nd)
     .,      UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)
      write(6,*) r0_del6_NAME
      retval = nf_def_var(ncid, r0_del6_NAME, NF_REAL, 0, 0
     .,      r0_del6_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_att_text(ncid, r0_del6_varid, UNITS, len(UNITS_nd)
     .,      UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)
      write(6,*) r_NAME
      retval = nf_def_var(ncid, r_NAME, NF_REAL, 0, 0, r_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_att_text(ncid, r_varid, UNITS, len(UNITS_nd)
     .,      UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)
      write(6,*) tau_NAME
      retval = nf_def_var(ncid, tau_NAME, NF_REAL, 0, 0, tau_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_att_text(ncid, tau_varid, UNITS, len(UNITS_nd)
     .,      UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)
      write(6,*) f_amp_NAME
      retval = nf_def_var(ncid, f_amp_NAME, NF_REAL, 0, 0, f_amp_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_att_text(ncid, f_amp_varid, UNITS, len(UNITS_nd)
     .,      UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)
      write(6,*) dxkf_NAME
      retval = nf_def_var(ncid, dxkf_NAME, NF_REAL, 0, 0, dxkf_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_att_text(ncid, dxkf_varid, UNITS, len(UNITS_nd)
     .,      UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)
      write(6,*) xkf_NAME
      retval = nf_def_var(ncid, xkf_NAME, NF_REAL, 0, 0, xkf_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_att_text(ncid, xkf_varid, UNITS, len(UNITS_nd)
     .,      UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)
      write(6,*) c0_rf_NAME
      retval = nf_def_var(ncid, c0_rf_NAME, NF_REAL, 0, 0, c0_rf_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_att_text(ncid, c0_rf_varid, UNITS, len(UNITS_nd)
     .,      UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)
      write(6,*) ndt_NAME
      retval = nf_def_var(ncid, ndt_NAME, NF_INT, 0, 0, ndt_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_att_text(ncid, ndt_varid, UNITS, len(UNITS_nd)
     .,      UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)
      write(6,*) dtn_NAME
      retval = nf_def_var(ncid, dtn_NAME, NF_REAL, 0, 0, dtn_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_att_text(ncid, dtn_varid, UNITS, len(UNITS_nd)
     .,      UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)
      write(6,*) rcap_NAME
      retval = nf_def_var(ncid, rcap_NAME, NF_REAL, 0, 0, rcap_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_att_text(ncid, rcap_varid, UNITS, len(UNITS_nd)
     .,      UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)
      write(6,*) dt_out_NAME
      retval = nf_def_var(ncid, dt_out_NAME, NF_REAL, 0, 0
     .,       dt_out_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_att_text(ncid, dt_out_varid, UNITS, len(UNITS_nd)
     .,      UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)
      write(6,*) ifrict_NAME
      retval = nf_def_var(ncid, ifrict_NAME, NF_INT, 0, 0
     .,       ifrict_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_att_text(ncid, ifrict_varid, UNITS, len(UNITS_nd)
     .,      UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)

C   Define the dimensions for the spectral variables.
c   The record dimension is defined to have
C   unlimited length - it can grow as needed. In this case it is
C   the time dimension.
      retval = nf_def_dim(ncid, LAT_NAME, NLATS, lat_dimid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_def_dim(ncid, LON_NAME, NLONS, lon_dimid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_def_dim(ncid, REC_NAME, NF_UNLIMITED, rec_dimid)
      if (retval .ne. nf_noerr) call handle_err(retval)

C   Define the coordinate variables. We will only define coordinate
C   variables for lat and lon.  Ordinarily we would need to provide
C   an array of dimension IDs for each variable's dimensions, but
C   since coordinate variables only have one dimension, we can
C   simply provide the address of that dimension ID (lat_dimid) and
C   similarly for (lon_dimid).
      retval = nf_def_var(ncid, LAT_NAME, NF_REAL, 1, lat_dimid
     .,    lat_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_def_var(ncid, LON_NAME, NF_REAL, 1, lon_dimid
     .,    lon_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)

C   Assign units attributes to coordinate variables.
      retval = nf_put_att_text(ncid, lat_varid, UNITS, len(UNITS_nd)
     .,   UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_att_text(ncid, lon_varid, UNITS, len(UNITS_nd)
     .,   UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)
      if (retval .ne. nf_noerr) call handle_err(retval)

C   Create dimensionless lat-lon grid values
      twopi=8*atan(1.0)
      do lat = 1, NLATS
         lats(lat) = START_LAT + (lat - 1) * twopi/(xl*M)
      end do
      do lon = 1, NLONS
         lons(lon) = START_LON + (lon - 1) * twopi/(xk*N)
      end do

C   The dimids array is used to pass the dimids of the dimensions of
C   the netCDF variables. Both of the netCDF variables we are creating
C   share the same three dimensions. In Fortran, the unlimited
C   dimension must come last on the list of dimids.
      dimids(1) = lon_dimid
      dimids(2) = lat_dimid
      dimids(3) = rec_dimid

C   Define the netCDF variables for the stream function and forcing data.
      retval = nf_def_var(ncid, psi_NAME, NF_REAL, NDIMS, dimids
     .,    psi_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_def_var(ncid, Fcap0_NAME, NF_REAL, NDIMS, dimids
     .,    Fcap0_varid)
      if (retval .ne. nf_noerr) call handle_err(retval)

C   Assign units attributes to the stream function and forcing variables.
      retval = nf_put_att_text(ncid, psi_varid, UNITS, len(UNITS_nd)
     .,    UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_att_text(ncid, Fcap0_varid, UNITS, len(UNITS_nd)
     .,    UNITS_nd)
      if (retval .ne. nf_noerr) call handle_err(retval)

C   End define mode.
      write(6,*) FILE_NAME
      retval = nf_enddef(ncid)
      if (retval .ne. nf_noerr) call handle_err(retval)

c  write parameter values
      retval = nf_put_var_real(ncid, bb_varid, bb)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_var_real(ncid, f1_varid, f1)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_var_real(ncid, xk_varid, xk)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_var_real(ncid, xl_varid, xl)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_var_real(ncid, dt_varid, dt)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_var_real(ncid, rpsi_varid, rpsi)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_var_real(ncid, rek_varid, rek)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_var_real(ncid, r0_del6_varid, r0_del6)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_var_real(ncid, r_varid, r)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_var_real(ncid, tau_varid, tau)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_var_real(ncid, f_amp_varid, f_amp)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_var_real(ncid, dxkf_varid, dxkf)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_var_real(ncid, xkf_varid, xkf)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_var_real(ncid, c0_rf_varid, c0_rf)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_var_int(ncid, ndt_varid, ndt)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_var_real(ncid, dtn_varid, dtn)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_var_real(ncid, rcap_varid, rcap)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_var_real(ncid, dt_out_varid, dt_out)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_var_int(ncid, ifrict_varid, ifrict)
      if (retval .ne. nf_noerr) call handle_err(retval)

C   Write the coordinate variable data. This will put the latitudes
C   and longitudes of our data grid into the netCDF file.
      retval = nf_put_var_real(ncid, lat_varid, lats)
      if (retval .ne. nf_noerr) call handle_err(retval)
      retval = nf_put_var_real(ncid, lon_varid, lons)
      if (retval .ne. nf_noerr) call handle_err(retval)

C   These settings tell netcdf to write one timestep of data. (The
C   setting of start(4) inside the loop below tells netCDF which
C   timestep to write.)
      count(1) = NLONS
      count(2) = NLATS
      count(3) = 1
      start(1) = 1
      start(2) = 1

C   Write the stream function and forcing arrays.
c   The arrays only hold the initial data.
c
      do l=1,M+2
       do k=1,N+2
        p1(k,l)=a0(k,l)
       enddo
      enddo
c
      call set99(trigs,ifax,N)
      call set99(trigs2,ifax2,M)
      inc=1
      jump=N+2
      call fft991(p1,work,trigs,ifax,inc,jump,N,M,+1)
      inc=N+2
      jump=1
      call fft991(p1,work2,trigs2,ifax2,inc,jump,M,N,+1)
      call set99(trigs,ifax,2*N)
      call set99(trigs2,ifax2,2*M)
c
      do l=1,M
       do k=1,N
        p1_nc(k,l)=p1(k,l)
       enddo
      enddo

      start(3) = 1
      retval = nf_put_vara_real(ncid, psi_varid, start, count, p1_nc)
      if (retval .ne. nf_noerr) call handle_err(retval)
c
      do l=1,M+2
       do k=1,N+2
        p1(k,l)=force_a(k,l)
       enddo
      enddo
c
      call set99(trigs,ifax,N)
      call set99(trigs2,ifax2,M)
      inc=1
      jump=N+2
      call fft991(p1,work,trigs,ifax,inc,jump,N,M,+1)
      inc=N+2
      jump=1
      call fft991(p1,work2,trigs2,ifax2,inc,jump,M,N,+1)
      call set99(trigs,ifax,2*N)
      call set99(trigs2,ifax2,2*M)
c
      do l=1,M
       do k=1,N
        p1_nc(k,l)=p1(k,l)
       enddo
      enddo

      start(3) = 1
      retval = nf_put_vara_real(ncid, Fcap0_varid, start, count, p1_nc)
      if (retval .ne. nf_noerr) call handle_err(retval)

C   Close the file. This causes netCDF to flush all buffers and make
C   sure your data are really written to disk.
      retval = nf_close(ncid)
      if (retval .ne. nf_noerr) call handle_err(retval)

      print *,'*** SUCCESS writing initial state file: '
     ., FILE_NAME
      end

      subroutine handle_err(errcode)
      implicit none
      include 'netcdf.inc'
      integer errcode

      print *, 'Error: ', nf_strerror(errcode)
      stop 2
      end


SUBROUTINE SSBEV_F95( A, W, UPLO, Z, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => SP
   USE LA_AUXMOD, ONLY: ERINFO, LSAME
   USE F77_LAPACK, ONLY: SBEV_F77 => LA_SBEV
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
   CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
   INTEGER, INTENT(OUT), OPTIONAL :: INFO
!  .. ARRAY ARGUMENTS ..
   REAL(WP), INTENT(INOUT) :: A(:,:)
   REAL(WP), INTENT(OUT) :: W(:)
   REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: Z(:,:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!     LA_SBEV and LA_SBEVD compute all eigenvalues and, optionally, all
! eigenvectors of a real symmetric matrix A in band form.
!     LA_HBEV and LA_HBEVD compute all eigenvalues and, optionally, all
! eigenvectors of a complex Hermitian matrix A in band form.
!     LA_SBEVD and LA_HBEVD use a divide and conquer algorithm. They are
! much faster than LA_SBEV and LA_HBEV for large matrices but use more
! workspace.
!
! =========
!
!         SUBROUTINE LA_SBEV / LA_HBEV / LA_SBEVD /
!                  LA_HBEVD( AB, W, UPLO=uplo, Z=z, INFO=info )
!             <type>(<wp>), INTENT(INOUT) :: AB(:,:)
!             REAL(<wp>), INTENT(OUT) :: W(:)
!             CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
!             <type>(<wp>), INTENT(OUT), OPTIONAL :: Z(:,:)
!             INTEGER, INTENT(OUT), OPTIONAL :: INFO
!         where
!             <type> ::= REAL | COMPLEX
!             <wp> ::= KIND(1.0) | KIND(1.0D0)
!
! Arguments
! =========
! AB     (input/output) REAL or COMPLEX array, shape (:,:) with
!        size(AB,1) = kd + 1 and
!        size(AB,2) = n, where kd is the number of subdiagonals or
!        superdiagonals in the band and n is the order of A.
!        On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')
!        triangle of matrix A in band storage. The kd + 1 diagonals of A
!        are stored in the rows of AB so that the j-th column of A is
!        stored in the j-th column of AB as follows:
!         if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j
!                                                    1<=j<=n
!         if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd)
!                                                    1<=j<=n.
!        On exit, AB is overwritten by values generated during the
!        reduction of A to a tridiagonal matrix T . If UPLO = 'U', the
!        first superdiagonal and the diagonal of T are returned in rows
!        kd and kd + 1 of AB. If UPLO = 'L', the diagonal and first
!        subdiagonal of T are returned in the first two rows of AB.
! W      (output) REAL array, shape (:) with size(W) = n.
!        The eigenvalues in ascending order.
! UPLO   Optional (input) CHARACTER(LEN=1).
!        = 'U': Upper triangle of A is stored;
!        = 'L': Lower triangle of A is stored.
!        Default value: 'U'.
! Z      Optional (output) REAL or COMPLEX square array, shape (:,:) with
!        size(Z,1) = n.
!        The columns of Z contain the orthonormal eigenvectors of A in
!        the order of the eigenvalues.
! INFO   Optional (output) INTEGER.
!        = 0: successful exit.
!        < 0: if INFO = -i, the i-th argument had an illegal value.
!        > 0: if INFO = i, then i off-diagonal elements of an intermediate
!             tridiagonal form did not converge to zero.
!        If INFO is not present and an error occurs, then the program is
!        terminated with an error message.
!----------------------------------------------------------------------
!  .. LOCAL PARAMETERS ..
   CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_SBEV'
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: LUPLO, LJOBZ
   INTEGER :: N, KD, LINFO, LD, ISTAT, ISTAT1, S1Z, S2Z
!  .. LOCAL ARRAYS ..
   REAL(WP), TARGET :: LLZ(1,1)
   REAL(WP), POINTER :: WORK(:)
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC MAX, PRESENT
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; KD = SIZE(A,1)-1; N = SIZE(A,2); LD = MAX(1,SIZE(A,1))
   IF( PRESENT(UPLO) ) THEN; LUPLO = UPLO; ELSE; LUPLO = 'U'; END IF
   IF( PRESENT(Z) )THEN; S1Z = SIZE(Z,1); S2Z = SIZE(Z,2); LJOBZ = 'V'
   ELSE; S1Z = 1; S2Z = 1; LJOBZ = 'N'; END IF
!  .. TEST THE ARGUMENTS
   IF( KD < 0 .OR. N < 0 ) THEN; LINFO = -1
   ELSE IF( SIZE( W ) /= N )THEN; LINFO = -2
   ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -3
   ELSE IF( PRESENT(Z) .AND. ( S1Z /= N .OR. S2Z /= N ) )THEN; LINFO = -4
   ELSE IF( N > 0 )THEN
!  .. DETERMINE THE WORKSPACE
      ALLOCATE(WORK(MAX(1,3*N-2)), STAT=ISTAT)
      IF( ISTAT == 0 ) THEN
         IF( PRESENT(Z) )THEN
   !     .. CALL LAPACK77 ROUTINE
            CALL SBEV_F77( LJOBZ, LUPLO, N, KD, A, LD, W, Z, S2Z, WORK, LINFO )
	 ELSE
	    CALL SBEV_F77( LJOBZ, LUPLO, N, KD, A, LD, W, LLZ, S2Z, WORK, LINFO )
	 ENDIF
      ELSE; LINFO = -100; ENDIF
      DEALLOCATE(WORK, STAT=ISTAT1)
   ENDIF
   CALL ERINFO(LINFO,SRNAME,INFO,ISTAT)
END SUBROUTINE SSBEV_F95


!!*------------------------------------------------------------------*!!
!!  Project : mfpDataStructure
!!*------------------------------------------------------------------*!!
!!
!!  Fortran Module
!!      Special Function
!!
!!  Description
!!      FyMC Pack General Module
!!
!!  Authors
!!      YoungMyung Choi, Ecole Centrale de Nantes
!!          - youngmyung.choi@ec-nantes.fr
!!
!!*------------------------------------------------------------------*!!

!! ------------------------------------------------------------------ !!

    Module mfpSpecialFunction

!!  Dependency ------------------------------------------------------ !!

        use mfpGlobal

!!  Variable Declaration -------------------------------------------- !!

    Implicit None

    private

    !! Public

        PUBLIC :: xBetaX2m1

        PUBLIC :: testGx

    Contains

!!  Procedure Files ------------------------------------------------- !!

    include "gammaFunction/xBetax2m1.inc"

!! ------------------------------------------------------------------ !!
    End Module
!! ------------------------------------------------------------------ !!


use s2d

_render_board( [], _, _, _, _, _ ): 1.

_render_board( h <~ [t], k, tlx, tly, w, s ):
    x <- (k % w) * s + tlx
    y <- (k / w) * s + tly

    s2d_quad(x+1., y+1., x+s-1., y+1., x+s-1., y+s-1., x+1., y+s-1., h, h, 0.5, 1.)

    _render_board(t, k + 1, tlx, tly, w, s).

#########################################
#
# tlx: top left x-coord where board starts
# tly: top left y-coord where board starts
# w: number of squares per row
# s: size of a square
#
#########################################
render_board( board, tlx, tly, w, s ):
    _render_board( board, 0, tlx, tly, w, s).


SUBROUTINE user5_setaux_manifold(mbc,mx,my, &
        xlower,ylower,dx,dy,maux,aux, &
        xnormals,xtangents,ynormals,ytangents, &
        surfnormals,area)
  IMPLICIT NONE

  INTEGER mx,my,mbc,maux
  DOUBLE PRECISION xlower,ylower,dx,dy
  DOUBLE PRECISION aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)

  !! Still hoping to be able to include this using 'metric_terms.i'
  DOUBLE PRECISION         area(-mbc:mx+mbc+1,-mbc:my+mbc+1)
  DOUBLE PRECISION  surfnormals(-mbc:mx+mbc+1,-mbc:my+mbc+1,3)
  DOUBLE PRECISION     xnormals(-mbc:mx+mbc+2,-mbc:my+mbc+2,3)
  DOUBLE PRECISION     ynormals(-mbc:mx+mbc+2,-mbc:my+mbc+2,3)
  DOUBLE PRECISION    xtangents(-mbc:mx+mbc+2,-mbc:my+mbc+2,3)
  DOUBLE PRECISION    ytangents(-mbc:mx+mbc+2,-mbc:my+mbc+2,3)

  INTEGER i,j

  DO  j = 1-mbc,my+mbc
     DO i = 1-mbc,mx+mbc
        aux(1,i,j) = area(i,j)/(dx*dy)

        aux(2,i,j) = xnormals(i,j,1)
        aux(3,i,j) = xnormals(i,j,2)
        aux(4,i,j) = xnormals(i,j,3)
        aux(5,i,j) = xtangents(i,j,1)
        aux(6,i,j) = xtangents(i,j,2)
        aux(7,i,j) = xtangents(i,j,3)

        aux(8,i,j)  = ynormals(i,j,1)
        aux(9,i,j)  = ynormals(i,j,2)
        aux(10,i,j) = ynormals(i,j,3)
        aux(11,i,j) = ytangents(i,j,1)
        aux(12,i,j) = ytangents(i,j,2)
        aux(13,i,j) = ytangents(i,j,3)

        aux(14,i,j) = surfnormals(i,j,1)
        aux(15,i,j) = surfnormals(i,j,2)
        aux(16,i,j) = surfnormals(i,j,3)
     ENDDO
  ENDDO

END SUBROUTINE user5_setaux_manifold


!< Jiang-Shu alpha coefficients object.
module wenoof_alpha_coefficients_js
!< Jiang-Shu alpha coefficients object.
!<
!< @note The provided WENO alpha coefficient implements the alpha coefficients defined in *Efficient Implementation of Weighted ENO
!< Schemes*, Guang-Shan Jiang, Chi-Wang Shu, JCP, 1996, vol. 126, pp. 202--228, doi:10.1006/jcph.1996.0130.

use penf, only : I_P, R_P
use wenoof_alpha_coefficients

implicit none
private
public :: alpha_coefficients_js
public :: alpha_coefficients_js_constructor
public :: create_alpha_coefficients_js_constructor

type, extends(alpha_coefficients_constructor) :: alpha_coefficients_js_constructor
  !< Jiang-Shu alpha coefficient object constructor.
endtype alpha_coefficients_js_constructor

type, extends(alpha_coefficients) :: alpha_coefficients_js
  !< Jiang-Shu alpha coefficient object.
  !<
  !< @note The provided WENO alpha coefficient implements the alpha coefficients defined in *Efficient Implementation of Weighted
  !< ENO Schemes*, Guang-Shan Jiang, Chi-Wang Shu, JCP, 1996, vol. 126, pp. 202--228, doi:10.1006/jcph.1996.0130.
  private
  contains
    ! deferred public methods
    procedure, pass(self) :: compute     !< Compute alpha coefficients.
    procedure, nopass     :: description !< Return alpha coefficients string-description.
endtype alpha_coefficients_js

contains
  ! public non TBP
  subroutine create_alpha_coefficients_js_constructor(S, constructor)
  !< Create alpha coefficients constructor.
  integer(I_P),                                       intent(in)  :: S           !< Stencils dimension.
  class(alpha_coefficients_constructor), allocatable, intent(out) :: constructor !< Alpha coefficients constructor.

  allocate(alpha_coefficients_js_constructor :: constructor)
  constructor%S = S
  endsubroutine create_alpha_coefficients_js_constructor

  ! deferred public methods
  pure subroutine compute(self, S, weight_opt, IS, eps, f1, f2)
  !< Compute alpha coefficients.
  class(alpha_coefficients_js), intent(inout) :: self                       !< Alpha coefficient.
  integer(I_P),                 intent(in)    :: S                          !< Number of stencils used.
  real(R_P),                    intent(in)    :: weight_opt(1: 2, 0: S - 1) !< Optimal weight of the stencil.
  real(R_P),                    intent(in)    :: IS(1: 2, 0: S - 1)         !< Smoothness indicators of the stencils.
  real(R_P),                    intent(in)    :: eps                        !< Parameter for avoiding divided by zero.
  integer(I_P),                 intent(in)    :: f1, f2                     !< Faces to be computed.
  integer(I_P)                                :: f, s1                      !< Counters.

  self%alpha_tot = 0._R_P
  do s1=0, S - 1 ! stencil loops
    do f=f1, f2 ! 1 => left interface (i-1/2), 2 => right interface (i+1/2)
      self%alpha_coef(f, s1) = weight_opt(f, s1) * (1._R_P/(eps + IS(f, s1))**S)
      self%alpha_tot(f) = self%alpha_tot(f) + self%alpha_coef(f, s1)
    enddo
  enddo
  endsubroutine compute

  pure function description() result(string)
  !< Return alpha coefficients string-descripition.
  character(len=:), allocatable :: string           !< String-description.
  character(len=1), parameter   :: nl=new_line('a') !< New line character.

  string = 'WENO alpha coefficient'//nl
  string = string//'  Based on the work by Jiang and Shu "Efficient Implementation of Weighted ENO Schemes", see '// &
           'JCP, 1996, vol. 126, pp. 202--228, doi:10.1006/jcph.1996.0130'//nl
  string = string//'  The "compute" method has the following public API'//nl
  string = string//'    alpha(S, weigt_opt, IS, eps, f1, f2)'//nl
  string = string//'  where:'//nl
  string = string//'    S: integer(I_P), intent(in), the number of the stencils used'//nl
  string = string//'    weight_opt: real(R_P), intent(in), the optimal weight of the actual stencil'//nl
  string = string//'    IS: real(R_P), intent(in), the smoothness indicator of the actual stencil'//nl
  string = string//'    eps: real(R_P), intent(in), the coefficient to avoid zero division used'//nl
  string = string//'    f1, f2: integer(I_P), intent(in), the faces to be computed (1 => left interface, 2 => right interface)'
  endfunction description
endmodule wenoof_alpha_coefficients_js


C $Id$
************************************************************************
*                                                                      *
      subroutine ecp_bess_pow (n,m,x,bess,term,xt,test,tol)
*                                                                      *
*   Calculate modified spherical bessel function i_m(x) using the      *
*   series expansion.                                                  *
*                                                                      *
*   Argument (status) - description                                    *
*                                                                      *
*   n (inp) - number of bessel functions to be evaluated for given     *
*             order                                                    *
*   m (inp) - order of bessel function                                 *
*   x (inp) - array of arguments for bessel function                   *
*   bess (out) - bessel functions                                      *
*   term (scr) - array of terms in series                              *
*   xt (scr) - work space for functions of x                           *
*   test (scr) - array of ratios of terms to sums                      *
*   prefactor (scr) - x^m/(2m+1)!!                                     *
*   tol (inp) - maximum relative error in bessel functions             *
*                                                                      *
*   Written by K. G. Dyall                                             *
*                                                                      *
************************************************************************
      implicit none
      integer n,m,i,idamax
      double precision x(n),bess(n),term(n),xt(n),test(n),
     &    tol,fac0,fac1,fac2,one,two
      parameter (one = 1.0d00, two = 2.0d00)
*
      if (n .le. 0) return
*
      do i = 1,n
        xt(i) = x(i)*x(i)
        bess(i) = 0.0d00
        term(i) = exp(-x(i))
        test(i) = one
      end do
      fac2 = 0.0d00
      fac1 = m+m+1
*
    1 fac1 = fac1+two
      fac2 = fac2+two
      fac0 = one/(fac1*fac2)
      do i = 1,n
        if (test(i) .ge. tol) then
          bess(i) = bess(i)+term(i)
          term(i) = term(i)*xt(i)*fac0
          test(i) = term(i)/bess(i)
        end if
      end do
      i = idamax(n,test,1)
      if (i .gt. 0) then
        if (test(i) .ge. tol) go to 1
      end if
      if (m .eq. 0) return
*
      fac0 = one
      do i = 3,m+m+1,2
        fac1 = i
        fac0 = fac0/fac1
      end do
      do i = 1,n
        bess(i) = bess(i)*fac0*x(i)**m
      end do
      return
      end


PROGRAM LA_ZGBSV_ET_EXAMPLE
!
!  -- LAPACK95 INTERFACE DRIVER ROUTINE (VERSION 3.0) --
!     UNI-C, DENMARK; UNIV. OF TENNESSEE, USA; NAG LTD., UK
!     SEPTEMBER, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => DP
   USE F95_LAPACK, ONLY: LA_GBSV
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
   CHARACTER(LEN=*), PARAMETER :: FMT = '(4(1X,1H(,F9.3,1H,,F9.3,1H):))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   INTEGER :: K, KL, KU, I, J, INFO, N, NRHS
!  .. LOCAL ARRAYS ..
   INTEGER, ALLOCATABLE :: IPIV(:)
   REAL(WP), ALLOCATABLE :: AA(:,:), BB(:,:)
   COMPLEX(WP), ALLOCATABLE :: A(:,:), B(:,:)
!  .. EXECUTABLE STATEMENTS ..
   WRITE (NOUT,*) 'ZGBSV ET_Example Program Results.'
   READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
   READ ( NIN, * ) N, KL, KU, NRHS
   PRINT *, 'N = ', N, ' KL = ', KL, ' KU = ', KU, ' NRHS = ', NRHS
   ALLOCATE ( A(2*KL+KU+1,N), AA(2*KL+KU+1,N), B(N,NRHS), BB(N,NRHS), IPIV(N) )
!
      DO I = KL+1, KL+1+KU
        READ (NIN, *) (AA(I, J), J = KU-I+KL+2, N)
      ENDDO
      DO I = KL+2+KU, 2*KL+KU+1
        READ (NIN, *) (AA(I, J), J = 1, N-I+KL+1+KU)
      ENDDO
!     ENDDO
      B = 0.0_WP
      DO I = 1, NRHS
         DO J = 1, N
            DO K = MAX(1,J-KL), MIN(J+KU,N)
               BB(J,I) = AA(KL+KU+1+J-K,K) + BB(J,I)
            ENDDO
         ENDDO
         BB(:,I) = BB(:,I)*I
      ENDDO
      A = AA; B = BB
      WRITE(NOUT,*) 'The matrix A:'
      DO I = KL+1, 2*KL+KU+1
        WRITE (NOUT,*) 'I = ', I; WRITE (NOUT,FMT) A(I,MAX(1,KL+KU+2-I):MIN(N,KL+KU+N+1-I))
      ENDDO
      WRITE(NOUT,*) 'The RHS matrix B:'
      DO J = 1, NRHS
        WRITE (NOUT,*) 'RHS', J; WRITE (NOUT,FMT) B(:,J)
      ENDDO
!
   WRITE ( NOUT, * )'---------------------------------------------------------'
   WRITE ( NOUT, * )
      WRITE ( NOUT, * )'Details of LA_ZGBSV LAPACK Subroutine Results.'
   WRITE ( NOUT, * )
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GBSV( A, B, KL, IPIV, INFO )'
   A=AA; B=BB
   CALL LA_GBSV( A, B, KL, IPIV, INFO )
   WRITE(NOUT,*)'   B - the solution vectors computed by LA_GBSV, INFO = ', INFO
   DO J = 1, NRHS; WRITE (NOUT,FMT) B(:,J); END DO
   WRITE(NOUT,*) 'Pivots: ', IPIV
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GBSV( A, B(1:N,1), KL, IPIV, INFO )'
   A=AA; B=BB
   CALL LA_GBSV( A, B(1:N,1), KL, IPIV, INFO )
   WRITE(NOUT,*)'   B - the solution vectors computed by LA_GBSV, INFO = ', INFO
   WRITE (NOUT,FMT) B(:,1)
   WRITE(NOUT,*) 'Pivots: ', IPIV
!
   WRITE(NOUT,*)'   B - the solution vectors computed by LA_GBSV:'
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GBSV(A, B, KL)'
   A=AA; B=BB
   CALL LA_GBSV(A,B,KL)
   WRITE(NOUT,*)'   B - the solution vectors computed by LA_GBSV:'
   DO J = 1, NRHS; WRITE (NOUT,FMT) B(:,J); END DO
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GBSV(A, B(1:N,1), KL)'
   A=AA; B=BB
      CALL LA_GBSV(A,B(1:N,1),KL)
   WRITE(NOUT,*)'   B - the solution vectors computed by LA_GBSV:'
   WRITE (NOUT,FMT) B(:,1)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GBSV(A, B, IPIV=IPIV)'
   A=AA; B=BB
   CALL LA_GBSV(A,B,IPIV=IPIV)
   WRITE(NOUT,*)'   B - the solution vectors computed by LA_GBSV:'
   DO J = 1, NRHS
      WRITE (NOUT,FMT) B(:,J)
   END DO
   WRITE(NOUT,*) 'Pivots: ', IPIV
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GBSV(A,B(1:N,1),KL,IPIV)'
   A=AA; B=BB
   CALL LA_GBSV(A,B(1:N,1),KL,IPIV)
   WRITE(NOUT,*)'   B - the solution vectors computed by LA_GBSV:'
   WRITE (NOUT,FMT) B(1:N,1)
   WRITE(NOUT,*) 'Pivots: ', IPIV
!
END PROGRAM LA_ZGBSV_ET_EXAMPLE


! { dg-do compile }
! Check the fix for PR47850, in which the argument of ANY, below, was not
! simplified, thereby causing an ICE.
!
! Contributed by Tobias Burnus  <burnus@gcc.gnu.org> but based on James van Buskirk's program in
! http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/625faf82578e9af8
!
!
program Cindex
   implicit none
   integer,parameter :: SENSOR_CHANNEL(8) = &
      [10,12,17,20,22,30,33,34]
   integer,parameter :: NLTE_CHANNEL(3) = [20,22,34]
   integer,parameter :: N_NLTE_CHANNELS = size(NLTE_CHANNEL)
   integer,parameter :: N_CHANNELS = size(SENSOR_CHANNEL)
   integer i
   integer,parameter :: C_INDEX(8) = unpack( &
      vector = [(i,i=1,size(SENSOR_CHANNEL))], &
      mask = [(any(SENSOR_CHANNEL(i) == NLTE_CHANNEL), &
         i=lbound(SENSOR_CHANNEL,1),ubound(SENSOR_CHANNEL,1))], &
      field = 0)
   character(20) fmt

   write(fmt,'(a,i0,a)') '(a,t19,',size(SENSOR_CHANNEL),'(i3:","))'
   write(*,fmt) 'SENSOR_CHANNEL = ',SENSOR_CHANNEL
   write(fmt,'(a,i0,a)') '(a,t19,',size(NLTE_CHANNEL),'(i3:","))'
   write(*,fmt) 'NLTE_CHANNEL = ',NLTE_CHANNEL
   write(*,'(a,t19,i3)') 'N_NLTE_CHANNELS = ',N_NLTE_CHANNELS
   write(*,'(a,t19,i3)') 'N_CHANNELS = ',N_CHANNELS
   write(fmt,'(a,i0,a)') '(a,t19,',size(C_INDEX),'(i3:","))'
   write(*,fmt) 'C_INDEX = ',C_INDEX
end program Cindex


c       this file contains the following user-callable routines:
c
c
c       routine idz_sffti initializes routine idz_sfft.
c
c       routine idz_sfft rapidly computes a subset of the entries
c       of the DFT of a vector, composed with permutation matrices
c       both on input and on output.
c
c       routine idz_ldiv finds the greatest integer less than or equal
c       to a specified integer, that is divisible by another (larger)
c       specified integer.
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
c
        subroutine idz_ldiv(l,n,m)
c
c       finds the greatest integer less than or equal to l
c       that divides n.
c
c       input:
c       l -- integer at least as great as m
c       n -- integer divisible by m
c
c       output:
c       m -- greatest integer less than or equal to l that divides n
c
        implicit none
        integer n,l,m
c
c
        m = l
c
 1000   continue
        if(m*(n/m) .eq. n) goto 2000
c
          m = m-1
          goto 1000
c
 2000   continue
c
c
        return
        end
c
c
c
c
        subroutine idz_sffti(l,ind,n,wsave)
c
c       initializes wsave for use with routine idz_sfft.
c
c       input:
c       l -- number of entries in the output of idz_sfft to compute
c       ind -- indices of the entries in the output of idz_sfft
c              to compute
c       n -- length of the vector to be transformed
c
c       output:
c       wsave -- array needed by routine idz_sfft for processing
c
        implicit none
        integer l,ind(l),n,nblock,ii,m,idivm,imodm,i,j,k
        real*8 r1,twopi,fact
        complex*16 wsave(2*l+15+3*n),ci,twopii
c
        ci = (0,1)
        r1 = 1
        twopi = 2*4*atan(r1)
        twopii = twopi*ci
c
c
c       Determine the block lengths for the FFTs.
c
        call idz_ldiv(l,n,nblock)
        m = n/nblock
c
c
c       Initialize wsave for use with routine zfftf.
c
        call zffti(nblock,wsave)
c
c
c       Calculate the coefficients in the linear combinations
c       needed for the direct portion of the calculation.
c
        fact = 1/sqrt(r1*n)
c
        ii = 2*l+15
c
        do j = 1,l
c
          i = ind(j)
c
          idivm = (i-1)/m
          imodm = (i-1)-m*idivm
c
          do k = 1,m
            wsave(ii+m*(j-1)+k) = exp(-twopii*imodm*(k-1)/(r1*m))
     1       * exp(-twopii*(k-1)*idivm/(r1*n)) * fact
          enddo ! k
c
        enddo ! j
c
c
        return
        end
c
c
c
c
        subroutine idz_sfft(l,ind,n,wsave,v)
c
c       computes a subset of the entries of the DFT of v,
c       composed with permutation matrices both on input and on output,
c       via a two-stage procedure (routine zfftf2 is supposed
c       to calculate the full vector from which idz_sfft returns
c       a subset of the entries, when zfftf2 has the same parameter
c       nblock as in the present routine).
c
c       input:
c       l -- number of entries in the output to compute
c       ind -- indices of the entries of the output to compute
c       n -- length of v
c       v -- vector to be transformed
c       wsave -- processing array initialized by routine idz_sffti
c
c       output:
c       v -- entries indexed by ind are given their appropriate
c            transformed values
c
c       _N.B._: The user has to boost the memory allocations
c               for wsave (and change iii accordingly) if s/he wishes
c               to use strange sizes of n; it's best to stick to powers
c               of 2.
c
c       references:
c       Sorensen and Burrus, "Efficient computation of the DFT with
c            only a subset of input or output points,"
c            IEEE Transactions on Signal Processing, 41 (3): 1184-1200,
c            1993.
c       Woolfe, Liberty, Rokhlin, Tygert, "A fast randomized algorithm
c            for the approximation of matrices," Applied and
c            Computational Harmonic Analysis, 25 (3): 335-366, 2008;
c            Section 3.3.
c
        implicit none
        integer n,m,l,k,j,ind(l),i,idivm,nblock,ii,iii
        real*8 r1,twopi
        complex*16 v(n),wsave(2*l+15+3*n),ci,sum
c
        ci = (0,1)
        r1 = 1
        twopi = 2*4*atan(r1)
c
c
c       Determine the block lengths for the FFTs.
c
        call idz_ldiv(l,n,nblock)
c
c
        m = n/nblock
c
c
c       FFT each block of length nblock of v.
c
        do k = 1,m
          call zfftf(nblock,v(nblock*(k-1)+1),wsave)
        enddo ! k
c
c
c       Transpose v to obtain wsave(2*l+15+2*n+1 : 2*l+15+3*n).
c
        iii = 2*l+15+2*n
c
        do k = 1,m
          do j = 1,nblock
            wsave(iii+m*(j-1)+k) = v(nblock*(k-1)+j)
          enddo ! j
        enddo ! k
c
c
c       Directly calculate the desired entries of v.
c
        ii = 2*l+15
        iii = 2*l+15+2*n
c
        do j = 1,l
c
          i = ind(j)
c
          idivm = (i-1)/m
c
          sum = 0
c
          do k = 1,m
            sum = sum + wsave(ii+m*(j-1)+k) * wsave(iii+m*idivm+k)
          enddo ! k
c
          v(i) = sum
c
        enddo ! j
c
c
        return
        end


      PROGRAM driver

      INCLUDE 'KPP_ROOT_Parameters.h'
      INCLUDE 'KPP_ROOT_Global.h'

      INTEGER i

C ---- TIME VARIABLES ------------------

      RTOLS = 1e-3
      do i=1,NVAR
        RTOL(i) = RTOLS
        ATOL(i) = 1E-18
      end do

      CALL Initialize()

      open(10, file='Extrapd.m')
      write(10,*) 'ed=['

      TSTART = 3600*12
      TEND = TSTART + 3600*24*5
      STEPMIN = 0.01
      STEPMAX = 900
      DT = 3600.
      TEMP = 236.21

C -- BELOW THIS LIMIT USE TAYLOR INSTEAD OF EXP ---
C ********** TIME LOOP *************************
      TIME = TSTART
      do while (TIME .le. TEND)

        write(6,991) (C(MONITOR(i))/CFACTOR, i=1,NMONITOR)

        write(10,992) (TIME-TSTART)/3600.D0,
     *                (C(LOOKAT(i))/CFACTOR, i=1,NLOOKAT)

        call Update_SUN()
        call Update_RCONST()

        call INTEGRATE( TIME, TIME+DT )

      end do
C *********** END TIME LOOP ********

      write(10,*) '];'
      close(10)
      STOP

991   FORMAT('Monitor:',10(1X,E12.6))
992   FORMAT(F6.1,100(1X,D24.16))
      END


FUNCTION setbds(clay,sand,om)
!
IMPLICIT NONE
!
! Function arguments
!
REAL :: clay,om,sand
REAL :: setbds
!
! Local variables
!
REAL :: fi,fj,mbd,mbd_hi_hj,mi,mj,tempsum
INTEGER :: hi,hj,li,lj
INTEGER :: int
REAL,DIMENSION(0:10,0:10) :: mbdtv
!
!     + + + purpose + + +
!     the following function estimates settled soil bulk density from
!     intrinsic properties. see rawls (1983) soil science 135, 123-125.

!     should eventually be called by main to initialize the values
!     for each subregion (unless soil composition changes).

!     + + + keywords + + +
!     bulk density, initialization

!     + + + parameters and common blocks + + +
!     none

!     + + + argument declarations + + +

!     + + + argument definitions + + +

!     setbd - settled bulk density
!     clay  - fraction of soil clay content
!     sand  - fraction of soil sand content
!     om    - organic matter

!     + + + local variables + + +
!

!     li  - index into table less than sand content
!     lj  - index into table less than clay content
!     hi  - index into table higher than sand content
!     hj  - index into table higher than clay content
!     mi  - value between indexes for interpolation for sand
!     mj  - value between indexes for interpolation for clay
!     fi  - fraction of distance between grid cells for sand
!     fj  - fraction of distance between grid cells for clay
!     mbdtv (0:10,0:10) - data table of settled bulk density
!                         as a function of sand (across the top)
!                         and clay (down the side)
!     mbd   - mineral bulk density without organic matter
!     mbd_hi_hj - value for mbdtv(hi,hj), if outside triangular
!                 part of table it is reflected from mbdtv(li,lj)
!                 otherwise it is just the real point

!     + + + subroutines called + + +

!     + + + function declaratons + + +

!     + + + data initializations + + +
!     first index in this direction ->
!     second index || goes down
!                  \/
DATA mbdtv/1.48,1.25,1.00,1.06,1.16,1.22,1.30,1.39,1.45,1.51,1.52,1.52,1.40,    &
   & 1.19,1.25,1.32,1.40,1.52,1.58,1.63,1.65,0.,1.52,1.40,1.25,1.35,1.45,1.53,  &
   & 1.60,1.64,1.72,0.,0.,1.52,1.40,1.29,1.41,1.50,1.57,1.63,1.68,0.,0.,0.,1.50,&
   & 1.40,1.35,1.43,1.53,1.61,1.64,0.,0.,0.,0.,1.46,1.40,1.40,1.43,1.53,1.62,0.,&
   & 0.,0.,0.,0.,1.45,1.40,1.38,1.42,1.50,0.,0.,0.,0.,0.,0.,1.42,1.37,1.33,1.33,&
   & 0.,0.,0.,0.,0.,0.,0.,1.33,1.32,1.20,0.,0.,0.,0.,0.,0.,0.,0.,1.23,1.18,0.,  &
   & 0.,0.,0.,0.,0.,0.,0.,0.,1.15,0.,0.,0.,0.,0.,0.,0.,0.,0.,0./

!     + + + end specifications + + +

tempsum = sand + clay
IF (tempsum.GT.1.0) THEN
  sand = sand/tempsum
  clay = clay/tempsum
  WRITE (*,*) 'setbds: sand plus clay fractions greater than 1.0'
  WRITE (*,*) 'values adjusted by averaging the difference'
END IF

!      i = nint(sand*100.0/10.0)
!      j = nint(clay*100.0/10.0)

!      mbd = mbdtv(i,j)

mi = sand*10.0
li = int(mi)
fi = mi - li
hi = min(li+1,10)

mj = clay*10.0
lj = int(mj)
fj = mj - lj
hj = min(lj+1,10)

!     check for table edge
IF (li+lj.EQ.10) THEN
!         on table edge, no interpolation necessary
  mbd = mbdtv(li,lj)
ELSE
  IF (hi+hj.GT.10) THEN
!             interpolation on the triangular edge of the table
!             mirror li,lj value to make using grid interpolation possible
     mbd_hi_hj = mbdtv(li,hj) + mbdtv(hi,lj) - mbdtv(li,lj)
  ELSE
!             interpolation within the table, use grid point
     mbd_hi_hj = mbdtv(hi,hj)
  END IF
  mbd = (1-fi)*(1-fj)*mbdtv(li,lj) + (1-fi)*fj*mbdtv(li,hj) + fi*(1-fj)         &
      & *mbdtv(hi,lj) + fi*fj*mbd_hi_hj
END IF

setbds = 1.0/((om/0.224)+(1.0-om)/mbd)
!
END FUNCTION setbds

Project Documents/Source Code Original/Setbds.f90


c     DRSBESJ0
c>> 2009-10-26 DRSBESJ0 Krogh Moved function calls from print statement.
c>> 1996-05-30 DRSBESJ0 Krogh Added external statement.
c>> 1994-10-19 DRSBESJ0 Krogh  Changes to use M77CON
c>> 1994-09-13 DRSBESJ0 CLL Typed all variables.
c>> 1994-09-01 DRSBESJ0 WVS Moved formats to top for C conversion
c>> 1994-08-09 DRSBESJ0 WVS set up for CHGTYP
c>> 1992-04-29 DRSBESJ0 CAO Replaced '1' in format.
c>> 1987-12-09 DRSBESJ0 Lawson  Initial Code.
c--S replaces "?": ?BESJ0, ?BESJ1, ?BESY0, ?BESY1, DR?BESJ0
c     Demonstration driver for Bessel functions.
c
c     Z = (PI / 2) * X * ( J1(X)*Y0(X) - J0(X)*Y1(X) ) - 1.0
c
      integer IX
      real             BEJ0, BEJ1, BEY0, BEY1
      external SBESJ0, SBESJ1, SBESY0, SBESY1
      real             SBESJ0, SBESJ1, SBESY0, SBESY1, PI2, X, Z
c
      data PI2 / 1.5707963267948966192313216E0 /
c
  100 format (' ',2X,A1,7X,A5,8X,A5,8X,A5,8X,A5,8X,A1/3X,'-',7X,
     *        5('-'),8X,5('-'),8X,5('-'),8X,5('-'),8X,'-')
  150 format (' ',F4.1,1X,2(F12.7,1X),3X,'-INFINITY',4X,'-INFINITY')
  200 format (' ',F4.1,1X,4(F12.7,1X),1X,G9.2)
c
      print 100, 'X','J0(X)','J1(X)','Y0(X)','Y1(X)','Z'
c
      X = 0.E0
      BEJ0 = SBESJ0(X)
      BEJ1 = SBESJ1(X)
      print 150, X, BEJ0, BEJ1
c
      do 250 IX = 5, 50, 5
        X = IX / 10.E0
        BEJ0 = SBESJ0(X)
        BEJ1 = SBESJ1(X)
        BEY0 = SBESY0(X)
        BEY1 = SBESY1(X)
        Z = PI2 * X * ( BEJ1*BEY0  - BEJ0*BEY1 ) - 1.0e0
        print 200, X,BEJ0,BEJ1,BEY0,BEY1,Z
  250 continue
      stop
c
      end


      PROGRAM LA_SSYSV_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_SYSV
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, J, INFO, N, NRHS
!  .. "Local Arrays" ..
      INTEGER, ALLOCATABLE :: IPIV(:)
      REAL(WP), ALLOCATABLE :: A(:,:), AA(:,:), B(:,:), BB(:,:)
!  .. "Intrinsic Functions" ..
      INTRINSIC  SUM
!  .. "Executable Statements" ..
      WRITE (*,*) 'SSYSV Example Program Results'
      N = 5; NRHS = 3
      WRITE(*,'(5H N = , I4, 9H; NRHS = , I4)') N, NRHS
      ALLOCATE ( A(N,N), AA(N,N), B(N,NRHS), BB(N,NRHS), IPIV(N) )

      OPEN(UNIT=21,FILE='sysv.ma',STATUS='UNKNOWN')
      DO I=1,N
         DO J=I,N
         READ(21,'(F3.0)') A(I,J);
         ENDDO
      ENDDO;
      CLOSE(21)

      WRITE(*,*) 'The array A :'
      DO I=1,N
      WRITE(*,'(10(I3,1X,1X),I3,1X)') INT(A(I,1:N));
      ENDDO
      AA=TRANSPOSE(A)
      DO I = 1, N
        DO J = 1, NRHS
        B(I,J) = (SUM(A(I,I:N)) + SUM(A(1:I-1,I)))*J
        ENDDO
      ENDDO

      WRITE(*,*) 'The array B :'
      DO I=1,N
            WRITE(*,'(3(I3,1X,1X))') INT(B(I,1:NRHS));
      ENDDO
      BB=B
      WRITE(*,*)' CALL LA_SYSV( A, B, IPIV=IPIV )'
      CALL LA_SYSV( A, B, IPIV=IPIV )

      WRITE(*,*)'A on exit: '
      DO J=1,N; WRITE(*,"(6(E13.5))") A(J,:);
      ENDDO

      WRITE(*,*)'B on exit: '
      DO I=1,N; WRITE(*,"(3(F9.5))") B(I,:);
      ENDDO

      WRITE(*,*)'IPIV on exit : ', IPIV

      WRITE(*,*)' * EXAMPLE 2 * '

      WRITE(*,*) 'The array A :'
      DO I=1,N
      WRITE(*,'(10(I3,1X,1X),I3,1X)') INT(AA(I,1:N));
      ENDDO
      WRITE(*,*) 'The array B :'
      DO I=1,N
      WRITE(*,'(3(I3,1X,1X))') INT(BB(I,1));
      ENDDO

      WRITE(*,*)"CALL LA_SYSV( A, B(:,1), 'L', IPIV, INFO )"
      CALL LA_SYSV( AA, BB(:,1), 'L', IPIV, INFO )

      WRITE(*,*)'A on exit: '
      DO J=1,N; WRITE(*,"(6(E13.5))") AA(J,:);
      ENDDO

      WRITE(*,*)'B(:,1) on exit: '
      DO I=1,N; WRITE(*,"(3(F9.5))") BB(I,1);
      ENDDO

      WRITE(*,*)' IPIV = ',IPIV
      WRITE(*,*)' INFO = ',INFO

!      DEALLOCATE (A, AA, B, BB, IPIV)
      print *,'after the dealloc'
      END PROGRAM LA_SSYSV_EXAMPLE


      PROGRAM LA_SPPSV_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements"
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_PPSV
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, J, N, NN, NRHS
!  .. Local Arrays ..
      REAL(WP), ALLOCATABLE :: AP(:) ,B(:,:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'SPPSV Example Program Results.'
      N = 5; NRHS = 1
      NN = N*(N+1)/2
      ALLOCATE ( AP(NN), B(N,NRHS) )

      OPEN(UNIT=21,FILE='posv.ma',STATUS='UNKNOWN')
      DO I=1,NN
         READ(21,'(F3.0)') AP(I);
      ENDDO;
      CLOSE(21)

      WRITE(*,*) 'The array AP :'
      DO I=1,NN
      WRITE(*,'(10(I3,1X,1X),I3,1X)') INT(AP(I));
      ENDDO

      OPEN(UNIT=21,FILE='ppsv.mb',STATUS='UNKNOWN')
      DO I=1,N
      DO J=1,NRHS
         READ(21,'(F3.0)') B(I,J);
      ENDDO;
      ENDDO;
      CLOSE(21)

      WRITE(*,*) 'The array B :'
      DO I=1,N
       WRITE(*,'(10(I3,1X,1X),I3,1X)') INT(B(I,:));
      ENDDO;

      WRITE(*,*) "CALL LA_PPSV( AP, B, 'L' )"
      CALL LA_PPSV(  AP, B, 'L' )

      WRITE(*,*)'AP on exit :'
      DO I=1,NN; WRITE(*,"(5(E13.6))") AP(I);
      ENDDO

      WRITE(*,*)'B on exit :'
      DO I=1,N; WRITE(*,"(5(E13.6))") B(I,:);
      ENDDO

      END PROGRAM LA_SPPSV_EXAMPLE


!===========================================================
!
!> @brief     Sorting algorithms
!!
!> @author    Christopher Kebschull (ChK)
!> @author    Vitali Braun (VB)
!!
!> @date

!!
VB:  05.11.2013 (initial design)

!!
ChK: 10.07.2015 (assimilated into libslam)

!!

!!
!! @details   This module contains parameters, subroutines
!!            and functions required for sorting data
!!
!> @copyright Institute of Space Systems / TU Braunschweig
!!
!-----------------------------------------------------------
module slam_sort

  use slam_types
  use slam_math, only: pi, halfPi, twoPi, rad2deg, deg2rad

  implicit none

  private

  ! Bubble sort
  interface bubble_sort
    module procedure bubble_sort_i, bubble_sort_d
  end interface bubble_sort

  ! Quick sort
  interface quick_sort
    module procedure quick_sort_d
  end interface quick_sort

  ! public methods
  !---------------------------------
  public :: bubble_sort
  public :: quick_sort

contains

  !===========================================================
  !> @brief   sorts obj(1:n) using a hybrid quick sort-insertion sort algorithm
  !!
  !> @author Institute of Space Systems
  !!
  !> @par Version
  !!      0.2
  !!
  !> @par Changelog
  !!

  !!
 12.02.2016 - Initial Design
  !!
 14.08.2018 - moved to libslam (VS)
  !!

  !!
  !! @param [in]     n         number of values to be sorted, integer
  !! @param [in]    obj(1:n)  values to be sorted, real(dp)
  !! @param [out] indx(1:n) sorted order, beginning with the smallest value. smallest value: obj(indx(1)), biggest value: obj(indx(n)), real(dp)
  !!
  !> @par Description\n
  !!          sorts obj(1:n) using a hybrid quick sort-insertion sort algorithm, based on source of Len Moss (15 Jul 1986), SLAC
  !!
  !----------------------------------------------------
  subroutine quick_sort_d(n, obj, indx)

    implicit none

    ! INPUT
    integer n
    real(dp) :: obj(n)

    ! OUTPUT
    integer indx(1:n)

    ! internal
    integer   M
    parameter (M=9)

    integer LSTK(31)
    integer RSTK(31)
    integer ISTK
    integer L
    integer R
    integer I
    integer J
    integer P
    integer INDEXP
    integer INDEXT

    real(dp) :: DATAP

    !Make initial guess for indx
    do I=1,N
      indx(I)=I
    end do

    ! If array is short, skip quick_sort and go directly to
    !...the straight insertion sort.
    if (n .GT.M) then

      ! initialize
      istk = 0
      l = 1
      r = n

      do

        ! Sort the subsequence obj[L]..obj[R].
        i = l
        j = r

        ! Select pivot key
        !
        ! Let the pivot, P, be the midpoint of this subsequence,
        ! P=(L+R)/2; then rearrange INDX(L), INDX(P), and INDX(R)
        ! so the corresponding obj values are in increasing order.
        ! The pivot key, DATAP, is then obj[P].
        P=(L+R)/2
        INDEXP=indx(P)
        DATAP=obj(INDEXP)
        !     write(*,*) 'quick do', i,j
        if (obj(indx(L)) .GT. DATAP) then
          indx(P)=indx(L)
          indx(L)=INDEXP
          INDEXP=indx(P)
          DATAP=obj(INDEXP)
        end if

        if (DATAP .GT. obj(indx(R))) then
          if (obj(indx(L)) .GT. obj(indx(R))) then
            indx(P)=indx(L)
            indx(L)=indx(R)
          else
            indx(P)=indx(R)
          end if
          indx(R)=INDEXP
          INDEXP=indx(P)
          DATAP=obj(INDEXP)
        end if

        ! Now we swap values between the right and left sides and/or
        ! move DATAP until all smaller values are on the left and all
        ! larger values are on the right.  Neither the left or right
        ! side will be internally ordered yet; however, DATAP will be
        ! in its final position.

        do

          ! Search for datum on left >= DATAP
          do
            I=I+1
            if (obj(indx(I)).LT.DATAP) cycle
            exit
          end do

          ! Search for datum on right <= DATAP
          do
            J=J-1
            if (obj(indx(J)).GT.DATAP) cycle
            exit
          end do

          ! Have the two scans collided?
          if (I.LT.J) then
            ! No, interchange objIi] <--> obj[j] and continue
            INDEXT=indx(I)
            indx(I)=indx(J)
            indx(J)=INDEXT
            ! CYCLE
            cycle
          end if

          ! or EXIT
          exit

        end do

        ! Yes, select next subsequence to sort

        ! If both subsequences are
        ! more than M elements long, push the longer one on the stack and
        ! go back to quick_sort the shorter; if only one is more than M
        ! elements long, go back and quick_sort it; otherwise, pop a
        ! subsequence off the stack and quick_sort it.

        if (R-J .GE. I-L .AND. I-L .GT. M) then
          ISTK=ISTK+1
          LSTK(ISTK)=J+1
          RSTK(ISTK)=R
          R=I-1
        else if (I-L .GT. R-J .AND. R-J .GT. M) then
          ISTK=ISTK+1
          LSTK(ISTK)=L
          RSTK(ISTK)=I-1
          L=J+1
        else if (R-J .GT. M) then
          L=J+1
        else if (I-L .GT. M) then
          R=I-1
        else
          ! Q8: Pop the stack, or terminate quick_sort if empty
          if (ISTK.LT.1) exit
          L=LSTK(ISTK)
          R=RSTK(ISTK)
          ISTK=ISTK-1
        end if

      end do

    end if

    ! Straight Insertion sort
    do I=2,N

      if (obj(indx(I-1)) .GT. obj(indx(I))) then

        INDEXP=indx(I)
        DATAP=obj(INDEXP)
        P=I-1

        do
          indx(P+1) = indx(P)
          P=P-1
          ! CYCLE
          !       write(*,*) 'quick do', p,'p'
          !       IF ((P.GT.0).AND.(obj(indx(P)).GT.DATAP)) CYCLE
          if (P.GT.0) then
            if (obj(indx(P)).GT.DATAP) cycle
          end if
          ! or EXIT
          exit
        end do

        indx(P+1) = INDEXP

      endif

    end do

  end subroutine quick_sort_d

  !===========================================================
  !
  !> @brief   Bubble sort algorithm for real valued array
  !!
  !> @author  Vitali Braun
  !> @date

  !!
05.11.2013 (initial design)

  !!

  !!
  !!-----------------------------------------------------------
  subroutine bubble_sort_d(val, nval)

      integer,  intent(in) :: nval
      real(dp), dimension(nval), intent(inout) :: val

      integer  :: i
      logical  :: swapped      ! flag indicating element swap
      real(dp) :: temp         ! temporary for element swap

      do

        swapped = .false.

        do i = 1, nval - 1
          if(val(i) .gt. val(i+1)) then
            ! swap values
            temp     = val(i)
            val(i)   = val(i+1)
            val(i+1) = temp
            swapped  = .true.
          end if
        end do

        if(.not. swapped) exit

      end do

  end subroutine bubble_sort_d

  !===========================================================
  !
  !> @brief   Bubble sort algorithm for integer valued array
  !!
  !> @author  Vitali Braun
  !> @date

  !!
05.11.2013 (initial design)

  !!

  !!
  !!-----------------------------------------------------------
  subroutine bubble_sort_i(val, nval)

      integer,  intent(in) :: nval
      integer, dimension(nval), intent(inout) :: val

      integer  :: i
      logical  :: swapped      ! flag indicating element swap
      integer  :: temp         ! temporary for element swap

      do

        swapped = .false.

        do i = 1, nval - 1
          if(val(i) .gt. val(i+1)) then
            ! swap values
            temp     = val(i)
            val(i)   = val(i+1)
            val(i+1) = temp
            swapped  = .true.
          end if
        end do

        if(.not. swapped) exit

      end do

  end subroutine bubble_sort_i

end module slam_sort


program test_intersection
use iso_fortran_env,only:int8,int16,int32,int64,real32,real64,real128
use mod_testing,only:assert,initialize_tests,report_tests
use mod_functional

implicit none

logical,dimension(:),allocatable :: tests
logical :: test_failed
integer :: n,norder,ntests
integer,parameter :: stdout = 6

n = 1
ntests = 11
call initialize_tests(tests,ntests)

tests(n) = assert(all(intersection([1_int8,2_int8],[2_int8,3_int8]) == [2]),&
                  'intersection, int8')
n = n + 1

tests(n) = assert(all(intersection([1_int16,2_int16],[2_int16,3_int16]) == [2]),&
                  'intersection, int16')
n = n + 1

tests(n) = assert(all(intersection([1_int32,2_int32],[2_int32,3_int32]) == [2]),&
                  'intersection, int32')
n = n + 1

tests(n) = assert(all(intersection([1_int64,2_int64],[2_int64,3_int64]) == [2]),&
                  'intersection, int64')
n = n + 1

tests(n) = assert(all(intersection([1._real32,2._real32],[2._real32,3._real32]) == [2]),&
                  'intersection, real32')
n = n + 1

tests(n) = assert(all(intersection([1._real64,2._real64],[2._real64,3._real64]) == [2]),&
                  'intersection, real64')
n = n + 1

tests(n) = assert(all(intersection([1._real128,2._real128],[2._real128,3._real128]) == [2]),&
                  'intersection, real128')
n = n + 1

tests(n) = assert(all(intersection([cmplx(1._real32,0._real32),cmplx(2._real32,0._real32)],&
                                   [cmplx(2._real32,0._real32),cmplx(3._real32,0._real32)])&
                       == [cmplx(2._real32,0._real32)]),&
                  'intersection, complex real32')
n = n + 1

tests(n) = assert(all(intersection([cmplx(1._real64,0._real64),cmplx(2._real64,0._real64)],&
                                   [cmplx(2._real64,0._real64),cmplx(3._real64,0._real64)])&
                       == [cmplx(2._real64,0._real64)]),&
                  'intersection, complex real64')
n = n + 1

tests(n) = assert(all(intersection([cmplx(1._real128,0._real128),cmplx(2._real128,0._real128)],&
                                   [cmplx(2._real128,0._real128),cmplx(3._real128,0._real128)])&
                       == [cmplx(2._real128,0._real128)]),&
                  'intersection, complex real128')
n = n + 1

tests(n) = assert(all(intersection([1,2],[2,3]) == ([1,2].intersection.[2,3])),&
                  'intersection operator, x.intersection.y')
n = n + 1

test_failed = .false.
call report_tests(tests,test_failed)
if(test_failed)stop 1

endprogram test_intersection


! This file is part of mctc-lib.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

!> Numerical constants
module mctc_io_constants
   use mctc_env_accuracy, only : wp
   implicit none
   private

   public :: pi, codata

   !> Ratio between a circles diameter and its circumfence
   real(wp), parameter :: pi = 3.1415926535897932384626433832795029_wp

   !> Natural constants defining the SI unit base
   type :: enum_codata

      !> Planck's constant
      real(wp) :: h = 6.6260715e-34_wp ! J·s = kg·m²·s⁻¹

      !> Speed of light in vacuum
      real(wp) :: c = 299792458.0_wp ! m·s⁻¹

      !> Boltzmann's constant
      real(wp) :: kb = 1.380649e-23_wp ! J·K⁻¹ = kg·m²·s⁻²·K⁻¹

      !> Avogadro's number
      real(wp) :: NA = 6.02214076e23_wp ! mol⁻¹

      !> Elementary charge
      real(wp) :: e = 1.602176634e-19_wp ! C

      !> fine structure constant (CODATA2018)
      real(wp) :: alpha = 1.0_wp/137.035999046_wp ! dimensionless

      !> electron rest mass
      real(wp) :: me = 9.10938356e-31_wp ! kg

   end type enum_codata

   !> Actual collection of natural constants
   type(enum_codata), parameter :: codata = enum_codata()

end module mctc_io_constants


!-------------------------------------------------------------------------------------------------------------
! file: Test_SWCharEst.f90
! Test of module SWCharEst.
! build:
!    gfortran -g -o Test_SWCharEst ../src/SWCharEst.f90 Test_SWCharEst.f90
! run:
!    ./Test_SWCharEst
!-------------------------------------------------------------------------------------------------------------

subroutine DisplaySWCharEst ( name, values )

    implicit none
    character (len = *) :: name
    real :: values(1:4)

    print*, "  ", name, ": WP, FC, thetaS, Ks = ", &
	    values(1), ", ",  &
	    values(2), ", ",  &
	    values(3), ", ",  &
	    values(4)

end subroutine DisplaySWCharEst

! Returns true if fabs(a-b) / a <= threshold (a != 0)
! or if fabs(a-b) / b <= threshold (b != 0)
! or true if a = b = 0.
function AreClose ( a, b, threshold ) result( isClose )

    implicit none
    real :: a, b, threshold
    logical :: isClose

    isClose = .true.
    if ( 1.0 + (a - b) - 1.0 .ne. 0.0 ) then
	    if ( a .ne. 0.0 ) then
		isClose = ( abs ((a - b) / a) .le. threshold )
	    else if ( b .ne. 0.0 ) then
		isClose = ( abs ((a - b) / b) .le. threshold )
	    end if
    end if

end function AreClose

subroutine Compare ( expected, results )

    implicit none
    real :: expected(1:4), results(1:4)
    logical :: AreClose, passed

    passed = AreClose( expected(1), results(1), 1.0e-4 ) .and. &
	     AreClose( expected(2), results(2), 1.0e-4 ) .and. &
	     AreClose( expected(3), results(3), 1.0e-4 ) .and. &
	     AreClose( expected(4), results(4), 1.0e-3 )

    if ( passed ) then
	print*, "  passed"
    else
	print*, "  failed"
    endif

end subroutine Compare

program Test_SWCharEst

    use SWCharEst

    call Usage()
    call Test1()
    call Test2()

    contains

	subroutine Test1 ()
	    ! Example - sand:

	    implicit none
	    ! sand fraction, clay fraction, organic matter wt %
	    real :: soilTexture(1:3) = (/ 0.85, 0.04, 2.08 /)
	    !                          WP      FC       thetaS  Ks
	    real :: expected(1:4) = (/ 0.0400, 0.09785, 0.4545, 0.003096 /)
	    real :: results(1:4)

	    print*, "Test: SWCharEst( 0.85, 0.04, 2.08 )"
	    results = Get( soilTexture(1), soilTexture(2), soilTexture(3) );
	    call DisplaySWCharEst( "expected", expected );
	    call DisplaySWCharEst( "results", results );
	    call Compare( expected, results )

	end subroutine Test1

	subroutine Test2 ()
	    ! Example - silt loam:

	    implicit none
	    ! sand fraction, clay fraction, organic matter wt %
	    real :: soilTexture(1:3) = (/ 0.15, 0.18, 3.05 /)
	    !                          WP      FC       thetaS  Ks
	    real :: expected(1:4) = (/ 0.1286, 0.33148, 0.5050, 0.000433 /)
	    real :: results(1:4)

	    print*, "Test: SWCharEst( 0.15, 0.18, 3.05 )"
	    results = Get( soilTexture(1), soilTexture(2), soilTexture(3) );
	    call DisplaySWCharEst( "expected", expected );
	    call DisplaySWCharEst( "results ", results );
	    call Compare( expected, results )

	end subroutine Test2

end program