! Main routine for genetic algorithms for optimization.
! Igor Lopes, February 2015
SUBROUTINE GENETIC(NDIM)
    IMPLICIT NONE
    ! Parameters
    REAL(8) R0 /0.0D0/
    REAL(8) R1 /1.0D0/
    REAL(8) R2 /2.0D0/
    ! Argument
    INTEGER NDIM
    ! Locals
    INTEGER     :: IBIT, ICOUNT, IDIM, IPOP, IGEN, NPOP, NTBIT, MGEN,&
                   NGENT, NSONS, NSURV, NTOPOUT, NTOPT
    INTEGER,DIMENSION(NDIM) :: NBITS
    REAL(8),DIMENSION(NDIM) :: XMIN, XMAX, PRECIS
    REAL(8),ALLOCATABLE,DIMENSION(:)    :: VFITO, VFIT, OBJFUN
    INTEGER,ALLOCATABLE,DIMENSION(:,:)  :: POPO, POP
    REAL(8),ALLOCATABLE,DIMENSION(:,:)  :: XVEC
    CHARACTER   :: STRING*256
    REAL(8)     :: RANDN, SRATE, PMUT
    LOGICAL     :: THEEND
    !
100 FORMAT('Define limits for each variable:')
105 FORMAT('Xmin_',I3,', Xmax_',I3)
107 FORMAT(' i ',2X,' Xmin_i ',2X,' Xmax_i ',2X,'nr.bits',2X,'Precision')
108 FORMAT(I3,2X,F8.3,2X,F8.3,3X,I5,3X,F8.6)
110 FORMAT('Define number of individuals in the population:')
115 FORMAT('Define precision for each variable:')
117 FORMAT('nr. bits per chromossome:',I5,/'nr. chromossomes/individuals in the population:',I5,&
                    /'total nr. of bits in population:',I5)
120 FORMAT('X_',I3,':')
125 FORMAT('Define maximum number of generations:')
127 FORMAT('Maximum number of generations:',I5)
130 FORMAT('Define survival rate (0-1):')
135 FORMAT('No offspring with this survival rate...')
137 FORMAT('Survival rate:',F8.5,/'nr. of surviving individuals:',I5,&
                    /'nr. of sons in new population:',I5)
140 FORMAT('Define mutation probability (0-1):')
143 FORMAT('Mutation probability:',F8.5,/'Expected nr. of mutated bits:',I5)
145 FORMAT('Value is outside admissible range...')
150 FORMAT('Define nr. of TOP individuals for ouput:')
153 FORMAT('nr TOP cannot be greater than nr individuals...')
155 FORMAT('Define nr of TOP individuals and nr of generations'/&
                'without changes in TOP for termination criteria:')
157 FORMAT('Termination criteria: i) Maximum number of generations,'/&
            'ii) Reduction of diversity in population - every locus is has more than 90% of the same allele,'/&
            'iii) TOP ',I3,' does not change for ',I3,' generations.')
160 FORMAT('#GEN',2X,'TOP',6X,<NDIM>('X_'I3,10X),'obj.Func',3X,'Fitness')
163 FORMAT('-------------------------------------------------------------------------')
    ! Initialize
    CALL RANDOM_SEED
    STRING='geneticalgorithm.res'
    CALL RESULTFILE(STRING)
    ICOUNT=0
    POPO=0
    VFITO=R0
    THEEND=.FALSE.
    ! Algorithm
    WRITE(*,100)
    DO IDIM=1,NDIM
        WRITE(*,105)IDIM,IDIM
        READ(*,*)XMIN(IDIM),XMAX(IDIM)
    ENDDO
    WRITE(*,115)
    NTBIT=0
    WRITE(11,107)
    DO IDIM=1,NDIM
        WRITE(*,120)IDIM
        READ(*,*)PRECIS(IDIM)
        NBITS(IDIM)=CEILING(LOG(R1+(XMAX(IDIM)-XMIN(IDIM))/PRECIS(IDIM))/LOG(R2))
        NTBIT=NTBIT+NBITS(IDIM)
        WRITE(11,108)IDIM,XMIN(IDIM),XMAX(IDIM),NBITS(IDIM),PRECIS(IDIM)
    ENDDO
    WRITE(*,110)
    READ(*,*)NPOP
    WRITE(11,117)NTBIT,NPOP,NTBIT*NPOP
    WRITE(*,125)
    READ(*,*)MGEN
    WRITE(11,127)MGEN
10  WRITE(*,130)
    READ(*,*)SRATE
    IF(SRATE.LT.R0.OR.SRATE.GT.R1)THEN
        WRITE(*,145)
        GOTO 10
    ENDIF
    NSURV=INT(SRATE*NPOP)
    NSONS=NPOP-NSURV
    IF(NSONS.EQ.0)THEN
        WRITE(*,135)
        GOTO 10
    ENDIF
    WRITE(11,137)SRATE,NSURV,NSONS
15  WRITE(*,140)
    READ(*,*)PMUT
    IF(PMUT.LT.R0.OR.PMUT.GT.R1)THEN
        WRITE(*,145)
        GOTO 15
    ENDIF
    WRITE(11,143)PMUT,INT(PMUT*NTBIT*NSONS)
20  WRITE(*,150)
    READ(*,*)NTOPOUT
    IF(NTOPOUT.GT.NPOP)THEN
        WRITE(*,153)
        GOTO 20
    ENDIF
25  WRITE(*,155)
    READ(*,*)NTOPT,NGENT
    IF(NTOPOUT.GT.NPOP)THEN
        WRITE(*,153)
        GOTO 25
    ENDIF
    WRITE(*,157)NTOPT,NGENT
    WRITE(11,157)NTOPT,NGENT
    WRITE(11,163);WRITE(*,163)
    WRITE(11,160)(IDIM,IDIM=1,NDIM);WRITE(*,160)(IDIM,IDIM=1,NDIM)
    WRITE(11,163);WRITE(*,163)
    !
    ALLOCATE(POPO(NPOP,NTBIT))
    ALLOCATE(POP(NPOP,NTBIT))
    ALLOCATE(VFIT(NPOP))
    ALLOCATE(VFITO(NPOP))
    ALLOCATE(OBJFUN(NPOP))
    ALLOCATE(XVEC(NDIM,NPOP))
    DO IBIT=1,NTBIT
        DO IPOP=1,NPOP
            CALL RANDOM_NUMBER(RANDN)
            POP(IPOP,IBIT)=NINT(RANDN)
        ENDDO
    ENDDO
    !
    CALL FITNESS(XMIN,XMAX,XVEC,POP,VFIT,OBJFUN,NBITS,NDIM,NPOP,NTBIT)
    CALL STATISTICS(0,XVEC,VFIT,OBJFUN,NDIM,NPOP,NTOPOUT)
    WRITE(11,163);WRITE(*,163)
    DO IGEN=1,MGEN
        POPO=POP
        VFITO=VFIT
        ! Survival of the fittest is implicit
        ! Reproduction
        CALL REPRODUCTION(POPO,POP,VFITO,VFIT,NSURV,NPOP,NTBIT)
        ! Mutation
        IF(PMUT.NE.R0)CALL MUTATION(POP,NPOP,PMUT,NSURV,NTBIT)
        WRITE(11,163);WRITE(*,163)
        !
        CALL FITNESS(XMIN,XMAX,XVEC,POP,VFIT,OBJFUN,NBITS,NDIM,NPOP,NTBIT)
        !
        CALL STATISTICS(IGEN,XVEC,VFIT,OBJFUN,NDIM,NPOP,NTOPOUT)
        WRITE(11,163);WRITE(*,163)
        CALL TERMINATION(POPO,POP,NPOP,NTBIT,NTOPT,NGENT,ICOUNT,THEEND)
        IF(THEEND)GOTO 99
    ENDDO

99  CLOSE(UNIT=11)

END SUBROUTINE


      SUBROUTINE SPRPL1(X,Y,NP,TITLE,XNAME,YNAME,
     *  NLINES, NCHARS, IMAGE, IERR)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-10-20 SPRPL1 Krogh  Changes to use M77CON
C>> 1994-08-05 SPRPL1 CLL Replaced 0.5 with 0.5001 for more consistent
c              rounding on different computers.
C>> 1992-02-14 SPRPL1 CLL Added choice of no. of rows & cols in output.
C>> 1990-10-29 PRPL1 CLL More changes to formatting of x-grid labels.
C>> 1990-10-22 PRPL1 CLL Added FAC, XSMALL, YSMALL.
C>> 1989-07-20 PRPL1  WV Snyder JPL Change ROW1 and ROW2 dimensions to *
C>> 1988-05-24 PRPL1  Lawson  Initial code.
C     SPRPL1  Enhanced version of PRPL1.  1992-01-29, CLL
C     PRPL1       This replaces EZPLTA of JPL$.
C     Only first 51 characters of YNAME() are used.
C     C.L.Lawson & Stella Chan,JPL,April 4,1983
c     Coded for Fortran 77.
C     1990 Oct.  Reworked formatting of labels for the x-grid lines.
c     No. of major subdivisions, KMAJX, returned by SCALK8 will be
c     3, 4, 5, 6, 7, or 8.  Generally we print KMAJX+1 labels, but print
c     only 5 for KMAJX = 8.
c     Will print numbers in the form -1.2345E-201 except when KMAJX = 7
c     in which case we reduce to     -1.234E-201.  Provides one or more
c     spaces between numbers.
c     Also reduced spacing between the ROW1() & ROW2() items.
c     ------------------------------------------------------------------
c                             SUBROUTINE ARGUMENTS
c
c   X(),Y()   Arrays of (x,y) coordinate pairs defining the
c             curve to be plotted.
C
c   NP        Number of (x,y) points to be plotted.
C
c   TITLE     Character string to be
c             printed above the plot grid as a title for the
c             graph.
C
c   XNAME     Character string to be
c             printed below the plot grid to identify the
c             abscissa variable.
C
c   YNAME     Character string to be
c             printed in a vertical column at the left of the
c             plot grid to identify the ordinate variable.
C
c   NLINES [in] Number of lines available for the output image.
c
c   NCHARS [in]  Number of characters per line available for the
c          output image.
c   IMAGE() [out,array of chars]  Array of at least NLINES elements,
c      each being a character variable of length at least NCHARS.
c      This subr will build the output plot image in this array.
c   IERR [out,integer]  Termination status indicator.  0 means ok.
c      1 means need larger NCHARS.  2 means need larger NLINES.
c     ------------------------------------------------------------------
c--S replaces "?": ?PRPL1, ?PRPL3
C     ------------------------------------------------------------------
      integer BOTTOM
      integer I, IERR, ILINE, J
      integer L1, LEFT, NCHARS, NLINES, NP, RIGHT, TOP
      real             FACX, FACY
      real             X(NP), X1, X2, XMAX, XMIN
      real             Y(NP), Y1, Y2, YMAX, YMIN
      character*(*) TITLE, XNAME, YNAME
      character IMAGE(NLINES)*(*)
C     ------------------------------------------------------------------
C
C                          Find min's and max's of data values.
C
      X1=X(1)
      Y1=Y(1)
      X2=X1
      Y2=Y1
      do 20 I=2,NP
        X2=max(X2,X(I))
        X1=min(X1,X(I))
        Y2=max(Y2,Y(I))
        Y1=min(Y1,Y(I))
   20 continue
C
C        Subroutine SPRPL3 determine data values for the first and last
c        grid lines:  XMIN, XMAX,    YMIN, YMAX,
c        and corresponding index values for use in the character array
c        IMAGE()():   LEFT, RIGHT,   BOTTOM, TOP,
c        and constructs grid lines, labels, and titles in IMAGE()().
c
      call SPRPL3(X1, X2, Y1, Y2, XMIN, XMAX, YMIN, YMAX,
     *           LEFT, RIGHT, BOTTOM, TOP,
     *           TITLE, XNAME, YNAME, NLINES, NCHARS, IMAGE, IERR)
