c -----------------------------------------------------------
c NCLFORTSTART
      SUBROUTINE DLININT1(NXI,XI,FI,ICYCX,NXO,XO,FO,XIW,FXIW,NXI2,XMSG,
     +                    IOPT,IER)
      IMPLICIT NONE
      INTEGER NXI,NXO,NXI2,IOPT,ICYCX,IER
      DOUBLE PRECISION XI(NXI),FI(NXI)
      DOUBLE PRECISION XO(NXO),FO(NXO),XMSG
      DOUBLE PRECISION XIW(NXI2),FXIW(NXI2)
c NCLEND

c This is written  with GNU f77 acceptable extensions
c .   to allow for compilation on linux platforms.
c .   This could be improved considerably with f90

c NCL:  fo = linint1 (xi,fi, wrapX, xo, iopt)
c
c            {nxi,nxo} = dimsizes( {xi,xo} )
c            fo is the same size xo and same type as "fi"
c            xmsg = fi@_FillValue
c            wrapX is an NCL logical; a False ==> 0
c                                     a True  ==> 1
c            iopt = 0 try to preserve msg areas
c                 = 1 try to fill in entire grid
c
c            The NCL wrapper should allow for multiple datasets
c            so the user need only make one call to the function.

c perform piecewise linear interpolation allowing for missing data
c .  nothing fancy

c nomenclature:
c .   nxi     - lengths of xi and dimensions of fi (must be >= 2)
c .   xi      - coordinates of fi (eg, lon)
c .             must be monotonically (in/de)creasing [same as xo]
c .   fi      - functional input values [2D]
c .   icycx   - 0 if fi is cyclic in x (cyclic pt should NOT included)
c .             .ne.0 if cyclic
c .   nxo     - lengths of xo and dimensions of fo (must be >= 1)
c .   xo      - coordinates of fo (eg, lon)
c .             must be monotonically (in/de)creasing [same as xi]
c .   fo      - functional output values [interpolated]
c .   xmsg    - missing code
c .   iopt    - options
c .           - iopt=0  means to try to preserve missing areas
c .           - iopt=1  means to try to try to fill-in missing areas
c .   ier     - error code
c .             =0;   no error
c .             =1;   not enough points in input/output array
c .             =2;   xi are not monotonically increasing
c .             =4;   xo yo are not monotonically increasing
c
c                              local
      INTEGER NX,NPTS,IFLAG,NXSTRT,NXLAST
c                              gross error checking
      IER = 0
      IF (NXO.LT.1) THEN
          IER = 1
          RETURN
      END IF
c                              initialize to msg
      DO NX = 1,NXO
          FO(NX) = XMSG
      END DO

      IF (NXI.LE.1) THEN
          IER = 1
          RETURN
      END IF
c                              mono (in/de)creasing ?
      CALL DMONOID2(NXI,XI,NXO,XO,IFLAG,IER)
      IF (IFLAG.EQ.0 .OR. IER.NE.0) RETURN
c                              are data to be treated cyclic?
      IF (ICYCX.EQ.0) THEN
c                              data are not cyclic
          IF (IOPT.EQ.0) THEN

              CALL DLIN2INT1(NXI,XI,FI,NXO,XO,FO,XMSG,IFLAG)
          ELSE IF (IOPT.EQ.1) THEN
c                              collapse data array (eliminate msg)
              NPTS = 0
              DO NX = 1,NXI
                  IF (FI(NX).NE.XMSG) THEN
                      NPTS = NPTS + 1
                      XIW(NPTS+1)  = XI(NX)
                      FXIW(NPTS+1) = FI(NX)
                  END IF
              END DO

              CALL DLIN2INT1(NPTS,XIW(2),FXIW(2),NXO,XO,FO,XMSG,IFLAG)
          END IF
      ELSE
c                              data are cyclic
          IF (IOPT.EQ.0) THEN
c                              preserve msg region
              DO NX = 1,NXI
                  XIW(NX+1)  = XI(NX)
                  FXIW(NX+1) = FI(NX)
              END DO

              CALL DLINCYC(NXI,XI,FI,1,NXI,IFLAG,XIW,FXIW,NXI)
              CALL DLIN2INT1(NXI+2,XIW,FXIW,NXO,XO,FO,XMSG,IFLAG)

          ELSE IF (IOPT.EQ.1) THEN
c                              collapse data array
              NPTS = 0
              NXSTRT = 0
              NXLAST = 0
              DO NX = 1,NXI
                  IF (FI(NX).NE.XMSG) THEN
                      NPTS = NPTS + 1
                      XIW(NPTS+1)  = XI(NX)
                      FXIW(NPTS+1) = FI(NX)
                      IF (NPTS.EQ.1) NXSTRT = NX
                      NXLAST = NX
                  END IF
              END DO

              IF (NPTS.EQ.0) THEN
                  IER = 1
                  RETURN
              END IF

              CALL DLINCYC(NXI,XI,FI,NXSTRT,NXLAST,IFLAG,XIW,FXIW,NPTS)
              CALL DLIN2INT1(NPTS+2,XIW,FXIW,NXO,XO,FO,XMSG,IFLAG)
c c c         do nx=0,npts+1
c c c            write (*,"(i5,2(1x,f10.5))") nx, xiw(nx+1), fxiw(nx+1)
c c c         end do
          END IF

      END IF

      RETURN
      END
c -----------------------------------------------------------
C NCLFORTSTART
      SUBROUTINE DLININT2(NXI,XI,NYI,YI,FI,ICYCX,NXO,XO,NYO,YO,FO,XIW,
     +                    FXIW,NXI2,XMSG,IOPT,IER)
      IMPLICIT NONE
      INTEGER NXI,NYI,NXO,NYO,NXI2,ICYCX,IOPT,IER
      DOUBLE PRECISION XI(NXI),YI(NYI),FI(NXI,NYI)
      DOUBLE PRECISION XO(NXO),YO(NYO),FO(NXO,NYO),XMSG
      DOUBLE PRECISION XIW(NXI2),FXIW(NXI2)
C NCLEND

C This is written  with GNU f77 acceptable extensions
C .   to allow for compilation on linux platforms.
c .   This could be improved considerably with f90

c NCL:  fo = linint2 (xi,yi,fi, wrapX, xo,yo, iopt)
c
c            {nxi,nyi,nxo,nyo} = dimsizes( {xi,yi,xo,yo} )
c            fo is the same size xo, yo and same type as "fi"
c            xmsg = fi@_FillValue
c            wrapX is an NCL logical; a False ==> 0
c                                     a True  ==> 1
c
c            The NCL wrapper should allow for multiple datasets
c            so the user need only make one call to the function.

c perform bilinear interpolation allowing for missing data
c .  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)
c .             must be monotonically increasing
c .   yi      - coordinates of fi (eg, lat)
c .             must be monotonically increasing
c .   fi      - functional input values [2D]
c .   icycx   - 0 if fi is cyclic in x (cyclic pt should NOT included)
c .             .ne.0 if cyclic
c .   nxo,nyo - lengths of xo,yo and dimensions of fo (must be >= 2)
c .   xo      - coordinates of fo (eg, lon)
c .             must be monotonically increasing
c .   yo      - coordinates of fo (eg, lat)
c .             must be monotonically increasing
c .   fo      - functional output values [interpolated]
c .   xmsg    - missing code
c .   iopt    - =0 try to preserve msg areas
c .             =1 try to fill in entire grid
c .   ier     - error code
c .             =0;   no error
c .             =1;   not enough points in input/output array
c .             =2;   xi or xo are not monotonically (in/de)creasing
c .             =3;   yi or yo are not monotonically (in/de)creasing
c
c                              local and temporary/work arrays
      INTEGER IFLAG,NPTS,NXSTRT,NXLAST
      DOUBLE PRECISION YIW(NYI),FYIW(NYI),FOYW(NYO)
      DOUBLE PRECISION FTMP(NXO,NYI)

c                              local
      INTEGER NX,NY
c                              error checking
      IER = 0
      IF (NXO.LT.1 .OR. NYO.LT.1) THEN
          IER = 1
          RETURN
      END IF
c                              set to msg
      DO NY = 1,NYO
          DO NX = 1,NXO
              FO(NX,NY) = XMSG
          END DO
      END DO

      IF (NXI.LT.2 .OR. NYI.LT.2) THEN
          IER = 1
          RETURN
      END IF
c                              error mono increasing ?
      CALL DMONOID2(NXI,XI,NXO,XO,IFLAG,IER)
      IF (IFLAG.EQ.0 .OR. IER.NE.0) THEN
          IER = 2
          RETURN
      END IF
      CALL DMONOID2(NYI,YI,NYO,YO,IFLAG,IER)
      IF (IFLAG.EQ.0 .OR. IER.NE.0) THEN
          IER = 3
          RETURN
      END IF
c                               is the input array cyclic in x
      IF (ICYCX.EQ.0) THEN
c                               preserve missing areas
          IF (IOPT.EQ.0) THEN
c                               interpolate in the x direction
              DO NY = 1,NYI
                  CALL DLIN2INT1(NXI,XI,FI(1,NY),NXO,XO,FTMP(1,NY),
     +                          XMSG,IFLAG)
              END DO
c                               interpolate in the y direction
              DO NX = 1,NXO
                  DO NY = 1,NYI
                      FYIW(NY) = FTMP(NX,NY)
                  END DO

                  CALL DLIN2INT1(NYI,YI,FYIW,NYO,YO,FOYW,XMSG,IFLAG)

                  DO NY = 1,NYO
                      FO(NX,NY) = FOYW(NY)
                  END DO
              END DO
          ELSE IF (IOPT.EQ.1) THEN
c                               interpolate in the x direction
c                               collapse data array
              DO NY = 1,NYI
                  NPTS = 0
                  DO NX = 1,NXI
                      IF (FI(NX,NY).NE.XMSG) THEN
                          NPTS = NPTS + 1
                          XIW(NPTS+1)  = XI(NX)
                          FXIW(NPTS+1) = FI(NX,NY)
                      END IF
                  END DO

                  CALL DLIN2INT1(NPTS,XIW(2),FXIW(2),NXO,XO,FTMP(1,NY),
     +                          XMSG,IFLAG)
              END DO
c                               interpolate in the y direction
              DO NX = 1,NXO
                  NPTS = 0
                  DO NY = 1,NYI
                      IF (FTMP(NX,NY).NE.XMSG) THEN
                          NPTS = NPTS + 1
                          YIW(NPTS) = YI(NY)
                          FYIW(NPTS) = FTMP(NX,NY)
                      END IF
                  END DO

                  CALL DLIN2INT1(NPTS,YIW,FYIW,NYO,YO,FOYW,XMSG,IFLAG)

                  DO NY = 1,NYO
                      FO(NX,NY) = FOYW(NY)
                  END DO
              END DO

          END IF
      ELSE
c                               must be cyclic in x
c                               create cyclic "x" coordinates
          IF (IOPT.EQ.0) THEN
              DO NY = 1,NYI
                  DO NX = 1,NXI
                      XIW(NX+1)  = XI(NX)
                      FXIW(NX+1) = FI(NX,NY)
                  END DO

                  NPTS = NXI
                  CALL DLINCYC(NXI,XI,FI(1,NY),1,NXI,IFLAG,XIW,FXIW,
     +                         NPTS)
                  CALL DLIN2INT1(NXI+2,XIW,FXIW,NXO,XO,FTMP(1,NY),XMSG,
     +                           IFLAG)
              END DO
c                               interpolate in the y direction
              DO NX = 1,NXO
                  DO NY = 1,NYI
                      FYIW(NY) = FTMP(NX,NY)
                  END DO

                  CALL DLIN2INT1(NYI,YI,FYIW,NYO,YO,FOYW,XMSG,IFLAG)

                  DO NY = 1,NYO
                      FO(NX,NY) = FOYW(NY)
                  END DO
              END DO

          ELSE IF (IOPT.EQ.1) THEN
              DO NY = 1,NYI
c                              collapse data array
                  NPTS = 0
                  NXSTRT = 0
                  NXLAST = 0
                  DO NX = 1,NXI
                      IF (FI(NX,NY).NE.XMSG) THEN
                          NPTS = NPTS + 1
                          XIW(NPTS+1)  = XI(NX)
                          FXIW(NPTS+1) = FI(NX,NY)
                          IF (NPTS.EQ.1) NXSTRT = NX
                          NXLAST = NX
                      END IF
                  END DO

                  CALL DLINCYC(NXI,XI,FI(1,NY),NXSTRT,NXLAST,IFLAG,XIW,
     +                         FXIW,NPTS)
                  CALL DLIN2INT1(NPTS+2,XIW,FXIW,NXO,XO,FTMP(1,NY),
     +                           XMSG,IFLAG)
              END DO
