C NCLFORTSTART
      SUBROUTINE DRCM2RGRID(NGRD,NYI,NXI,YI,XI,FI,NYO,YO,NXO,XO,FO
     +                      ,XMSG,NCRIT,OPT,IER)
      IMPLICIT NONE
      INTEGER          NGRD,NXI,NYI,NXO,NYO,NCRIT,OPT,IER
      DOUBLE PRECISION XI(NXI,NYI),YI(NXI,NYI),FI(NXI,NYI,NGRD)
      DOUBLE PRECISION XO(NXO),YO(NYO),FO(NXO,NYO,NGRD),XMSG
C NCLEND

C This is written  with GNU f77 acceptable extensions
c .   This could be improved considerably with f90

c NCL:  fo = rcm2rgrid (lat2d,lon2d,fi, lat, lon iopt)
c                        yi    xi   fi  yo   xo
c
c            fo is the same size xo, yo and same type as "fi"
c            xmsg = fi@_FillValue
c            opt unused option
c
c            The NCL wrapper should allow for multiple datasets
c            so the user need only make one call to the function.

c perform 2D interpolation allowing for missing data:  nothing fancy

c nomenclature:
c .   nxi,nyi - lengths of xi,yi and dimensions of fi (must be >= 2)
c .   xi      - coordinates of fi (eg, lon [2D] )
c .   yi      - coordinates of fi (eg, lat [2D] )
c .   fi      - functional input values [2D]
c .   nxo,nyo - lengths of xo,yo and dimensions of fo (must be >= 1)
c .   xo      - coordinates of fo (eg, lon [1D])
c .             must be monotonically increasing
c .   yo      - coordinates of fo (eg, lat [1D])
c .             must be monotonically increasing
c .   fo      - functional output values [interpolated]
c .   xmsg    - missing code
c .   opt     - unused
c .   ier     - error code
c .             =0;   no error
c .             =1;   not enough points in input/output array
c .             =2/3; xi or yi are not monotonically increasing
c .             =4/5; xo or yo are not monotonically increasing
c
c                              local
      INTEGER          NG, NX,NY,NEXACT,IX,IY,M,N,NW,NER,K,NCRT
      INTEGER          MFLAG, MPTCRT, MKNT
      DOUBLE PRECISION FW(2,2),W(2,2),SUMF,SUMW,CHKLAT(NYI),CHKLON(NXI)
      DOUBLE PRECISION EPS
      DOUBLE PRECISION DGCDIST
c                              error checking
      IER = 0
      IF (NXI.LE.1 .OR. NYI.LE.1 .OR. NXO.LE.1 .OR. NYO.LE.1) THEN
          IER = 1
          RETURN
      END IF
      IF (IER.NE.0) RETURN

      CALL DMONOINC(YO,NYO,IER,NER)
      IF (IER.NE.0) RETURN
      CALL DMONOINC(XO,NXO,IER,NER)
      IF (IER.NE.0) RETURN

      DO NY = 1,NYI
         CHKLAT(NY) = YI(1,NY)
c c c    print *,"chklat: ny=",ny,"  chklat=",chklat(ny)
      END DO
      CALL DMONOINC(CHKLAT,NYI,IER,NER)
      IF (IER.NE.0) RETURN

      DO NX = 1,NXI
         CHKLON(NX) = XI(NX,1)
c c c    print *,"chklon: nx=",nx,"  chklon=",chklon(nx)
      END DO
      CALL DMONOINC(CHKLAT,NYI,IER,NER)
      IF (IER.NE.0) RETURN

      K = 2
c c c k = opt

      IF (NCRIT.LE.1) THEN
          NCRT = 1
      ELSE
          NCRT = MIN(4,NCRIT)
      END IF
c                              initialize to xmsg
      DO NG=1,NGRD
         DO NY = 1,NYO
            DO NX = 1,NXO
               FO(NX,NY,NG) = XMSG
            END DO
         END DO
      END DO
c                              main loop [exact matches]
c                              people want bit-for-bit match
      EPS    = 1.D-04
      NEXACT = 0

      DO NY = 1,NYO
        DO NX = 1,NXO
           DO IY = 1,NYI
              DO IX = 1,NXI
                 IF (XO(NX).GE.(XI(IX,IY)-EPS) .AND.
     +                XO(NX).LE.(XI(IX,IY)+EPS) .AND.
     +                YO(NY).GE.(YI(IX,IY)-EPS) .AND.
     +                YO(NY).LE.(YI(IX,IY)+EPS) ) THEN

                    DO NG=1,NGRD
                       FO(NX,NY,NG) = FI(IX,IY,NG)
                       NEXACT = NEXACT + 1
                    END DO
                    GO TO 10
                 END IF
              END DO
           END DO

 10        CONTINUE
        END DO
      END DO

c c c print *, "nexact=",nexact
c                              main loop [interpolation]
      DO NY = 1,NYO
        DO NX = 1,NXO

               DO IY = 1,NYI-K
                 DO IX = 1,NXI-K
                    IF (XO(NX).GE.XI(IX,IY) .AND.
     +                  XO(NX).LE.XI(IX+K,IY) .AND.
     +                  YO(NY).GE.YI(IX,IY) .AND.
     +                  YO(NY).LE.YI(IX,IY+K)) THEN

                        W(1,1) = (1.D0/DGCDIST(YO(NY),XO(NX),
     +                            YI(IX,IY),XI(IX,IY),2))**2
                        W(2,1) = (1.D0/DGCDIST(YO(NY),XO(NX),
     +                            YI(IX+K,IY),XI(IX+K,IY),2))**2
                        W(1,2) = (1.D0/DGCDIST(YO(NY),XO(NX),
     +                            YI(IX,IY+K),XI(IX,IY+K),2))**2
                        W(2,2) = (1.D0/DGCDIST(YO(NY),XO(NX),
     +                            YI(IX+K,IY+K),XI(IX+K,IY+K),2))**2
                      DO NG=1,NGRD
                        IF (FO(NX,NY,NG).EQ.XMSG) THEN
                            FW(1,1) = FI(IX,IY,NG)
                            FW(2,1) = FI(IX+K,IY,NG)
                            FW(1,2) = FI(IX,IY+K,NG)
                            FW(2,2) = FI(IX+K,IY+K,NG)

                            NW   = 0
                            SUMF = 0.0D0
                            SUMW = 0.0D0
                            DO N = 1,2
                              DO M = 1,2
                                 IF (FW(M,N).NE.XMSG) THEN
                                     SUMF = SUMF + FW(M,N)*W(M,N)
                                     SUMW = SUMW + W(M,N)
                                     NW   = NW + 1
                                 END IF
                              END DO
                            END DO
c                                             nw >=3 arbitrary
c c c                       IF (NW.GE.3 .AND. SUMW.GT.0.D0) THEN
c                                             nw =1 nearest neighbor
                            IF (NW.GE.NCRT .AND. SUMW.GT.0.D0) THEN
                                FO(NX,NY,NG) = SUMF/SUMW
                            END IF
                        END IF
                      END DO
                      GO TO 20
                   END IF
                 END DO
               END DO
   20          CONTINUE
       END DO
      END DO

C Since the RCM grid is curvilinear the above algorithm may not work
C .   for all of the locations on regular grid. Fill via linear interp.

      MKNT   =  0
      MFLAG  =  0
      MPTCRT =  2
      DO NG=1,NGRD
        DO NY=1,NYO
          DO NX=1,NXO
             IF (FO(NX,NY,NG).EQ.XMSG) THEN
                 CALL DLINMSG(FO(1,NY,NG),NXO,XMSG,MFLAG,MPTCRT)
                 MKNT = MKNT + 1
             END IF
          END DO
        END DO
      END DO

C C C PRINT *,"MKNT=",MKNT

      RETURN
      END
c -----------------------------------------------------------
C NCLFORTSTART
      SUBROUTINE DRGRID2RCM(NGRD,NYI,NXI,YI,XI,FI,NYO,NXO,YO,XO,FO
     +                     ,XMSG,NCRIT,OPT,IER)
      IMPLICIT NONE
      INTEGER          NGRD,NXI,NYI,NXO,NYO,OPT,NCRIT,IER
      DOUBLE PRECISION XI(NXI),YI(NYI),FI(NXI,NYI,NGRD)
      DOUBLE PRECISION XO(NXO,NYO),YO(NXO,NYO),FO(NXO,NYO,NGRD),XMSG
C NCLEND

C This is written  with GNU f77 acceptable extensions
c .   This could be improved considerably with f90

c            fo is the same size xo, yo and same type as "fi"
c            xmsg = fi@_FillValue
c            opt unused option
c
c            The NCL wrapper should allow for multiple datasets
c            so the user need only make one call to the function.

c perform 2D interpolation allowing for missing data:  nothing fancy

c nomenclature:
c .   nxi,nyi - lengths of xi,yi and dimensions of fi (must be >= 2)
c .   xi      - coordinates of fi (eg, lon [1D])
c .   yi      - coordinates of fi (eg, lat [1D])
c .   fi      - functional input values [2D]
c .   nxo,nyo - lengths of xo,yo and dimensions of fo (must be >= 1)
c .   xo      - coordinates of fo (eg, lon [2D])
c .             must be monotonically increasing
c .   yo      - coordinates of fo (eg, lat [2D])
c .             must be monotonically increasing
c .   fo      - functional output values [interpolated]
c .   xmsg    - missing code
c .   opt     - unused
c .   ier     - error code
c .             =0;   no error
c .             =1;   not enough points in input/output array
c .             =2/3; xi or yi are not monotonically increasing
c .             =4/5; xo or yo are not monotonically increasing
c
c                              local
      INTEGER          NG,NX,NY,NEXACT,IX,IY,M,N,NW,NER,K
      DOUBLE PRECISION FW(2,2),W(2,2),SUMF,SUMW,EPS
      DOUBLE PRECISION DGCDIST

c                              in-line functions (bilinear interp)
      DOUBLE PRECISION Z1,Z2,Z3,Z4,SLOPE,SLPX,SLPY,FLI,FBLI

      FLI(Z1,Z2,SLOPE) = Z1 + SLOPE* (Z2-Z1)
      FBLI(Z1,Z2,Z3,Z4,SLPX,SLPY) = FLI(Z1,Z2,SLPX) +
     +                              SLPY* (FLI(Z3,Z4,SLPX)-
     +                              FLI(Z1,Z2,SLPX))

c                              error checking
      IER = 0
      IF (NXI.LE.1 .OR. NYI.LE.1 .OR. NXO.LE.1 .OR. NYO.LE.1) THEN
          IER = 1
          RETURN
      END IF
      IF (IER.NE.0) RETURN

      CALL DMONOINC(YI,NYI,IER,NER)
      IF (IER.NE.0) RETURN
      CALL DMONOINC(XI,NXI,IER,NER)
      IF (IER.NE.0) RETURN
c                              Init to missing
      DO NG = 1,NGRD
        DO NY = 1,NYO
          DO NX = 1,NXO
             FO(NX,NY,NG) = XMSG
          END DO
        END DO
      END DO