C
c        Plot the xy data points.
c        Note:  (BOTTOM - TOP) will be positive.
c
      FACX = real(RIGHT - LEFT) / (XMAX-XMIN)
      FACY = real(BOTTOM - TOP) / (YMAX-YMIN)
      do 40 J=1,NP
        ILINE = BOTTOM - int((Y(J)-YMIN) * FACY + 0.5001e0)
        L1    = LEFT +   int((X(J)-XMIN) * FACX + 0.5001e0)
        IMAGE(ILINE)(L1:L1) = '*'
   40 continue
C
      return
      end


!
!    Copyright 2011 Sebastian Heimann
!
!    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.
!

program test_orthodrome

    use util
    use constants
    use orthodrome

    implicit none

    type(t_geo_coords) :: a,b
    real*8 :: azi,dist,bazi
    real :: km

    call test_begin("test_orthodrome")

    a%lat = 0.
    a%lon = 0.

    b%lat = 90.
    b%lon = 0.
    if (.not. near(0D00, r2d(azimuth( d2r(a), d2r(b) )), 0.001D00)) then
        call test_fail("azimuth 1")
    end if
    if (.not. near(90D00, r2d(arcdistance( d2r(a), d2r(b) )), 0.001D00)) then
        call test_fail("arcdistance 1")
    end if

    b%lat = 0.
    b%lon = 100.
    if (.not. near(90D00, r2d(azimuth( d2r(a), d2r(b) )), 0.001D00)) then
        call test_fail("azimuth 2")
    end if
    if (.not. near(100D00, r2d(arcdistance( d2r(a), d2r(b) )), 0.001D00)) then
        call test_fail("arcdistance 2")
    end if

    a%lon = 10.
    b%lat = 0.
    b%lon = -10.
    if (.not. near(-90D00, r2d(azimuth( d2r(a), d2r(b) )), 0.001D00)) then
        call test_fail("azimuth 3")
    end if
    if (.not. near(20D00, r2d(arcdistance( d2r(a), d2r(b) )), 0.001D00)) then
        call test_fail("arcdistance 3")
    end if

    a%lat = 10.
    a%lon = 0.
    b%lat = -10.
    b%lon = -0.001
    if (.not. near(-180D00, r2d(azimuth( d2r(a), d2r(b) )), 0.1D00)) then
        call test_fail("azimuth 4")
    end if
    if (.not. near(20D00, r2d(arcdistance( d2r(a), d2r(b) )), 0.001D00)) then
        call test_fail("arcdistance 4")
    end if

    a%lat = 10.
    a%lon = 0.
    b%lat = -10.
    b%lon = 0.
    if (.not. near(180D00, r2d(azimuth( d2r(a), d2r(b) )), 0.1D00)) then
        call test_fail("azimuth 5")
    end if
    if (.not. near(20D00, r2d(arcdistance( d2r(a), d2r(b) )), 0.001D00)) then
        call test_fail("arcdistance 5")
        print *, r2d(arcdistance( d2r(a), d2r(b) ))
    end if

    km = 1000.

  ! a real world test: distance hamburg-munich
    a%lat = 53.556867
    a%lon = 9.994622
    b%lat = 48.139743
    b%lon = 11.560050
    dist = distance_accurate50m( d2r(a), d2r(b) )
    if (.not. near(dist/km, 612.59D00, 0.05D00)) then
        print *, dist
        call test_fail( "hamburg-munich: " )
    end if

  ! geomatikum-home
    a%lat = 53.568391
    a%lon = 9.973672
    b%lat = 53.580049
    b%lon = 9.956507
    dist = distance_accurate50m( d2r(a), d2r(b) )
    if (.not. near(dist/km, 1.73D00, 0.05D00)) then
        call test_fail("geomatikum-home")
    end if

  ! a real world test: distance berlin-tokio
    a%lat = 52.5167
    a%lon = 13.4000
    b%lat = 35.7000
    b%lon = 139.7667
    dist = distance_accurate50m( d2r(a), d2r(b) )
    if (.not. near(dist/km, 8941.20671D00, 0.05D00)) then
        call test_fail( "berlin-tokio")
    end if

    call approx_differential_azidist( 10.*km,10.*km, &
                                      d2r(90D00), d2r(-90D00), 20D00*km, &
                                      azi, bazi, dist )

    if (.not. (near(r2d(azi),135D00,1D00) .and. &
        near(dist,10D00*km*sqrt(2.),1D00))) then
        call test_fail("differential azidist 1")
    end if

    call approx_differential_azidist( 10.*km,10.*km, &
                                      d2r(90D00), d2r(-90D00), 1111.95D00*km, &
                                      azi, bazi, dist )
    if (.not. (near(r2d(azi),90D00,1D00) .and. &
        near(dist,1111.95D00*km-10D00*km,50D00))) then
        call test_fail("differential azidist 2")
    end if

    call test_end()
    call cleanup()

contains

    elemental logical function near( a,b, eps )
        real*8, intent(in) :: a,b,eps
        near = abs(a-b) < eps
    end function

end program


program poisson
    use, intrinsic :: iso_c_binding
    use amgcl
    implicit none

    integer :: n, n2, idx, nnz, i, j
    integer(c_int), allocatable :: ptr(:), col(:)
    real(c_double), allocatable :: val(:), rhs(:), x(:)
    integer(c_size_t) :: solver, params
    type(conv_info) :: cnv

    ! Assemble matrix in CRS format for a Poisson problem in n x n square.
    n  = 256
    n2 = n * n

    allocate(ptr(n2 + 1))
    allocate(col(n2 * 5))
    allocate(val(n2 * 5))
    ptr(1) = 1

    idx = 1
    nnz = 0
    do i = 1,n
        do j = 1,n
            if (i > 1) then
                nnz = nnz + 1
                col(nnz) = idx - n
                val(nnz) = -1
            end if

            if (j > 1) then
                nnz = nnz + 1
                col(nnz) = idx - 1
                val(nnz) = -1
            end if

            nnz = nnz + 1
            col(nnz) = idx
            val(nnz) = 4

            if (j < n) then
                nnz = nnz + 1
                col(nnz) = idx + 1
                val(nnz) = -1
            end if

            if (i < n) then
                nnz = nnz + 1
                col(nnz) = idx + n
                val(nnz) = -1
            end if

            idx = idx + 1
            ptr(idx) = nnz + 1
        end do
    end do

    allocate(rhs(n2))
    allocate(x(n2))
    rhs = 1
    x = 0

    ! Create solver parameters.
    params = amgcl_params_create()
    call amgcl_params_sets(params, "solver.type", "cg")
    call amgcl_params_setf(params, "solver.tol", 1e-6)

    ! Create solver, printout its structure.
    solver = amgcl_solver_create(n2, ptr, col, val, params)
    call amgcl_solver_report(solver)

    ! Solve the problem for the given right-hand-side.
    cnv = amgcl_solver_solve(solver, rhs, x)
    write(*,"('Iterations:', I3, ', residual: ', E13.6)") cnv%iterations, cnv%residual

    ! Destroy solver and parameter pack.
    call amgcl_solver_destroy(solver)
    call amgcl_params_destroy(params)
end program poisson


C     ( Last modified on 23 Dec 2000 at 22:01:38 )
      PROGRAM          PDSMA
C
C  PDS test driver for problems derived from SIF files.
C
C  A. R Conn and Ph. Toint for CGT Productions.
C  January 1995, substantially modified September 1996.
C
      INTEGER          NMAX  , SCH, INPUT, INDR, IOUT
      INTEGER          DIM   , RES, IMAX
CTOY  PARAMETER      ( NMAX  =  10, DIM  =   10, IMAX = 2000 )
CMED  PARAMETER      ( NMAX  = 100, DIM  =   20, IMAX = 4000 )
CBIG  PARAMETER      ( NMAX  = 500, DIM  =   30, IMAX = 6000 )
CCUS  PARAMETER      ( NMAX  = 200, DIM  =   25, IMAX = 5000 )
      PARAMETER      ( INPUT =  55, INDR =   46, RES  =   56 )
      PARAMETER      ( IOUT  =   6, SCH  =   48 )
      INTEGER          CNT   , DEBUG, ERROR , UNIQUE, MAXITR, N
      INTEGER          IFACT , TYPE , RESIZE, SSS   , LIMIT
      PARAMETER      ( LIMIT = ( DIM + 2 ) * IMAX )
      INTEGER          SCHEME( LIMIT ), LIST( LIMIT ), INDEX( LIMIT )
CS    REAL             X     ( NMAX  ), BU  ( NMAX  ), BL   ( NMAX  )
CS    REAL             FACTOR, FBEST , LENGTH, S( DIM * ( DIM + 1 ) )
CS    REAL             SCALE , TOL   , WORK( DIM )
CS    REAL             WORK1( -3 : DIM + 1 ), WORK2( -3 : DIM + 1 )
CD    DOUBLE PRECISION X     ( NMAX ), BU   ( NMAX  ), BL   ( NMAX  )
CD    DOUBLE PRECISION FACTOR, FBEST , LENGTH, S( DIM * ( DIM + 1 ) )
CD    DOUBLE PRECISION SCALE , TOL   , WORK( DIM )
CD    DOUBLE PRECISION WORK1( -3 : DIM + 1 ), WORK2( -3 : DIM + 1 )
      CHARACTER*10     XNAMES( NMAX ), PNAME
      INTEGER          I
      LOGICAL          BOUNDS
      REAL             CPU( 2 ), CALLS( 4 )
CS    REAL             BIGINF
CD    DOUBLE PRECISION BIGINF
CS    PARAMETER      ( BIGINF = 9.0E+19 )
CD    PARAMETER      ( BIGINF = 9.0D+19 )
      EXTERNAL         UFN
C
C  Open the Spec file for the method.
C
      OPEN( INDR , FILE = 'PDS.SPC', FORM = 'FORMATTED',
     *      STATUS = 'OLD' )
      REWIND INDR
C
C  Read input Spec data.
C
C   TOL    = the stopping tolerance for the step size
C   MAXITR = the maximum number of iterations allowed
C   TYPE     specifies the type of initial simplex
C            0   User provides the initial simplex
C            1   Automatic generation of a right-angled simplex
C            2   Automatic generation of a regular simplex
C            3   Automatic generation of a scaled right-angled simplex
C   SCALE    If the simplex is automatically generated, scale should
C            contain both the base length and the orientation of the edges
C   DEBUG    should be set to 0, 1, 2, 3 or 4, it controls the amount of
C            printing.
C            0   no debugging output
C            1   display the iteration count, the best vertex
C                and its function value
C            2   include the simplex and flag whether or
C                not strict decrease was obtained
C            3   include all vertices constructed and their
C                finction values
C            4   Include the points that define the search scheme
C   SSS      number of points used in the search strategy
C
C  Set up algorithmic input data.
C
      READ ( INDR, 1000 ) TOL, MAXITR, TYPE, SCALE, DEBUG, SSS
C
C  Close SPEC file
C
      CLOSE( INDR )
C
C  Open the relevant file.
C
      OPEN( INPUT, FILE = 'OUTSDIF.d', FORM = 'FORMATTED',
     *      STATUS = 'OLD' )
      REWIND INPUT
C
C  Set up SIF data.
C
      CALL USETUP( INPUT, IOUT, N, X, BL, BU, NMAX )
      CLOSE(INPUT)
C
C  Obtain variable names.
C
      CALL UNAMES( N, PNAME, XNAMES )
C
C  Set up algorithmic input data.
C
      BOUNDS  = .FALSE.
      DO 10 I = 1, N
         IF ( BL( I ) .GT. - BIGINF .OR. BU( I ) .LT. BIGINF )
     *      BOUNDS = .TRUE.
   10 CONTINUE
      IF ( BOUNDS ) WRITE( IOUT, 2030 )
      DO 20 I = 1, N
         S(I) = X(I)
   20 CONTINUE