c                               interpolate in the y direction
              DO NX = 1,NXO
                  NPTS = 0
                  DO NY = 1,NYI
                      IF (FTMP(NX,NY).NE.XMSG) THEN
                          NPTS = NPTS + 1
                          YIW(NPTS) = YI(NY)
                          FYIW(NPTS) = FTMP(NX,NY)
                      END IF
                  END DO

                  CALL DLIN2INT1(NPTS,YIW,FYIW,NYO,YO,FOYW,XMSG,IFLAG)

                  DO NY = 1,NYO
                      FO(NX,NY) = FOYW(NY)
                  END DO
              END DO
          END IF
      END IF

      RETURN
      END
c -----------------------------------------------------------
      SUBROUTINE DLIN2INT1(NIN,XI,FI,NOUT,XO,FO,XMSG,IFLAG)
      IMPLICIT NONE
      INTEGER NIN,NOUT,IFLAG
      DOUBLE PRECISION XI(NIN),FI(NIN),XO(NOUT),FO(NOUT),XMSG

c perform 1D piecewise linear interpolation allowing for missing data
c .  this works with lin2int [does no error chk]
c .  nothing fancy
c                              local
      INTEGER NI,NO,NISTRT,NIS,NEXACT
      DOUBLE PRECISION SLOPE

      DO NO = 1,NOUT
          FO(NO) = XMSG
      END DO
c                              main loop [exact matches]
c                              nistrt minimizes extra checks
      NEXACT = 0
      NISTRT = 1
      NIS = NISTRT
      DO NO = 1,NOUT
          DO NI = NISTRT,NIN
              IF (XO(NO).EQ.XI(NI)) THEN
                  FO(NO) = FI(NI)
                  NIS = NI + 1
                  NEXACT = NEXACT + 1
                  GO TO 10
              END IF
          END DO
   10     NISTRT = NIS
      END DO

c                              main loop [interpolation]
      IF (IFLAG.EQ.1) THEN
          DO NO = 1,NOUT
              DO NI = 1,NIN - 1
                  IF (XO(NO).GT.XI(NI) .AND. XO(NO).LT.XI(NI+1)) THEN
                      IF (FI(NI).NE.XMSG .AND. FI(NI+1).NE.XMSG) THEN
                          SLOPE = (FI(NI+1)-FI(NI))/ (XI(NI+1)-XI(NI))
                          FO(NO) = FI(NI) + SLOPE* (XO(NO)-XI(NI))
                      END IF
                  END IF
              END DO
          END DO
      ELSE IF (IFLAG.EQ.-1) THEN
          DO NO = 1,NOUT
              DO NI = 1,NIN - 1
                  IF (XO(NO).LT.XI(NI) .AND. XO(NO).GT.XI(NI+1)) THEN
                      IF (FI(NI).NE.XMSG .AND. FI(NI+1).NE.XMSG) THEN
                          SLOPE = (FI(NI+1)-FI(NI))/ (XI(NI+1)-XI(NI))
                          FO(NO) = FI(NI) + SLOPE* (XO(NO)-XI(NI))
                      END IF
                  END IF
              END DO
          END DO
      END IF

      RETURN
      END
c ---------------------------------------------
      SUBROUTINE DLINCYC(NXI,XI,FI,NXSTRT,NXLAST,IFLAG,XIW,FXIW,NPTS)
c
c handle the "x" cyclic point
c
      IMPLICIT NONE
      INTEGER NXI,NXSTRT,NXLAST,IFLAG,NPTS
      DOUBLE PRECISION XI(NXI),FI(NXI),XIW(0:NXI+1),FXIW(0:NXI+1)
      DOUBLE PRECISION DX

      IF (NXSTRT.EQ.1 .AND. NXLAST.EQ.NXI) THEN
          DX = ABS(XI(2)-XI(1))
          XIW(0) = XI(1) - IFLAG*DX
          FXIW(0) = FI(NXI)
          DX = ABS(XI(NXI)-XI(NXI-1))
          XIW(NPTS+1) = XI(NXI) + IFLAG*DX
          FXIW(NPTS+1) = FI(1)
      ELSE
c                              arbitrary
          DX = (NXSTRT+ (NXI-NXLAST))*ABS(XI(2)-XI(1))
          XIW(0) = XIW(1) - IFLAG*DX
          FXIW(0) = FXIW(NPTS)
          DX = ((NXI-NXLAST)+NXSTRT)*ABS(XI(NXI)-XI(NXI-1))
          XIW(NPTS+1) = XIW(NPTS) + IFLAG*DX
          FXIW(NPTS+1) = FXIW(1)
      END IF

      RETURN
      END
c ---------------------------------------------
      SUBROUTINE DMONOINC(X,NX,NER,IER)
      IMPLICIT NONE

c chk to make sure that x is monotonically increasing

      INTEGER NX,NER,IER
      DOUBLE PRECISION X(NX)
c                          local
      INTEGER N

      IER = 0
      IF (NX.LE.1) RETURN

      DO N = 1,NX - 1
          IF (X(N+1).LE.X(N)) THEN
              IER = NER
              RETURN
          END IF
      END DO

      RETURN
      END
c     ---------------------------------------------------
      SUBROUTINE DMONOID1(NIN,XI,IFLAG,IER)
c
c chk to see if a series is mono (in/de)creasing
c
      IMPLICIT NONE
      INTEGER NIN,IFLAG,IER
      DOUBLE PRECISION XI(NIN)
c                              local
      INTEGER NI

      IER = 0
      IFLAG = 0
c
c if only one element, then treat it as monotonically increasing
c
      IF (NIN.LT.2) THEN
         IFLAG = +1
         RETURN
      END IF

      IF (XI(2).GT.XI(1)) THEN
c                              ? mono INcreasing
          DO NI = 1,NIN - 1
              IF (XI(NI+1).LE.XI(NI)) THEN
                  IER = 2
                  RETURN
              END IF
          END DO

          IFLAG = +1
      ELSE
c                              ? mono DEcreasing
          DO NI = 1,NIN - 1
              IF (XI(NI+1).GE.XI(NI)) THEN
                  IER = 2
                  RETURN
              END IF
          END DO

          IFLAG = -1
      END IF

      RETURN
      END
c     ---------------------------------------------------
      SUBROUTINE DMONOID2(NIN,XI,NOUT,XO,IFLAG,IER)
c
c make sure the two series are mono (in/de)creasing
c
      IMPLICIT NONE
      INTEGER NIN,NOUT,IFLAG,IER
      DOUBLE PRECISION XI(NIN),XO(NOUT)
c                              local
      INTEGER NFLAG,NER

      IER = 0
      IFLAG = 0
      NFLAG = 0

      CALL DMONOID1(NIN,XI,IFLAG,IER)
      IF (IFLAG.EQ.0) THEN
         IER = 2
      ELSE
         CALL DMONOID1(NOUT,XO,NFLAG,NER)
         IF (NFLAG.EQ.0) THEN
            IER = 3
         ELSE IF (IFLAG.NE.NFLAG) THEN
            IER = 4
         END IF
      END IF

      RETURN
      END

c -----------------------------------------------------------
C NCLFORTSTART
      SUBROUTINE DLININT2PTS(NXI,XI,NYI,YI,FI,ICYCX,NXYO,XO,YO,FO,
     +                       XIW,FIXW,NXI2,XMSG,IER)
      IMPLICIT NONE
      INTEGER NXI,NYI,NXYO,ICYCX,NXI2,IER
      DOUBLE PRECISION XI(NXI),YI(NYI),FI(NXI,NYI)
      DOUBLE PRECISION XO(NXYO),YO(NXYO),FO(NXYO)
      DOUBLE PRECISION XIW(NXI2),FIXW(NXI2,NYI),XMSG
C NCLEND

C This is written  with GNU f77 acceptable extensions
C .   to allow for compilation on linux platforms.
c .   This could be improved considerably with f90

c NCL:  fo = linint2_points (xi,yi,fi, wrapX, xo,yo, foOpt)
c
c            {nxi,nyi} = dimsizes( {xi,yi} )
c            {nxyo} = dimsizes( {xo} )  = dimsizes( {yo} )
c            fo is the same size xo, yo and same type as "fi"
c            xmsg = fi@_FillValue
c            wrapX is an NCL logical; a False ==> 0
c                                     a True  ==> 1
c            foOpt 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 piecewise linear interpolation allowing for missing data
c .  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)
c .             must be monotonically increasing
c .   yi      - coordinates of fi (eg, lat)
c .             must be monotonically increasing
c .   fi      - functional input values [2D]
c .   icycx   - 0 if fi is cyclic in x (cyclic pt should NOT included)
c .             .ne.0 if cyclic
c .   nxyo    - number of xo,yo coordinate pairs
c .   xo,yo   - coordinate pairs
c .   fo      - functional output values [interpolated]
c .   xmsg    - missing code
c .   nopt    - option for how to handle case when not all values
c .              present
c .              >= 0 means set the interpolated point to xmsg
c .              =-1 try some sort of weighted average
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
c                              automatic temporary/work arrays
      DOUBLE PRECISION DX

c                              local
      INTEGER NX,NY,NOPT
c                              this could be made an argument
      NOPT = -1
c                              error checking
      IER = 0
      IF (NXI.LT.2 .OR. NYI.LT.2) THEN
          IER = 1
          RETURN
      END IF
c                              error mono increasing ?
      CALL DMONOINC(XI,NXI,2,IER)
      IF (IER.NE.0) RETURN
      CALL DMONOINC(YI,NYI,3,IER)
      IF (IER.NE.0) RETURN
c                               is the input array cyclic in x
      IF (ICYCX.EQ.0) THEN
          CALL DLINT2XY(NXI,XI,NYI,YI,FI,NXYO,XO,YO,FO,XMSG,NOPT,IER)
      ELSE
c                               must be cyclic in x
c                               create cyclic "x" coordinates
          DO NX = 1,NXI
              XIW(NX+1) = XI(NX)
          END DO
          DX = XI(2) - XI(1)
          XIW(1)    = XI(1) - DX
          XIW(NXI2) = XI(NXI) + DX

          DO NY = 1,NYI
              DO NX = 1,NXI
                  FIXW(NX+1,NY) = FI(NX,NY)
              END DO
              FIXW(1,NY)    = FI(NXI,NY)
              FIXW(NXI2,NY) = FI(1,NY)
          END DO
          CALL DLINT2XY(NXI2,XIW,NYI,YI,FIXW,NXYO,XO,YO,FO,XMSG,NOPT,
     +                  IER)
      END IF

      RETURN
      END

c -----------------------------------------------------------
c                           could be improved with f90 cycle/continue
      SUBROUTINE DLINT2XY(NXI,XI,NYI,YI,FI,NXYO,XO,YO,FO,XMSG,NOPT,IER)
      IMPLICIT NONE
      INTEGER NXI,NYI,NXYO,NOPT,IER
      DOUBLE PRECISION XI(NXI),YI(NYI),FI(NXI,NYI),XMSG
      DOUBLE PRECISION XO(NXYO),YO(NXYO),FO(NXYO)
c                               local
      INTEGER N,M,NXY,NN,MM
      DOUBLE PRECISION TMP1,TMP2,SLPX,SLPY

      DO NXY = 1,NXYO
          FO(NXY) = XMSG

          NN = 0
          DO N = 1,NXI - 1
              IF (XO(NXY).GE.XI(N) .AND. XO(NXY).LT.XI(N+1)) THEN
                  NN = N
                  GO TO 20
              END IF
          END DO

   20     MM = 0
          DO M = 1,NYI - 1
              IF (YO(NXY).GE.YI(M) .AND. YO(NXY).LT.YI(M+1)) THEN
                  MM = M
                  GO TO 40
              END IF
          END DO

   40     IF (NN.NE.0 .AND. MM.NE.0) THEN
              IF (XO(NXY).EQ.XI(NN) .AND. YO(NXY).EQ.YI(MM)) THEN
c                               exact location [no interpolation]
                  FO(NXY) = FI(NN,MM)
              ELSE IF (FI(NN,MM).NE.XMSG .AND. FI(NN+1,MM).NE.XMSG .AND.
     +                 FI(NN,MM+1).NE.XMSG .AND.
     +                 FI(NN+1,MM+1).NE.XMSG) THEN
c                               must interpolate: calculate slopes
                  SLPX = (XO(NXY)-XI(NN))/ (XI(NN+1)-XI(NN))
                  SLPY = (YO(NXY)-YI(MM))/ (YI(MM+1)-YI(MM))
c                               interpolate in "x" first
                  TMP1 = FI(NN,MM) + SLPX* (FI(NN+1,MM)-FI(NN,MM))
                  TMP2 = FI(NN,MM+1) + SLPX* (FI(NN+1,MM+1)-FI(NN,MM+1))
c                               interpolate in "y"
                  FO(NXY) = TMP1 + SLPY* (TMP2-TMP1)
              ELSE IF (NOPT.EQ.-1) THEN
                  CALL ESTFOW(FI(NN,MM),FI(NN+1,MM),FI(NN,MM+1),
     +                        FI(NN+1,MM+1),XI(NN),XI(NN+1),YI(MM),
     +                        YI(MM+1),FO(NXY),XO(NXY),YO(NXY),XMSG)
              END IF
          END IF

      END DO

      RETURN
      END