c                              main loop [exact matches]
      EPS    = 1.D-03
      NEXACT = 0

      DO NY = 1,NYO
        DO NX = 1,NXO

          DO IY = 1,NYI
            DO IX = 1,NXI
               IF (XO(NX,NY).GE.(XI(IX)-EPS) .AND.
     +             XO(NX,NY).LE.(XI(IX)+EPS) .AND.
     +             YO(NX,NY).GE.(YI(IY)-EPS) .AND.
     +             YO(NX,NY).LE.(YI(IY)+EPS) ) THEN

                   DO NG=1,NGRD
                      FO(NX,NY,NG) = FI(IX,IY,NG)
                      NEXACT = NEXACT + 1
                   END DO
                   GO TO 10
                END IF
            END DO
          END DO

   10      CONTINUE
          END DO
        END DO

c c c print *, "nexact=",nexact

      K = 1
c c c k = opt

c                              main loop [interpolation]
      DO NY = 1,NYO
        DO NX = 1,NXO

          DO IY = 1,NYI - K
            DO IX = 1,NXI - K
               IF (XO(NX,NY).GE.XI(IX) .AND.
     +             XO(NX,NY).LT.XI(IX+K) .AND.
     +             YO(NX,NY).GE.YI(IY) .AND.
     +             YO(NX,NY).LT.YI(IY+K)) THEN

               DO NG = 1,NGRD
                 IF (FO(NX,NY,NG).EQ.XMSG) THEN
                   IF (FI(IX,IY,NG).NE.XMSG .AND.
     +                 FI(IX+K,IY,NG).NE.XMSG .AND.
     +                 FI(IX,IY+K,NG).NE.XMSG .AND.
     +                 FI(IX+K,IY+K,NG).NE.XMSG) THEN

                       FO(NX,NY,NG) =FBLI(FI(IX,IY,NG),FI(IX+K,IY,NG),
     +                                  FI(IX,IY+K,NG),FI(IX+K,IY+K,NG),
     +                                  (XO(NX,NY)-XI(IX))/
     +                                  (XI(IX+K)-XI(IX)),
     +                                  (YO(NX,NY)-YI(IY))/
     +                                  (YI(IY+K)-YI(IY)))

                   ELSE
c                                            OVERKILL
                       FW(1,1) = FI(IX,IY,NG)
                       FW(2,1) = FI(IX+K,IY,NG)
                       FW(1,2) = FI(IX,IY+K,NG)
                       FW(2,2) = FI(IX+K,IY+K,NG)

                       W(1,1) = (1.D0/DGCDIST(YO(NX,NY),XO(NX,NY)
     +                          ,YI(IY),XI(IX),2))**2
                       W(2,1) = (1.D0/DGCDIST(YO(NX,NY),XO(NX,NY)
     +                          ,YI(IY),XI(IX+K),2))**2
                       W(1,2) = (1.D0/DGCDIST(YO(NX,NY),XO(NX,NY)
     +                          ,YI(IY+K),XI(IX),2))**2
                       W(2,2) = (1.D0/DGCDIST(YO(NX,NY),XO(NX,NY)
     +                          ,YI(IY+K),XI(IX+K),2))**2

                       NW = 0
                       SUMF = 0.0D0
                       SUMW = 0.0D0
                       DO N = 1,2
                         DO M = 1,2
                            IF (FW(M,N).NE.XMSG) THEN
                                SUMF = SUMF + FW(M,N)*W(M,N)
                                SUMW = SUMW + W(M,N)
                                NW = NW + 1
                            END IF
                         END DO
                       END DO
c                                             nw >=3 arbitrary
c c c                  IF (NCRIT.GE.3 .AND. SUMW.GT.0.D0) THEN
c                                             nw  =1 nearest neighbor
                       IF (NCRIT.GE.1 .AND. SUMW.GT.0.D0) THEN
                           FO(NX,NY,NG) = SUMF/SUMW
                       END IF
                   END IF
                 END IF
               END DO
               GO TO 20
             END IF
            END DO
          END DO

   20         CONTINUE
        END DO
      END DO

      RETURN
      END


module simplex_m

  use globals
  implicit none
  private
  public :: simplex

contains

  subroutine simplex(x,xlo,xhi,y,f)
    interface
      pure real(dp) function simplexfun(x)
        import sp,dp
        real(dp), dimension(:), intent(in) :: x
      end function
    end interface
    real(dp), dimension(:,:), intent(inout) :: x
    real(dp), dimension(:), intent(in) :: xlo, xhi
    real(dp), dimension(:), intent(out) :: y
    procedure(simplexfun) :: f

    real(dp), dimension(*), parameter :: a = [ 1.0, 2.0, 0.5, 0.5 ]
    integer,  dimension(size(x,1) + 1) :: s
    real(dp), dimension(size(x,1)) :: x_0, x_r, x_e, x_c
    real(dp) :: y_r
    integer :: iter, i, n

    character(*), parameter :: actionfmt = '("simplex ", I2, ": ", &
          & A12, "(", I2, ")")'
    character(*), parameter :: statfmt = &
          & '(8X, "miny = ", Es10.3, " (", I2, ")", &
          &   3X, "maxy = ", Es10.3, " (", I2, ")")'

    n = size(x,1)

    if (size(x,2) /= n + 1) error stop "simplex: x must have shape (n,n+1)"
    if (size(y)   /= n + 1) error stop "simplex: size(y) /= size(x,1) + 1"
    if (size(xlo) /= n) error stop "simplex: size(xlo) /= size(x,1)"
    if (size(xhi) /= n) error stop "simplex: size(xhi) /= size(x,1)"

    !$omp parallel do
    do i = 1,n+1
      y(i) = f(x(:,i))
    end do
    !$omp end parallel do

    simplex_loop: do iter = 1, 72

      call isort(y,s)
      x_0 = sum(x(:,s(1:n)),2) / n

      write (0, statfmt) y(s(1)), s(1), y(s(n+1)), s(n+1)

      ! reflection
      x_r = x_0 + a(1) * (x_0 - x(:,s(n+1)))
      y_r = f(x_r)
      if (y_r < y(s(n))) then
        if (y_r > y(s(1))) then
          write (0,actionfmt) iter, "REFLECT", s(n+1)
          x(:,s(n+1)) = x_r
        else
          ! expansion
          x_e = x_0 + a(2) * (x_r - x_0)
          if (f(x_e) < y_r) then
            write (0,actionfmt) iter, "EXPAND", s(n+1)
            x(:,s(n+1)) = x_e
          else
            write (0,actionfmt) iter, "REFLECT", s(n+1)
            x(:,s(n+1)) = x_r
          end if
        end if
        y(s(n+1)) = f(x(:,s(n+1)))
      else
        ! contraction
        x_c = x_0 + a(3) * (x(:,s(n+1)) - x_0)
        if (f(x_c) < y(s(n+1))) then
          write (0,actionfmt) iter, "CONTRACT", s(n+1)
          x(:,s(n+1)) = x_c
          y(s(n+1)) = f(x(:,s(n+1)))
        else
          ! shrink
          write (0,actionfmt) iter, "SHRINK", s(1)
          !$omp parallel do
          do i = 2,n+1
            x(:,s(i)) = x(:,s(1)) + a(4) * (x(:,s(i)) - x(:,s(1)))
            y(s(i)) = f(x(:,s(i)))
          end do
          !$omp end parallel do
          ! do concurrent (i = 2:n+1)
          !   x(:,s(i)) = x(:,s(1)) + a(4) * (x(:,s(i)) - x(:,s(1)))
          !   y(s(i)) = f(x(:,s(i)))
          ! end do
        end if
      end if
    end do simplex_loop

    call isort(y,s)
    write (0, statfmt) y(s(1)), s(1), y(s(n+1)), s(n+1)

    x = x(:,s)
    y = y(s)

  end subroutine

  pure subroutine isort(x,s)
    real(dp), intent(in)  :: x(:)
    integer,  intent(out) :: s(:)
    integer :: i,j,sref

    if (size(x) /= size(s)) error stop "isort: size(x) /= size(s)"

    forall (i = 1:size(x)) s(i) = i

    do i = 2, size(x)
      sref = s(i)
      j = i - 1
      do while ( j > 0 .and. x(s(j)) > x(sref) )
        s(j + 1) = s(j)
        j = j - 1
      end do
      s(j + 1) = sref
    end do
  end subroutine

end module


! { dg-do run { xfail hppa*-*-hpux* } }
! { dg-require-effective-target fortran_largest_fp_has_sqrt }
!
! This test checks whether the largest possible
! floating-point number works.
!
! This is a run-time check. Depending on the architecture,
! this tests REAL(8), REAL(10) or REAL(16) and REAL(16)
! might be a hardware or libquadmath 128bit number.
!
program test_qp
   use iso_fortran_env, only: real_kinds
   implicit none
   integer, parameter :: QP = real_kinds(ubound(real_kinds,dim=1))
   real(qp) :: fp1, fp2, fp3, fp4
   character(len=80) :: str1, str2, str3, str4
   fp1 = 1
   fp2 = sqrt (2.0_qp)
   write (str1,*) fp1
   write (str2,'(g0)') fp1
   write (str3,*) fp2
   write (str4,'(g0)') fp2

!   print '(3a)', '>',trim(str1),'<'
!   print '(3a)', '>',trim(str2),'<'
!   print '(3a)', '>',trim(str3),'<'
!   print '(3a)', '>',trim(str4),'<'

   read (str1, *) fp3
   if (fp1 /= fp3) call abort()
   read (str2, *) fp3
   if (fp1 /= fp3) call abort()
   read (str3, *) fp4
   if (abs (fp2 - fp4)/fp2 > epsilon(fp2)) call abort()
   read (str4, *) fp4
   if (abs (fp2 - fp4)/fp2 > epsilon(fp2)) call abort()

   select case (qp)
     case (8)
       if (str1 /= "   1.0000000000000000") call abort()
       if (str2 /= "1.0000000000000000") call abort()
       if (str3 /= "   1.4142135623730951") call abort()
       if (str4 /= "1.4142135623730951") call abort()

     case (10)
       if (str1 /= "   1.00000000000000000000") call abort()
       if (str2 /= "1.00000000000000000000") call abort()
       if (str3 /= "   1.41421356237309504876") call abort()
       if (str4 /= "1.41421356237309504876") call abort()

     case (16)
       if (digits(1.0_qp) == 113) then
         ! IEEE 754 binary 128 format
         ! e.g. libquadmath/__float128 on i686/x86_64/ia64
         if (str1 /= "   1.00000000000000000000000000000000000") call abort()
         if (str2 /= "1.00000000000000000000000000000000000") call abort()
         if (str3 /= "   1.41421356237309504880168872420969798") call abort()
         if (str4 /= "1.41421356237309504880168872420969798") call abort()
       else if (digits(1.0_qp) == 106) then
         ! IBM binary 128 format
         if (str1 /= "   1.0000000000000000000000000000000") call abort()
         if (str2 /= "1.0000000000000000000000000000000") call abort()
         if (str3(1:37) /= "   1.4142135623730950488016887242097") call abort()
         if (str4(1:34) /= "1.4142135623730950488016887242097") call abort()
       end if

       ! Do a libm run-time test
       block
         real(qp), volatile :: fp2a
         fp2a = 2.0_qp
         fp2a = sqrt (fp2a)
         if (abs (fp2a - fp2) > sqrt(2.0_qp)-nearest(sqrt(2.0_qp),-1.0_qp)) call abort()
       end block

     case default
       call abort()
   end select