C
C  Form the scheme
C
      OPEN( SCH, FILE = 'SCHEME', STATUS = 'UNKNOWN',
     *      FORM = 'UNFORMATTED')
      CALL SEARCH( N, SCH, LIMIT, SCHEME, INDEX, LIST, UNIQUE, IFACT,
     *             ERROR )
      CLOSE( SCH )
C
      OPEN( RES, FILE = 'RESULT', STATUS = 'UNKNOWN',
     *      FORM = 'FORMATTED')
      FACTOR = FLOAT( IFACT )
      IF ( ERROR .EQ. 0 ) THEN
         WRITE( RES, 100 ) N
         WRITE( RES, 200 ) UNIQUE
         WRITE( RES, 300 ) IFACT
      ELSE
         WRITE( RES, 400 )
      ENDIF
C
C  Re-open the search scheme file.
C
      OPEN( SCH, FILE = 'SCHEME', STATUS = 'OLD',
     *      FORM = 'UNFORMATTED')
      REWIND( SCH )
C
C  Read in the search scheme and determine the "shrink" factor (which
C  depends on the size of the search scheme that has been specified).
C
      CALL GETSS( N, SCH, SSS, SCHEME, FACTOR, RESIZE, ERROR )
C
C  Close the file for the search scheme.
C
      CLOSE( SCH )
      IF ( ERROR .EQ. 0 ) THEN
C
C  Call the optimizer if no error occured so far
C
         CALL PDS( N, IOUT, TYPE , SCALE , DEBUG , TOL   , MAXITR,
     *             SSS    , UFN  , FACTOR, SCHEME, RESIZE, S     ,
     *             INDEX  , FBEST, LENGTH, CNT   , WORK  , WORK1 ,
     *             WORK2 )
C
C  Write the results to a file and on the standard output.
C
         WRITE ( IOUT, 2010 )
         DO 30 I = 1, N
            WRITE( IOUT, 2020 ) XNAMES(I), S(I)
   30    CONTINUE
         CALL RESULT( N, CNT, S, FBEST, INDEX, RES )
      ELSE IF ( ERROR .EQ. 1 ) THEN
         WRITE( RES, 500 )
      ELSE IF ( ERROR .EQ. 2 ) THEN
         WRITE( RES, 600 )
      ENDIF
      CLOSE( RES )
C
C  Write results on the standard output
C
      CALL UREPRT( CALLS, CPU )
      WRITE ( IOUT, 2000 ) PNAME, N, CALLS(1), ERROR, FBEST,
     *                     CPU(1), CPU(2)
      STOP