c ---------------------------------------------
      SUBROUTINE ESTFOW(F1,F2,F3,F4,X1,X2,Y1,Y2,F0,X0,Y0,XMSG)
      IMPLICIT NONE
      DOUBLE PRECISION F1,F2,F3,F4,X1,X2,Y1,Y2,F0,X0,Y0,XMSG
c local
      DOUBLE PRECISION FI(2,2),W(2,2),SUM,SWT
      INTEGER N,M

c     f3(x1,y2)+++++++++++f4(x2,y2)
c        f0(x0,y0)         someplace within the surrounding 4 pts
c     f3(x1,y1)+++++++++++f4(x2,y1)

c if all msg return

      F0 = XMSG
      IF (F1.EQ.XMSG .AND. F2.EQ.XMSG .AND. F3.EQ.XMSG .AND.
     +    F4.EQ.XMSG) RETURN

c compute 'distance wgted average
c .   make assumption that dx/dy are small and
c .   pythag theorem is good enough

c inverse distance wgts
      W(1,1) = 1.D0/SQRT((X1-X0)**2+ (Y1-Y0)**2)
      W(2,1) = 1.D0/SQRT((X2-X0)**2+ (Y1-Y0)**2)
      W(1,2) = 1.D0/SQRT((X1-X0)**2+ (Y2-Y0)**2)
      W(2,2) = 1.D0/SQRT((X2-X0)**2+ (Y2-Y0)**2)

      FI(1,1) = F1
      FI(2,1) = F2
      FI(1,2) = F3
      FI(2,2) = F4

      SUM = 0.D0
      SWT = 0.D0
      DO M = 1,2
          DO N = 1,2
              IF (FI(N,M).NE.XMSG) THEN
                  SUM = SUM + FI(N,M)*W(N,M)
                  SWT = SWT + W(N,M)
              END IF
          END DO
      END DO
c                               wgted average
      IF (SWT.GT.0.D0) THEN
          F0 = SUM/SWT
      END IF

      RETURN
      END


PROGRAM sgd_grid
  ! Program creates a large number of self-gravitating disc models
  ! So that user can carry out a parameter survey
  ! Writes disc properties and fragmentation outcomes...
  ! ******** Assumes fixed Q
  ! ******** Surveys the mdot - r parameter space only
  ! Finds local Jeans mass ==> potential fragment masses

  use eosdata
  implicit none

  integer :: frag,selfgrav,irad,imdot,irrchoice
  integer :: nrad, nmdot
  real, parameter :: tolerance = 1.0e-5
  real, parameter :: Qfrag = 2.0
  real,parameter :: Q_irrcrit = 1.99
  real,parameter :: alpha_sat = 0.1 ! Value of alpha at which gravitoturbulence saturates
  real, parameter :: gamma_Jcrit = -5 ! Minimum GammaJ value to be exceeded for fragmentation
  real, parameter :: gamma_Qcrit = 10 ! abs(gamma_Q) must be greater than this for self-gravitating disc

  real :: Mstar, rmax,rmin,dr,r
  real :: mdotmin, mdotmax, mdotvisc, dmdot
  real :: sigma, omega, cs,rhomid,alpha, gamma, mu, T, kappa
  real :: mtot,qratio,tevolve
  real :: dT,sigma_old,ntries,mdot_try,fine
  real :: deltasigma, metallicity

  real :: gamma_J, gamma_omega, gamma_sigma, gamma_Q
  real :: csterm, gamma_sigma_max
  real :: mdot_eq, alpha_eq
  real :: tau,H,betac,dsig
  real :: mjeans, ljeans, rhill
  real :: cs_irr, T_irr, Q_irr, Msol, rAU, TLin
  real :: TLin_constant

  character(100) :: outputprefix,outputfile

  !**********************************
  ! 1. Determine input parameters
  !**********************************

  ! Write header
  print*, " "
  print*, "-----------------------------------------------"
  print*, "  SGD_GRID: GRIDS OF 1D SELF-GRAVITATING DISC MODELS  "
  print*, "     Created by D. Forgan, May 2011 "
  print*, "     Majorly Revised, Jan 2013  "
  print*, "     Current Version: Jan 2018  "
  print*, "	                                        	  "
  print*, "-----------------------------------------------"
  print*, " "
  print*, " "
  print*, " input files: ./sgd_grid.params ./myeos.dat"
  print*, " "
  print*, "-----------------------------------------------"
  print*, " "

  OPEN(10,file='sgd_grid.params', status='unknown')
  READ(10,*) outputprefix
  READ(10,*) nrad
  READ(10,*) nmdot
  READ(10,*) Mstar
  READ(10,*) rmin
  READ(10,*) rmax
  read(10,*) mdotmin
  read(10,*) mdotmax
  read(10,*) metallicity
  read(10,*) gamma_sigma
  read(10,*) gamma_omega
  read(10,*) irrchoice
  read(10,*) Q_irr
  read(10,*) T_irr

  close(10)

  outputfile = trim(outputprefix)//'.sgdmodel'

  print*, 'Outputting to file ', outputfile
  print*, 'Mstar (msol) ', Mstar
  print*, 'Radial Limits: ', rmin, rmax
  print*, 'log(mdotmin), log(mdotmax): ', mdotmin,mdotmax
  print*, 'Metallicity (relative to solar): ', metallicity

  if(irrchoice==-1) then
     print*, 'No Irradiation'
  else if(irrchoice==0) then
     print*, 'Irradiation: fixed Qirr of ', Q_irr
  else if(irrchoice==1) then
     print*, 'Irradiation: fixed Tirr of ', T_irr
  else if (irrchoice==2) then
     print*, 'Irradiation: Ida Lin prescription'
     TLin_constant = T_irr
     print*, 'Scaling constant ', TLin_constant
  endif

  print*, 'Gamma_Omega: ', gamma_omega
  print*, 'Gamma_Sigma: ', gamma_sigma

  rmin = rmin*udist
  rmax = rmax*udist

  dr = (rmax-rmin)/REAL(nrad)
  dmdot = (mdotmax-mdotmin)/REAL(nmdot)
  Mstar = Mstar*umass	! star mass in cgs

  ! Read in Equation of State data

  ! gammamuT columns:
  ! 1) gamma
  ! 2) mu
  ! 3) T
  ! 4) Opacity
  ! 5) Mass Weighted Opacity (Stamatellos et al 2007)

  allocate(gammamuT(5)	)
  CALL eosread

  OPEN(10,file=outputfile ,status='unknown')
  write(10,*) nrad, nmdot, rmin/udist,rmax/udist,mdotmin,mdotmax, &
       Mstar/umass, metallicity, gamma_sigma,gamma_omega, irrchoice, Q_irr, T_irr

  ! Loop over parameters: accretion rate, and outer radius

  DO imdot = 1, nmdot

     mdotvisc = mdotmin + (imdot-1)*dmdot

     print*, 'Testing mdot ', imdot, 10.0**mdotvisc

     mdotvisc = (10.0**mdotvisc)*umass/3.15e7 ! convert to cgs

     mtot = 0.0

     ! Loop over radii
     DO irad = 1,nrad

        !************************************************
        ! 2. Determine local disc surface density, sound speed
        !************************************************

	r = rmin +(irad-1)*dr
        sigma = 0.0
        omega = 0.0
        T = 0.0
        cs = 0.0
        mjeans = 0.0
	betac = 0.0
	alpha = 0.0
	alpha_eq = 0.0
	mdot_eq = 0.0

 ! mjeans always has the same prefactor - do this first
        mjeans = 4.0*1.412*pi*pi*pi/(3.0*G)

        ! Set flags for selfgravitating regions, fragmenting regions
	frag =0
        selfgrav = 0

        ! Calculate Omega - Keplerian frequency

	omega = sqrt(G*Mstar/r**3)

 ! Begin iteration process to determine (sound speed,Sigma) for fixed Q, omega

 ! Guess Sigma (start from previous answer)

	IF(irad==1) sigma_old = 50000.0

	sigma = 2.0*sigma_old

	dT = 1.0e30
	ntries = 0
        fine = 0.01
	DO WHILE(ABS(dT)> tolerance)

    !	Calculate sound speed assuming fixed Q

           cs = Qfrag*pi*G*sigma/omega

           !	Calculate scale height

           H = cs/omega

           rhomid = sigma/(2.0*H)

           !	Use EoS to calculate optical depth, gamma, cooling time

           CALL eos_cs(rhomid, cs)

           gamma = gammamuT(1)
           mu = gammamuT(2)
           T = gammamuT(3)
           kappa = gammamuT(4)*metallicity

           tau = sigma*kappa

           ! If no irradiation, then set all irradiation parameters to zero
           IF(irrchoice==-1) THEN
              T_irr = 0.0
              Q_irr = 0.0
              cs_irr = 0.0
           ENDIF

           ! If irradiation at fixed Q_irr, calculate other irradiation parameters
           IF(irrchoice==0) THEN
              cs_irr = Q_irr*pi*G*sigma/omega
              T_irr = 0.0
              IF(cs_irr/=0.0) THEN
                 CALL eos_cs(rhomid,cs_irr)
                 T_irr = gammamuT(3)
              ENDIF

              ! If irradiation uses T_irr, calculate this and other parameters
           ELSE IF(irrchoice>0) THEN
              ! Ida and Lin prescription
              ! Modify T_irr
              IF(irrchoice==2) THEN
                 rAU = r/udist
                 Msol = Mstar/umass
                 TLin = TLin_constant*Msol/sqrt(rAU)
                 ! Must account for optical depth
                 IF(tau>1.0e-30)TLin = TLin/(tau+1.0/tau)**0.25
                 !               T_irr = max(TLin, T_irr)
                 T_irr = TLin
              ENDIF

              cs_irr = SQRT(gamma*Boltzmannk*T_irr/(mu*mH))
              Q_irr = cs_irr*omega/(pi*G*sigma)

           ENDIF

           ! Calculate cooling timescale for these parameters

           betac = (tau+1.0/tau)*(cs*cs)*omega/&
                (sigma_SB*(T**4.0-T_irr**4.0)*gamma*(gamma-1.0))

           !	Calculate alpha from this value --> accretion rate

           alpha = 4.0/(9.0*gamma*(gamma-1.0)*betac)

           !	Compare calculated mdot with imposed mdot

           mdot_try = 3.0*pi*alpha*cs*cs*sigma/omega
           dT = (mdotvisc-mdot_try)/mdotvisc

           ! If the iteration isn't converging after 1000 tries,
           ! Reduce the amount by which sigma is modified

           IF(ntries> 1000) THEN
              fine = fine/10.0
              ntries = 0.0
           ENDIF

           dsig = (sigma-sigma_old)/sigma_old

           IF(ABS(dsig)<1.0e-5.and.ntries>500) exit  ! Exit if percentage change in sigma very small

           ! Modify sigma according to how poorly accretion rate is matched
           sigma_old = sigma
           sigma = sigma*(1.0 +dT/(abs(dT))*fine)

           ntries = ntries+1
	ENDDO

 ! Check for MRI activation
 ! If so, then set alpha=0.01 and readjust sigma to maintain mdotvisc

        !IF(T>1000.0) THEN
           !	print*, 'MRI active ',r/udist, T, alpha, sigma
        !   alpha = 0.01
        !   sigma = mdotvisc*omega/(3.0*pi*alpha*cs*cs)
           !	print*, 'MRI active ', T, alpha, sigma
        !ENDIF

        !***************************************************
        ! 3. Calculate Local Jeans Mass, Jeans length
        !***************************************************

        ! First strength of density perturbations
        deltasigma = 1.0+4.47*sqrt(alpha)

        mjeans = mjeans*cs*cs*sqrt(Qfrag)*H/deltasigma
        !mjeans = mjeans*cs*cs*cs*cs*sqrt(Qfrag)/(pi*G*sigma*deltasigma)
        ljeans = sqrt(2.0*pi*pi*Qfrag/deltasigma)*H
        ljeans = ljeans/udist

        ! Calculate fragment Hill Radius

        rhill = r*(mjeans/Mstar)**0.333
        rhill = rhill/udist

        ! Convert Jeans mass to Jupiter masses
        mjeans = mjeans/mjup

        ! Calculate if fragmentation is likely
        ! requires two conditions to be met:

        ! 1. gamma_J small and negative (Jeans mass decreases rapidly)
        ! 2. gamma_Q large (Q relatively unchanging)

        ! First, calculate gamma_Q from gamma_sigma, gamma_omega

        ! If self-gravitating alpha exceeds saturation, fix it at saturation
        IF(alpha> alpha_sat) alpha = alpha_sat

        csterm = 9.0*alpha*gamma*(gamma-1)/4.0 - 1/betac

        ! Calculate maximum gamma sigma value allowed to maintain a steady disc

        gamma_sigma_max = 2.0*csterm
        IF(gamma_sigma_max/=0.0) THEN
           gamma_sigma_max = 1.0/gamma_sigma_max
        ELSE
           gamma_sigma_max = 1.0e20
        ENDIF

        IF(gamma_sigma>gamma_sigma_max) THEN
           gamma_Q = 5e-31
           gamma_J = 1.5*csterm
        ELSE
           gamma_J = 1.25*csterm - 1.5/gamma_sigma + 0.5/gamma_omega
           gamma_Q = 0.5*csterm - 1.0/gamma_sigma + 1.0/gamma_omega
        ENDIF

        ! Only do inverse operation for non-zero denominators
        IF(gamma_J/=0.0) then
           gamma_J = 1.0/gamma_J
        else
           gamma_J = 1.0e30
        endif

        IF(gamma_Q/=0.0) then
           gamma_Q = 1.0/gamma_Q
        else
           gamma_Q = 1.0e30
        endif

        !************************************
        ! 4. Test region for fragmentation
        !************************************

        frag = 1  ! Set fragmentation flag to 'true' initially
        selfgrav = 1 ! Set self-gravitating flag to 'true' initially

        ! If gamma_J not small and negative, disc non-fragmenting
        IF(gamma_J < gamma_Jcrit .or. gamma_J > 0.0) frag = 0

        ! If irradiation completely suppresses self-gravity, not self-gravitating
        IF(Q_irr==Q_irrcrit) selfgrav = 0

        ! Calculate enclosed disc mass and mass ratio

        mtot = mtot + twopi*r*sigma*dr
        qratio = mtot/Mstar

        ! If disc will be completely accreted within 5 orbital periods, not of interest

        tevolve = mtot*omega/mdotvisc
        !        if(tevolve < 5) selfgrav = 0

        ! Now check fragmenting disc is self-gravitating
        frag = frag*selfgrav

        ! If disc isn't fragmenting, then set fragment properties to nil
        IF(frag==0) THEN
           mjeans = 0.0
           rhill=0.0
           ljeans = 0.0
        ENDIF

        ! Do not write anything if the disc is non-self-gravitating
        IF(selfgrav==0) THEN
           mtot = 0.0
           sigma = 0.0
           qratio = 0.0
           cs = 0.0
           T = 0.0
           alpha = 0.0
           betac=0.0
           T_irr = 0.0
           cs_irr = 0.0
           Q_irr = 0.0
        ENDIF

        !************************************
        ! 5. Write disc model to file
        !************************************

        WRITE(10,*) r/udist, mdotvisc*3.15e7/umass, qratio,sigma,cs,omega, &
             T,betac,alpha,mjeans, ljeans, rhill,H/udist, T_irr,cs_irr,Q_irr,&
             log10(1.0/gamma_J), log10(1.0/gamma_Q)
     ENDDO
     ! End of loop over radius

  ENDDO
  ! End of loop over accretion rates