end program test_qp


      subroutine factrb ( w, ipivot, d, nrow, ncol, last, iflag )
c  adapted from p.132 of 'element.numer.analysis' by conte-de boor
c
c  constructs a partial plu factorization, corresponding to steps 1,...,
c   l a s t   in gauss elimination, for the matrix  w  of order
c   ( n r o w ,  n c o l ), using pivoting of scaled rows.
c
c  parameters
c    w	     contains the (nrow,ncol) matrix to be partially factored
c	     on input, and the partial factorization on output.
c    ipivot  an integer array of length nrow containing a record of the
c	     pivoting strategy used; row ipivot(i) is used during the
c	     i-th elimination step, i=1,...,last.
c    d	     a work array of length nrow used to store row sizes
c	     temporarily.
c    nrow    number of rows of w.
c    ncol    number of columns of w.
c    last    number of elimination steps to be carried out.
c    iflag   on output, equals iflag on input times (-1)**(number of
c	     row interchanges during the factorization process), in
c	     case no zero pivot was encountered.
c	     otherwise, iflag = 0 on output.
c
      integer nrow
      integer ipivot(nrow),ncol,last,iflag, i,ipivi,ipivk,j,k,kp1
      real w(nrow,ncol),d(nrow), awikdi,colmax,ratio,rowmax
c  initialize ipivot, d
      do 10 i=1,nrow
	 ipivot(i) = i
	 rowmax = 0.
	 do 9 j=1,ncol
    9	    rowmax = amax1(rowmax, abs(w(i,j)))
	 if (rowmax .eq. 0.)		go to 999
   10	 d(i) = rowmax
c gauss elimination with pivoting of scaled rows, loop over k=1,.,last
      k = 1
c	 as pivot row for k-th step, pick among the rows not yet used,
c	 i.e., from rows ipivot(k),...,ipivot(nrow), the one whose k-th
c	 entry (compared to the row size) is largest. then, if this row
c	 does not turn out to be row ipivot(k), redefine ipivot(k) ap-
c	 propriately and record this interchange by changing the sign
c	 of  i f l a g .
   11	 ipivk = ipivot(k)
	 if (k .eq. nrow)		go to 21
	 j = k
	 kp1 = k+1
	 colmax = abs(w(ipivk,k))/d(ipivk)
c	       find the (relatively) largest pivot
	 do 15 i=kp1,nrow
	    ipivi = ipivot(i)
	    awikdi = abs(w(ipivi,k))/d(ipivi)
	    if (awikdi .le. colmax)	go to 15
	       colmax = awikdi
	       j = i
   15	    continue
	 if (j .eq. k)			go to 16
	 ipivk = ipivot(j)
	 ipivot(j) = ipivot(k)
	 ipivot(k) = ipivk
	 iflag = -iflag
   16	 continue
c	 if pivot element is too small in absolute value, declare
c	 matrix to be noninvertible and quit.
	 if (abs(w(ipivk,k))+d(ipivk) .le. d(ipivk))
     *					go to 999
c	 otherwise, subtract the appropriate multiple of the pivot
c	 row from remaining rows, i.e., the rows ipivot(k+1),...,
c	 ipivot(nrow), to make k-th entry zero. save the multiplier in
c	 its place.
	 do 20 i=kp1,nrow
	    ipivi = ipivot(i)
	    w(ipivi,k) = w(ipivi,k)/w(ipivk,k)
	    ratio = -w(ipivi,k)
	    do 20 j=kp1,ncol
   20	       w(ipivi,j) = ratio*w(ipivk,j) + w(ipivi,j)
	 k = kp1
c	 check for having reached the next block.
	 if (k .le. last)		go to 11
					return
c     if  last	.eq. nrow , check now that pivot element in last row
c     is nonzero.
   21 if( abs(w(ipivk,nrow))+d(ipivk) .gt. d(ipivk) )
     *					return
c		    singularity flag set
  999 iflag = 0
					return
      end


      subroutine boundary_planes(ig,i,j,k,nx,ny,nz)
c s kelkar March 24, 06
c given the local indices i,j,k that specify the subgrid cell
c within the coarse grid cell ig, define the equations of the planes
c bounding the control volume.
c********************************************************************
c INPUT VARIABLES
c     ig : node # of the node in the coarse grid
c     nx,ny,nz : # of divisions along the x,y,z,axis for the subgrid
c     i,j,k : indices representing the cell in the subgrid
c
c OUTOUT VARIABLES
c     boundary_cord(1:6) : value of the coordinate for the plane
c                 bounding the control volume of the node ig in the
c                 following order:
c           1 : -x
c           2 : -y
c           3 : -z
c           4 : +x
c           5 : +y
c           6 : +z
c
c INTERNAL VARIABLES
c********************************************************************

      use comparttr_sg
      use comunits

      implicit none

      integer ig,i,j,k,nx,ny,nz

      if(nx*ny*nz.eq.0) then
       write(error_unit_number,*)'zero subdivisions in boundary_planes '
     1        ,ig
         write(error_unit_number,*)'STOP'
         stop
      else
         boundary_cord(1)= dfloat((i-1))/dfloat(nx)
         boundary_cord(2)= dfloat((j-1))/dfloat(ny)
         boundary_cord(3)= dfloat((k-1))/dfloat(nz)
         boundary_cord(4)= dfloat((i))/dfloat(nx)
         boundary_cord(5)= dfloat((j))/dfloat(ny)
         boundary_cord(6)= dfloat((k))/dfloat(nz)
      endif

      return

      end

c........................................................................


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

      subroutine  initialize

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

c---------------------------------------------------------------------
c     This subroutine initializes the field variable u using
c     tri-linear transfinite interpolation of the boundary values
c---------------------------------------------------------------------

      include 'header.h'

      integer i, j, k, m, ix, iy, iz
      double precision  xi, eta, zeta, Pface(5,3,2), Pxi, Peta,
     >     Pzeta, temp(5)

c---------------------------------------------------------------------
c  Later (in compute_rhs) we compute 1/u for every element. A few of
c  the corner elements are not used, but it convenient (and faster)
c  to compute the whole thing with a simple loop. Make sure those
c  values are nonzero by initializing the whole thing here.
c---------------------------------------------------------------------
!$omp parallel default(shared) private(i,j,k,m)
!$omp do
      do k = 0, grid_points(3)-1
         do j = 0, grid_points(2)-1
            do i = 0, grid_points(1)-1
      	       do m = 1, 5
                  u(m,i,j,k) = 1.0
                  rhs(m,i,j,k) = 0.0
               end do
            end do
         end do
      end do
!$omp end do nowait
!$omp do
      do k = 0, grid_points(3)-1
         do j = 0, grid_points(2)-1
            do i = 0, grid_points(1)-1
               us(i,j,k) = 0.0
               vs(i,j,k) = 0.0
               ws(i,j,k) = 0.0
               qs(i,j,k) = 0.0
               rho_i(i,j,k) = 0.0
               square(i,j,k) = 0.0
            end do
         end do
      end do
!$omp end do nowait
!$omp end parallel
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     first store the "interpolated" values everywhere on the grid
c---------------------------------------------------------------------

!$omp parallel default(shared)
!$omp& private(i,j,k,m,zeta,eta,xi,ix,iy,iz,Pface,Pxi,Peta,Pzeta,temp)
!$omp do
      do k = 0, grid_points(3)-1
         zeta = dble(k) * dnzm1
         do j = 0, grid_points(2)-1
            eta = dble(j) * dnym1
            do i = 0, grid_points(1)-1
               xi = dble(i) * dnxm1

               do ix = 1, 2
                  call exact_solution(dble(ix-1), eta, zeta,
     >                    Pface(1,1,ix))
               enddo

               do iy = 1, 2
                  call exact_solution(xi, dble(iy-1) , zeta,
     >                    Pface(1,2,iy))
               enddo

               do iz = 1, 2
                  call exact_solution(xi, eta, dble(iz-1),
     >                    Pface(1,3,iz))
               enddo

               do m = 1, 5
                  Pxi   = xi   * Pface(m,1,2) +
     >                    (1.0d0-xi)   * Pface(m,1,1)
                  Peta  = eta  * Pface(m,2,2) +
     >                    (1.0d0-eta)  * Pface(m,2,1)
                  Pzeta = zeta * Pface(m,3,2) +
     >                    (1.0d0-zeta) * Pface(m,3,1)

                  u(m,i,j,k) = Pxi + Peta + Pzeta -
     >                    Pxi*Peta - Pxi*Pzeta - Peta*Pzeta +
     >                    Pxi*Peta*Pzeta

               enddo
            enddo
         enddo
      enddo
!$omp end do nowait

c---------------------------------------------------------------------
c     now store the exact values on the boundaries
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     west face
c---------------------------------------------------------------------
      i = 0
      xi = 0.0d0
!$omp do
      do k = 0, grid_points(3)-1
         zeta = dble(k) * dnzm1
         do j = 0, grid_points(2)-1
            eta = dble(j) * dnym1
            call exact_solution(xi, eta, zeta, temp)
            do m = 1, 5
               u(m,i,j,k) = temp(m)
            enddo
         enddo
      enddo
!$omp end do nowait

c---------------------------------------------------------------------
c     east face
c---------------------------------------------------------------------

      i = grid_points(1)-1
      xi = 1.0d0
!$omp do
      do k = 0, grid_points(3)-1
         zeta = dble(k) * dnzm1
         do j = 0, grid_points(2)-1
            eta = dble(j) * dnym1
            call exact_solution(xi, eta, zeta, temp)
            do m = 1, 5
               u(m,i,j,k) = temp(m)
            enddo
         enddo
      enddo
!$omp end do nowait

c---------------------------------------------------------------------
c     south face
c---------------------------------------------------------------------
      j = 0
      eta = 0.0d0
!$omp do
      do k = 0, grid_points(3)-1
         zeta = dble(k) * dnzm1
         do i = 0, grid_points(1)-1
            xi = dble(i) * dnxm1
            call exact_solution(xi, eta, zeta, temp)
            do m = 1, 5
               u(m,i,j,k) = temp(m)
            enddo
         enddo
      enddo
!$omp end do nowait

c---------------------------------------------------------------------
c     north face
c---------------------------------------------------------------------
      j = grid_points(2)-1
      eta = 1.0d0
!$omp do
      do k = 0, grid_points(3)-1
         zeta = dble(k) * dnzm1
         do i = 0, grid_points(1)-1
            xi = dble(i) * dnxm1
            call exact_solution(xi, eta, zeta, temp)
            do m = 1, 5
               u(m,i,j,k) = temp(m)
            enddo
         enddo
      enddo
!$omp end do

c---------------------------------------------------------------------
c     bottom face
c---------------------------------------------------------------------
      k = 0
      zeta = 0.0d0
!$omp do
      do j = 0, grid_points(2)-1
         eta = dble(j) * dnym1
         do i =0, grid_points(1)-1
            xi = dble(i) *dnxm1
            call exact_solution(xi, eta, zeta, temp)
            do m = 1, 5
               u(m,i,j,k) = temp(m)
            enddo
         enddo
      enddo
!$omp end do nowait

c---------------------------------------------------------------------
c     top face
c---------------------------------------------------------------------
      k = grid_points(3)-1
      zeta = 1.0d0