C
C  Non-executable statements.
C
 100  FORMAT( 'Successfully completed a search strategy for problems '
     *        ,'of dimension', I6 )
 200  FORMAT( 'The total number of unique points available is', I26 )
 300  FORMAT( 'The factor needed to restore these points to their ',
     *        'real values is', I7 )
 400  FORMAT( 'Returned without a completed search strategy because', /
     *      , 'of internal stack overflow in the QUICKSORT routines.', /
     *      , 'Check the documentation for further details.')
 500  FORMAT( //, ' Search scheme was of the wrong dimension.', /
     *      , ' Exited without calling PDS.' // )
 600  FORMAT( //, ' Insufficient number of points in scheme.', /
     *      , ' Exited without calling PDS.' // )
 1000 FORMAT( D10.3, /, I10, /, I10, /, D10.3, /, I10, /, I10 )
 2000 FORMAT( /, 24('*'), ' CUTEr statistics ', 24('*') //
     *    , ' Code used               :  PDS', /
     *    , ' Problem                 :  ', A10,  /
     *    , ' # variables             =      ', I10 /
     *    , ' # objective functions   =        ', F8.2 /
     *    , ' Exit code               =      ', I10 /
     *    , ' Final f                 = ', E15.7 /
     *    , ' Set up time             =      ', 0P, F10.2, ' seconds' /
     *    , ' Solve time              =      ', 0P, F10.2, ' seconds' //
     *      66('*') / )
 2010 FORMAT( /, '                 X  ' )
 2020 FORMAT(  A10, 1P, D12.4 )
 2030 FORMAT(  /, ' ** Warning from PDSMA. The problem as stated',
     *            ' includes simple bounds. ', /,
     *            '    These bounds will be ignored. ' )
C
C  End of PDSMA
C
      END


module fenwic_tree_int32_mod
    use vector_mod
    use,intrinsic :: iso_fortran_env
    implicit none
    type,public:: fenwic
        type(vector_int32):: vec
    contains
        procedure:: push => fw_push
        procedure:: prefix_sum => fw_prefix_sum
        procedure:: sec_sum => fw_sum
        procedure:: add => fw_add
    end type
contains
    function lsb(x) result(ret)
        ! x & -x => 立っている最下位ビットを返す
        integer(int32),intent(in):: x
        integer(int32):: ret

        ret = iand(x,-x)
    end function

    subroutine fw_push(fw,x)
        class(fenwic),intent(inout):: fw
        integer(int32),intent(in):: x
        integer(int32):: bx,k
        integer(int32):: i,n

        i=1
        bx=x
        n=fw%vec%l+1
        k=lsb(n)

        do while(i /= k)
            bx=bx+fw%vec%array(n-i)
            i=i*2
        end do

        call fw%vec%push_back(bx)
    end subroutine

    function fw_prefix_sum(fw,i) result(ret)
        class(fenwic):: fw
        integer(int32),intent(in):: i
        integer(int32):: ret
        integer(int32):: bi

        ret=0; bi=int(i,kind=int32)
        do while(bi>0)
            ret=ret+fw%vec%array(bi)
            bi=bi-lsb(bi)
        end do
    end function

    function fw_sum(fw,l,r) result(ret)
        class(fenwic):: fw
        integer(int32),intent(in):: l,r
        integer(int32):: ret

        ret = fw%prefix_sum(r) - fw%prefix_sum(l-1)
    end function

    subroutine fw_add(fw,i,x)
        class(fenwic):: fw
        integer(int32),intent(in):: i,x
        integer(int32):: bi

        bi = int(i,int32)
        do while (bi <= fw%vec%l)
            fw%vec%array(bi) = fw%vec%array(bi)+x
            bi=bi+lsb(bi)
        end do
    end subroutine

    subroutine fw_from_array(fw,ar)
        type(fenwic):: fw
        integer(int32):: ar(:)
        integer(int32):: n,i

        n=size(ar)
        do i=1,n
            call fw_push(fw,ar(i))
        end do
    end subroutine
end module

module fenwic_tree_int64_mod
    use vector_mod
    use,intrinsic :: iso_fortran_env
    implicit none
    type,public:: fenwic
        type(vector_int64):: vec
    contains
        procedure:: push => fw_push
        procedure:: prefix_sum => fw_prefix_sum
        procedure:: sec_sum => fw_sum
        procedure:: add => fw_add
    end type
contains
    function lsb(x) result(ret)
        ! x & -x => 立っている最下位ビットを返す
        integer(int32),intent(in):: x
        integer(int32):: ret

        ret = iand(x,-x)
    end function

    subroutine fw_push(fw,x)
        class(fenwic),intent(inout):: fw
        integer(int64),intent(in):: x
        integer(int64):: bx,k
        integer(int32):: i,n

        i=1
        bx=x
        n=fw%vec%l+1
        k=lsb(n)

        do while(i /= k)
            bx=bx+fw%vec%array(n-i)
            i=i*2
        end do

        call fw%vec%push_back(bx)
    end subroutine

    function fw_prefix_sum(fw,i) result(ret)
        class(fenwic):: fw
        integer(int64),intent(in):: i
        integer(int64):: ret
        integer(int32):: bi

        ret=0; bi=int(i,kind=int32)
        do while(bi>0)
            ret=ret+fw%vec%array(bi)
            bi=bi-lsb(bi)
        end do
    end function

    function fw_sum(fw,l,r) result(ret)
        class(fenwic):: fw
        integer(int64),intent(in):: l,r
        integer(int64):: ret

        ret = fw%prefix_sum(r) - fw%prefix_sum(l-1)
    end function

    subroutine fw_add(fw,i,x)
        class(fenwic):: fw
        integer(int64),intent(in):: i,x
        integer(int32):: bi

        bi = int(i,int32)
        do while (bi <= fw%vec%l)
            fw%vec%array(bi) = fw%vec%array(bi)+x
            bi=bi+lsb(bi)
        end do
    end subroutine

    subroutine fw_from_array(fw,ar)
        type(fenwic):: fw
        integer(int64):: ar(:)
        integer(int32):: n,i

        n=size(ar)
        do i=1,n
            call fw_push(fw,ar(i))
        end do
    end subroutine
end module

module fenwic_tree_real64_mod
    use vector_mod
    use,intrinsic :: iso_fortran_env
    implicit none
    type,public:: fenwic
        type(vector_real64):: vec
    contains
        procedure:: push => fw_push
        procedure:: prefix_sum => fw_prefix_sum
        procedure:: sec_sum => fw_sum
        procedure:: add => fw_add
    end type
contains
    function lsb(x) result(ret)
        ! x & -x => 立っている最下位ビットを返す
        integer(int32),intent(in):: x
        integer(int32):: ret

        ret = iand(x,-x)
    end function

    subroutine fw_push(fw,x)
        class(fenwic),intent(inout):: fw
        real(real64),intent(in):: x
        real(real64):: bx,k
        integer(int32):: i,n

        i=1
        bx=x
        n=fw%vec%l+1
        k=lsb(n)

        do while(i /= k)
            bx=bx+fw%vec%array(n-i)
            i=i*2
        end do

        call fw%vec%push_back(bx)
    end subroutine

    function fw_prefix_sum(fw,i) result(ret)
        class(fenwic):: fw
        real(real64),intent(in):: i
        real(real64):: ret
        integer(int32):: bi

        ret=0; bi=int(i,kind=int32)
        do while(bi>0)
            ret=ret+fw%vec%array(bi)
            bi=bi-lsb(bi)
        end do
    end function

    function fw_sum(fw,l,r) result(ret)
        class(fenwic):: fw
        real(real64),intent(in):: l,r
        real(real64):: ret

        ret = fw%prefix_sum(r) - fw%prefix_sum(l-1)
    end function

    subroutine fw_add(fw,i,x)
        class(fenwic):: fw
        real(real64),intent(in):: i,x
        integer(int32):: bi

        bi = int(i,int32)
        do while (bi <= fw%vec%l)
            fw%vec%array(bi) = fw%vec%array(bi)+x
            bi=bi+lsb(bi)
        end do
    end subroutine

    subroutine fw_from_array(fw,ar)
        type(fenwic):: fw
        real(real64):: ar(:)
        integer(int32):: n,i

        n=size(ar)
        do i=1,n
            call fw_push(fw,ar(i))
        end do
    end subroutine
end module

module fenwic_tree_mod
    use fenwic_tree_int32_mod, fenwic_int32 => fenwic
    use fenwic_tree_int64_mod, fenwic_int64 => fenwic
    use fenwic_tree_real64_mod, fenwic_real64 => fenwic
    implicit none
    private
    public:: fenwic_int32
    public:: fenwic_int64
    public:: fenwic_real64
end module


function RandomN(idum)
!------------------------------------------------------------------------------
!
!   Minimal random number generator of Park and Miller combined with a
!   Marsaglia shift sequence. Returns a uniform random deviate between 0.0 and
!   1.0 (exclusive of the endpoint values). This fully portable scalar
!   generator has the "traditional" (not Fortran 90) calling sequence with a
!   random deviate as the returned function value. Call with idum a negative
!   integer to initialize; thereafter, do not alter idum except to
!   reinitialize. The period of this generator is about 3.1 10^18.
!
!   NOTE:   When used within an OpenMP parallet construct, a different seed must
!           be used for each thread.
!
!   Modified from the algorithm published in Numerical Recipes (f90)
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp) :: RandomN
    integer(int32), intent(inout) :: idum
    integer(int32), parameter :: IA = 16807, IM = 2147483647, IQ = 127773, &
                                IR = 2836, one = 1, param1 = 888889999, &
                                param2 = 777755555
    real(dp), save :: am
    integer(int32), save :: ix = -1, iy = -1, k

!$OMP   threadprivate(am, ix, iy, k)

    if (idum <= 0 .or.iy < 0) then
        ! Initialize.
        am = nearest(1.0_dp,-1.0_dp) / dble(IM)
        iy = ior(ieor(param1, abs(idum)), one)
        ix = ieor(param2, abs(idum))
        idum = abs(idum) + 1    ! Set idum positive.
    end if

    ! Marsaglia shift sequence with period 2^32 -1
    ix = ieor(ix,ishft(ix,13))
    ix = ieor(ix,ishft(ix,-17))
    ix = ieor(ix,ishft(ix,5))

    ! Park-Miller sequence by Schrage's method, period 2^31 -2
    k = iy / IQ

    iy = IA * (iy - k * IQ)-IR * k
    if (iy < 0) iy = iy + IM

    ! Combine the two generators with masking to ensure nonzero value
    RandomN=am * ior(iand(IM, ieor(ix,iy)), one)

end function RandomN

function RandomGaussian(idum)
!------------------------------------------------------------------------------
!
!   Returns a normally distributed deviate with
!   zero mean and unit variance, using RandomN(idum)
!   as the source of uniform deviates. To convert to a
!   normal distribution with standard deviation sigma,
!   multiply this function by sigma.
!
!   NOTE:   When used within an OpenMP parallet construct, a different seed
!           must be used for each thread.
!
!   Modified from the algorithm published in Numerical Recipes (f77)
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use SHTOOLS, only: RandomN
    use ftypes

    implicit none

    real(dp) :: RandomGaussian
    integer(int32), intent(inout) :: idum
    real(dp) :: rsq, v1, v2
    real(dp), save :: gset
    logical, save :: gaus_stored = .false.

!$OMP   threadprivate(gset, gaus_stored)

    ! Reinitialize.
    if (idum < 0) gaus_stored = .false.

    if (gaus_stored) then
        RandomGaussian = gset
        gaus_stored = .false.

    else
        ! We don't have an extra deviate handy, so pick two uniform numbers
        !in the square extending from -1 to +1 in each direction, see if they
        ! are in the unit circle, and if they are not, try again.
        do
            v1 = RandomN(idum)
            v2 = RandomN(idum)
            v1 = 2.0_dp * v1 -1.0_dp
            v2 = 2.0_dp * v2 -1.0_dp
            rsq = v1**2 + v2**2
            if (rsq > 0.0_dp .and. rsq < 1.0_dp) exit

        end do

        ! Now make the Box-Muller transformation to get two normal deviates.
        ! Return one and save the other for next time.
        rsq = sqrt(-2.0_dp * log(rsq) / rsq)

        RandomGaussian = v1 * rsq
        gset = v2 * rsq
        gaus_stored = .true.

    end if

end function RandomGaussian


module local_routines
    !!
    !! Setup for the dam-break problem
    !!
    use global_mod, only: dp, ip, wall_elevation
    use domain_mod, only: domain_type, STG, UH, VH, ELV
    implicit none

    contains

    subroutine set_initial_conditions_dam(domain, h_upstream, h_downstream)
        !!
        !! Initial conditions for the dam-break problem
        !!
        class(domain_type), target, intent(inout):: domain
        real(dp), intent(in) :: h_upstream, h_downstream

        integer(ip):: i,j
        real(dp):: x, y, cx, cy, initial_stage_1, initial_stage_2, radius

        initial_stage_1 = h_downstream !0.0001_dp
        initial_stage_2 = h_upstream !1.0_dp

        ! Stage
        domain%U(:,:,STG) = initial_stage_1
        do j = 1, domain%nx(2)
            where(domain%x > 0.0_dp) domain%U(:,j,STG) = initial_stage_2
        end do

        ! Elevation
        domain%U(:,:,ELV) = 0._dp

        ! Ensure stage >= elevation
        domain%U(:,:,STG) = max(domain%U(:,:,STG), domain%U(:,:,ELV))

        domain%manning_squared = 0.0_dp

    end subroutine

end module

!@!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program dam_break
    !!
    !! 1D Dam-break problem with a flat bed.
    !!
    use global_mod, only: ip, dp, charlen, default_nonlinear_timestepping_method
    use domain_mod, only: domain_type
    use file_io_mod, only: read_csv_into_array
    use local_routines
    use boundary_mod, only: transmissive_boundary
    implicit none

    integer(ip):: i, nsteps
    real(dp):: last_write_time
    type(domain_type):: domain

    ! Approx timestep between outputs
    real(dp), parameter :: approximate_writeout_frequency = 0.2_dp
    real(dp), parameter :: final_time = 30.0_dp * 1

    ! length/width
    real(dp), parameter, dimension(2):: global_lw = [200._dp, 20._dp]
    ! lower-left corner coordinate
    real(dp), parameter, dimension(2):: global_ll = -global_lw/2.0_dp
    ! grid size (number of x/y cells)
    integer(ip), parameter, dimension(2):: global_nx = [200, 20] * 4 ! [400, 400]

    ! analytical solution
    real(dp), allocatable :: analytical_solution(:,:)
    character(len=charlen):: analytical_solution_file, input_char
    real(dp) :: h_upstream, h_downstream

    domain%timestepping_method = default_nonlinear_timestepping_method

    ! Get the upstream/downstream initial depth from the command line
    call get_command_argument(1, input_char)
    read(input_char, *) h_upstream
    call get_command_argument(2, input_char)
    read(input_char, *) h_downstream

    !@ rk2 still works well with the following parameters, which would usually be seen
    !@ as voilating stability constraints.
    !domain%cfl = 1.49_dp
    !domain%theta = 4.0_dp

    ! Allocate domain
    CALL domain%allocate_quantities(global_lw, global_nx, global_ll)

    ! Call local routine to set initial conditions
    CALL set_initial_conditions_dam(domain, h_upstream, h_downstream)

    domain%boundary_subroutine => transmissive_boundary

    ! Trick to get the code to write out just after the first timestep
    last_write_time = -approximate_writeout_frequency

    ! Evolve the code
    do while (.TRUE.)

        if(domain%time - last_write_time >= approximate_writeout_frequency) then

            last_write_time = last_write_time + approximate_writeout_frequency

            call domain%print()
            call domain%write_to_output_files()

            if (domain%time > final_time) then
                exit
            end if

        end if

        call domain%evolve_one_step()

    end do

    call domain%write_max_quantities()

    call domain%timer%print()

    CALL domain%finalise()

end program


program ParticlesAndFieldTester

use NumberKindsModule
use LoggerModule
use ParticlesModule
use FieldModule

implicit none

integer(kint) :: i, j
real(kreal), parameter :: dx = 0.1;
real(kreal), parameter :: xmin = -5.0_kreal
real(kreal), parameter :: xmax = 5.0_kreal
real(kreal), parameter :: ymin = xmin
real(kreal), parameter :: ymax = xmax
integer(kint), parameter :: nn = 101

type(Logger) :: exeLog
type(Particles) :: aParticles
type(Field) :: scalarField
type(Field) :: vectorField

real(kreal) :: vec(2)
print *, "ParticlesAndFieldTest : 1. build a particle set from a ", nn," x ", nn, " uniform planar mesh."
print *, "ParticlesAndFieldTest : 2. define a scalar field on that particle set."
print *, "ParticlesAndFieldTest : 3. define a vector field on that particle set."
print *, "ParticlesAndFieldTest : 4. test Matlab output."

call New(exeLog, DEBUG_LOGGING_LEVEL )

open(unit=WRITE_UNIT_1, file="particlesFieldTest.m", STATUS='REPLACE', action="WRITE")

call New(aParticles, nn * nn, PLANAR_GEOM )

do i = 1, nn
	vec(1) = xmin + dx * (i-1)
	do j = 1, nn
		vec(2) = ymin + dx * (j-1)
		call InsertParticle(aParticles, vec, vec )
	enddo
enddo

call LogStats(aParticles, exeLog )
call WriteParticlesToMatlab( aParticles, WRITE_UNIT_1 )

call New(scalarField, 1, aParticles%N, "sineWaves" )

do i = 1, aParticles%N
	call InsertScalarToField( scalarField, SineWaves([aParticles%x(i), aParticles%y(i)]) )
enddo

call LogStats(scalarField, exeLog )
call WriteFieldToMatlab(scalarField, WRITE_UNIT_1)

call New(vectorField, 2, aParticles%N, "sineWavesGrad")

do i = 1, aParticles%N
	call InsertVectorToField( vectorField, SineWavesGrad([aParticles%x(i), aParticles%y(i)]) )
enddo

call LogStats(vectorField, exeLog)
call WriteFieldToMatlab(vectorField, WRITE_UNIT_1)

write(WRITE_UNIT_1,*) "figure(1);clf; scatter(x,y,8,scalarField_sineWaves);"
write(WRITE_UNIT_1,*) "sineWavesGrad = vectorField_sineWavesGrad';"
write(WRITE_UNIT_1,*) "figure(2);clf; quiver(x,y,sineWavesGrad(1,:),sineWavesGrad(2,:));"

call Delete(vectorField)
call Delete(scalarField)
call Delete(aParticles)
close(WRITE_UNIT_1)
call Delete(exeLog)

contains

function SineWaves( xy )
	real(kreal) :: SineWaves
	real(kreal), intent(in) :: xy(2)
	SineWaves = sin( 2.0_kreal * PI * xy(1) / 5.0_kreal) * sin(2.0_kreal * PI * xy(2) / 5.0_kreal )
end function

function SineWavesGrad( xy )
	real(kreal) :: SineWavesGrad(2)
	real(kreal), intent(in) :: xy(2)
	SineWavesGrad(1) = 2.0_kreal * PI / 5.0_kreal * cos(2.0_kreal * PI * xy(1) / 5.0_kreal) * &
		sin(2.0_kreal * PI * xy(2) / 5.0_kreal)
	SineWavesGrad(2) = 2.0_kreal * PI / 5.0_kreal * sin(2.0_kreal * PI * xy(1) / 5.0_kreal) * &
	    cos(2.0_kreal * PI * xy(2) / 5.0_kreal)
end function

end program


C
C $Id: curvsdp.f,v 1.3 2008-07-27 03:10:11 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
C NOTE: If you make any changes to this software, please remember to
C make the same changes to the corresponding single precision routine.
C
      SUBROUTINE CURVSDP(N,X,Y,D,ISW,S,EPS,YS,YSP,SIGMA,TEMP,IERR)
c
      INTEGER N,ISW,IERR
      DOUBLE PRECISION X(N),Y(N),D(N),S,EPS,YS(N),YSP(N),SIGMA,TEMP(N,9)
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute a smoothing spline under tension. for a given
c increasing sequence of abscissae (x(i)), i = 1,..., n and
c associated ordinates (y(i)), i = 1,..., n, the function
c determined minimizes the summation from i = 1 to n-1 of
c the square of the second derivative of f plus sigma
c squared times the difference of the first derivative of f
c and (f(x(i+1))-f(x(i)))/(x(i+1)-x(i)) squared, over all
c functions f with two continuous derivatives such that the
c summation of the square of (f(x(i))-y(i))/d(i) is less
c than or equal to a given constant s, where (d(i)), i = 1,
c ..., n are a given set of observation weights. the
c function determined is a spline under tension with third
c derivative discontinuities at (x(i)), i = 2,..., n-1. for
c actual computation of points on the curve it is necessary
c to call the function curv2dp. the determination of the curve
c is performed by subroutine curvssdp, the subroutine curvsdp
c only decomposes the workspace for curvssdp.
c
c on input--
c
c   n is the number of values to be smoothed (n.ge.2).
c
c   x is an array of the n increasing abscissae of the
c   values to be smoothed.
c
c   y is an array of the n ordinates of the values to be
c   smoothed, (i. e. y(k) is the functional value
c   corresponding to x(k) ).
c
c   d is a parameter containing the observation weights.
c   this may either be an array of length n or a scalar
c   (interpreted as a constant). the value of d
c   corresponding to the observation (x(k),y(k)) should
c   be an approximation to the standard deviation of error.
c
c   isw contains a switch indicating whether the parameter
c   d is to be considered a vector or a scalar,
c          = 0 if d is an array of length n,
c          = 1 if d is a scalar.
c
c   s contains the value controlling the smoothing. this
c   must be non-negative. for s equal to zero, the
c   subroutine does interpolation, larger values lead to
c   smoother funtions. if parameter d contains standard
c   deviation estimates, a reasonable value for s is
c   dble(n).
c
c   eps contains a tolerance on the relative precision to
c   which s is to be interpreted. this must be greater than
c   or equal to zero and less than or equal to one. a
c   reasonable value for eps is sqrt(2./dble(n)).
c
c   ys is an array of length at least n.
c
c   ysp is an array of length at least n.
c
c   sigma contains the tension factor. this value indicates
c   the degree to which the first derivative part of the
c   smoothing functional is emphasized. if sigma is nearly
c   zero (e. g. .001) the resulting curve is approximately a
c   cubic spline. if sigma is large (e. g. 50.) the
c   resulting curve is nearly a polygonal line.  If sigma
c   equals zero a cubic spline results. A standard value for
c   sigma is approximately 1.
c
c and
c
c   temp is an array of length at least 9*n which is used
c   for scratch storage.
c
c on output--
c
c   ys contains the smoothed ordinate values.
c
c   ysp contains the values of the second derivative of the
c   smoothed curve at the given nodes.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2,
c        = 2 if s is negative,
c        = 3 if eps is negative or greater than one,
c        = 4 if x-values are not strictly increasing,
c        = 5 if a d-value is non-positive.
c
c and
c
c   n, x, y, d, isw, s, eps, and sigma are unaltered.
c
c this subroutine references package modules curvssdp, termsdp,
c and snhcshdp.
c
c-----------------------------------------------------------
c
c decompose temp into nine arrays and call curvss
c
      CALL CURVSSDP(N,X,Y,D,ISW,S,EPS,YS,YSP,SIGMA,TEMP(1,1),TEMP(1,2),
     +            TEMP(1,3),TEMP(1,4),TEMP(1,5),TEMP(1,6),TEMP(1,7),
     +            TEMP(1,8),TEMP(1,9),IERR)
      RETURN
      END


!>  Program file for Poisson case
!
!v  Based on prototype/ex3 a port of PETSc ksp/tutorial/ex3.c to ASiMoV-CCS style code.
!  This case demonstrates setting up a linear system and solving it with ASiMoV-CCS, note
!  the code is independent of PETSc.
!  The example case solves the equation
!  \[
!    {\nabla^2} p = f
!  \]
!  in the unit square with Dirichlet boundary conditions
!  \[
!    p\left(\boldsymbol{x}\right) = y,\ \boldsymbol{x}\in\partial\Omega
!  \]

program poisson

  !! ASiMoV-CCS uses
  use constants, only : ndim, add_mode, insert_mode
  use kinds, only : ccs_real, ccs_int
  use types, only : vector_spec, ccs_vector, matrix_spec, ccs_matrix, &
       equation_system, linear_solver, ccs_mesh, cell_locator, face_locator, &
       neighbour_locator, vector_values, matrix_values
  use meshing, only : set_cell_location, set_face_location, set_neighbour_location
  use vec, only : create_vector
  use mat, only : create_matrix, set_nnz
  use solver, only : create_solver, solve, set_equation_system, axpy, norm
  use utils, only : update, begin_update, end_update, finalise, initialise, &
                    set_size, set_values, pack_entries
  use mesh_utils, only : build_square_mesh
  use meshing, only : get_face_area, get_centre, get_volume, get_global_index, &
       count_neighbours, get_boundary_status
  use parallel_types, only: parallel_environment
  use parallel, only: initialise_parallel_environment, &
                      cleanup_parallel_environment, &
                      read_command_line_arguments, &
                      timer, sync

  implicit none

  class(parallel_environment), allocatable, target :: par_env
  class(ccs_vector), allocatable, target :: u, b
  class(ccs_vector), allocatable :: u_exact
  class(ccs_matrix), allocatable, target :: M
  class(linear_solver), allocatable :: poisson_solver

  type(vector_spec) :: vec_properties
  type(matrix_spec) :: mat_properties
  type(equation_system) :: poisson_eq
  type(ccs_mesh) :: mesh

  integer(ccs_int) :: cps = 10 ! Default value for cells per side

  real(ccs_real) :: err_norm

  double precision :: start_time
  double precision :: end_time

  call initialise_parallel_environment(par_env)
  call read_command_line_arguments(par_env, cps=cps)

  call sync(par_env)
  call timer(start_time)

  call initialise_poisson(par_env)

  !! Initialise with default values
  call initialise(vec_properties)
  call initialise(mat_properties)
  call initialise(poisson_eq)

  !! Create stiffness matrix
  call set_size(par_env, mesh, mat_properties)
  call set_nnz(5, mat_properties)
  call create_matrix(mat_properties, M)

  call discretise_poisson(M)

  call begin_update(M) ! Start the parallel assembly for M

  !! Create right-hand-side and solution vectors
  call set_size(par_env, mesh, vec_properties)
  call create_vector(vec_properties, b)
  call create_vector(vec_properties, u_exact)
  call create_vector(vec_properties, u)

  call begin_update(u) ! Start the parallel assembly for u

  !! Evaluate right-hand-side vector
  call eval_rhs(b)

  call begin_update(b) ! Start the parallel assembly for b
  call end_update(M) ! Complete the parallel assembly for M
  call end_update(b) ! Complete the parallel assembly for b

  !! Modify matrix and right-hand-side vector to apply Dirichlet boundary conditions
  call apply_dirichlet_bcs(M, b)
  call begin_update(b) ! Start the parallel assembly for b
  call finalise(M)

  call end_update(u) ! Complete the parallel assembly for u
  call end_update(b) ! Complete the parallel assembly for b

  !! Create linear solver & set options
  call set_equation_system(par_env, b, u, M, poisson_eq)
  call create_solver(poisson_eq, poisson_solver)
  call solve(poisson_solver)

  !! Check solution
  call set_exact_sol(u_exact)
  call axpy(-1.0_ccs_real, u_exact, u)

  err_norm = norm(u, 2) * mesh%h
  if (par_env%proc_id == par_env%root) then
     print *, "Norm of error = ", err_norm
  end if

  !! Clean up
  deallocate(u)
  deallocate(b)
  deallocate(u_exact)
  deallocate(M)
  deallocate(poisson_solver)

  call timer(end_time)

  if (par_env%proc_id == par_env%root) then
    print *, "Elapsed time = ", (end_time - start_time)
  end if

  call cleanup_parallel_environment(par_env)

contains

  subroutine eval_rhs(b)

    class(ccs_vector), intent(inout) :: b

    integer(ccs_int) :: i
    real(ccs_real) :: r

    type(vector_values) :: val_dat

    type(cell_locator) :: loc_p
    real(ccs_real), dimension(ndim) :: cc
    real(ccs_real) :: V
    integer(ccs_int) :: global_index_p

    val_dat%setter_mode = add_mode
    allocate(val_dat%global_indices(1))
    allocate(val_dat%values(1))

    associate(nloc => mesh%nlocal, &
         h => mesh%h)
      ! this is currently setting 1 vector value at a time
      ! consider changing to doing all the updates in one go
      ! to do only 1 call to eval_cell_rhs and set_values
      do i = 1, nloc
        call set_cell_location(mesh, i, loc_p)
        call get_centre(loc_p, cc)
        call get_volume(loc_p, V)
        call get_global_index(loc_p, global_index_p)
        associate(x => cc(1), y => cc(2))
          call eval_cell_rhs(x, y, h**2, r)
          r = V * r
          call pack_entries(1, global_index_p, r, val_dat)
          call set_values(val_dat, b)
        end associate
      end do
    end associate

    deallocate(val_dat%global_indices)
    deallocate(val_dat%values)

  end subroutine eval_rhs

  !>  Apply forcing function
  pure subroutine eval_cell_rhs (x, y, H, r)

    real(ccs_real), intent(in) :: x, y, H
    real(ccs_real), intent(out) :: r

    r = 0.0_ccs_real &
         + 0.0_ccs_real * (x + y + H) ! Silence unused dummy argument error

  end subroutine eval_cell_rhs

  subroutine discretise_poisson(M)

    class(ccs_matrix), intent(inout) :: M

    type(matrix_values) :: mat_coeffs
    integer(ccs_int) :: i, j

    integer(ccs_int) :: row, col
    real(ccs_real) :: coeff_f, coeff_p, coeff_nb

    type(face_locator) :: loc_f
    real(ccs_real) :: A

    integer(ccs_int) :: global_index_p
    type(cell_locator) :: loc_p
    integer(ccs_int) :: nnb

    type(neighbour_locator) :: loc_nb
    logical :: is_boundary
    integer(ccs_int) :: global_index_nb

    mat_coeffs%setter_mode = insert_mode

    !! Loop over cells
    do i = 1, mesh%nlocal
      !> @todo: Doing this in a loop is awful code - malloc maximum coefficients per row once,
      !!        filling from front, and pass the number of coefficients to be set, requires
      !!        modifying the matrix_values type and the implementation of set_values applied to
      !!        matrices.
      call set_cell_location(mesh, i, loc_p)
      call get_global_index(loc_p, global_index_p)
      call count_neighbours(loc_p, nnb)

      allocate(mat_coeffs%global_row_indices(1))
      allocate(mat_coeffs%global_col_indices(1 + nnb))
      allocate(mat_coeffs%values(1 + nnb))

      row = global_index_p
      coeff_p = 0.0_ccs_real

      !! Loop over faces
      do j = 1, nnb
        call set_neighbour_location(loc_p, j, loc_nb)
        call get_boundary_status(loc_nb, is_boundary)

        if (.not. is_boundary) then
          !! Interior face

          call set_face_location(mesh, i, j, loc_f)
          call get_face_area(loc_f, A)
          coeff_f = (1.0 / mesh%h) * A

          call get_global_index(loc_nb, global_index_nb)

          coeff_p = coeff_p - coeff_f
          coeff_nb = coeff_f
          col = global_index_nb
        else
          col = -1
          coeff_nb = 0.0_ccs_real
        end if
        call pack_entries(1, j + 1, row, col, coeff_nb, mat_coeffs)

      end do

      !! Add the diagonal entry
      col = row
      call pack_entries(1, 1, row, col, coeff_p, mat_coeffs)

      !! Set the values
      call set_values(mat_coeffs, M)

      deallocate(mat_coeffs%global_row_indices)
      deallocate(mat_coeffs%global_col_indices)
      deallocate(mat_coeffs%values)

    end do

  end subroutine discretise_poisson

  subroutine apply_dirichlet_bcs(M, b)

    implicit none

    class(ccs_matrix), intent(inout) :: M
    class(ccs_vector), intent(inout) :: b

    integer(ccs_int) :: i, j
    real(ccs_real) :: boundary_coeff, boundary_val

    integer(ccs_int) :: idx, row, col
    real(ccs_real) :: r, coeff

    type(vector_values) :: vec_values
    type(matrix_values) :: mat_coeffs

    type(face_locator) :: loc_f
    real(ccs_real) :: A

    type(cell_locator) :: loc_p
    integer(ccs_int) :: global_index_p
    type(neighbour_locator) :: loc_nb

    integer(ccs_int) :: nnb
    logical :: is_boundary

    allocate(mat_coeffs%global_row_indices(1))
    allocate(mat_coeffs%global_col_indices(1))
    allocate(mat_coeffs%values(1))
    allocate(vec_values%global_indices(1))
    allocate(vec_values%values(1))

    mat_coeffs%setter_mode = add_mode
    vec_values%setter_mode = add_mode

    do i = 1, mesh%nlocal
      if (minval(mesh%neighbour_indices(:, i)) < 0) then
        call set_cell_location(mesh, i, loc_p)
        call get_global_index(loc_p, global_index_p)
        coeff = 0.0_ccs_real
        r = 0.0_ccs_real

        row = global_index_p
        col = global_index_p
        idx = global_index_p

        call count_neighbours(loc_p, nnb)
        do j = 1, nnb

          call set_neighbour_location(loc_p, j, loc_nb)
          call get_boundary_status(loc_nb, is_boundary)

          if (is_boundary) then
            call set_face_location(mesh, i, j, loc_f)
            call get_face_area(loc_f, A)
            boundary_coeff = (2.0 / mesh%h) * A
            boundary_val = rhs_val(i, j)

            ! Coefficient
            coeff = coeff - boundary_coeff

            ! RHS vector
            r = r - boundary_val * boundary_coeff
          end if

        end do

        call pack_entries(1, 1, row, col, coeff, mat_coeffs)
        call pack_entries(1, idx, r, vec_values)

        call set_values(mat_coeffs, M)
        call set_values(vec_values, b)

      end if
    end do

    deallocate(vec_values%global_indices)
    deallocate(vec_values%values)

  end subroutine apply_dirichlet_bcs

  subroutine set_exact_sol(u_exact)

    class(ccs_vector), intent(inout) :: u_exact

    type(vector_values) :: vec_values
    integer(ccs_int) :: i

    type(cell_locator) :: loc_p
    integer(ccs_int) :: global_index_p

    allocate(vec_values%global_indices(1))
    allocate(vec_values%values(1))
    vec_values%setter_mode = insert_mode
    do i = 1, mesh%nlocal
      call set_cell_location(mesh, i, loc_p)
      call get_global_index(loc_p, global_index_p)
      call pack_entries(1, global_index_p, rhs_val(i), vec_values)
      call set_values(vec_values, u_exact)
    end do
    deallocate(vec_values%global_indices)
    deallocate(vec_values%values)

    call update(u_exact)
  end subroutine set_exact_sol

  subroutine initialise_poisson(par_env)

    class(parallel_environment) :: par_env

    mesh = build_square_mesh(par_env, cps, 1.0_ccs_real)

  end subroutine initialise_poisson

  function rhs_val(i, f) result(r)

    integer(ccs_int), intent(in) :: i !< Cell index
    integer(ccs_int), intent(in), optional :: f !< Face index (local wrt cell)

    type(cell_locator) :: loc_p
    type(face_locator) :: loc_f

    real(ccs_real), dimension(ndim) :: x
    real(ccs_real) :: r

    if (present(f)) then
      !! Face-centred value
      call set_face_location(mesh, i, f, loc_f)
      call get_centre(loc_f, x)
      associate(y => x(2))
        r = y
      end associate
    else
      !! Cell-centred value
      call set_cell_location(mesh, i, loc_p)
      call get_centre(loc_p, x)
      associate(y => x(2))
        r = y
      end associate
    end if

  end function rhs_val

end program poisson


*     TG01MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDE, LDQ, LDZ
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDE = NMAX, LDQ = NMAX, LDZ = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 4*NMAX )
*     .. Local Scalars ..
      CHARACTER*1      JOB
      INTEGER          I, INFO, J, M, N, ND, NF, NIBLCK, P
      DOUBLE PRECISION TOL