END PROGRAM sgd_grid


! ader_dg.f90
! author: sunder

!-----------------------------------------------------------------------
! Main module containing all the necessary data structures
!-----------------------------------------------------------------------

module ader_dg

    implicit none
    public

    ! ---------------------------------------------------------------------------------------------------------
    ! Can be modified by the user
    ! ---------------------------------------------------------------------------------------------------------

    integer, parameter  :: N = 4      ! Polynomial degree of our approximation in space and time
    integer, parameter  :: nDim = 2   ! The number of space dimensions that we actually want to simulate
    real, parameter     :: CFL = 0.9  ! The Courant-Friedrichs-Lewy number < 1
    real, parameter     :: m_pi = 4.0*atan(1.0)
    integer, parameter  :: nVar = 9   ! The number of variables of the PDE system

    ! ---------------------------------------------------------------------------------------------------------
    ! Do not change beyond this point
    ! ---------------------------------------------------------------------------------------------------------

    ! The following variables contain important information about the numerical method.

    real, parameter :: PNPMTable(0:9) = (/ 1.0, 0.33, 0.17, 0.1, 0.069, 0.045,  0.038, 0.03, 0.02, 0.015 /)   ! maximum CFL numbers for PNPM schemes
    integer         :: nDOF(0:2)                           ! The number of degrees of freedom in space and time
    real            :: xiGPN(N+1), wGPN(N+1)               ! The Gauss-Legendre quadrature nodes and weights
    real            :: xin(N+1)                            ! The nodes used for our basis (can in principle be different from the Gauss-Legendre nodes, like for example also the bad Gauss-Lobatto nodes)
    real            :: MM(N+1,N+1), iMM(N+1,N+1)           ! Element mass-matrix and its inverse
    real            :: Kxi(N+1,N+1), dudx(N+1,N+1)         ! Element stiffness matrix and discrete derivative operator
    real            :: FLm(N+1,N+1), FLp(N+1,N+1)          ! Left flux matrices
    real            :: FRm(N+1,N+1), FRp(N+1,N+1)          ! Right flux matrices
    real            :: FLcoeff(N+1), FRcoeff(N+1)          ! extrapolation coefficients to the left and right boundary
    real            :: F0(N+1), F1(N+1,N+1)                ! Time flux matrices
    real            :: K1(N+1,N+1), iK1(N+1,N+1)           ! F1 - Ktau

    ! Stuff related to the problem setup, mesh and output

    integer              :: IMAX, JMAX                     ! Number of cells in each space dimension
    integer              :: nElem, nFace, nNode            ! Number of elements, faces and nodes
    integer              :: timestep                       ! Number of the current time step
    integer              :: WriteInterval                  ! Number of time steps after which to write output data
    real                 :: xL(nDim), xR(nDim)             ! Computational domain
    real                 :: dx(nDim), dt                   ! Vector of mesh spacings in each dimension and the time step
    real                 :: time, tend                     ! Current time  and final time
    real, pointer        :: x(:,:,:)                       ! Coordinates of cell centers
    integer, parameter   :: nVtx = 2**nDim, nFac = 2*nDim  ! Number of vertices and faces per element
    integer              :: ICType                         ! Type of initial condition to be used
    integer              :: bL, bR, bB, bT                     ! Boundary conditions on the left, right, bottom and top of the domain
    character(len=200)   :: BaseFile                       ! Basic filename to write the results

    ! Some diagnostics                                        !
    real               :: tCPU1, tCPU2                        ! CPU times
    integer(8)         :: TEU                                 ! total element updates

    ! Data needed for the subcell limiter

    integer, parameter :: nSubLim = 2*N+1             ! Number of subcells
    integer            :: nSubLimV(nDim)              ! Vector for number of subcells in each dimension
    real, pointer      :: uh2lim(:,:), lim2uh(:,:)    ! Mapping from DG polynomials to the subcells and back
    real, pointer      :: uh2lob(:,:)                 ! Mapping from the DG polynomials to the Gauss-Lobatto points
    real               :: xiLob(N+1), wLob(N+1)       ! Gauss lobatto points and weights
    integer, pointer   :: neighbor(:,:,:,:,:)         ! Set of Voronoi neighbors of a cell
    real, pointer      :: olduh(:,:,:,:,:)            ! for the a posteriori limiter, we need the possibility to go back
    integer, pointer   :: recompute(:,:)              ! Map containing the troubled zones that need to be recomputed
    real               :: xilimbary(nSubLim)          ! Barycenters of the subcells
    integer            :: Face2Neigh(2,4)             ! Mapping from face to neighbor index
    integer            :: dn(2)                       ! number of direct neighbors in each dimension

    type tLimiter
    integer        :: status, oldstatus
    real, pointer  :: Lh(:,:,:)
    real, pointer  :: NewLh(:,:,:)
    real           :: lmin(nVar), lmax(nVar)
    real           :: lmin_old(nVar), lmax_old(nVar)
    end type tLimiter

    type(tLimiter), pointer :: Limiter(:,:)

    ! The main variables of the ADER-DG scheme

    real, pointer  :: uh(:,:,:,:,:)               ! Coefficients of the DG polynomial
    real, pointer  :: wh(:,:,:)                   ! Cell average values of primitive variables
    real, pointer  :: duh(:,:,:,:,:)              ! Update coefficients of the DG polynomial
    real, pointer  :: qhi(:,:,:,:,:)              ! Time-averaged coefficients of the space-time predictor
    real, pointer  :: Fhi(:,:,:,:,:,:)            ! Time-averaged coefficients of the flux tensor of the space-time predictor
    real, pointer  :: Shi(:,:,:,:,:)              ! Time-averaged coefficients of source of the space-time predictor
    real, pointer  :: qbnd(:,:,:,:,:)             ! Boundary-extrapolated data for the state vector Q in the element
    real, pointer  :: Fbnd(:,:,:,:,:)             ! Boundary-extrapolated data for the normal flux F in the element
    real, pointer  :: Fp(:,:,:,:)                 ! +ve fluctuation flux in the x-direction
    real, pointer  :: Fm(:,:,:,:)                 ! -ve fluctuation flux in the x-direction
    real, pointer  :: Gp(:,:,:,:)                 ! +ve fluctuation flux in the y-direction
    real, pointer  :: Gm(:,:,:,:)                 ! -ve fluctuation flux in the y-direction

    ! Important info and parameters concerning the governing PDE system

    type tEquations
        real :: GAMMA_S, GAMMA_G, PI_S, PI_G
    end type tEquations

    type(tEquations)   :: EQN

end module ader_dg


C****************************************************************************
C WAVETEST: Example Fortran program for WAVELET, using NINO3 SST dataset
C
C COMPILE:   f77 chisqr.f cfftpack.f wavelet.f wavetest.f
C
C See "http://paos.colorado.edu/research/wavelets/"
C
C  Copyright (C) 1998, Christopher Torrence and Gilbert P. Compo
C This software may be used, copied, or redistributed as long as it is not
C sold and this copyright notice is reproduced on each copy made.  This
C routine is provided as is without any express or implied warranties
C whatsoever.
C
C Modified: November 1999 by Arjan van Dijk to include IMPLICIT NONE and
C           to convert all routines to DOUBLE precision.
C****************************************************************************

      PROGRAM wavetest

      IMPLICIT none

      INTEGER n,subscale,jtot
      DOUBLE PRECISION dt,s0,dj

C these parameters depend on the particular time series
      PARAMETER (n=504,dt=0.25D0,s0=dt)
      PARAMETER (subscale=4)
      PARAMETER (dj=1.D0/subscale,jtot=11*subscale)
C Note: for accurate reconstruction and wavelet-derived variance
C     do not pad with zeroes, set s0=dt (for Paul set s0=dt/4), and use
C     a large "jtot" (even though the extra scales will be within
C     the cone of influence).
C     For plotting purposes, it is only necessary to use
C     s0=2dt (for Morlet) and "jtot" from Eqn(10) Torrence&Compo(1998).

      INTEGER mother,ibase2,npad
      DOUBLE PRECISION sst(n),recon_sst(n),param,pi
      DOUBLE PRECISION scale(jtot),period(jtot),coi(n)
      DOUBLE COMPLEX wave(n,jtot)

      INTEGER i,j,isigtest,javg1,javg2
      DOUBLE PRECISION lag1,siglvl,dof(jtot)
      DOUBLE PRECISION fft_theor(jtot),signif(jtot),ymean,variance
      DOUBLE PRECISION recon_mean,recon_vari
      DOUBLE PRECISION Cdelta,psi0
      DOUBLE PRECISION global_ws(jtot),global_signif(jtot)
      DOUBLE PRECISION savg_dof(jtot),savg_signif(jtot),sstENSO(n)

      pi = 4.D0*ATAN(1.D0)
      ibase2 = NINT(LOG(DBLE(n))/LOG(2.D0))+1
      npad = INT(2.D0**ibase2)
C      npad = n  ! this is for no padding with zeroes

C*************************************************** Wavelet transform

C** let the WAVELET subroutine choose the defaults for these:
      mother = 0
      param = 6.D0

C** read in the NINO3 SST data
      OPEN(UNIT=11,FILE='sst_nino3.dat',STATUS='old')
      READ(11,*) sst
      CLOSE(11)
      PRINT'(/,"sst(1)=",F6.2,"  sst(n) = ",F6.2,/)',sst(1),sst(n)

C** get the wavelet transform
      CALL WAVELET(n,sst,dt,mother,param,s0,dj,jtot,npad,
     &             wave,scale,period,coi)

C*************************************************** Significance testing

C** local significance test
      isigtest = 0
      lag1 = 0.72D0
      siglvl = 0.05D0
      CALL WAVE_SIGNIF (isigtest,n,sst,dt,mother,param,dj,jtot,
     &       scale,period,lag1,siglvl,dof,fft_theor,signif,
     &       ymean,variance,Cdelta,psi0)

C** global wavelet spectrum & significance test
      isigtest = 1
      lag1 = 0.72D0
      siglvl = 0.05D0
      DO 10 j=1,jtot
        DO 20 i=1,n
          global_ws(j) = global_ws(j) + ABS(wave(i,j))**2