!$omp do
      do j = 0, grid_points(2)-1
         eta = dble(j) * dnym1
         do i =0, grid_points(1)-1
            xi = dble(i) * dnxm1
            call exact_solution(xi, eta, zeta, temp)
            do m = 1, 5
               u(m,i,j,k) = temp(m)
            enddo
         enddo
      enddo
!$omp end do nowait
!$omp end parallel

      return
      end

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

      subroutine lhsinit(lhs, ni)

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

      integer i, m, n, ni
      double precision lhs(5,5,3,0:ni)

c---------------------------------------------------------------------
c     zero the whole left hand side for starters
c     set all diagonal values to 1. This is overkill, but convenient
c---------------------------------------------------------------------
      i = 0
      do m = 1, 5
         do n = 1, 5
            lhs(m,n,1,i) = 0.0d0
            lhs(m,n,2,i) = 0.0d0
            lhs(m,n,3,i) = 0.0d0
         end do
         lhs(m,m,2,i) = 1.0d0
      end do
      i = ni
      do m = 1, 5
         do n = 1, 5
            lhs(m,n,1,i) = 0.0d0
            lhs(m,n,2,i) = 0.0d0
            lhs(m,n,3,i) = 0.0d0
         end do
         lhs(m,m,2,i) = 1.0d0
      end do

      return
      end


! =============================================================================
!                       Test ellipse split
!
!         This unit test checks the splitting of an ellipse. The ellipse
!         is centred at the origin with an orientation of 45 degrees.
! =============================================================================
program test_ellipse_split
    use unit_test
    use constants, only : pi, zero, one, three, four, five, ten, f12, f14
    use parcel_container
    use parcel_split, only : split_ellipses, split_timer
    use parameters, only : update_parameters, nx, nz, extent, lower, vmax
    use timer
    implicit none

    double precision, parameter :: lam = five
    double precision, parameter :: angle = f14 * pi
    double precision, parameter :: evec(2) = (/dcos(angle), dsin(angle)/)
    double precision :: h, ab, B11, B12, B22, pos(2, 2), error, a2, b2

    nx = 10
    nz = 10
    extent = (/ten, ten/)
    lower = (/-five, -five/)
    call update_parameters

    vmax = one

    call register_timer('parcel split', split_timer)

    n_parcels = 1
    call parcel_alloc(2)

    ab = one

    a2 = ab * lam
    b2 = ab / lam

    parcels%position(:, 1) = zero
    parcels%volume(1) = ab * pi
    parcels%buoyancy(1) = one
#ifndef ENABLE_DRY_MODE
    parcels%humidity(1) = one
#endif
    B11 = a2 * dcos(angle) ** 2 + b2 * dsin(angle) ** 2
    B12 = f12 * (a2 - b2) * dsin(2.0 * angle)
    B22 = a2 * dsin(angle) ** 2 + b2 * dcos(angle) ** 2

    parcels%B(1, 1) = B11
    parcels%B(2, 1) = B12

    ! analytic split
    h = f14 * dsqrt(three * a2)
    B11 = B11 - 0.75d0 * a2 * evec(1) ** 2
    B12 = B12 - 0.75d0 * a2 * evec(1) * evec(2)
    pos(:, 1) = parcels%position(:, 1) + h * evec
    pos(:, 2) = parcels%position(:, 1) - h * evec

    ! numerical split
    call split_ellipses(parcels, threshold=four)

    !
    ! check result
    !

    error = zero

    ! first parcel
    error = max(error, abs(parcels%B(1, 1) - B11))
    error = max(error, abs(parcels%B(2, 1) - B12))
    error = max(error, sum(abs(pos(:, 1) - parcels%position(:, 1))))
    error = max(error, abs(f12 * ab * pi - parcels%volume(1)))
    error = max(error, abs(parcels%buoyancy(1) - one))
#ifndef ENABLE_DRY_MODE
    error = max(error, abs(parcels%humidity(1) - one))
#endif

    ! second parcel
    error = max(error, abs(parcels%B(1, 2) - B11))
    error = max(error, abs(parcels%B(2, 2) - B12))
    error = max(error, sum(abs(pos(:, 2) - parcels%position(:, 2))))
    error = max(error, abs(f12 * ab * pi - parcels%volume(2)))
    error = max(error, dble(abs(n_parcels - 2)))
    error = max(error, abs(parcels%buoyancy(2) - one))
#ifndef ENABLE_DRY_MODE
    error = max(error, abs(parcels%humidity(2) - one))
#endif
    call print_result_dp('Test ellipse split', error)

    call parcel_dealloc

end program test_ellipse_split


!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2011 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                     FFTPACK  version 5.1                      *
!     *                                                               *
!     *                 A Fortran Package of Fast Fourier             *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *               Paul Swarztrauber and Dick Valent               *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
program tcosq1

    use, intrinsic :: ISO_Fortran_env, only: &
        wp => REAL64, &
        ip => INT32, &
        stdout => OUTPUT_UNIT, &
        stderr => ERROR_UNIT

    use type_FFTpack, only: FFTpack

    ! Explicit typing only
    implicit none

    !------------------------------------------------------
    ! Dictionary
    !------------------------------------------------------
    type (FFTpack)          :: fft
    integer (ip)            :: error_flag
    integer (ip), parameter :: n=10**3
    real (wp)               :: real_data(n), data_copy(n)
    !------------------------------------------------------

    !
    !==> Allocate memory
    !
    fft = FFTpack(n)

    associate( &
        wsave => fft%saved_workspace, &
        work => fft%workspace &
        )
        !
        !==> Identify test and initialize FFT
        !
        write( stdout, '(A)') 'program tcosq1 and related messages:'
        call fft%cosq1i(n,wsave,size(wsave),error_flag)

        ! Check error flag
        if (error_flag /= 0) then
            write( stdout, '(A,I3,A)') 'error ',error_flag,' in routine cosq1i'
            stop
        end if

        !
        !==> Generate test vector for forward-backward test
        !
        call random_seed()
        call random_number(real_data)
        data_copy = real_data

        !
        !==> Perform forward transform
        !
        call fft%cosq1f(n,1,real_data,n, wsave,size(wsave),work, size(work),error_flag)

        ! Check error flag
        if (error_flag /= 0) then
            write( stdout, '(A,I3,A)') 'error ',error_flag,' in routine cosq1f !'
            stop
        end if

        !==> Perform backward transform

        call fft%cosq1b(n,1,real_data,n, wsave,size(wsave),work, size(work),error_flag)

        ! Check error flag
        if (error_flag /= 0) then
            write( stdout, '(A,I3,A)') 'error ',error_flag,' in routine cosq1b !'
            stop
        end if

        !
        !==> Print test results
        !
        associate( max_err => maxval(abs(real_data-data_copy)) )

            write( stdout, '(A,E23.15E3)' ) 'cosq1 forward-backward max error =', max_err

        end associate

        !
        !==> Generate test vector for backward-forward test
        !
        call random_seed()
        call random_number(real_data)
        data_copy = real_data

        !
        !==> Perform backward transform
        !
        call fft%cosq1b(n,1,real_data,n, wsave,size(wsave),work, size(work),error_flag)

        ! Check error flag
        if (error_flag /= 0) then
            write( stdout, '(A,I3,A)') 'error ',error_flag,' in routine cosq1b !'
            stop
        end if

        !
        !==> Perform forward transform
        !
        call fft%cosq1f(n,1,real_data,n, wsave,size(wsave),work, size(work),error_flag)

        ! Check error flag
        if (error_flag /= 0) then
            write( stdout, '(A,I3,A)') 'error ',error_flag,' in routine cosq1f !'
            stop
        end if

        !
        !==> Print test results
        !
        associate( max_err => maxval(abs(real_data-data_copy)) )

            write( stdout, '(A,E23.15E3)' ) 'cosq1 backward-forward max error =', max_err
            write( stdout, '(A,/)') 'end program tcosq1 and related messages'

        end associate

    end associate
    !
    !==> Release memory
    !
    call fft%destroy()

end program tcosq1


subroutine compute_Mder_legacy(s,n,der,I,J,F)
  real*8, intent(in) :: s
  integer*8, intent(in) :: n
  integer*8, intent(in) :: der
  integer*8, intent(out), dimension(3*n):: I
  integer*8, intent(out), dimension(3*n):: J
  real*8, intent(out), dimension(3*n):: F
  integer*8 :: p
  real*8 :: factor
  if (der==0) then
     factor=1;
  else
     factor=0;
  end if
  do p = 1, n
     I(p) = p
     J(p) = p
     F(p) = 2.0*factor;
  end do
  do p = 1, n-1
     I(n+p) = p
     J(n+p) = p+1
     F(n+p) = -1.0*factor;
     I(2*n+p) = p+1
     J(2*n+p) = p
     F(2*n+p) = -1.0*factor;
  end do
  I(2*n)=n;
  J(2*n)=1;
  if (der == 0) then
     F(2*n)=s*s*s;
  else if (der == 1) then
     F(2*n)=3*s*s;
  else if (der == 2) then
     F(2*n)=3*2*s;
  else if (der == 3) then
     F(2*n)=3*2;
  else
     F(2*n)=0;
  end if
  I(3*n)=1;
  J(3*n)=n;
  F(3*n)=-exp(s);
end subroutine compute_Mder_legacy


      program DRDNML
c>> 2001-05-25 DRDCDNML Krogh Added comma to format.
c>> 1996-05-28 DRDCDNML Krogh  Changes to use M77CON
c>> 1994-07-06 DRDCDNML WV Snyder JPL set up for CHGTYP
c>> 1994-04-12 DRDCDNML WV Snyder JPL repair format to display sign
c
c     Evaluate the Cumulative Normal Distribution using DCDNML.
c
c--D replaces "?": DR?NML, DR?CDNML, ?CDNML, ?PPNML
      double precision DCDNML, DPPNML
      external DCDNML, DPPNML
      double precision X, C, P, MU, SIGMA
c
10    format ('        X       C=DCDNML(X)     DPPNML(C)')
20    format (1x,1p,2g14.7,2x,g14.7)
      x = -4.0d0
      mu = 0.0d0
      sigma = 1.0d0
      print 10
30    if (x .le. 4.0d0) then
         c = dcdnml(x,mu,sigma)
         p = dppnml(c,mu,sigma)
         print 20, x, c, p
         x = x + 0.5d0
         go to 30
      end if
      stop
      end


module time_interp_mod

! <CONTACT EMAIL="Bruce.Wyman@noaa.gov">
!   Bruce Wyman
! </CONTACT>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!   Computes a weight and dates/indices for linearly interpolating between two dates.
! </OVERVIEW>

! <DESCRIPTION>
!     A time type is converted into two consecutive dates plus
!     a fraction representing the distance between the dates.
!     This information can be used to interpolate between the dates.
!     The dates may be expressed as years, months, or days or
!     as indices in an array.
! </DESCRIPTION>

! <PUBLIC>
!   Description summarizing public interface.
! </PUBLIC>

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