*     .. Local Arrays ..
      INTEGER          IBLCK(NMAX),  IWORK(NMAX)
      DOUBLE PRECISION A(LDA,NMAX),  ALPHAI(NMAX), ALPHAR(NMAX),
     $                 B(LDB,MMAX),    BETA(NMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), E(LDE,NMAX), Q(LDQ,NMAX),
     $                 Z(LDZ,NMAX)
*     .. External Subroutines ..
      EXTERNAL         TG01MD
*     .. Intrinsic Functions ..
      INTRINSIC        DCMPLX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, JOB, TOL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99988 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99987 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99986 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*              Find the reduced descriptor system
*              (A-lambda E,B,C).
               CALL TG01MD( JOB, N, M, P, A, LDA, E, LDE, B, LDB, C,
     $                      LDC, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ,
     $                      NF, ND, NIBLCK, IBLCK, TOL, IWORK, DWORK,
     $                      LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99994 ) NF, ND
                  WRITE ( NOUT, FMT = 99989 ) NIBLCK + 1
                  IF ( NIBLCK.GT.0 ) THEN
                     WRITE ( NOUT, FMT = 99985 )
     $                     ( IBLCK(I), I = 1, NIBLCK )
                  END IF
                  WRITE ( NOUT, FMT = 99997 )
                  DO 10 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   10             CONTINUE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99993 )
                  DO 30 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   30             CONTINUE
                  WRITE ( NOUT, FMT = 99992 )
                  DO 40 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 50 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,N )
   50             CONTINUE
                  WRITE ( NOUT, FMT = 99990 )
                  DO 60 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99985 )
                  DO 70 I = 1, NF
                     WRITE ( NOUT, FMT = 99984 )
     $                  DCMPLX( ALPHAR(I), ALPHAI(I) )/BETA(I)
   70             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TG01MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TG01MD = ',I2)