20      CONTINUE
        global_ws(j) = global_ws(j)/n
        dof(j) = n - scale(j)
10    CONTINUE

      CALL WAVE_SIGNIF (isigtest,n,sst,dt,mother,param,dj,jtot,
     &       scale,period,lag1,siglvl,dof,fft_theor,global_signif,
     &       ymean,variance,Cdelta,psi0)

C** scale-average time series & significance test
      isigtest = 2
      lag1 = 0.72D0
      siglvl = 0.05D0
C    scale average between 2 and 7.9 years
      savg_dof(1) = 2.0D0
      savg_dof(2) = 7.9D0
C    find the "j"-values that correspond to savg_dof(1) & savg_dof(2)
      javg1 = 0
      javg2 = 0
      DO 30 j=1,jtot
        IF ((scale(j).GE.savg_dof(1)).AND.(javg1.EQ.0)) javg1 = j
        IF (scale(j).LE.savg_dof(2)) javg2 = j
30    CONTINUE
C   call wave_signif first, to get the value of "Cdelta"
      CALL WAVE_SIGNIF (isigtest,n,sst,dt,mother,param,dj,jtot,
     &     scale,period,lag1,siglvl,savg_dof,fft_theor,savg_signif,
     &     ymean,variance,Cdelta,psi0)
C   construct the scale-averaged time series [Eqn(24)]
      DO 50 i=1,n
        sstENSO(i) = 0.D0
        DO 60 j=javg1,javg2
          sstENSO(i) = sstENSO(i) + (ABS(wave(i,j))**2)/scale(j)
60      CONTINUE
        sstENSO(i) = dj*dt*sstENSO(i)/Cdelta
50    CONTINUE

C************************************************************* print results
      PRINT*,' n=',n
      PRINT*,' dt=',dt
      PRINT*,' mother=',mother
      PRINT*,' param=',param
      PRINT*,' s0=',s0
      PRINT*,' dj=',dj
      PRINT*,' jtot=',jtot
      PRINT*,' npad=',npad
      PRINT'(/,"Let w = wave(n/2,j)",/)'
      PRINT'(A4,7A10)',"j","Scale","Period","ABS(w)^2","phase(w)",
     &  "5%signif","Global","GWS5%sig"
      PRINT'(I4,7F10.3)',(j,scale(j),period(j),
     &   ABS(wave(n/2,j))**2,
     &   ATAN2(DIMAG(wave(n/2,j)),DBLE(wave(n/2,j)))*180.D0/pi,
     &   signif(j),global_ws(j),global_signif(j),j=1,jtot)
      PRINT'(/,A,F10.3)',
     &    ' Scale-average degrees of freedom = ',savg_dof(1)
      PRINT'(A,F10.3,/)',
     &    ' Scale-avg 5% significance level  = ',savg_signif(1)

C************************************************************ Reconstruction