use time_manager_mod, only: time_type, get_date, set_date, set_time, &
                            days_in_year, days_in_month, leap_year,  &
                            time_type_to_real, real_to_time_type,    &
                            operator(+), operator(-), operator(>),   &
                            operator(<), operator( // ), operator( / ),  &
                            operator(>=), operator(<=), operator( * ), &
                            operator(==), print_date

use          fms_mod, only: write_version_number, &
                            error_mesg, FATAL, stdout

implicit none
private

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

public :: time_interp_init, time_interp, fraction_of_year

! <INTERFACE NAME="time_interp">

!   <OVERVIEW>
!      Returns a weight and dates or indices for interpolating between two dates. The
!      interface fraction_of_year is provided for backward compatibility with the
!      previous version.
!   </OVERVIEW>
!   <DESCRIPTION>
!      Returns weight by interpolating Time between Time1 and Time2.
!      i.e. weight = (Time-Time1)/(Time2-Time1)
!      Time1 and Time2 may be specified by any of several different ways,
!      which is the reason for multiple interfaces.

!      If Time1 and Time2 are the begining and end of the year in which
!      Time falls, use first interface.

!      If Time1 and Time2 fall on year boundaries, use second interface.

!      If Time1 and Time2 fall on month boundaries, use third.

!      If Time1 and Time2 fall on day boundaries, use fourth.

!      If Time1 and Time2 are consecutive elements of an assending list, use fifth.
!      The fifth also returns the indices of Timelist between which Time falls.

!      The sixth interface is for cyclical data. Time_beg and Time_end specify the
!      begining and end of a repeating period. In this case:
!      weight = (Time_adjusted - Time1) / (Time2 - Time1)
!      Where:
!      Time1 = Timelist(index1)
!      Time2 = Timelist(index2)
!      Time_adjusted = Time - N*Period
!      Period = Time_end-Time_beg
!      N is between (Time-Time_end)/Period and (Time-Time_beg)/Period
!      That is, N is the integer that results in Time_adjusted that is between Time_beg and Time_end.
!
!   </DESCRIPTION>
!   <TEMPLATE>
!     1. call time_interp( Time, weight )
!   </TEMPLATE>
!   <TEMPLATE>
!     2. call time_interp( Time, weight, year1, year2 )
!   </TEMPLATE>
!   <TEMPLATE>
!     3. call time_interp( Time, weight, year1, year2, month1, month2 )
!   </TEMPLATE>
!   <TEMPLATE>
!     4. call time_interp( Time, weight, year1, year2, month1, month2, day1, day2 )
!   </TEMPLATE>
!   <TEMPLATE>
!     5. call time_interp( Time, Timelist, weight, index1, index2 [, modtime] )
!   </TEMPLATE>
!   <TEMPLATE>
!     6. call time_interp( Time, Time_beg, Time_end, Timelist, weight, index1, index2 [,correct_leap_year_inconsistency])
!   </TEMPLATE>
!   <IN NAME="Time">
!      The time at which the the weight is computed.
!   </IN>
!   <IN NAME="Time_beg">
!      For cyclical interpolation: Time_beg specifies the begining time of a cycle.
!   </IN>
!   <IN NAME="Time_end">
!      For cyclical interpolation: Time_end specifies the ending time of a cycle.
!   </IN>
!   <IN NAME="Timelist">
!      For cyclical interpolation: Timelist is an array of times between Time_beg and Time_end.
!                                  Must be monotonically increasing.
!   </IN>
!   <IN NAME="modtime">
!   </IN>
!   <IN NAME="index1">
!      Timelist(index1) = The largest value of Timelist which is less than mod(Time,Time_end-Time_beg)
!   </IN>
!   <IN NAME="index2">
!      Timelist(index2) = The smallest value of Timelist which is greater than mod(Time,Time_end-Time_beg)
!   </IN>
!   <IN NAME="correct_leap_year_inconsistency">
!       Turns on a kluge for an inconsistency which may occur in a special case.
!       When the modulo time period (i.e. Time_end - Time_beg) is a whole number of years
!       and is not a multiple of 4, and the calendar in use has leap years, then it is
!       likely that the interpolation will involve mapping a common year onto a leap year.
!       In this case it is often desirable, but not absolutely necessary, to use data for
!       Feb 28 of the leap year when it is mapped onto a common year.
!       To turn this on, set correct_leap_year_inconsistency=.true.
!   </IN>
!   <OUT NAME="weight">
!     weight = (mod(Time,Time_end-Time_beg) - Timelist(index1)) / (Timelist(index2) - Timelist(index1))
!   </OUT>
!   <OUT NAME="year1"> </OUT>
!   <OUT NAME="year2"> </OUT>
!   <OUT NAME="month1"> </OUT>
!   <OUT NAME="month2"> </OUT>
!   <OUT NAME="day1"> </OUT>
!   <OUT NAME="day2"> </OUT>
!   <OUT NAME="index1"> </OUT>
!   <OUT NAME="index2"> </OUT>
!   <ERROR MSG="input time list not ascending order" STATUS="ERROR">
!     The list of input time types must have ascending dates.
!   </ERROR>
!   <ERROR MSG="modulo months must have same length" STATUS="ERROR">
!     The length of the current month for input Time and Time_list
!     must be the same when using the modulo month option. The
!     modulo month option is available but not supported.
!   </ERROR>
!   <ERROR MSG="invalid value for argument modtime" STATUS="ERROR">
!     The optional argument modtime must have a value set by one
!     of the public parameters: NONE, YEAR, MONTH, DAY. The
!     MONTH and DAY options are available but not supported.
!   </ERROR>
!   <ERROR MSG="period of list exceeds modulo period" STATUS="ERROR">
!     The difference between the last and first values in the input
!     Time list/array exceeds the length of the modulo period.
!   </ERROR>
!   <ERROR MSG="time before range of list or time after range of list" STATUS="ERROR">
!     The difference between the last and first values in the input
!     These errors occur when you are not using a modulo axis and
!     the input Time occurs before the first value in the Time
!     list/array or after the last value in the Time list/array.
!   </ERROR>
!   <NOTE>
!     Examples:
!     <PRE>
!       Time: Jan 01 00z    weight = 0.0
!       Time: Jul 01        weight ~ 0.5
!       Time: Dec 31 23z    weight ~ 1.0
!     </PRE>
!   </NOTE>

interface time_interp
    module procedure time_interp_frac,  time_interp_year, &
                     time_interp_month, time_interp_day,  &
                     time_interp_list,  time_interp_modulo
end interface
! </INTERFACE>

integer, public, parameter :: NONE=0, YEAR=1, MONTH=2, DAY=3

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

   integer, parameter ::  secmin = 60, minhour = 60, hourday = 24,  &
                         sechour = secmin*minhour,                  &
                          secday = secmin*minhour*hourday

   integer, parameter :: monyear = 12
   integer, parameter :: halfday = secday/2

   integer :: mtime
   integer :: yrmod, momod, dymod
   logical :: mod_leapyear

   character(len=128) :: version='$Id: time_interp.f90,v 13.0 2006/03/28 21:43:09 fms Exp $'
   character(len=128) :: tagname='$Name: latest $'

   logical :: module_is_initialized=.FALSE.

contains

 subroutine time_interp_init()

   if ( module_is_initialized ) return

   call write_version_number( version, tagname )

   module_is_initialized = .TRUE.

 end subroutine time_interp_init

!#######################################################################

! <SUBROUTINE NAME="time_interp_frac" INTERFACE="time_interp">
!   <IN NAME="Time" TYPE="time_type" > </IN>
!   <OUT NAME="weight" TYPE="real"> </OUT>
! </SUBROUTINE>
!  returns the fractional time into the current year

 subroutine time_interp_frac ( Time, weight )

   type(time_type), intent(in)  :: Time
   real           , intent(out) :: weight

   integer         :: year, month, day, hour, minute, second
   type(time_type) :: Year_beg, Year_end

   if ( .not. module_is_initialized ) call time_interp_init

!  ---- compute fractional time of year -----

     call get_date (Time, year, month, day, hour, minute, second)

     Year_beg = set_date(year  , 1, 1)
     Year_end = set_date(year+1, 1, 1)

     weight = (Time - Year_beg) // (Year_end - Year_beg)

 end subroutine time_interp_frac

!#######################################################################
! <SUBROUTINE NAME="fraction_of_year">
! <OVERVIEW>
!  Wrapper for backward compatibility
! </OVERVIEW>
! </SUBROUTINE>

 function fraction_of_year (Time)
 type(time_type), intent(in)  :: Time
 real :: fraction_of_year

  call time_interp_frac ( Time, fraction_of_year )

 end function fraction_of_year

!#######################################################################
! <SUBROUTINE NAME="time_interp_year" INTERFACE="time_interp">
!   <IN NAME="Time" TYPE="time_type" > </IN>
!   <OUT NAME="weight" TYPE="real"> </OUT>
!   <OUT NAME="year1" TYPE="integer"> </OUT>
!   <OUT NAME="year2" TYPE="integer"> </OUT>
! </SUBROUTINE>
!  returns fractional time between mid points of consecutive years

 subroutine time_interp_year ( Time, weight, year1, year2 )

   type(time_type), intent(in)  :: Time
   real           , intent(out) :: weight
   integer        , intent(out) :: year1, year2

   integer :: year, month, day, hour, minute, second
   type (time_type) :: Mid_year, Mid_year1, Mid_year2

   if ( .not. module_is_initialized ) call time_interp_init()

      call get_date (Time, year, month, day, hour, minute, second)

    ! mid point of current year
      Mid_year = year_midpt(year)

      if ( Time >= Mid_year ) then
    ! current time is after mid point of current year
           year1  = year
           year2  = year+1
           Mid_year2 = year_midpt(year2)
           weight = (Time - Mid_year) // (Mid_year2 - Mid_year)
      else
    ! current time is before mid point of current year
           year2  = year
           year1  = year-1
           Mid_year1 = year_midpt(year1)
           weight = (Time - Mid_year1) // (Mid_year - Mid_year1)
      endif

 end subroutine time_interp_year

!#######################################################################
! <SUBROUTINE NAME="time_interp_month" INTERFACE="time_interp">
!   <IN NAME="Time" TYPE="time_type" > </IN>
!   <OUT NAME="weight" TYPE="real"> </OUT>
!   <OUT NAME="year1" TYPE="integer"> </OUT>
!   <OUT NAME="year2" TYPE="integer"> </OUT>
!   <OUT NAME="month1" TYPE="integer"> </OUT>
!   <OUT NAME="month2" TYPE="integer"> </OUT>
! </SUBROUTINE>
!  returns fractional time between mid points of consecutive months

 subroutine time_interp_month ( Time, weight, year1, year2, month1, month2 )

   type(time_type), intent(in)  :: Time
   real           , intent(out) :: weight
   integer        , intent(out) :: year1, year2, month1, month2

   integer :: year, month, day, hour, minute, second,  &
              mid_month, cur_month, mid1, mid2

   if ( .not. module_is_initialized ) call time_interp_init()

      call get_date (Time, year, month, day, hour, minute, second)

    ! mid point of current month in seconds
      mid_month = days_in_month(Time) * halfday
    ! time into current month in seconds
      cur_month = second + secmin*minute + sechour*hour + secday*(day-1)

      if ( cur_month >= mid_month ) then
    ! current time is after mid point of current month
           year1  = year;  month1 = month
           year2  = year;  month2 = month+1
           if (month2 > monyear)  year2 = year2+1
           if (month2 > monyear) month2 = 1
           mid1 = mid_month
           mid2 = days_in_month(set_date(year2,month2,2)) * halfday
           weight = real(cur_month - mid1) / real(mid1+mid2)
      else
    ! current time is before mid point of current month
           year2  = year;  month2 = month
           year1  = year;  month1 = month-1
           if (month1 < 1)  year1 = year1-1
           if (month1 < 1) month1 = monyear
           mid1 = days_in_month(set_date(year1,month1,2)) * halfday
           mid2 = mid_month
           weight = real(cur_month + mid1) / real(mid1+mid2)
      endif

 end subroutine time_interp_month

!#######################################################################
! <SUBROUTINE NAME="time_interp_day" INTERFACE="time_interp">
!   <IN NAME="Time" TYPE="time_type" > </IN>
!   <OUT NAME="weight" TYPE="real"> </OUT>
!   <OUT NAME="year1" TYPE="integer"> </OUT>
!   <OUT NAME="year2" TYPE="integer"> </OUT>
!   <OUT NAME="month1" TYPE="integer"> </OUT>
!   <OUT NAME="month2" TYPE="integer"> </OUT>
!   <OUT NAME="day1" TYPE="integer"> </OUT>
!   <OUT NAME="day2" TYPE="integer"> </OUT>
! </SUBROUTINE>
!  returns fractional time between mid points of consecutive days

 subroutine time_interp_day ( Time, weight, year1, year2, month1, month2, day1, day2 )

   type(time_type), intent(in)  :: Time
   real           , intent(out) :: weight
   integer        , intent(out) :: year1, year2, month1, month2, day1, day2

   integer :: year, month, day, hour, minute, second, sday

   if ( .not. module_is_initialized ) call time_interp_init()

      call get_date (Time, year, month, day, hour, minute, second)

    ! time into current day in seconds
      sday = second + secmin*minute + sechour*hour

      if ( sday >= halfday ) then
    ! current time is after mid point of day
           year1 = year;  month1 = month;  day1 = day
           year2 = year;  month2 = month;  day2 = day + 1
           weight  = real(sday - halfday) / real(secday)

           if (day2 > days_in_month(Time)) then
               month2 = month2 + 1
               day2 = 1
               if (month2 > monyear) then
                    month2 = 1;  year2 = year2+1
               endif
           endif
      else
    ! current time is before mid point of day
           year2 = year;  month2 = month;  day2 = day
           year1 = year;  month1 = month;  day1 = day - 1
           weight  = real(sday + halfday) / real(secday)

           if (day1 < 1) then
               month1 = month1 - 1
               if (month1 < 1) then
                   month1 = monyear;  year1 = year1-1
               endif
               day1 = days_in_month(set_date(year1,month1,2))
           endif
      endif

 end subroutine time_interp_day

!#######################################################################
! <SUBROUTINE NAME="time_interp_modulo" INTERFACE="time_interp">
!   <IN NAME="Time" TYPE="time_type" > </IN>
!   <IN NAME="Time_beg" TYPE="time_type"> </IN>
!   <IN NAME="Time_end" TYPE="time_type"> </IN>
!   <IN NAME="Timelist" TYPE="time_type" DIM="(:)"> </IN>
!   <IN NAME="correct_leap_year_inconsistency" TYPE="logical, optional" DEFAULT=".false.">
!       Turns on a kluge for an inconsistency which may occur in a special case.
!       When the modulo time period (i.e. Time_end - Time_beg) is a whole number of years
!       and is not a multiple of 4, and the calendar in use has leap years, then it is
!       likely that the interpolation will involve mapping a common year onto a leap year.
!       In this case it is often desirable, but not absolutely necessary, to use data for
!       Feb 28 of the leap year when it is mapped onto a common year.
!       To turn this on, set correct_leap_year_inconsistency=.true. </IN>
!   <OUT NAME="weight" TYPE="real"> </OUT>
!   <OUT NAME="index1" TYPE="real"> </OUT>
!   <OUT NAME="index2" TYPE="real"> </OUT>
! </SUBROUTINE>

subroutine time_interp_modulo(Time, Time_beg, Time_end, Timelist, weight, index1, index2, &
                              correct_leap_year_inconsistency)
type(time_type), intent(in)  :: Time, Time_beg, Time_end, Timelist(:)
real           , intent(out) :: weight
integer        , intent(out) :: index1, index2
logical, intent(in), optional :: correct_leap_year_inconsistency

  type(time_type) :: Period, T
  integer :: is, ie,i1,i2
  integer :: ys,ms,ds,hs,mins,ss ! components of the starting date
  integer :: ye,me,de,he,mine,se ! components of the ending date
  integer :: yt,mt,dt,ht,mint,st ! components of the current date
  integer :: dt1                 ! temporary value for day
  logical :: correct_lyr

  if ( .not. module_is_initialized ) call time_interp_init

  if (Time_beg>=Time_end) then
     call print_date(Time_beg, 'Time_beg' )
     call print_date(Time_end, 'Time_end' )
     call error_handler("end of the specified time loop interval must be later than its beginning")
  endif

  Period = Time_end-Time_beg ! period of the time axis

  if(present(correct_leap_year_inconsistency)) then
    correct_lyr = correct_leap_year_inconsistency
  else
    correct_lyr = .false.
  endif

  ! bring the requested time inside the specified time period
  T = Time
  call get_date(Time_beg,ys,ms,ds,hs,mins,ss)
  call get_date(Time_end,ye,me,de,he,mine,se)

  if(correct_lyr.and.ms==me.and.ds==de.and.hs==he.and.mins==mine.and.ss==se) then
     ! whole number of years
     call get_date(T,yt,mt,dt,ht,mint,st)
     yt = ys+modulo(yt-ys,ye-ys)
     dt1 = dt
     if(mt==2.and.dt==29.and..not.leap_year(set_date(yt,1,1))) dt1=28
     T = set_date(yt,mt,dt1,ht,mint,st)
     if (T < Time_beg) then
        ! the requested time is within the first year,
        ! but before the starting date. So we shift it to the
        ! last year.
        if(mt==2.and.dt==29.and..not.leap_year(set_date(ye,1,1))) dt=28
        T = set_date(ye,mt,dt,ht,mint,st)
     endif
  else
     do while ( T > Time_end )
        T = T-Period
     enddo
     do while ( T < Time_beg )
        T = T+Period
     enddo
  endif

  ! find indices of the first and last records in the Timelist that are within
  ! the requested time period.
  if (Time_end<Timelist(1).or.Time_beg>Timelist(size(Timelist(:)))) then
     call print_date(Time_beg,                   'Time_beg'    )
     call print_date(Time_end,                   'Time_end'    )
     call print_date(Timelist(1),                'Timelist(1)' )
     call print_date(Timelist(size(Timelist(:))),'Timelist(n)' )
     write(stdout(),*)'where n =',size(Timelist(:))
     call error_handler('the entire time list is outside the specified time loop interval')
  endif

  mtime=NONE ! set a global variable that is used in set_modtime, called from bisect
  call bisect(Timelist,Time_beg,index1=i1,index2=i2)
  if (i1 < 1) then
     is = 1 ! Time_beg before lower boundary
  else if (Time_beg == Timelist(i1)) then
     is = i1 ! Time_beg right on the lower boundary
  else
     is = i2 ! Time_beg inside the interval (or on upper boubdary)
  endif
  call bisect(Timelist,Time_end,index1=i1,index2=i2)
  if (i2 > size(Timelist(:))) then
     ie = size(Timelist(:)) ! Time_end after the upper boundary
  else if (Time_end == Timelist(i2)) then
     ie = i2 ! Time_end right on the upper boundary
  else
     ie = i1 ! Time_end inside the interval (or on lower boundary)
  endif
  if (is>=ie) then
     call print_date(Time_beg,                   'Time_beg'    )
     call print_date(Time_end,                   'Time_end'    )
     call print_date(Timelist(1),                'Timelist(1)' )
     call print_date(Timelist(size(Timelist(:))),'Timelist(n)' )
     write(stdout(),*)'where n =',size(Timelist(:))
     write(stdout(),*)'is =',is,'ie =',ie
     call error_handler('error in calculation of time list bounds within the specified time loop interval')
  endif

  ! handle special cases:
  if( T>Timelist(ie) ) then
     ! time is after the end of the portion of the time list within the
     ! requested period
     index1 = ie;   index2 = is
     weight = (T-Timelist(ie))//(Period-(Timelist(ie)-Timelist(is)))
  else if (T<Timelist(is)) then
     ! time is before the beginning of the portion of the time list within
     ! the requested period
     index1 = ie;   index2 = is
     weight = 1.0-((Timelist(is)-T)//(Period-(Timelist(ie)-Timelist(is))))
  else
     call time_interp_list(T,Timelist,weight,index1,index2,NONE)
  endif

end subroutine time_interp_modulo

!#######################################################################
! given an array of times in ascending order and a specific time returns
! values of index1 and index2 such that the Timelist(index1)<=Time and
! Time<=Timelist(index2), and index2=index1+1
! index1=0, index2=1 or index=n, index2=n+1 are returned to indicate that
! the time is out of range
subroutine bisect(Timelist,Time,index1,index2)
  type(time_type)  , intent(in)  :: Timelist(:)
  type(time_type)  , intent(in)  :: Time
  integer, optional, intent(out) :: index1, index2

  integer :: i,il,iu,n,i1,i2

  n = size(Timelist(:))

  if (Time==Timelist(1)) then
     i1 = 1 ; i2 = 2
  else if (Time==Timelist(n)) then
     i1 = n-1 ; i2 = n
  else
     il = 0; iu=n+1
     do while(iu-il > 1)
        i = (iu+il)/2
        if(set_modtime(Timelist(i))>Time) then
           iu = i
        else
           il = i
        endif
     enddo
     i1 = il ; i2 = il+1
  endif

  if(PRESENT(index1)) index1 = i1
  if(PRESENT(index2)) index2 = i2
end subroutine bisect

!#######################################################################
! <SUBROUTINE NAME="time_interp_list" INTERFACE="time_interp">
!   <IN NAME="Time" TYPE="time_type" > </IN>
!   <IN NAME="Timelist" TYPE="time_type" DIM="(:)"> </IN>
!   <OUT NAME="weight" TYPE="real"> </OUT>
!   <OUT NAME="index1" TYPE="real"> </OUT>
!   <OUT NAME="index2" TYPE="real"> </OUT>
!   <IN NAME="modtime" TYPE="integer" > </IN>
! </SUBROUTINE>

subroutine time_interp_list ( Time, Timelist, weight, index1, index2, modtime )
type(time_type)  , intent(in)  :: Time, Timelist(:)
real             , intent(out) :: weight
integer          , intent(out) :: index1, index2
integer, optional, intent(in)  :: modtime

integer :: n, hr, mn, se
type(time_type) :: T, Ts, Te, Td, Period, Time_mod

  if ( .not. module_is_initialized ) call time_interp_init

  weight = 0.; index1 = 0; index2 = 0
  n = size(Timelist(:))

! setup modular time axis?
  mtime = NONE
  if (present(modtime)) then
     mtime = modtime
     Time_mod = (Timelist(1)+Timelist(n))/2
     call get_date (Time_mod, yrmod, momod, dymod, hr, mn, se)
     mod_leapyear = leap_year(Time_mod)
  endif

! starting and ending times from list
  Ts = set_modtime(Timelist(1))
  Te = set_modtime(Timelist(n))
  Td = Te-Ts
  T  = set_modtime(Time)

! set period for modulo axis
  select case (mtime)
     case (NONE)
       ! do nothing
     case (YEAR)
         Period = set_time(0,days_in_year(Time_mod))
     case (MONTH)
       ! month length must be equal
         if (days_in_month(Time_mod) /= days_in_month(Time)) &
         call error_handler ('modulo months must have same length')
         Period = set_time(0,days_in_month(Time_mod))
     case (DAY)
         Period = set_time(0,1)
     case default
         call error_handler ('invalid value for argument modtime')
  end select

! check length of modulo period
! list period cannot exceed modulo period
  if (mtime /= NONE) then
      if (Td >= Period) call error_handler &
                         ('period of list exceeds modulo period')
  endif

! time falls between start and end list values
  if ( T >= Ts .and. T <= Te ) then
     call bisect(Timelist,T,index1,index2)
     weight = (T-Timelist(index1)) // (Timelist(index2)-Timelist(index1))

! time falls before starting list value
  else if ( T < Ts ) then
     if (mtime == NONE) call error_handler ('time before range of list')
     Td = Te-Ts
     weight = 1. - ((Ts-T) // (Period-Td))
     index1 = n
     index2 = 1

! time falls after ending list value
  else if ( T > Te ) then
     if (mtime == NONE) call error_handler ('time after range of list')
     Td = Te-Ts
     weight = (T-Te) // (Period-Td)
     index1 = n
     index2 = 1
  endif

end subroutine time_interp_list

!#######################################################################
!  private routines
!#######################################################################

 function year_midpt (year)

   integer, intent(in) :: year
   type (time_type)    :: year_midpt, year_beg, year_end

   year_beg = set_date(year  , 1, 1)
   year_end = set_date(year+1, 1, 1)

   year_midpt = (year_beg + year_end) / 2

 end function year_midpt

!#######################################################################

 function month_midpt (year, month)

   integer, intent(in) :: year, month
   type (time_type)    :: month_midpt, month_beg, month_end

!  --- beginning of this month ---
   month_beg = set_date(year, month, 1)

!  --- start of next month ---
   if (month < 12) then
      month_end = set_date(year, month+1, 1)
   else
      month_end = set_date(year+1, 1, 1)
   endif

   month_midpt = (month_beg + month_end) / 2

 end function month_midpt

!#######################################################################

function set_modtime (Tin) result (Tout)
type(time_type), intent(in) :: Tin
type(time_type)             :: Tout
integer :: yr, mo, dy, hr, mn, se

  select case (mtime)
    case (NONE)
       Tout = Tin
    case (YEAR)
       call get_date (Tin, yr, mo, dy, hr, mn, se)
       yr = yrmod
        ! correct leap year dates
          if (.not.mod_leapyear .and. mo == 2 .and. dy > 28) then
             mo = 3; dy = dy-28
          endif
       Tout = set_date (yr, mo, dy, hr, mn, se)
    case (MONTH)
       call get_date (Tin, yr, mo, dy, hr, mn, se)
       yr = yrmod; mo = momod
       Tout = set_date (yr, mo, dy, hr, mn, se)
    case (DAY)
       call get_date (Tin, yr, mo, dy, hr, mn, se)
       yr = yrmod; mo = momod; dy = dymod
       Tout = set_date (yr, mo, dy, hr, mn, se)
  end select

end function set_modtime

!#######################################################################

subroutine error_handler (string)
character(len=*), intent(in) :: string

  call error_mesg ('time_interp_mod', trim(string), FATAL)

! write (*,'(a)') 'ERROR in time_interp: ' // trim(string)
! stop 111

end subroutine error_handler

!#######################################################################

end module time_interp_mod

! <INFO>

!   <ERROR MSG="input time list not ascending order" STATUS="">
!     The list of input time types must have ascending dates.
!   </ERROR> *
!   <ERROR MSG="modulo months must have same length" STATUS="">
!     The length of the current month for input Time and Time_list
!     must be the same when using the modulo month option.
!     The modulo month option is available but not supported.
!   </ERROR> *
!   <ERROR MSG="invalid value for argument modtime" STATUS="">
!     The optional argument modtime must have a value set by one
!     of the public parameters: NONE, YEAR, MONTH, DAY.
!     The MONTH and DAY options are available but not supported.
!   </ERROR> *
!   <ERROR MSG="period of list exceeds modulo period" STATUS="">
!     The difference between the last and first values in the
!     input Time list/array exceeds the length of the modulo period.
!   </ERROR> *
!   <ERROR MSG="time before range of list or time after range of list" STATUS="">
!     These errors occur when you are not using a modulo axis and the
!     input Time occurs before the first value in the Time list/array
!     or after the last value in the Time list/array.
!   </ERROR> *
!   <NOTE>
!   For all routines in this module the calendar type in module
!   time_manager must be set.
!   </NOTE>
!   <NOTE>
!     The following private parameters are set by this module:
! <PRE>
!           seconds per minute = 60
!           minutes per hour   = 60
!           hours   per day    = 24
!           months  per year   = 12
! </PRE>
!   </NOTE>

! </INFO>


!
! gsstep shift
!

module gsstep_mm
  implicit none
  public gsstep_fwd_mm_dense, gsstep_fwd_mm_csr, gsstep_fwd_mm_csc
  public gsstep_bwd_mm_dense, gsstep_bwd_mm_csr, gsstep_bwd_mm_csc
  private gsstep_fwd_mm_csr_notrans, gsstep_fwd_mm_csr_trans
  private gsstep_bwd_mm_csr_notrans, gsstep_bwd_mm_csr_trans

contains

! Gauss-Seidel step for solving the following linear equation
!
!         alpha * trans(A + f * g) * x = b
!
!         The step computes
!
!         x := (D + L)^(-1) (b/alpha - U) * x
!
!         A: square matrix
!         x: vector (in; initial vector for the step, out; updated vector)
!         b: constant vector
!         f: constant (column) vector
!         g: constant (row) vector

  subroutine gsstep_fwd_mm_dense(trans, n, alpha, A, lda, f, incf, g, incg, omega, b, incb, x, incx)
    character, intent(in) :: trans
    integer, intent(in) :: n, lda, incb, incx, incf, incg
    double precision, intent(in) :: alpha, omega, A(1:lda,1:n), b(1:incb,1:n)
    double precision, intent(inout) :: x(1:incx,1:n)
    double precision, intent(in) :: f(1:incf,1:n), g(1:incg,1:n)

    integer :: i, j
    double precision :: tmpx, tmpd

    select case (trans)
      case ('N', 'n')
        do i = 1, n
          tmpd = 0.0d0
          tmpx = b(1,i) / alpha
          do j = 1, n
            if (i == j) then
              tmpd = A(i,j) + f(1,i) * g(1,j)
            else
              tmpx = tmpx - (A(i,j) + f(1,i) * g(1,j)) * x(1,j)
            end if
          end do
          x(1,i) = omega * tmpx / tmpd + (1.0d0 - omega) * x(1,i)
        end do
      case ('T', 't')
        do j = 1, n
          tmpd = 0.0d0
          tmpx = b(1,j) / alpha
          do i = 1, n
            if (i == j) then
              tmpd = A(i,j) + f(1,i) * g(1,j)
            else
              tmpx = tmpx - (A(i,j) + f(1,i) * g(1,j)) * x(1,i)
            end if
          end do
          x(1,j) = omega * tmpx / tmpd + (1.0d0 - omega) * x(1,j)
        end do
    end select
  end subroutine gsstep_fwd_mm_dense

  !!!!

  subroutine gsstep_fwd_mm_csr(trans, n, alpha, spA, rowptr, colind, nnz, &
    f, incf, g, incg, omega, b, incb, x, incx)
    character, intent(in) :: trans
    integer, intent(in) :: n, nnz, incb, incx, incf, incg
    double precision, intent(in) :: alpha, omega, spA(1:nnz), b(1:incb,1:n)
    integer, intent(in) :: rowptr(1:n+1), colind(1:nnz)
    double precision, intent(inout) :: x(1:incx,1:n)
    double precision, intent(in) :: f(1:incf,1:n), g(1:incg,1:n)

    select case (trans)
      case ('N', 'n')
        call gsstep_fwd_mm_csr_notrans(n, alpha, spA, rowptr, colind, nnz, &
          f, incf, g, incg, omega, b, incb, x, incx)
      case ('T', 't')
        call gsstep_fwd_mm_csr_trans(n, alpha, spA, rowptr, colind, nnz, &
          f, incf, g, incg, omega, b, incb, x, incx)
    end select
  end subroutine gsstep_fwd_mm_csr

  subroutine gsstep_fwd_mm_csc(trans, n, alpha, spA, colptr, rowind, nnz, &
    f, incf, g, incg, omega, b, incb, x, incx)
    character, intent(in) :: trans
    integer, intent(in) :: n, nnz, incb, incx, incf, incg
    double precision, intent(in) :: alpha, omega, spA(1:nnz), b(1:incb,1:n)
    integer, intent(in) :: colptr(1:n+1), rowind(1:nnz)
    double precision, intent(inout) :: x(1:incx,1:n)
    double precision, intent(in) :: f(1:incf,1:n), g(1:incg,1:n)

    select case (trans)
      case ('N', 'n')
        call gsstep_fwd_mm_csr_trans(n, alpha, spA, colptr, rowind, nnz, &
          g, incg, f, incf, omega, b, incb, x, incx)
      case ('T', 't')
        call gsstep_fwd_mm_csr_notrans(n, alpha, spA, colptr, rowind, nnz, &
          g, incg, f, incf, omega, b, incb, x, incx)
    end select
  end subroutine gsstep_fwd_mm_csc

  subroutine gsstep_fwd_mm_csr_notrans(n, alpha, spA, rowptr, colind, nnz, &
      f, incf, g, incg, omega, b, incb, x, incx)
      use sparse
      integer, parameter :: base = sparse_base_index
      integer, intent(in) :: n, nnz, incb, incx, incf, incg
      double precision, intent(in) :: alpha, omega, spA(base:*), b(1:incb,base:base+n-1)
      integer, intent(in) :: rowptr(base:*), colind(base:*)
      double precision, intent(inout) :: x(1:incx,base:base+n-1)
      double precision, intent(in) :: f(1:incf,base:base+n-1), g(1:incg,base:base+n-1)

      integer :: i, j, z
      double precision :: tmpd, tmpx
      double precision :: sumxg
      double precision :: xg(base:base+n-1)

      xg(base:base+n-1) = x(1,base:base+n-1) * g(1,base:base+n-1)
      sumxg = sum(xg(base+1:base+n-1))
      do i = base, base+n-1
        tmpd = 0.0d0
        tmpx = b(1,i) / alpha
        if (i /= base) then
          sumxg = sumxg - xg(i) + x(1,i-1) * g(1,i-1)
        else
          sumxg = sumxg - xg(i)
        end if
        tmpx = tmpx - f(1,i) * sumxg
        do z = rowptr(i), rowptr(i+1)-1
          j = colind(z)
          if (i == j) then
            tmpd = spA(z) + f(1,i) * g(1,j)
          else
            tmpx = tmpx - spA(z) * x(1,j)
          end if
        end do
        x(1,i) = omega * tmpx / tmpd + (1.0d0 - omega) * x(1,i)
      end do
    end subroutine gsstep_fwd_mm_csr_notrans

    subroutine gsstep_fwd_mm_csr_trans(n, alpha, spA, rowptr, colind, nnz, &
      f, incf, g, incg, omega, b, incb, x, incx)
      use sparse
      integer, parameter :: base = sparse_base_index
      integer, intent(in) :: n, nnz, incb, incx, incf, incg
      double precision, intent(in) :: alpha, omega, spA(base:*), b(1:incb,base:base+n-1)
      integer, intent(in) :: rowptr(base:*), colind(base:*)
      double precision, intent(inout) :: x(1:incx,base:base+n-1)
      double precision, intent(in) :: f(1:incf,base:base+n-1), g(1:incg,base:base+n-1)

      integer :: i, j, z
      double precision :: tmp(base:base+n-1)
      integer :: diag(base:base+n-1)
      double precision :: sumxg
      double precision :: xg(base:base+n-1)

      tmp = 0.0d0
      call daxpy(n, 1.0/alpha, b, incb, tmp, 1)
      do i = base, base+n-1
        do z = rowptr(i), rowptr(i+1)-1
          j = colind(z)
          if (i == j) then
            diag(i) = z
            exit
          else
            tmp(j) = tmp(j) - spA(z) * x(1,i)
          end if
        end do
      end do

      xg(base:base+n-1) = x(1,base:base+n-1) * f(1,base:base+n-1)
      sumxg = sum(xg(base+1:base+n-1))

      do i = base, base+n-1
        if (i /= base) then
          sumxg = sumxg - xg(i) + x(1,i-1) * f(1,i-1)
        else
          sumxg = sumxg - xg(i)
        end if
        tmp(i) = tmp(i) - g(1,i) * sumxg
        x(1,i) = omega * tmp(i) / (spA(diag(i)) + f(1,i) * g(1,i)) + (1.0d0 - omega) * x(1,i)
        do z = diag(i)+1, rowptr(i+1)-1
          j = colind(z)
          tmp(j) = tmp(j) - spA(z) * x(1,i)
        end do
      end do
    end subroutine gsstep_fwd_mm_csr_trans

!!!! backward

subroutine gsstep_bwd_mm_dense(trans, n, alpha, A, lda, f, incf, g, incg, omega, b, incb, x, incx)
  character, intent(in) :: trans
  integer, intent(in) :: n, lda, incb, incx, incf, incg
  double precision, intent(in) :: alpha, omega, A(1:lda,1:n), b(1:incb,1:n)
  double precision, intent(inout) :: x(1:incx,1:n)
  double precision, intent(in) :: f(1:incf,1:n), g(1:incg,1:n)

  integer :: i, j
  double precision :: tmpx, tmpd

  select case (trans)
    case ('N', 'n')
      do i = n, 1, -1
        tmpd = 0.0d0
        tmpx = b(1,i) / alpha
        do j = n, 1, -1
          if (i == j) then
            tmpd = A(i,j) + f(1,i) * g(1,j)
          else
            tmpx = tmpx - (A(i,j) + f(1,i) * g(1,j)) * x(1,j)
          end if
        end do
        x(1,i) = omega * tmpx / tmpd + (1.0d0 - omega) * x(1,i)
      end do
    case ('T', 't')
      do j = n, 1, -1
        tmpd = 0.0d0
        tmpx = b(1,j) / alpha
        do i = n, 1, -1
          if (i == j) then
            tmpd = A(i,j) + f(1,i) * g(1,j)
          else
            tmpx = tmpx - (A(i,j) + f(1,i) * g(1,j)) * x(1,i)
          end if
        end do
        x(1,j) = omega * tmpx / tmpd + (1.0d0 - omega) * x(1,j)
      end do
  end select
end subroutine gsstep_bwd_mm_dense

!!!!

subroutine gsstep_bwd_mm_csr(trans, n, alpha, spA, rowptr, colind, nnz, &
  f, incf, g, incg, omega, b, incb, x, incx)
  character, intent(in) :: trans
  integer, intent(in) :: n, nnz, incb, incx, incf, incg
  double precision, intent(in) :: alpha, omega, spA(1:nnz), b(1:incb,1:n)
  integer, intent(in) :: rowptr(1:n+1), colind(1:nnz)
  double precision, intent(inout) :: x(1:incx,1:n)
  double precision, intent(in) :: f(1:incf,1:n), g(1:incg,1:n)

  select case (trans)
    case ('N', 'n')
      call gsstep_bwd_mm_csr_notrans(n, alpha, spA, rowptr, colind, nnz, &
        f, incf, g, incg, omega, b, incb, x, incx)
    case ('T', 't')
      call gsstep_bwd_mm_csr_trans(n, alpha, spA, rowptr, colind, nnz, &
        f, incf, g, incg, omega, b, incb, x, incx)
  end select
end subroutine gsstep_bwd_mm_csr

subroutine gsstep_bwd_mm_csc(trans, n, alpha, spA, colptr, rowind, nnz, &
  f, incf, g, incg, omega, b, incb, x, incx)
  character, intent(in) :: trans
  integer, intent(in) :: n, nnz, incb, incx, incf, incg
  double precision, intent(in) :: alpha, omega, spA(1:nnz), b(1:incb,1:n)
  integer, intent(in) :: colptr(1:n+1), rowind(1:nnz)
  double precision, intent(inout) :: x(1:incx,1:n)
  double precision, intent(in) :: f(1:incf,1:n), g(1:incg,1:n)

  select case (trans)
    case ('N', 'n')
      call gsstep_bwd_mm_csr_trans(n, alpha, spA, colptr, rowind, nnz, &
        g, incg, f, incf, omega, b, incb, x, incx)
    case ('T', 't')
      call gsstep_bwd_mm_csr_notrans(n, alpha, spA, colptr, rowind, nnz, &
        g, incg, f, incf, omega, b, incb, x, incx)
  end select
end subroutine gsstep_bwd_mm_csc

subroutine gsstep_bwd_mm_csr_notrans(n, alpha, spA, rowptr, colind, nnz, &
    f, incf, g, incg, omega, b, incb, x, incx)
    use sparse
    integer, parameter :: base = sparse_base_index
    integer, intent(in) :: n, nnz, incb, incx, incf, incg
    double precision, intent(in) :: alpha, omega, spA(base:*), b(1:incb,base:base+n-1)
    integer, intent(in) :: rowptr(base:*), colind(base:*)
    double precision, intent(inout) :: x(1:incx,base:base+n-1)
    double precision, intent(in) :: f(1:incf,base:base+n-1), g(1:incg,base:base+n-1)

    integer :: i, j, z
    double precision :: tmpd, tmpx
    double precision :: sumxg
    double precision :: xg(base:base+n-1)

    xg(base:base+n-1) = x(1,base:base+n-1) * g(1,base:base+n-1)
    sumxg = sum(xg(base+1:base+n-1))
    do i = base+n-1, base, -1
      tmpd = 0.0d0
      tmpx = b(1,i) / alpha
      if (i /= base) then
        sumxg = sumxg - xg(i) + x(1,i+1) * g(1,i+1)
      else
        sumxg = sumxg - xg(i)
      end if
      tmpx = tmpx - f(1,i) * sumxg
      do z = rowptr(i+1)-1, rowptr(i), -1
        j = colind(z)
        if (i == j) then
          tmpd = spA(z) + f(1,i) * g(1,j)
        else
          tmpx = tmpx - spA(z) * x(1,j)
        end if
      end do
      x(1,i) = omega * tmpx / tmpd + (1.0d0 - omega) * x(1,i)
    end do
  end subroutine gsstep_bwd_mm_csr_notrans

  subroutine gsstep_bwd_mm_csr_trans(n, alpha, spA, rowptr, colind, nnz, &
    f, incf, g, incg, omega, b, incb, x, incx)
    use sparse
    integer, parameter :: base = sparse_base_index
    integer, intent(in) :: n, nnz, incb, incx, incf, incg
    double precision, intent(in) :: alpha, omega, spA(base:*), b(1:incb,base:base+n-1)
    integer, intent(in) :: rowptr(base:*), colind(base:*)
    double precision, intent(inout) :: x(1:incx,base:base+n-1)
    double precision, intent(in) :: f(1:incf,base:base+n-1), g(1:incg,base:base+n-1)

    integer :: i, j, z
    double precision :: tmp(base:base+n-1)
    integer :: diag(base:base+n-1)
    double precision :: sumxg
    double precision :: xg(base:base+n-1)

    tmp = 0.0d0
    call daxpy(n, 1.0/alpha, b, incb, tmp, 1)
    do i = base+n-1, base, -1
      do z = rowptr(i+1)-1, rowptr(i), -1
        j = colind(z)
        if (i == j) then
          diag(i) = z
          exit
        else
          tmp(j) = tmp(j) - spA(z) * x(1,i)
        end if
      end do
    end do

    xg(base:base+n-1) = x(1,base:base+n-1) * f(1,base:base+n-1)
    sumxg = sum(xg(base+1:base+n-1))

    do i = base+n-1, base
      if (i /= base) then
        sumxg = sumxg - xg(i) + x(1,i+1) * f(1,i+1)
      else
        sumxg = sumxg - xg(i)
      end if
      tmp(i) = tmp(i) - g(1,i) * sumxg
      x(1,i) = omega * tmp(i) / (spA(diag(i)) + f(1,i) * g(1,i)) + (1.0d0 - omega) * x(1,i)
      do z = diag(i)-1, rowptr(i), -1
        j = colind(z)
        tmp(j) = tmp(j) - spA(z) * x(1,i)
      end do
    end do
  end subroutine gsstep_bwd_mm_csr_trans
end module gsstep_mm


      PROGRAM xbandec
C     driver for routine bandec
      REAL ran1
      REAL a(7,4),x(7),b(7),al(7,2),d
      INTEGER indx(7)
      INTEGER i,idum,j
      idum=-1
      do 12 i=1,7
        x(i)=ran1(idum)
        do 11 j=1,4
          a(i,j)=ran1(idum)
11      continue
12    continue
      call banmul(a,7,2,1,7,4,x,b)
      do 13 i=1,7
        write(*,*) i,b(i),x(i)
13    continue
      call bandec(a,7,2,1,7,4,al,2,indx,d)
      call banbks(a,7,2,1,7,4,al,2,indx,b)
      do 14 i=1,7
        write(*,*) i,b(i),x(i)
14    continue
      stop
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xbandec.for


module config_mod

    use globals_mod

    real(dp), parameter :: CFL = 0.8

    real(dp), parameter :: kappa = 1.4

    integer, parameter  :: ncells(  N_DIMS) = 32 * (/1,1/)

    real(dp), parameter :: width            = 0.25
    real(dp), parameter :: domain(2,N_DIMS) = width * reshape((/(/-1.0_dp, 1.0_dp/),(/-1.0_dp, 1.0_dp/)/),(/2,2/))

    real(dp), parameter :: inittime = 0.0
    real(dp), parameter :: stoptime = 5e-2
    real(dp), parameter :: dtdump = 1e-2

    real(dp), parameter :: dens0 = 1.0_dp
    real(dp), parameter :: velx0 = 0.0_dp
    real(dp), parameter :: vely0 = 0.0_dp
    real(dp), parameter :: pres0 = 1e-5_dp

    real(dp), parameter :: blast_ener = 1.0_dp
    real(dp), parameter :: blast_sigm = 1.0e-2

end module