99997 FORMAT (/' The transformed state dynamics matrix Q''*A*Z is ')
99996 FORMAT (/' The transformed descriptor matrix Q''*E*Z is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (' Order of reduced system =', I5/
     $        ' Number of non-dynamic infinite eigenvalues =', I5)
99993 FORMAT (/' The transformed input/state matrix Q''*B is ')
99992 FORMAT (/' The transformed state/output matrix C*Z is ')
99991 FORMAT (/' The left transformation matrix Q is ')
99990 FORMAT (/' The right transformation matrix Z is ')
99989 FORMAT ( ' Number of infinite blocks = ',I5)
99988 FORMAT (/' N is out of range.',/' N = ',I5)
99987 FORMAT (/' M is out of range.',/' M = ',I5)
99986 FORMAT (/' P is out of range.',/' P = ',I5)
99985 FORMAT (/' The finite generalized eigenvalues are '/
     $         ' real  part     imag  part ')
99984 FORMAT (1X,F9.4,SP,F9.4,S,'i ')
      END


!*==dlartgs.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DLARTGS generates a plane rotation designed to introduce a bulge in implicit QR iteration for the bidiagonal SVD problem.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DLARTGS + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DLARTGS( X, Y, SIGMA, CS, SN )
!
!       .. Scalar Arguments ..
!       DOUBLE PRECISION        CS, SIGMA, SN, X, Y
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DLARTGS generates a plane rotation designed to introduce a bulge in
!> Golub-Reinsch-style implicit QR iteration for the bidiagonal SVD
!> problem. X and Y are the top-row entries, and SIGMA is the shift.
!> The computed CS and SN define a plane rotation satisfying
!>
!>    [  CS  SN  ]  .  [ X^2 - SIGMA ]  =  [ R ],
!>    [ -SN  CS  ]     [    X * Y    ]     [ 0 ]
!>
!> with R nonnegative.  If X^2 - SIGMA and X * Y are 0, then the
!> rotation is by PI/2.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] X
!> \verbatim
!>          X is DOUBLE PRECISION
!>          The (1,1) entry of an upper bidiagonal matrix.
!> \endverbatim
!>
!> \param[in] Y
!> \verbatim
!>          Y is DOUBLE PRECISION
!>          The (1,2) entry of an upper bidiagonal matrix.
!> \endverbatim
!>
!> \param[in] SIGMA
!> \verbatim
!>          SIGMA is DOUBLE PRECISION
!>          The shift.
!> \endverbatim
!>
!> \param[out] CS
!> \verbatim
!>          CS is DOUBLE PRECISION
!>          The cosine of the rotation.
!> \endverbatim
!>
!> \param[out] SN
!> \verbatim
!>          SN is DOUBLE PRECISION
!>          The sine of the rotation.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2017
!
!> \ingroup auxOTHERcomputational
!
!  =====================================================================
      SUBROUTINE DLARTGS(X,Y,Sigma,Cs,Sn)
      IMPLICIT NONE