C** construct the wavelet derived variance (Parseval's theorem)  [Eqn(14)]
C   Cdelta & psi0 are returned from WAVE_SIGNIF
      recon_vari = 0.D0
      DO 900 i=1,n
        DO 1000 j=1,jtot
          recon_vari = recon_vari + (ABS(wave(i,j))**2)/scale(j)
1000    CONTINUE
900   CONTINUE
      recon_vari = dj*dt*recon_vari/(Cdelta*n)
      PRINT'(A,F14.5)',' Reconstructed variance=',recon_vari
      PRINT'(A,F14.5)',' Original variance   =',variance
      PRINT'(A,F14.5,A,/)',' Ratio = ',recon_vari/variance,
     &     ' (this is low due to padding with zeroes)'

C** reconstruct the time series [Eqn(11)]
C   check mean and RMS difference of reconstructed time series
      recon_mean=0.D0
      recon_vari = 0.D0
      DO 1100 i=1,n
        recon_sst(i)=0.D0
        DO 1200 j=1,jtot
          recon_sst(i) = recon_sst(i)+(DBLE(wave(i,j)))/SQRT(scale(j))
1200    CONTINUE
        recon_sst(i) = dj*SQRT(dt)*recon_sst(i)/(Cdelta*psi0)
        recon_vari = recon_vari+(sst(i)-ymean-recon_sst(i))**2
        recon_mean = recon_mean + recon_sst(i)
1100  CONTINUE
      recon_mean = recon_mean/n
      recon_vari = SQRT(recon_vari/n)

      PRINT'(A,F14.6)',' Reconstructed mean=',recon_mean
      PRINT'(A,F14.6)',' Original mean   =',ymean
      PRINT'(A,F14.6,/)',' Root-mean-square difference of time series=',
     &      recon_vari

      END


      SUBROUTINE ORDLEG(COA, IR, SX)
C
C THIS ROUTINE IS USED TO CALCULATE ORDINARY LEGENDRE POLYNOMIALS
C
C CALLED BY: GLATS
C CALLS:
C
C REVISIONS:
C 7-10-92 CHANGE TO CCM CODING CONVENTIONS (R. JAKOB)
C
C------------ Arguments ------------------------------------------------
C
C     Input
C
C COSINE OF COLATITUDE
      REAL COA
C WAVE NUMBER
      INTEGER IR
C
C     Output
C
C LEGENDRE POLYNOMIAL EVALUATED AT COA
      REAL SX
C
C------ Local Variables ------------------------------------------------
C
      REAL SQR2,DELTA,THETA,C1,FN,FN2,FN2SQ,ANG,S1,C4,A,B,FK
      INTEGER IRPP,IRPPM,N,N1,KK,K
C
C----- Executable Statements -------------------------------------------
C
      SQR2  = SQRT(2.)
      IRPP  = IR + 1
      IRPPM = IRPP - 1
      DELTA = ACOS(COA)
C
      THETA = DELTA
      C1    = SQR2
C
      DO 20 N = 1, IRPPM
         FN    = REAL(N)
         FN2   = 2.*FN
         FN2SQ = FN2*FN2
         C1    = C1* SQRT(1.0-1.0/FN2SQ)
   20 CONTINUE
C
      N   = IRPPM
      ANG = FN*THETA
      S1  = 0.0
      C4  = 1.0
      A   = -1.0
      B   = 0.0
      N1  = N+1
C
      DO 30 KK = 1, N1, 2
         K = KK-1
         IF (K .EQ. N) C4 = 0.5*C4
         S1  = S1+C4* COS(ANG)
         A   = A+2.0
         B   = B+1.0
         FK  = REAL(K)
         ANG = THETA*(FN-FK-2.0)
         C4  = (A*(FN-B+1.0)/(B*(FN2-A)))*C4
   30 CONTINUE
C
      SX = S1*C1
C
      RETURN
      END


submodule(euler_interface_m) euler_prob_0015_m
    implicit none

contains

    module character(len=20) function euler0015()
        write (euler0015, "(i20)") ans(20_int64)
    end function euler0015

    integer(int64) function ans(n)
        integer(int64), intent(in) :: n
        integer(int64) :: i, tmp

        tmp = 1_int64
        do i = 1_int64, n
            tmp = tmp*(n + i)/i
        end do
        ans = tmp
    end function ans

end submodule euler_prob_0015_m


c     program DRSRANE
c>> 2001-05-22 DRSRANE  Krogh Minor change for making .f90 version.
c>> 1996-05-28 DRSRANE  Krogh Added external statement.
c>> 1994-10-19 DRSRANE  Krogh  Changes to use M77CON
c>> 1987-12-09 DRSRANE  Lawson  Initial Code.
c--S replaces "?": DR?RANE, ?RANE, ?STAT1, ?STAT2
c
c     Driver to demonstrate use of SRANE to generate random numbers
c     from the exponential distribution with standard deviation, STDDEV.
c     Program computes histogram for N numbers
c     ------------------------------------------------------------------
      integer I, NCELLS
      parameter(NCELLS = 12+2)
      integer IHIST(NCELLS), N
      external SRANE
      real              SRANE, STATS(5), STDDEV, Y1, Y2, YTAB(1), ZERO
c
      parameter(ZERO = 0.0E0)
      data N / 10000 /
      data Y1, Y2 / 0.0E0, 6.0E0 /
      data STDDEV / 1.0E0 /
c     ------------------------------------------------------------------
      STATS(1) = ZERO
      do 20 I = 1, N
c                             Get random number
        YTAB(1) = SRANE(STDDEV)
c                          Accumulate statistics and histogram.
c
        call SSTAT1(YTAB(1), 1, STATS, IHIST, NCELLS, Y1, Y2)
   20 continue
c
      print '(11x,a)','Exponential random numbers from SRANE'
      print '(11x,a,g12.4,/1x)','with STDDEV = ',STDDEV
c
c                          Print the statistics and histogram.
c
      call SSTAT2(STATS, IHIST, NCELLS, Y1, Y2)
      stop
      end


!!# FUNCTION MODULE <<FUN_xyLIN2>>
MODULE FUN_xyLIN2

!!## PURPOSE
!! Return a linear function in 2D, <Lin2>.

!!## DETAILS
!! The function is stored as <Lin2=(a,b,c)> where
!!
!! $$ f(x,y) = a + b x + c y. $$

!!## EXTERNAL MODULES
USE FUN_Error                                   !!((04-A-FUN_Error.f90))
USE INT_LAPACK2                                 !!((08-B-INT_LAPACK2.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## PROCEDURE OVERLOADING
INTERFACE xyLIN2_Tr
 MODULE PROCEDURE xyLIN2_Tr_Rsp
 MODULE PROCEDURE xyLIN2_Tr_Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: xyLIN2_Tr

!!## CONTAINED PROCEDURES
CONTAINS

!!### FUNCTION <<xyLIN2_Tr_Rsp>>
FUNCTION xyLIN2_Tr_Rsp( Tr , Fv ) RESULT(Lin2)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rsp                           !!((02-A-PAR_Constants_Rsp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "09-C-FUN_xyLIN2_Tr.f90.hdr"
!!--begin--
INCLUDE "09-C-FUN_xyLIN2_Tr.f90.bdy"
!!--end--
END FUNCTION

!!### FUNCTION <<xyLIN2_Tr_Rdp>>
FUNCTION xyLIN2_Tr_Rdp( Tr , Fv ) RESULT(Lin2)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rsp                           !!((02-A-PAR_Constants_Rsp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "09-C-FUN_xyLIN2_Tr.f90.hdr"
!!--begin--
INCLUDE "09-C-FUN_xyLIN2_Tr.f90.bdy"
!!--end--
END FUNCTION

END MODULE


program funcDemo
    use elemFunc

    real :: a = 20.0, b = 30.0, c
    real, dimension(5) :: x = (/ 1.0, 2.0, 3.0, 4.0, 5.0 /), y = (/ 32.0, 16.0, 8.0, 4.0, 2.0 /), z

    c = multiply(a,b)     ! works with either function definition above

    z = multiply(x,y)     ! element-wise invocation only works with elemental function
end program funcDemo


!  *********************************************************************
!  *                                                                   *
!  *                         subroutine chknxe                         *
!  *                                                                   *
!  *********************************************************************
!  Single Precision Version 1.2
!  Written by Gordon A. Fenton, TUNS, Jul 16, 1999
!  Latest Update: Oct 17, 2002
!
!  PURPOSE	checks nxe and nye to ensure that they are compatible with
!		random fields produced by LAS2G
!
!  DESCRIPTION
!  This routine checks nxe and nye to ensure that they can be written in the
!  form;
!		nxe = k1*(2**m)
!		nye = k2*(2**m)
!
!  If not, nxe and nye are adjusted upwards until they do satisfy the above
!  equations for some non-negative integer m and positive integers (k1,k2)
!  with k1*k2 <= MXK.
!
!  ARGUMENTS
!
!   istat	unit number connected to a file to which error and warning
!		messages can be issued. (input)
!
!   iterm	unit number connected to the screen. If verbos is true, then
!		error and warning messages are also sent to the screen. (input)
!
!  verbos	logical flag which is true if error, warning, and progress
!		messages are allowed to be sent to the screen. (input)
!
!     nxe	integer giving the number of elements describing the soil
!		mass in the x-direction (horizontally). (input)
!
!     nye	integer giving the number of elements describing the soil
!		mass in the y-direction (vertically). (input)
!
!    nrfx	integer giving the number of cells in the x-direction in the
!		simulated random field. This is normally equal to nxe, but if
!		nxe is not an integer of the form nxe = k1*(2**m), where m is
!		a non-negative integer, and k1 is a positive integer with
!		k1*k2 < MXK (see below) then nrfx is set to the next larger
!		possible integer that does satisfy this requirement of LAS2G.
!		(output)
!
!    nrfy	integer giving the number of cells in the y-direction in the
!		simulated random field. This is normally equal to nye, but if
!		nye is not an integer of the form nye = k2*(2**m), where m is
!		a non-negative integer, and k2 is a positive integer with
!		k1*k2 < MXK (see below) then nrfy is set to the next larger
!		possible integer that does satisfy this requirement of LAS2G.
!		(output)
!
!  PARAMETERS:
!  MXK	maximum value that k1*k2 can be. This should be identical to that
!	prescribed in GAF77 library routine last2g.f.
!
!  REVISION HISTORY:
!  1.01	corrected truncated documentation above (Mar 1/02)
!  1.1	separated RF size from FEM size (Jul 23/02)
!  1.2	added data statement for zero (Oct 17/02)
!-----------------------------------------------------------------------
      subroutine chknxe(istat,iterm,verbos,nxe,nye,nrfx,nrfy)
      parameter (MXK = 256)
      logical verbos
      data zero/0.0/, half/0.5/, pt9/0.99999/, two/2.0/

   1  format(a)
!					compute minimum m
      aa = float(nxe*nye)/float(MXK)
      am = alog(aa)/(two*alog(two))
      if( am .lt. zero ) am = zero
      m  = int(am + pt9)		! round m up
      tm = two**m
!					now compute minimum k's
      ak1 = float(nxe)/tm
      k1  = int(ak1 + pt9)
      ak2 = float(nye)/tm
      k2  = int(ak2 + pt9)
!					new random field dimensions
      nrfx = k1*int(tm + half)
      nrfy = k2*int(tm + half)
!					note if we're changing anything

      if( (nrfx .ne. nxe) .or. (nrfy .ne. nye) ) then
         if( verbos ) then
            call print2(iterm,                                            &
              'Note: provided number of elements (%i, %i)%n',nxe,nye)
            write(iterm,1)'         incompatible with LAS2G simulator.'
            call print2(iterm,                                            &
              '      Adjusting random field size to (%i, %i)%n',          &
                        nrfx,nrfy)
         endif
         call print2(istat,                                               &
           'Note: provided number of elements (%i, %i)%n',nxe,nye)
         write(istat,1)'         incompatible with LAS2G simulator.'
         call print2(istat,                                               &
           '      Adjusting random field size to (%i, %i)%n',             &
                     nrfx,nrfy)
      endif

      return
      end


C Copyright (C) 2002, Carnegie Mellon University and others.
C All Rights Reserved.
C This code is published under the Common Public License.

      subroutine MODEL_F( NZ, NY, NU, NP, T, Z, ZDOT, Y, U, P, F )
C
C     Model of Roscoe's Tank
C     Andreas Waechter  05-25-00
C                       08-25-01  Fortran model version
C
      implicit none

      integer NZ, NY, NU, NP
      double precision T        ! Time
      double precision Z(NZ)    ! Differential variables
      double precision ZDOT(NZ) ! Derivatives of differential variables
      double precision Y(NY)    ! Algebraic variables
      double precision U(NU)    ! Control Variables
      double precision P(NP)    ! Parameters (might be subject to disturbances)
      double precision F(NZ+NY) ! RHS od DAE system
C
C     names for variables
C
      double precision h, hdot, hbar, pres, p_atm, F0, F1, rho, g
      double precision Area, CV

      integer l_z, l_y, l_u, l_p, l_ae, l_de

C =============================================================================
C
C                           Constants in model
C
C =============================================================================

      include 'TANK_CONSTS.INC'

C =============================================================================
C
C                  Copy Z, Y, U, P into variables with names
C
C =============================================================================

C
C     Initialize counters for variables
C
      l_z  = 0
      l_y  = 0
      l_p  = 0
      l_u  = 0
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C                           Differential Variables
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      l_z  = l_z + 1
      h    = Z   (l_z)
      hdot = ZDOT(l_z)
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C                            Algebraic Variables
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      l_y  = l_y + 1
      F1   = Y(l_y)
C
      l_y  = l_y + 1
      pres = Y(l_y) * 0.1d6
C
      l_y  = l_y + 1
      hbar = Y(l_y)
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C                             Control Variables
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      l_u  = l_u + 1
      CV   = U(l_u)
C
C =============================================================================
C
C                                  M O D E L
C
C =============================================================================
C
C
C     Initialize counters for equations
C
      l_de = 0
      l_ae = NZ
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C                            Differential Equations
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      l_de     = l_de + 1
      F(l_de)  = (F0-F1)/Area - hdot
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C                             Algebraic Equations
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      l_ae     = l_ae + 1
      F(l_ae)  = F1**2 - (CV**2)*(pres-p_atm)
C
      l_ae     = l_ae + 1
      F(l_ae)  = (pres - p_atm - rho*g*h) / 0.1d6
C
      l_ae     = l_ae + 1
      F(l_ae)  = h - hbar
C
      return
      end


!*==dsgesv.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  DSGESV computes the solution to system of linear equations A * X = B for GE matrices (mixed precision with iterative refinement)
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DSGESV + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DSGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK,
!                          SWORK, ITER, INFO )
!
!       .. Scalar Arguments ..
!       INTEGER            INFO, ITER, LDA, LDB, LDX, N, NRHS
!       ..
!       .. Array Arguments ..
!       INTEGER            IPIV( * )
!       REAL               SWORK( * )
!       DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), WORK( N, * ),
!      $                   X( LDX, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DSGESV computes the solution to a real system of linear equations
!>    A * X = B,
!> where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
!>
!> DSGESV first attempts to factorize the matrix in SINGLE PRECISION
!> and use this factorization within an iterative refinement procedure
!> to produce a solution with DOUBLE PRECISION normwise backward error
!> quality (see below). If the approach fails the method switches to a
!> DOUBLE PRECISION factorization and solve.
!>
!> The iterative refinement is not going to be a winning strategy if
!> the ratio SINGLE PRECISION performance over DOUBLE PRECISION
!> performance is too small. A reasonable strategy should take the
!> number of right-hand sides and the size of the matrix into account.
!> This might be done with a call to ILAENV in the future. Up to now, we
!> always try iterative refinement.
!>
!> The iterative refinement process is stopped if
!>     ITER > ITERMAX
!> or for all the RHS we have:
!>     RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX
!> where
!>     o ITER is the number of the current iteration in the iterative
!>       refinement process
!>     o RNRM is the infinity-norm of the residual
!>     o XNRM is the infinity-norm of the solution
!>     o ANRM is the infinity-operator-norm of the matrix A
!>     o EPS is the machine epsilon returned by DLAMCH('Epsilon')
!> The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00
!> respectively.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of linear equations, i.e., the order of the
!>          matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in] NRHS
!> \verbatim
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is DOUBLE PRECISION array,
!>          dimension (LDA,N)
!>          On entry, the N-by-N coefficient matrix A.
!>          On exit, if iterative refinement has been successfully used
!>          (INFO = 0 and ITER >= 0, see description below), then A is
!>          unchanged, if double precision factorization has been used
!>          (INFO = 0 and ITER < 0, see description below), then the
!>          array A contains the factors L and U from the factorization
!>          A = P*L*U; the unit diagonal elements of L are not stored.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[out] IPIV
!> \verbatim
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices that define the permutation matrix P;
!>          row i of the matrix was interchanged with row IPIV(i).
!>          Corresponds either to the single precision factorization
!>          (if INFO = 0 and ITER >= 0) or the double precision
!>          factorization (if INFO = 0 and ITER < 0).
!> \endverbatim
!>
!> \param[in] B
!> \verbatim
!>          B is DOUBLE PRECISION array, dimension (LDB,NRHS)
!>          The N-by-NRHS right hand side matrix B.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!> \endverbatim
!>
!> \param[out] X
!> \verbatim
!>          X is DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          If INFO = 0, the N-by-NRHS solution matrix X.
!> \endverbatim
!>
!> \param[in] LDX
!> \verbatim
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is DOUBLE PRECISION array, dimension (N,NRHS)
!>          This array is used to hold the residual vectors.
!> \endverbatim
!>
!> \param[out] SWORK
!> \verbatim
!>          SWORK is REAL array, dimension (N*(N+NRHS))
!>          This array is used to use the single precision matrix and the
!>          right-hand sides or solutions in single precision.
!> \endverbatim
!>
!> \param[out] ITER
!> \verbatim
!>          ITER is INTEGER
!>          < 0: iterative refinement has failed, double precision
!>               factorization has been performed
!>               -1 : the routine fell back to full precision for
!>                    implementation- or machine-specific reasons
!>               -2 : narrowing the precision induced an overflow,
!>                    the routine fell back to full precision
!>               -3 : failure of SGETRF
!>               -31: stop the iterative refinement after the 30th
!>                    iterations
!>          > 0: iterative refinement has been successfully used.
!>               Returns the number of iterations
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i, U(i,i) computed in DOUBLE PRECISION is
!>                exactly zero.  The factorization has been completed,
!>                but the factor U is exactly singular, so the solution
!>                could not be computed.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2016
!
!> \ingroup doubleGEsolve
!
!  =====================================================================
      SUBROUTINE DSGESV(N,Nrhs,A,Lda,Ipiv,B,Ldb,X,Ldx,Work,Swork,Iter,  &
     &                  Info)
      IMPLICIT NONE
!*--DSGESV199
!
!  -- LAPACK driver 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..--
!     June 2016
!
!     .. Scalar Arguments ..
      INTEGER Info , Iter , Lda , Ldb , Ldx , N , Nrhs
!     ..
!     .. Array Arguments ..
      INTEGER Ipiv(*)
      REAL Swork(*)
      DOUBLE PRECISION A(Lda,*) , B(Ldb,*) , Work(N,*) , X(Ldx,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      LOGICAL DOITREF
      PARAMETER (DOITREF=.TRUE.)
!
      INTEGER ITERMAX
      PARAMETER (ITERMAX=30)
!
      DOUBLE PRECISION BWDMAX
      PARAMETER (BWDMAX=1.0E+00)
!
      DOUBLE PRECISION NEGONE , ONE
      PARAMETER (NEGONE=-1.0D+0,ONE=1.0D+0)
!
!     .. Local Scalars ..
      INTEGER i , iiter , ptsa , ptsx
      DOUBLE PRECISION anrm , cte , eps , rnrm , xnrm
!
!     .. External Subroutines ..
      EXTERNAL DAXPY , DGEMM , DLACPY , DLAG2S , DGETRF , DGETRS ,      &
     &         SGETRF , SGETRS , SLAG2D , XERBLA
!     ..
!     .. External Functions ..
      INTEGER IDAMAX
      DOUBLE PRECISION DLAMCH , DLANGE
      EXTERNAL IDAMAX , DLAMCH , DLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , DBLE , MAX , SQRT
!     ..
!     .. Executable Statements ..
!
      Info = 0
      Iter = 0
!
!     Test the input parameters.
!
      IF ( N<0 ) THEN
         Info = -1
      ELSEIF ( Nrhs<0 ) THEN
         Info = -2
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -4
      ELSEIF ( Ldb<MAX(1,N) ) THEN
         Info = -7
      ELSEIF ( Ldx<MAX(1,N) ) THEN
         Info = -9
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('DSGESV',-Info)
         RETURN
      ENDIF
!
!     Quick return if (N.EQ.0).
!
      IF ( N==0 ) RETURN
!
!     Skip single precision iterative refinement if a priori slower
!     than double precision factorization.
!
      IF ( .NOT.DOITREF ) THEN
         Iter = -1
         GOTO 300
      ENDIF
!
!     Compute some constants.
!
      anrm = DLANGE('I',N,N,A,Lda,Work)
      eps = DLAMCH('Epsilon')
      cte = anrm*eps*SQRT(DBLE(N))*BWDMAX
!
!     Set the indices PTSA, PTSX for referencing SA and SX in SWORK.
!
      ptsa = 1
      ptsx = ptsa + N*N
!
!     Convert B from double precision to single precision and store the
!     result in SX.
!
      CALL DLAG2S(N,Nrhs,B,Ldb,Swork(ptsx),N,Info)
!
      IF ( Info/=0 ) THEN
         Iter = -2
         GOTO 300
      ENDIF
!
!     Convert A from double precision to single precision and store the
!     result in SA.
!
      CALL DLAG2S(N,N,A,Lda,Swork(ptsa),N,Info)
!
      IF ( Info/=0 ) THEN
         Iter = -2
         GOTO 300
      ENDIF
!
!     Compute the LU factorization of SA.
!
      CALL SGETRF(N,N,Swork(ptsa),N,Ipiv,Info)
!
      IF ( Info/=0 ) THEN
         Iter = -3
         GOTO 300
      ENDIF
!
!     Solve the system SA*SX = SB.
!
      CALL SGETRS('No transpose',N,Nrhs,Swork(ptsa),N,Ipiv,Swork(ptsx), &
     &            N,Info)
!
!     Convert SX back to double precision
!
      CALL SLAG2D(N,Nrhs,Swork(ptsx),N,X,Ldx,Info)
!
!     Compute R = B - AX (R is WORK).
!
      CALL DLACPY('All',N,Nrhs,B,Ldb,Work,N)
!
      CALL DGEMM('No Transpose','No Transpose',N,Nrhs,N,NEGONE,A,Lda,X, &
     &           Ldx,ONE,Work,N)
!
!     Check whether the NRHS normwise backward errors satisfy the
!     stopping criterion. If yes, set ITER=0 and return.
!
      DO i = 1 , Nrhs
         xnrm = ABS(X(IDAMAX(N,X(1,i),1),i))
         rnrm = ABS(Work(IDAMAX(N,Work(1,i),1),i))
         IF ( rnrm>xnrm*cte ) GOTO 100
      ENDDO
!
!     If we are here, the NRHS normwise backward errors satisfy the
!     stopping criterion. We are good to exit.
!
      Iter = 0
      RETURN
!
!
 100  DO iiter = 1 , ITERMAX
!
!        Convert R (in WORK) from double precision to single precision
!        and store the result in SX.
!
         CALL DLAG2S(N,Nrhs,Work,N,Swork(ptsx),N,Info)
!
         IF ( Info/=0 ) THEN
            Iter = -2
            GOTO 300
         ENDIF
!
!        Solve the system SA*SX = SR.
!
         CALL SGETRS('No transpose',N,Nrhs,Swork(ptsa),N,Ipiv,          &
     &               Swork(ptsx),N,Info)
!
!        Convert SX back to double precision and update the current
!        iterate.
!
         CALL SLAG2D(N,Nrhs,Swork(ptsx),N,Work,N,Info)
!
         DO i = 1 , Nrhs
            CALL DAXPY(N,ONE,Work(1,i),1,X(1,i),1)
         ENDDO
!
!        Compute R = B - AX (R is WORK).
!
         CALL DLACPY('All',N,Nrhs,B,Ldb,Work,N)
!
         CALL DGEMM('No Transpose','No Transpose',N,Nrhs,N,NEGONE,A,Lda,&
     &              X,Ldx,ONE,Work,N)
!
!        Check whether the NRHS normwise backward errors satisfy the
!        stopping criterion. If yes, set ITER=IITER>0 and return.
!
         DO i = 1 , Nrhs
            xnrm = ABS(X(IDAMAX(N,X(1,i),1),i))
            rnrm = ABS(Work(IDAMAX(N,Work(1,i),1),i))
            IF ( rnrm>xnrm*cte ) GOTO 200
         ENDDO
!
!        If we are here, the NRHS normwise backward errors satisfy the
!        stopping criterion, we are good to exit.
!
         Iter = iiter
!
         RETURN
!
!
 200  ENDDO
!
!     If we are at this place of the code, this is because we have
!     performed ITER=ITERMAX iterations and never satisfied the
!     stopping criterion, set up the ITER flag accordingly and follow up
!     on double precision routine.
!
      Iter = -ITERMAX - 1
!
!
!     Single-precision iterative refinement failed to converge to a
!     satisfactory solution, so we resort to double precision.
!
 300  CALL DGETRF(N,N,A,Lda,Ipiv,Info)
!
      IF ( Info/=0 ) RETURN
!
      CALL DLACPY('All',N,Nrhs,B,Ldb,X,Ldx)
      CALL DGETRS('No transpose',N,Nrhs,A,Lda,Ipiv,X,Ldx,Info)
!
!
!     End of DSGESV.
!
      END SUBROUTINE DSGESV


c               Copyright 1993 Colorado State University
c                       All Rights Reserved

C ... RAMP.F

      double precision function ramp(x, x1, y1, x2, y2)

      implicit none

c ... Argument declarations
      double precision x, x1, y1, x2, y2

c ... This function models a "ramp":
c ...             /-----
c ...            /
c ...      -----/

c ... Function declarations
      double precision line
      external  line

      if (x .lt. x1) then
        ramp = y1
      else if (x .ge. x2) then
        ramp = y2
      else
        ramp = line(x, x1, y1, x2, y2)
c ..... where line = (y2 - y1) / (x2 - x1) * (x - x2) + y2
      endif

      return
      end


module svd

  implicit none

  private

  public :: solve_svd

contains

  subroutine solve_svd ( m, n, a, b, x )

    use kinddefs, only : dp

    integer,                  intent(in)  :: m
    integer,                  intent(in)  :: n
    real(dp), dimension(m,n), intent(in)  :: a
    real(dp), dimension(m),   intent(in)  :: b
    real(dp), dimension(n),   intent(out) :: x

    integer :: i
    integer :: lda, ldu, ldv, lwork, info

    real(dp),              dimension(m,n)        :: s
    real(dp),              dimension(n,m)        :: sp
    real(dp),              dimension(max(m+1,n)) :: sdiag
    real(dp),              dimension(n,m)        :: a_pseudo
    real(dp),              dimension(m,m)        :: u
    real(dp),              dimension(n,n)        :: v
    real(dp), allocatable, dimension(:)          :: work
    integer,  allocatable, dimension(:)          :: iwork

    integer clock1, clock2, clock_rate
    real(dp) time

    continue

    lda = m
    ldu = m
    ldv = n

    call system_clock(clock1, clock_rate)
    allocate ( iwork(8*min(m,n)) )
    lwork = 4*min(m,n)**2 + 6*min(m,n) + max(m,n)
    allocate ( work(1:lwork) )
    call dgesdd ( 'A', m, n, a, lda, sdiag, u, ldu, v, ldv, work,              &
                 lwork, iwork, info )
    call system_clock(clock2, clock_rate)
    time = dble(clock2-clock1) / clock_rate
    write(*,'("dgesdd:",g15.7," sec")') time
    if ( info /= 0 ) then
      write ( *, '(a)' ) '  The SVD could not be calculated.'
      write ( *, '(a)' ) '  Try rerunning with different nk.'
      stop
    end if

    s(:,:) = 0.d0
    do i = 1, min ( m, n )
      s(i,i) = sdiag(i)
    end do
    v = transpose ( v )
    sp(:,:) = 0.d0
    do i = 1, min ( m, n )
      if ( s(i,i) /= 0.d0 ) then
        sp(i,i) = 1.d0 / s(i,i)
      end if
    end do
    a_pseudo(:,:) = matmul ( v(:,:), matmul ( sp(:,:), transpose ( u(:,:) ) ) )
    x(:) = matmul ( a_pseudo(:,:), b(:) )

  end subroutine solve_svd

end module svd


module spherical_fourier_mod

!Balaji: parallel spectral model using transpose method

use fms_mod,         only: mpp_pe, mpp_root_pe, error_mesg, FATAL, write_version_number

use mpp_mod,         only: mpp_error

use mpp_domains_mod, only: domain1D, mpp_get_compute_domains, mpp_get_domain_components, mpp_get_layout

use   constants_mod, only: pi

use spec_mpp_mod,    only: get_grid_domain, grid_domain, get_spec_domain

use spherical_mod,   only: spherical_init, spherical_end,                &
                           compute_lon_deriv_cos, compute_lat_deriv_cos, &
                           compute_laplacian, compute_vor, compute_div,  &
                           get_spherical_wave, get_fourier_wave,         &
                           get_eigen_laplacian, compute_gradient_cos,    &
                           compute_ucos_vcos, compute_vor_div,           &
                           triangular_truncation, rhomboidal_truncation

use gauss_and_legendre_mod, only: compute_legendre, compute_gaussian

!-------------------------------------------------------------------------
!  provides latitudinal transforms from spherical harmonics to
!       (zonal fourier, latitude (gaussian) grid) space , and
!       related operations
!       works within the window provided by windows module
!
!       spherical fields are complex, dimension(0:num_fourier, 0:num_spherical)
!         where the zonal wavenumber of (m,n) is M = m*fourier_inc
!             the "meridional" wavenumber is n
!             the "total", 2D, spherical wavenumber L = M+n
!       "fourier fields" are complex, dimension(0:num_fourier, lat_max)
!
!------------------------------------------------------------------------

implicit none
private

character(len=128), parameter :: version = '$Id: spherical_fourier.f90,v 13.0 2006/03/28 21:18:33 fms Exp $'
character(len=128), parameter :: tagname = '$Name: latest $'

interface trans_spherical_to_fourier
   module procedure trans_spherical_to_fourier_3d,  &
                    trans_spherical_to_fourier_2d
end interface
interface trans_fourier_to_spherical
   module procedure trans_fourier_to_spherical_3d,  &
                    trans_fourier_to_spherical_2d
end interface

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

!  public interfaces defined in this module

public :: spherical_fourier_init, spherical_fourier_end
public :: trans_spherical_to_fourier, trans_fourier_to_spherical
public :: get_south_to_north
public :: get_sin_lat, get_cos_lat, get_cosm_lat, get_cosm2_lat
public :: get_deg_lat, get_wts_lat

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

!  public interfaces carried forward from used modules

public :: spherical_init, spherical_end
public :: compute_lon_deriv_cos, compute_lat_deriv_cos
public :: compute_laplacian, compute_vor, compute_div
public :: get_spherical_wave, get_fourier_wave
public :: get_eigen_laplacian, compute_gradient_cos
public :: compute_ucos_vcos, compute_vor_div
public :: triangular_truncation, rhomboidal_truncation

public :: compute_legendre, compute_gaussian

! ---------------------------------------------------
integer :: fourier_max
integer :: fourier_inc
logical :: south_to_north_local

integer :: lat_max
integer :: num_fourier
integer :: num_spherical

real, allocatable, dimension(:) :: sin_lat
real, allocatable, dimension(:) :: cos_lat
real, allocatable, dimension(:) :: cosm_lat
real, allocatable, dimension(:) :: cosm2_lat
real, allocatable, dimension(:) :: deg_lat
real, allocatable, dimension(:) :: wts_lat
real, allocatable, dimension(:) :: sin_hem
real, allocatable, dimension(:,:,:) :: legendre
real, allocatable, dimension(:,:,:) :: legendre_wts

type(domain1D),save :: grid_domain_y !used by the trans_s_f anfd f_s routines
integer :: grid_layout(2)
logical, private :: debug=.FALSE.

logical :: module_is_initialized = .false.
integer :: is, ie, js, je, ms, me, ns, ne

contains

!-----------------------------------------------------------------------
subroutine spherical_fourier_init(radius, lat_max_in, num_fourier_in, &
                   fourier_inc_in, num_spherical_in, south_to_north)
!-----------------------------------------------------------------------

real,    intent(in) :: radius
integer, intent(in) :: lat_max_in
integer, intent(in) :: num_fourier_in
integer, intent(in) :: fourier_inc_in
integer, intent(in) :: num_spherical_in
logical, intent(in), optional :: south_to_north

call write_version_number(version, tagname)

if(present(south_to_north)) then
  south_to_north_local = south_to_north
else
  south_to_north_local = .true.
end if

call get_grid_domain(is, ie, js, je)
call get_spec_domain(ms, me, ns, ne)

lat_max       = lat_max_in

fourier_inc   = fourier_inc_in
num_spherical = num_spherical_in
num_fourier   = num_fourier_in
fourier_max   = num_fourier*fourier_inc

call spherical_init(radius, num_fourier, fourier_inc, num_spherical)
call define_gaussian
call define_legendre

call mpp_get_domain_components( grid_domain, y=grid_domain_y )
call mpp_get_layout( grid_domain, grid_layout )
module_is_initialized = .true.

return
end subroutine spherical_fourier_init

!-------------------------------------------------------------------------
subroutine trans_spherical_to_fourier_3d(spherical,fourier)
!-------------------------------------------------------------------------

!in parallel, assumes that computational domains are being passed in.

  complex, intent(in),  dimension(ms:,ns:,:) :: spherical
  complex, intent(out), dimension(ms:,:,:,:) :: fourier

  complex :: x_odd, x_even

  integer :: m,n,j,k, num_levels

  integer :: neven, nodd
  integer :: jd, joff, nd, nj
  integer, dimension(grid_layout(2)) :: jstart

  if( size(spherical,1).ne.me-ms+1 )&
       call mpp_error( FATAL, 'TRANS_SPHERICAL_TO_FOURIER: size(spherical,1).NE.me-ms+1.' )
  if( size(spherical,2).NE.ne-ns+1 )&
       call mpp_error( FATAL, 'TRANS_SPHERICAL_TO_FOURIER: size(spherical,2).NE.ne-ns+1.' )
  if( size(fourier,2)*size(fourier,4).NE.lat_max ) &
       call mpp_error( FATAL, 'TRANS_SPHERICAL_TO_FOURIER: size(fourier,2)*size(fourier,4).NE.lat_max.' )

  num_levels = size(spherical,3)
  nd = grid_layout(2)   !also equal to size(fourier,4), could put in an error check
  nj = je-js+1 !this version requires grid domains equal in Y
  if( debug )write( 0,'(a,i2,2i4)' )'pe, nd, nj=', mpp_pe(), nd, nj

  if( mod(ns,2).EQ.0 )then
      neven = ns
      nodd = ns+1
  else
      nodd = ns
      neven = ns+1
  endif

  call mpp_get_compute_domains( grid_domain_y, begin=jstart(:) )
  DOMAIN_LOOP: do jd=1,nd/2+1
!each domain jd has a mirror domain nd+1-jd
!if nd is even we stop at jd=nd/2; if nd is odd we stop at j=nj/2
     if( jd.EQ.nd/2+1 .AND. mod(nd,2).EQ.0 )exit DOMAIN_LOOP
     joff = jstart(jd) - 1
     if( debug )write( 0,'(a,i2,2i4)' )'pe, jd, joff=', mpp_pe(), jd, joff
     do j = 1,nj
        if( jd.EQ.nd/2+1 .AND. j.GT.nj/2 )exit DOMAIN_LOOP
        if(south_to_north_local) then !how long are we going to keep carrying around S2N and N2S?
            do k=1,num_levels
               do m=ms,me
                  x_even = cmplx(0.,0.)
                  x_odd  = cmplx(0.,0.)

                  do n=neven,ne,2
                     x_even = x_even + spherical(m,n,k) * legendre(m,n,j+joff)
                  end do
                  do n=nodd,ne,2
                     x_odd  = x_odd  + spherical(m,n,k) * legendre(m,n,j+joff)
                  end do

                  fourier(m,     j,k,     jd) = x_even - x_odd
                  fourier(m,nj+1-j,k,nd+1-jd) = x_even + x_odd
               end do
            end do
        else
            do k=1,num_levels
               do m=ms,me
                  x_even = cmplx(0.,0.)
                  x_odd  = cmplx(0.,0.)

                  do n=neven,ne,2
                     x_even = x_even + spherical(m,n,k) * legendre(m,n,j+joff)
                  end do
                  do n=nodd,ne,2
                     x_odd  = x_odd  + spherical(m,n,k) * legendre(m,n,j+joff)
                  end do

                  fourier(m,     j,k,     jd) = x_even + x_odd
                  fourier(m,nj+1-j,k,nd+1-jd) = x_even - x_odd
               end do
            end do
        end if
     end do
  end do DOMAIN_LOOP

  return
end subroutine trans_spherical_to_fourier_3d

!-----------------------------------------------------------------------
subroutine trans_fourier_to_spherical_3d(fourier,spherical)
!-----------------------------------------------------------------------

  complex, intent (out), dimension(ms:,ns:,:) :: spherical
  complex, intent (in),  dimension(ms:,:,:,:) :: fourier

  integer :: k,j,m,n
!  complex, dimension(ms:me, size(spherical,3)) :: x_odd, x_even
  complex :: x_odd, x_even

  integer :: num_levels, nd, nj

  integer :: neven, nodd
  integer :: jd, joff
  integer, dimension(grid_layout(2)) :: jstart

  if( size(spherical,1).ne.me-ms+1 )&
       call mpp_error( FATAL, 'TRANS_SPHERICAL_TO_FOURIER: size(spherical,1).NE.me-ms+1.' )
  if( size(spherical,2).NE.ne-ns+1 )&
       call mpp_error( FATAL, 'TRANS_SPHERICAL_TO_FOURIER: size(spherical,2).NE.ne-ns+1.' )
  if( size(fourier,2)*size(fourier,4).NE.lat_max ) &
       call mpp_error( FATAL, 'TRANS_SPHERICAL_TO_FOURIER: size(fourier,2)*size(fourier,4).NE.lat_max.' )

  num_levels = size(spherical,3)
  nd = grid_layout(2)   !also equal to size(fourier,4), could put in an error check
  nj = je-js+1 !this version requires grid domains equal in Y

  if( mod(ns,2).EQ.0 )then
      neven = ns
      nodd = ns+1
  else
      nodd = ns
      neven = ns+1
  endif

  call mpp_get_compute_domains( grid_domain_y, begin=jstart(:) )
  spherical = cmplx(0.,0.)
  DOMAIN_LOOP: do jd=1,nd/2+1
!each domain jd has a mirror domain nd+1-jd
!if nd is even we stop at jd=nd/2; if nd is odd we stop at j=nj/2
     if( jd.EQ.nd/2+1 .AND. mod(nd,2).EQ.0 )exit DOMAIN_LOOP
     joff = jstart(jd) - 1
     do j = 1,nj
        if( jd.EQ.nd/2+1 .AND. j.GT.nj/2 )exit DOMAIN_LOOP
        if(south_to_north_local) then
            do k = 1,num_levels
               do m = ms,me
                  x_even = fourier(m,nj+1-j,k,nd+1-jd) + fourier(m,j,k,jd)
                  x_odd  = fourier(m,nj+1-j,k,nd+1-jd) - fourier(m,j,k,jd)
                  do n=neven,ne,2
                     spherical(m,n,k) = spherical(m,n,k) + x_even*legendre_wts(m,n,j+joff)
                  end do
                  do n=nodd, ne,2
                     spherical(m,n,k) = spherical(m,n,k) + x_odd *legendre_wts(m,n,j+joff)
                  end do
               end do
            enddo
        else
            do k = 1,num_levels
               do m = ms,me
                  x_even = fourier(m,j,k,jd) + fourier(m,nj+1-j,k,nd+1-jd)
                  x_odd  = fourier(m,j,k,jd) - fourier(m,nj+1-j,k,nd+1-jd)
                  do n=neven,ne,2
                     spherical(m,n,k) = spherical(m,n,k) + x_even*legendre_wts(m,n,j+joff)
                  end do
                  do n=nodd, ne,2
                     spherical(m,n,k) = spherical(m,n,k) + x_odd *legendre_wts(m,n,j+joff)
                  end do
               end do
            enddo
        end if
     end do
  end do DOMAIN_LOOP

  return
end subroutine trans_fourier_to_spherical_3d

!-------------------------------------------------------------------------
subroutine trans_spherical_to_fourier_2d(spherical,fourier)
!-------------------------------------------------------------------------

complex, intent(in),  dimension(:,:) :: spherical
complex, intent(out), dimension(:,:,:) :: fourier

complex, dimension(size(spherical,1), size(spherical,2), 1) :: spherical_3d
complex, dimension(size(fourier,1),   size(fourier,2),   1, size(fourier,3)) :: fourier_3d

spherical_3d(:,:,1) = spherical(:,:)
call trans_spherical_to_fourier_3d(spherical_3d,fourier_3d)
fourier(:,:,:) = fourier_3d(:,:,1,:)

return
end subroutine trans_spherical_to_fourier_2d

!-----------------------------------------------------------------------
subroutine trans_fourier_to_spherical_2d(fourier,spherical)
!-----------------------------------------------------------------------

complex, intent (in), dimension(:,:,:) :: fourier
complex, intent (out),  dimension(:,:) :: spherical

complex, dimension(size(spherical,1), size(spherical,2), 1) :: spherical_3d
complex, dimension(size(fourier,1),   size(fourier,2),   1, size(fourier,3)) :: fourier_3d

fourier_3d(:,:,1,:) = fourier(:,:,:)
call trans_fourier_to_spherical_3d(fourier_3d,spherical_3d)
spherical(:,:) = spherical_3d(:,:,1)

return
end subroutine trans_fourier_to_spherical_2d

!-----------------------------------------------------------------------
subroutine define_legendre
!-----------------------------------------------------------------------

integer j
real, dimension(0:num_fourier,0:num_spherical,lat_max/2) :: legendre_global

allocate(legendre(ms:me,ns:ne,lat_max/2))

allocate(legendre_wts(ms:me,ns:ne,lat_max/2))

call compute_legendre(legendre_global, num_fourier, fourier_inc, num_spherical, sin_hem, lat_max/2)
legendre = legendre_global(ms:me,ns:ne,:)

do j=1,lat_max/2
  legendre_wts(:,:,j) = legendre(:,:,j)*wts_lat(j)
end do

return
end subroutine define_legendre

!----------------------------------------------------------------------
subroutine define_gaussian
!----------------------------------------------------------------------

integer j
real, dimension(lat_max/2) :: wts_hem

allocate (sin_lat(lat_max))
allocate (cos_lat(lat_max))
allocate (cosm_lat(lat_max))
allocate (cosm2_lat(lat_max))
allocate (wts_lat(lat_max))
allocate (deg_lat(lat_max))
allocate (sin_hem(lat_max/2))

call compute_gaussian(sin_hem, wts_hem, lat_max/2)

if(south_to_north_local) then
   sin_lat(1:lat_max/2)   = - sin_hem
else
   sin_lat(1:lat_max/2)   =   sin_hem
end if

do j=1,lat_max/2
  sin_lat(lat_max+1-j) = - sin_lat(j)
  wts_lat(j)           =   wts_hem(j)
  wts_lat(lat_max+1-j) =   wts_hem(j)
end do

cos_lat   = sqrt(1-sin_lat*sin_lat)
cosm_lat  = 1./cos_lat
cosm2_lat = 1./(cos_lat*cos_lat)
deg_lat   = asin(sin_lat)*180.0/pi

return
end subroutine define_gaussian

!-----------------------------------------------------------------------
subroutine get_south_to_north(south_to_north_out)
!-----------------------------------------------------------------------

logical, intent (out) :: south_to_north_out

if(.not. module_is_initialized) then
  call error_mesg('get_south_to_north','failed to define package', FATAL)
end if

south_to_north_out = south_to_north_local

return
end subroutine get_south_to_north

!-----------------------------------------------------------------------
subroutine get_sin_lat(sin_lat_out)
!-----------------------------------------------------------------------

real, intent (out), dimension(:) :: sin_lat_out

if(.not. module_is_initialized) then
  call error_mesg('get_sin_lat','failed to define package', FATAL)
end if

if(size(sin_lat_out,1).eq.lat_max) then
    sin_lat_out = sin_lat
else                            !assume grid compute domain
    sin_lat_out = sin_lat(js:je)
end if

return
end subroutine get_sin_lat

!-----------------------------------------------------------------------
subroutine get_cos_lat(cos_lat_out)
!-----------------------------------------------------------------------

real, intent (out), dimension(:) :: cos_lat_out

if(.not. module_is_initialized) then
  call error_mesg('get_cos_lat','failed to define package', FATAL)
end if

if(size(cos_lat_out,1).eq.lat_max) then
    cos_lat_out = cos_lat
else                            !assume grid compute domain
    cos_lat_out = cos_lat(js:je)
end if

return
end subroutine get_cos_lat

!-----------------------------------------------------------------------
subroutine get_cosm_lat(cosm_lat_out)
!-----------------------------------------------------------------------

real, intent (out), dimension(:) :: cosm_lat_out

if(.not. module_is_initialized) then
  call error_mesg('get_cosm_lat','failed to define package', FATAL)
end if

if(size(cosm_lat_out,1).eq.lat_max) then
    cosm_lat_out = cosm_lat
else                            !assume grid compute domain
    cosm_lat_out = cosm_lat(js:je)
end if

return
end subroutine get_cosm_lat

!-----------------------------------------------------------------------
subroutine get_cosm2_lat(cosm2_lat_out)
!-----------------------------------------------------------------------

real, intent (out), dimension(:) :: cosm2_lat_out

if(.not. module_is_initialized) then
  call error_mesg('get_cosm2_lat','failed to define package', FATAL)
end if

if(size(cosm2_lat_out,1).eq.lat_max) then
    cosm2_lat_out = cosm2_lat
else                            !assume grid compute domain
    cosm2_lat_out = cosm2_lat(js:je)
end if

return
end subroutine get_cosm2_lat

!-----------------------------------------------------------------------
subroutine get_deg_lat(deg_lat_out)
!-----------------------------------------------------------------------

real, intent (out), dimension(:) :: deg_lat_out

if(.not. module_is_initialized) then
  call error_mesg('get_deg_lat','failed to define package', FATAL)
end if

if(size(deg_lat_out,1).eq.lat_max) then
    deg_lat_out = deg_lat
else                            !assume grid compute domain
    deg_lat_out = deg_lat(js:je)
end if

return
end subroutine get_deg_lat

!-----------------------------------------------------------------------
subroutine get_wts_lat(wts_lat_out)
!-----------------------------------------------------------------------

real, intent (out), dimension(:) :: wts_lat_out

if(.not. module_is_initialized) then
  call error_mesg('get_wts_lat','failed to define package', FATAL)
end if

if(size(wts_lat_out,1).eq.lat_max) then
    wts_lat_out = wts_lat
else                            !assume grid compute domain
    wts_lat_out = wts_lat(js:je)
end if

return
end subroutine get_wts_lat

!----------------------------------------------------------------------
subroutine spherical_fourier_end

if(.not. module_is_initialized) return

deallocate(sin_lat, cos_lat, cosm_lat, cosm2_lat, wts_lat, deg_lat)
deallocate(sin_hem, legendre, legendre_wts)
call spherical_end
module_is_initialized = .false.

return
end subroutine spherical_fourier_end
!----------------------------------------------------------------------
end module spherical_fourier_mod