!*--DLARTGS94
!
!  -- LAPACK computational routine (version 3.8.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2017
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION Cs , Sigma , Sn , X , Y
!     ..
!
!  ===================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION NEGONE , ONE , ZERO
      PARAMETER (NEGONE=-1.0D0,ONE=1.0D0,ZERO=0.0D0)
!     ..
!     .. Local Scalars ..
      DOUBLE PRECISION r , s , thresh , w , z
!     ..
!     .. External Subroutines ..
      EXTERNAL DLARTGP
!     ..
!     .. External Functions ..
      DOUBLE PRECISION DLAMCH
      EXTERNAL DLAMCH
!     .. Executable Statements ..
!
      thresh = DLAMCH('E')
!
!     Compute the first column of B**T*B - SIGMA^2*I, up to a scale
!     factor.
!
      IF ( (Sigma==ZERO .AND. ABS(X)<thresh) .OR.                       &
     &     (ABS(X)==Sigma .AND. Y==ZERO) ) THEN
         z = ZERO
         w = ZERO
      ELSEIF ( Sigma==ZERO ) THEN
         IF ( X>=ZERO ) THEN
            z = X
            w = Y
         ELSE
            z = -X
            w = -Y
         ENDIF
      ELSEIF ( ABS(X)<thresh ) THEN
         z = -Sigma*Sigma
         w = ZERO
      ELSE
         IF ( X>=ZERO ) THEN
            s = ONE
         ELSE
            s = NEGONE
         ENDIF
         z = s*(ABS(X)-Sigma)*(s+Sigma/X)
         w = s*Y
      ENDIF
!
!     Generate the rotation.
!     CALL DLARTGP( Z, W, CS, SN, R ) might seem more natural;
!     reordering the arguments ensures that if Z = 0 then the rotation
!     is by PI/2.
!
      CALL DLARTGP(w,z,Sn,Cs,r)
!
!
!     End DLARTGS
!
      END SUBROUTINE DLARTGS


FUNCTION PekerisRoot( z )

  ! At one time, this was used to return the 'Pekeris branch cut'
  ! which is just a particular branch of the square root that
  ! exposes many 'leaky' or 'virtual' modes.

  ! The current version implements a particular branch that was convenient

  IMPLICIT NONE
  COMPLEX (KIND=8), INTENT(  IN ) :: z
  COMPLEX (KIND=8)                :: PekerisRoot

  IF ( REAL( z ) >= 0.0D0 ) THEN
     PekerisRoot = SQRT( z )
  ELSE
     PekerisRoot = ( 0.0D0, 1.0D0 ) * SQRT( -z )
  ENDIF

END FUNCTION PekerisRoot


      SUBROUTINE PELPE3(XMOM,PARA)
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  PARAMETER ESTIMATION VIA L-MOMENTS FOR THE PEARSON TYPE 3 DISTRIBUTION
C
C  PARAMETERS OF ROUTINE:
C  XMOM   * INPUT* ARRAY OF LENGTH 3. CONTAINS THE L-MOMENTS LAMBDA-1,
C                  LAMBDA-2 AND TAU-3.
C  PARA   *OUTPUT* ARRAY OF LENGTH 3. ON EXIT, CONTAINS THE PARAMETERS
C                  IN THE ORDER MU, SIGMA, GAMMA (MEAN, S.D., SKEWNESS).
C
C  OTHER ROUTINES USED: DLGAMA
C
C  METHOD: RATIONAL APPROXIMATION IS USED TO EXPRESS ALPHA, THE SHAPE
C  PARAMETER OF THE GAMMA DISTRIBUTION, AS A FUNCTION OF TAU-3.
C  RELATIVE ACCURACY OF THE APPROXIMATION IS BETTER THAN 3E-5.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION XMOM(3),PARA(3)
      DATA ZERO/0D0/,THIRD/0.33333333D0/,HALF/0.5D0/,ONE/1D0/,TWO/2D0/
C
C         SMALL IS USED TO TEST WHETHER SKEWNESS IS EFFECTIVELY ZERO
C
      DATA SMALL/1D-6/
C
C         CONSTANTS USED IN MINIMAX APPROXIMATIONS
C
      DATA C1,C2,C3/ 0.2906D0,  0.1882D0,  0.0442D0/
      DATA D1,D2,D3/ 0.36067D0,-0.59567D0, 0.25361D0/
      DATA D4,D5,D6/-2.78861D0, 2.56096D0,-0.77045D0/
      DATA PI3,ROOTPI/9.4247780D0,1.7724539D0/
C
      T3=DABS(XMOM(3))
      IF(XMOM(2).LE.ZERO.OR.T3.GE.ONE)GOTO 1000
      IF(T3.LE.SMALL)GOTO 100
      IF(T3.GE.THIRD)GOTO 10
      T=PI3*T3*T3
      ALPHA=(ONE+C1*T)/(T*(ONE+T*(C2+T*C3)))
      GOTO 20
   10 CONTINUE
      T=ONE-T3
      ALPHA=T*(D1+T*(D2+T*D3))/(ONE+T*(D4+T*(D5+T*D6)))
   20 CONTINUE
      RTALPH=DSQRT(ALPHA)
      BETA=ROOTPI*XMOM(2)*DEXP(DLGAMA(ALPHA)-DLGAMA(ALPHA+HALF))
      PARA(1)=XMOM(1)
      PARA(2)=BETA*RTALPH
      PARA(3)=TWO/RTALPH
      IF(XMOM(3).LT.ZERO)PARA(3)=-PARA(3)
      RETURN
C
C         ZERO SKEWNESS
C
  100 CONTINUE
      PARA(1)=XMOM(1)
      PARA(2)=XMOM(2)*ROOTPI
      PARA(3)=ZERO
      RETURN
C
 1000 WRITE(6,7000)
      DO 1010 I=1,3
 1010 PARA(I)=ZERO
      RETURN
C
 7000 FORMAT(' *** ERROR *** ROUTINE PELPE3 : L-MOMENTS INVALID')
      END


      DOUBLE PRECISION FUNCTION DK211(I,A,B,X)
      DOUBLE PRECISION F6211, A, B, X, XX, C1, C2, AAJ, C3
      DIMENSION  X(1)
      XX = X(I)
      IF ( (B * XX) ** 2 - A ** 2 ) 100,1,200
    1 CONTINUE
      IF (A .NE. B * XX) GO TO 50
      F6211 = 0.5D0 * (DLOG (DABS(2.0D0 * B * XX)) ) **2
      DK211 = F6211
      RETURN
   50 CONTINUE
      F6211 = 0.0D0
      DK211 = F6211
      RETURN
  100 CONTINUE
      F6211 = DLOG(DABS(A))* DLOG(DABS(XX))
      C1 =-B * XX / A
      C2 = 1.0D0
      J = 0
  110 J = J + 1
      AAJ = J
      C2 = C2 * C1
      C3 = C2 / (AAJ ** 2)
      F6211 = F6211 - C3
      IF(DABS(C3) .GT. 0.1D-5)   GO TO 110
      DK211 = F6211
      RETURN
  200 CONTINUE
      F6211 = (DLOG(DABS(B* XX)) ** 2) / 2.0D0
      C1 =-A / (B * XX)
      C2 = 1.0D0
      J = 0
  210 J = J + 1
      AAJ = J
      C2 = C2 * C1
      C3 = C2 / (AAJ ** 2)
      F6211 = F6211 + C3
      IF(DABS(C3) .GT. 0.1D-5)   GO TO 210
      DK211 = F6211
      RETURN
      END


!**********************************************************************
!
! SETS UP FFT PLANS TO DRIVE FFTW ROUTINES. PLANS DEFINED IN SETUP_FFTW
! ARE USED IN HORIZONTAL 2D FFTS (horfft).
!
! USAGE:
!
!     1. TO INITIALIZE PLANS USE OPTION 1:
!
!    CALL SETUP_FFTW(1)
!
!    THIS INITIALIZATION IS DONE ONLY ONCE AND THE CREATED PLANS
!    ARE USED THROUGHOUT THE MAIN PROGRAM.
!
!     2.0 TO DESTROY PLANS USE OPTION 0:
!
!    CALL SETUP_FFTW(0)
!
!    THIS IS USUALLY DONE AT THE END OF MAIN PROGRAM.
!
! REQUIREMENTS:
!
!     1. FFTW 3.3.2
!
!     2.0 ARRAY DIMENSIONS
!
! REVISION HISTORY:
!
!     ORIGINAL: T.SAKAI 10-16-2012 @ CORNELL UNIVERSITY
!**********************************************************************

module modfftw

! THIS MODULE DEFINES FLAGS AND FFTW PLAN VARIABLES USED IN HORIZONTAL
! FFTS.
!
! DESCRIPTION OF VARIABLES:
!
! PLAN_X_FWD     : PLAN FOR 1D real-TO-COMPLEX FORWARD FFT IN X-DIR.
! PLAN_Y_FWD     : PLAN FOR 1D COMPLEX-TO-COMPLEX FORWARD FFT IN Y-DIR.
! PLAN_X_BACKWD: PLAN FOR 1D COMPLEX-TO-real FORWARD FFT IN X-DIR.
! PLAN_Y_BACKWD: PLAN FOR 1D COMPLEX-TO-COMPLEX BACKWARD FFT IN Y-DIR.
use, intrinsic :: iso_c_binding
implicit none
public
save
include 'fftw3.f03'
! include 'fftw3.f'

! integer, parameter, private :: KD=8
integer(kind=8) :: PLAN_X_FWD
integer(kind=8) :: PLAN_Y_FWD
integer(kind=8) :: PLAN_X_BACKWD
integer(kind=8) :: PLAN_Y_BACKWD

contains

subroutine setup_fftw(ioption)
    ! THIS SUBROUTINE SETS UP FFTW PLANS FOR 2D (HORIZONTAL) FFTS. SET
    ! ioption = 1 (integer) FOR INITIALIZATION OR ioption = 0 FOR
    ! FINALIZATION(FREE ALL PLANS).
    use dim, only: nx, nxpp, ny, nypl, nxpl, nz, nzpl

    ! Argument variables
    integer, intent(IN) :: ioption

    ! Local variables
    real, dimension(nxpp,nypl)    :: arr2d
    real, dimension(nxpl,ny)    :: arr2df
    integer :: n_rank,n_howmany,idist,odist,istride,ostride
    integer, dimension(1) :: n_len,inembed,onembed

    !     integer :: nthreads, tid, iret

    if ( ioption == 1 ) then
        ! Add threading support
    !         call dfftw_init_threads(iret)
    !         print *, iret
    !         call dfftw_plan_with_nthreads(4)

        ! Plan 1D real-to-Complex Forward FFT in x-direction
        n_rank = 1
        n_len(1) = nx
        n_howmany = nypl
        idist = nxpp
        odist = nx/2+1
        istride = 1
        ostride = 1
        inembed(1) = nxpp
        onembed(1) = nx/2+1

        call dfftw_plan_many_dft_r2c(PLAN_X_FWD,n_rank,n_len,n_howmany,arr2d(1,1),inembed,istride,idist,arr2d(1,1),onembed,ostride,odist,FFTW_MEASURE)

        ! Plan 1D Complex-to-Complex Forward FFT in y-direction
        n_rank = 1
        n_len(1) = ny
        n_howmany = nxpl/2
        idist = 1
        odist = 1
        istride = nxpl/2
        ostride = nxpl/2
        inembed(1) = ny
        onembed(1) = ny

        call dfftw_plan_many_dft(PLAN_Y_FWD,n_rank,n_len,n_howmany,arr2df(1,1),inembed,istride,idist,arr2df(1,1),onembed,ostride,odist,FFTW_FORWARD,FFTW_MEASURE)

        ! Plan 1D Complex-to-Complex Backward FFT in y-direction
        n_rank = 1
        n_len(1) = ny
        n_howmany = nxpl/2
        idist = 1
        odist = 1
        istride = nxpl/2
        ostride = nxpl/2
        inembed(1) = ny
        onembed(1) = ny

        call dfftw_plan_many_dft(PLAN_Y_BACKWD,n_rank,n_len,n_howmany,arr2df(1,1),inembed,istride,idist,arr2df(1,1),onembed,ostride,odist,FFTW_BACKWARD,FFTW_MEASURE)

        ! Plan 1D Complex-to-real Backward FFT in x-direction
        n_rank = 1
        n_len(1) = nx
        n_howmany = nypl
        idist = nx/2+1
        odist = nxpp
        istride = 1
        ostride = 1
        inembed(1) = nx/2+1
        onembed(1) = nxpp

        call dfftw_plan_many_dft_c2r(PLAN_X_BACKWD,n_rank,n_len,n_howmany,arr2d(1,1),inembed,istride,idist,arr2d(1,1),onembed,ostride,odist,FFTW_MEASURE)

    elseif ( ioption == 0 ) then

        ! Destroy plans
        call dfftw_destroy_plan(PLAN_X_FWD)
        call dfftw_destroy_plan(PLAN_Y_FWD)
        call dfftw_destroy_plan(PLAN_X_BACKWD)
        call dfftw_destroy_plan(PLAN_Y_BACKWD)

    else

        write(*,*)'setup_fftw: invalid option.'

    end if

end subroutine setup_fftw

end module modfftw


c
c interfaces for various Cumalative Distribution Functions
c based upon: www/stat.unipg.it/stat/dcdflib
c

c ================================================================
c NCLFORTSTART
      SUBROUTINE DCDFBINP(N,S,XN,PR,P,IER)
c NCL: p = cdfbin_p(s,xn,pr)
      IMPLICIT NONE
c input
      INTEGER N
      DOUBLE PRECISION S(N),XN(N),PR(N)
c output
      INTEGER IER
      DOUBLE PRECISION P(N)
c NCLEND
c local
      INTEGER WHICH, I
      DOUBLE PRECISION Q,OMPR,BOUND

C iwhich = 1 : Calculate P and Q from S, XN, PR
c              Q, OMPR not returned

      WHICH = 1

      DO I=1,N
         Q    = 1.D0 - P(I)
         OMPR = 1.D0 - PR(I)
         CALL CDFBIN(WHICH,P(I),Q,S(I),XN(I),PR(I),OMPR,IER,BOUND)
         IF (IER.NE.0) CALL CDFBERR('CDFBIN_P',IER)
      END DO

      RETURN
      END
c ------------
c NCLFORTSTART
      SUBROUTINE DCDFBINS(N,P,XN,PR,S,IER)
c NCL: s = cdfbin_s(p,xn,pr)
      IMPLICIT NONE
c input
      INTEGER N
      DOUBLE PRECISION P(N),XN(N),PR(N)
c output
      INTEGER IER
      DOUBLE PRECISION S(N)
c NCLEND
c local
      INTEGER WHICH, I
      DOUBLE PRECISION Q,OMPR,BOUND

C iwhich = 2 : Calculate S from P,Q,XN,PR and OMPR

      WHICH = 2
      DO I=1,N
         Q    = 1.0D0 - P(I)
         OMPR = 1.0D0 - PR(I)
         CALL CDFBIN(WHICH,P(I),Q,S(I),XN(I),PR(I),OMPR,IER,BOUND)
         IF (IER.NE.0) CALL CDFBERR('CDFBIN_X',IER)
      END DO

      RETURN
      END
c ------------
c NCLFORTSTART
      SUBROUTINE DCDFBINXN(N,P,S,PR,XN,IER)
c NCL: n = cdfbin_xn(p,s,pr)
      IMPLICIT NONE
c input
      INTEGER N
      DOUBLE PRECISION P(N),S(N),PR(N)
c output
      INTEGER IER
      DOUBLE PRECISION XN(N)
c NCLEND
c local
      INTEGER WHICH, I
      DOUBLE PRECISION Q,OMPR,BOUND

C iwhich = 3 : Calculate XN from P,Q,S,PR and OMPR

      WHICH = 3
      DO I=1,N
         OMPR = 1.0D0 - PR(I)
         Q    = 1.0D0 - P(I)
         CALL CDFBIN(WHICH,P(I),Q,S(I),XN(I),PR(I),OMPR,IER,BOUND)
         IF (IER.NE.0) CALL CDFBERR('CDFBIN_XN',IER)
      END DO

      RETURN
      END
c ------------
c NCLFORTSTART
      SUBROUTINE DCDFBINPR(N,P,S,XN,PR,IER)
c NCL: pr = cdfbin_pr(p,s,xn)
      IMPLICIT NONE
c input
      INTEGER N
      DOUBLE PRECISION P(N),S(N),XN(N)
c output
      INTEGER IER
      DOUBLE PRECISION PR(N)
c NCLEND
c local
      INTEGER WHICH, I
      DOUBLE PRECISION Q,OMPR,BOUND

C iwhich = 4 : Calculate PR and OMPR from P,Q,S and XN
c              OMPR not returned
      WHICH = 4
      DO I=1,N
         Q    = 1.0D0 - P(I)
         OMPR = 1.0D0 - PR(I)
         CALL CDFBIN(WHICH,P(I),Q,S(I),XN(I),PR(I),OMPR,IER,BOUND)
         IF (IER.NE.0) CALL CDFBERR('CDFBIN_PR',IER)
      END DO

      RETURN
      END

c ------------
      SUBROUTINE CDFBERR(NAME,IER)
c error messages for cdfbin_{p,x,n,pr} functions
      IMPLICIT NONE
      CHARACTER*(*) NAME
      INTEGER IER

      IF (IER.NE.0) THEN
          IF (IER.EQ.1) PRINT *,NAME,': lower bound error'
          IF (IER.EQ.2) PRINT *,NAME,': upper bound error'
          IF (IER.EQ.3) PRINT *,NAME,': P+Q .ne. 1'
          IF (IER.EQ.4) PRINT *,NAME,': PR + OMPR .ne. 1'
      END IF
      RETURN
      END

c ================================================================
c NCLFORTSTART
      SUBROUTINE DCDFGAMP(N,X,SHAPE,SCALE,P,IER)
c NCL: p = cdfgam_p(x,shape,scale)
      IMPLICIT NONE
c input
      INTEGER N
      DOUBLE PRECISION X(N),SHAPE(N),SCALE(N)
c output
      INTEGER IER
      DOUBLE PRECISION P(N)
c NCLEND
c local
      INTEGER WHICH, I
      DOUBLE PRECISION Q,BOUND

C iwhich = 1 : Calculate P and Q from X,SHAPE and SCALE
c              Q not returned
      WHICH = 1
      BOUND = -999.D0
      DO I=1,N
         CALL CDFGAM(WHICH,P(I),Q,X(I),SHAPE(I),SCALE(I),IER,BOUND)
         IF (IER.NE.0) CALL CDFGERR('CDFGAM_P',IER)
      END DO

      RETURN
      END

c ------------
c NCLFORTSTART
      SUBROUTINE DCDFGAMX(N,P,SHAPE,SCALE,X,IER)
c NCL: x = cdfgam_x(p,shape,scale)
      IMPLICIT NONE
c input
      INTEGER N
      DOUBLE PRECISION P(N),SHAPE(N),SCALE(N)
c output
      INTEGER IER
      DOUBLE PRECISION X(N)
C NCLEND
c local
      INTEGER WHICH, I
      DOUBLE PRECISION Q,BOUND

C iwhich = 2 : Calculate X from P,Q,SHAPE and SCALE

      WHICH = 2
      BOUND = -999.D0

      DO I=1,N
         Q = 1.0D0 - P(I)
         CALL CDFGAM(WHICH,P(I),Q,X(I),SHAPE(I),SCALE(I),IER,BOUND)
         IF (IER.NE.0) CALL CDFGERR('CDFGAM_X',IER)
      END DO

      RETURN
      END

c ------------
      SUBROUTINE CDFGERR(NAME,IER)
c error messages for cdfgam_{p,x} functions
      IMPLICIT NONE
      CHARACTER*(*) NAME
      INTEGER IER

      IF (IER.NE.0) THEN
          IF (IER.EQ.1) PRINT *,NAME,': lower bound error'
          IF (IER.EQ.2) PRINT *,NAME,': upper bound error'
          IF (IER.EQ.3) PRINT *,NAME,': P+Q .ne. 1'
          IF (IER.EQ.10)PRINT *,NAME,': gamma/inverse gamma err'
          IF (IER.LT.0) PRINT *,NAME,': illegal input'
      END IF

      RETURN
      END

c ================================================================
c NCLFORTSTART
      SUBROUTINE DCDFNORP(N,X,MEAN,SD,P,IER)
c NCL: p = cdfnor_p(x,mean,sd)
      IMPLICIT NONE
c input
      INTEGER N
      DOUBLE PRECISION X(N),MEAN(N),SD(N)
c output
      INTEGER IER
      DOUBLE PRECISION P(N)
c NCLEND
c local
      INTEGER WHICH, I
      DOUBLE PRECISION Q,BOUND

C iwhich = 1 : Calculate P and Q from X,MEAN and SD
c              Q not returned

      WHICH = 1
      DO I=1,N
         CALL CDFNOR(WHICH,P(I),Q,X(I),MEAN(I),SD(I),IER,BOUND)
         IF (IER.NE.0) CALL CDFNERR('CDFNOR_P',IER)
      END DO

      RETURN
      END

c ------------
c NCLFORTSTART
      SUBROUTINE DCDFNORX(N,P,MEAN,SD,X,IER)
c NCL: x = cdfnor_x(p,mean,sd)
      IMPLICIT NONE
c input
      INTEGER N
      DOUBLE PRECISION P(N),MEAN(N),SD(N)
c output
      INTEGER IER
      DOUBLE PRECISION X(N)
c NCLEND
c local
      INTEGER WHICH, I
      DOUBLE PRECISION Q,BOUND

C iwhich = 2 : Calculate X from P,Q,MEAN and SD
      WHICH = 2
      DO I=1,N
         Q = 1.0D0 - P(I)
         CALL CDFNOR(WHICH,P(I),Q,X(I),MEAN(I),SD(I),IER,BOUND)
         IF (IER.NE.0) CALL CDFNERR('CDFNOR_X',IER)
      END DO

      RETURN
      END
c ------------
      SUBROUTINE CDFNERR(NAME,IER)
c error messages for cdfnor_{p,x} functions
      IMPLICIT NONE
      CHARACTER*(*) NAME
      INTEGER IER

      IF (IER.NE.0) THEN
          IF (IER.EQ.1) PRINT *,NAME,': lower bound error'
          IF (IER.EQ.2) PRINT *,NAME,': upper bound error'
          IF (IER.EQ.3) PRINT *,NAME,': P+Q .ne. 1'
      END IF

      RETURN
      END
c ------------
c NCLFORTSTART
      SUBROUTINE DCDFCHIP(N,X,DF,P,IER)
c NCL: p = cdfchi_p(x,df)
      IMPLICIT NONE
c input
      INTEGER N
      DOUBLE PRECISION X(N),DF(N)
c output
      INTEGER IER
      DOUBLE PRECISION P(N)
c NCLEND
c local
      INTEGER WHICH, I
      DOUBLE PRECISION Q,BOUND

C iwhich = 1 : Calculate P and Q from X and DF
c              Q not returned
      WHICH = 1
      BOUND = -999.D0
      DO I=1,N
         CALL CDFCHI(WHICH,P(I),Q,X(I),DF(I),IER,BOUND)
         IF (IER.NE.0) CALL CDFGERR('CDFCHI_P',IER)
      END DO

      RETURN
      END


program aoc01
    use io
    implicit none

    integer, dimension(:), allocatable :: mass_list
    integer :: n_modules
    character(len=2048) :: filename

    integer :: i, fuel, fuel_r
    integer :: total_fuel

    filename = 'input.txt'
    call load_list_i(filename, n_modules, mass_list)

    total_fuel = 0
    do i = 1, n_modules
        total_fuel = total_fuel + fuel(mass_list(i))
    end do

    write (*,*) total_fuel

    total_fuel = 0
    do i = 1, n_modules
        total_fuel = total_fuel + fuel_r(mass_list(i))
    end do

    write (*,*) total_fuel

    deallocate(mass_list)

end program

function fuel(mass) result(f)
    implicit none
    integer :: f
    integer, intent(in) :: mass
    f = 0
    if (mass.gt.6) then
        f = int(real(mass) / 3.0 - 2)
    end if
end function fuel

recursive function fuel_r(mass) result(f)
    implicit none
    integer :: f, fuel
    integer, intent(in) :: mass
    if (mass.le.0) then
        f = 0
        return
    else
        f = fuel(mass)
        f = f + fuel_r(f)
    end if
end function fuel_r


!! R755 forall-triplet-spec
!    is index-name = subscript : subscript [ : stride]

10 forall (ii = 1:10, jj = 1:10, kk=4:8)
11 end forall
forall (ii = 1:nn)
end forall
forall (ii = 1:nn:5)
end forall
forall (ii = 1:30:N, jj=K:5:3)
end forall

end


program call_c
!! Demonstrate Fortran calling C or C++.
!!
!! Normally BIND(C) should be used after the function name in the interface block,
!! rather than postpending underscore(s).

use, intrinsic :: iso_c_binding, only: c_int
implicit none (type, external)

interface
subroutine timestwo(a, a2, L)  bind (c)
import c_int
integer(c_int), value :: L
integer(c_int) :: a(L), a2(L)
end subroutine timestwo
end interface

integer(c_int) :: N, i
integer(c_int), allocatable :: x(:), x2(:)

N = 3

allocate(x(N), x2(N))

!! dummy data
do i=1,N
  x(i) = i
enddo

call timestwo(x, x2, N)

if (any(2*x /= x2)) error stop 'x2 /= 2*x'

end program


program test1_ll
#if (_DP==0)
 use iso_fortran_env,only:int32,int64,wp=>real32
#else
 use iso_fortran_env,only:int32,int64,wp=>real64
#endif
 use modsparse
 implicit none
 integer(kind=int32)::nrow,i,j
 integer(kind=int32)::row
 integer(kind=int32)::col
 integer(kind=int32)::iunit, istat
 real(kind=wp)::val
 logical::lup=.false.
 type(llsparse)::ll
 type(coosparse)::coo
 type(crssparse)::crs

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 !LINKED LINK
 open(newunit=iunit,file='crsinput.ascii',status='old',action='read')
 read(iunit,*) nrow

 ll=llsparse(nrow,lupper=lup)

 do
  read(iunit,*,iostat=istat) row,col,val
  if(istat.ne.0)exit
  call ll%add(row,col,val)
 end do
 close(iunit)

 call ll%printstats()

 call ll%print()
 !call coo%print(lint=.false.)
 call ll%printtofile('ll.dat')

 print*,'size ll: ',ll%nonzero()

 do i=1,ll%getdim(1)
  do j=1,ll%getdim(2)
   print*,i,j,ll%get(i,j)
  enddo
 enddo

end program


! vim: set ft=fortran sw=4 ts=4:

module mod_array

    ! Utilty functions for arrays

    implicit none

    private
    public :: denan, mean

contains

    pure function denan(x)
        ! Given input array x, returns an array
        ! of elements that exclude NaNs.
        use ieee_arithmetic, only: ieee_is_nan

        real, allocatable, intent(in) :: x(:)
        real, allocatable :: denan(:)

        denan = pack(x, .not. ieee_is_nan(x))

    end function denan

    pure real function mean(x)
        ! return mean value of array x.

        real, allocatable, intent(in) :: x(:)

        mean = sum(x) / size(x)

    end function mean

end module mod_array


program vinay
  print *, (3 <= 4) .and. .not. (3 >= 6)
end program vinay