submodule(forlab_stats) forlab_stats_mean

    implicit none

contains

    module procedure mean_1_sp
    mean = sum(x)/size(x)
    return
    end procedure mean_1_sp

    module procedure mean_2_sp
    integer :: i, m, n
    m = size(A, 1)
    n = size(A, 2)
    if ((.not. present(dim)) .or. (dim == 1)) then
        allocate (mean(n))
        do i = 1, n
            mean(i) = mean_1_sp(A(:, i))
        end do
    elseif (dim == 2) then
        allocate (mean(m))
        do i = 1, m
            mean(i) = mean_1_sp(A(i, :))
        end do
    end if
    return
    end procedure mean_2_sp
    module procedure mean_1_dp
    mean = sum(x)/size(x)
    return
    end procedure mean_1_dp

    module procedure mean_2_dp
    integer :: i, m, n
    m = size(A, 1)
    n = size(A, 2)
    if ((.not. present(dim)) .or. (dim == 1)) then
        allocate (mean(n))
        do i = 1, n
            mean(i) = mean_1_dp(A(:, i))
        end do
    elseif (dim == 2) then
        allocate (mean(m))
        do i = 1, m
            mean(i) = mean_1_dp(A(i, :))
        end do
    end if
    return
    end procedure mean_2_dp

end submodule forlab_stats_mean


implicit none
integer :: i,n
real :: y=0, term

read *, n
do i=1,n
	term=1./(i*(i+1))
	y=y+term
	if(abs(term)<=1.e-5) exit
end do
print *, 'sum',y,' term=',i

end


program test_linalg_tri
    use forlab_linalg, only: tril, triu, ones
    use forlab_io, only: disp
    real :: X(4, 4)
    call disp("tri U L test")
    x = ones(4, 4)
    call disp(X, "A=")
    call disp(tril(X), "tril")
    call disp(triu(X), "triu")
    call disp(tril(X, -1), "tril")
    call disp(triu(X, 1), "triu")
end program test_linalg_tri


! { dg-do run }
! Tests for the constant folding of the NEAREST intrinsic
! We compare against the results of the runtime implementation,
! thereby making sure that they remain consistent
REAL, PARAMETER :: x(10) = (/ 1., 0.49999997, 0.5, 8388609.0, -1., &
                                      -0.49999997, -0.5, -8388609.0, &
                                      0., 0. /), &
                 dir(10) = (/ -1.,       +1., -1.,       -1., +1., &
                                             -1.,  +1.,        +1., &
                                     +1.,-1./)
REAL :: a(10)

a = x
if (nearest (x(1), dir(1)) /= nearest (a(1), dir(1))) STOP 1
if (nearest (x(2), dir(2)) /= nearest (a(2), dir(2))) STOP 2
if (nearest (x(3), dir(3)) /= nearest (a(3), dir(3))) STOP 3
if (nearest (x(4), dir(4)) /= nearest (a(4), dir(4))) STOP 4
if (nearest (x(5), dir(5)) /= nearest (a(5), dir(5))) STOP 5
if (nearest (x(6), dir(6)) /= nearest (a(6), dir(6))) STOP 6
if (nearest (x(7), dir(7)) /= nearest (a(7), dir(7))) STOP 7
if (nearest (x(8), dir(8)) /= nearest (a(8), dir(8))) STOP 8
! These last two tests are commented out because mpfr provides no support
! for denormals, and therefore we get TINY instead of the correct result.
!if (nearest (x(9), dir(9)) /= nearest (a(9), dir(9))) STOP 9
!if (nearest (x(10), dir(10)) /= nearest (a(10), dir(10))) STOP 10

end


C
C     --------------------------------------------------------------------
C     Conjugate Gradient methods for solving unconstrained nonlinear
C     optimization problems, as described in the paper:
C
C     Gilbert, J.C. and Nocedal, J. (1992). "Global Convergence Properties
C     of Conjugate Gradient Methods", SIAM Journal on Optimization, Vol. 2,
C     pp. 21-42.
C
C     A web-based Server which solves unconstrained nonlinear optimization
C     problems using this Conjugate Gradient code can be found at:
C
C       http://www-neos.mcs.anl.gov/neos/solvers/UCO:CGPLUS/
C
C     --------------------------------------------------------------------
C
      SUBROUTINE CGFAM(N,X,F,G,D,GOLD,IPRINT,EPS,W,
     *                  IFLAG,IREST,METHOD,FINISH )
C
C Subroutine parameters
C
      DOUBLE PRECISION X(N),G(N),D(N),GOLD(N),W(N),F,EPS
      INTEGER N,IPRINT(2),IFLAG,IREST,METHOD,IM,NDES
C
C     N      =  NUMBER OF VARIABLES
C     X      =  ITERATE
C     F      =  FUNCTION VALUE
C     G      =  GRADIENT VALUE
C     GOLD   =  PREVIOUS GRADIENT VALUE
C     IPRINT =  FREQUENCY AND TYPE OF PRINTING
C               IPRINT(1) < 0 : NO OUTPUT IS GENERATED
C               IPRINT(1) = 0 : OUTPUT ONLY AT FIRST AND LAST ITERATION
C               IPRINT(1) > 0 : OUTPUT EVERY IPRINT(1) ITERATIONS
C               IPRINT(2)     : SPECIFIES THE TYPE OF OUTPUT GENERATED;
C                               THE LARGER THE VALUE (BETWEEN 0 AND 3),
C                               THE MORE INFORMATION
C               IPRINT(2) = 0 : NO ADDITIONAL INFORMATION PRINTED
C 		IPRINT(2) = 1 : INITIAL X AND GRADIENT VECTORS PRINTED
C		IPRINT(2) = 2 : X VECTOR PRINTED EVERY ITERATION
C		IPRINT(2) = 3 : X VECTOR AND GRADIENT VECTOR PRINTED
C				EVERY ITERATION
C     EPS    =  CONVERGENCE CONSTANT
C     W      =  WORKING ARRAY
C     IFLAG  =  CONTROLS TERMINATION OF CODE, AND RETURN TO MAIN
C               PROGRAM TO EVALUATE FUNCTION AND GRADIENT
C               IFLAG = -3 : IMPROPER INPUT PARAMETERS
C               IFLAG = -2 : DESCENT WAS NOT OBTAINED
C               IFLAG = -1 : LINE SEARCH FAILURE
C               IFLAG =  0 : INITIAL ENTRY OR
C                            SUCCESSFUL TERMINATION WITHOUT ERROR
C               IFLAG =  1 : INDICATES A RE-ENTRY WITH NEW FUNCTION VALUES
C               IFLAG =  2 : INDICATES A RE-ENTRY WITH A NEW ITERATE
C     IREST  =  0 (NO RESTARTS); 1 (RESTART EVERY N STEPS)
C     METHOD =  1 : FLETCHER-REEVES
C               2 : POLAK-RIBIERE
C               3 : POSITIVE POLAK-RIBIERE ( BETA=MAX{BETA,0} )
C
C Local variables
C
      DOUBLE PRECISION GTOL,ONE,ZERO,GNORM,DDOT,STP1,FTOL,XTOL,STPMIN,
     .       STPMAX,STP,BETA,BETAFR,BETAPR,DG0,GG,GG0,DGOLD,
     .       DGOUT,DG,DG1
      INTEGER MP,LP,ITER,NFUN,MAXFEV,INFO,I,NFEV,NRST,IDES
      LOGICAL NEW,FINISH
C
C     THE FOLLOWING PARAMETERS ARE PLACED IN COMMON BLOCKS SO THEY
C     CAN BE EASILY ACCESSED ANYWHERE IN THE CODE
C
C     MP = UNIT NUMBER WHICH DETERMINES WHERE TO WRITE REGULAR OUTPUT
C     LP = UNIT NUMBER WHICH DETERMINES WHERE TO WRITE ERROR OUPUT
      COMMON /CGDD/MP,LP
C
C     ITER: KEEPS TRACK OF THE NUMBER OF ITERATIONS
C     NFUN: KEEPS TRACK OF THE NUMBER OF FUNCTION/GRADIENT EVALUATIONS
      COMMON /RUNINF/ITER,NFUN
      SAVE
      DATA ONE,ZERO/1.0D+0,0.0D+0/
C
C IFLAG = 1 INDICATES A RE-ENTRY WITH NEW FUNCTION VALUES
      IF(IFLAG.EQ.1) GO TO 72
C
C IFLAG = 2 INDICATES A RE-ENTRY WITH A NEW ITERATE
      IF(IFLAG.EQ.2) GO TO 80
C
C     INITIALIZE
C     ----------
C
C
C     IM =   NUMBER OF TIMES BETAPR WAS NEGATIVE FOR METHOD 2 OR
C            NUMBER OF TIMES BETAPR WAS 0 FOR METHOD 3
C
C     NDES = NUMBER OF LINE SEARCH ITERATIONS AFTER WOLFE CONDITIONS
C            WERE SATISFIED
C
      ITER= 0
      IF(N.LE.0) GO TO 96
      NFUN= 1
      NEW=.TRUE.
      NRST= 0
      IM=0
      NDES=0
C
      DO 5 I=1,N
 5    D(I)= -G(I)
      GNORM= DSQRT(DDOT(N,G,1,G,1))
      STP1= ONE/GNORM
C
C     PARAMETERS FOR LINE SEARCH ROUTINE
C     ----------------------------------
C
C     FTOL AND GTOL ARE NONNEGATIVE INPUT VARIABLES. TERMINATION
C       OCCURS WHEN THE SUFFICIENT DECREASE CONDITION AND THE
C       DIRECTIONAL DERIVATIVE CONDITION ARE SATISFIED.
C
C     XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS
C       WHEN THE RELATIVE WIDTH OF THE INTERVAL OF UNCERTAINTY
C       IS AT MOST XTOL.
C
C     STPMIN AND STPMAX ARE NONNEGATIVE INPUT VARIABLES WHICH
C       SPECIFY LOWER AND UPPER BOUNDS FOR THE STEP.
C
C     MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION
C       OCCURS WHEN THE NUMBER OF CALLS TO FCN IS AT LEAST
C       MAXFEV BY THE END OF AN ITERATION.

      FTOL= 1.0D-4
      GTOL= 1.0D-1
      IF(GTOL.LE.1.D-04) THEN
        IF(LP.GT.0) WRITE(LP,145)
        GTOL=1.D-02
      ENDIF
      XTOL= 1.0D-17
      STPMIN= 1.0D-20
      STPMAX= 1.0D+20
      MAXFEV= 40
C
      IF(IPRINT(1).GE.0) CALL CGBD(IPRINT,ITER,NFUN,
     *   GNORM,N,X,F,G,STP,FINISH,NDES,IM,BETAFR,BETAPR,BETA)
C
C     MAIN ITERATION LOOP
C    ---------------------
C
 8    ITER= ITER+1
C     WHEN NRST>N AND IREST=1 THEN RESTART
      NRST= NRST+1
      INFO=0
C
C
C     CALL THE LINE SEARCH ROUTINE OF MOR'E AND THUENTE
C     (modified for our CG method)
C     -------------------------------------------------
C
C       JJ Mor'e and D Thuente, "Linesearch Algorithms with Guaranteed
C       Sufficient Decrease". ACM Transactions on Mathematical
C       Software 20 (1994), pp 286-307.
C
      NFEV=0
      DO 70 I=1,N
  70  GOLD(I)= G(I)
      DG= DDOT(N,D,1,G,1)
      DGOLD=DG
      STP=ONE
C
C Shanno-Phua's Formula For Trial Step
C
      IF(.NOT.NEW) STP= DG0/DG
      IF (ITER.EQ.1) STP=STP1
      IDES=0
      new=.false.
  72  CONTINUE
C
C     write(6,*) 'step= ', stp
C
C Call to the line search subroutine
C
      CALL CVSMOD(N,X,F,G,D,STP,FTOL,GTOL,
     *            XTOL,STPMIN,STPMAX,MAXFEV,INFO,NFEV,W,DG,DGOUT)

C       INFO IS AN INTEGER OUTPUT VARIABLE SET AS FOLLOWS:
C         INFO = 0  IMPROPER INPUT PARAMETERS.
C         INFO =-1  A RETURN IS MADE TO COMPUTE THE FUNCTION AND GRADIENT.
C         INFO = 1  THE SUFFICIENT DECREASE CONDITION AND THE
C                   DIRECTIONAL DERIVATIVE CONDITION HOLD.
C         INFO = 2  RELATIVE WIDTH OF THE INTERVAL OF UNCERTAINTY
C                   IS AT MOST XTOL.
C         INFO = 3  NUMBER OF CALLS TO FCN HAS REACHED MAXFEV.
C         INFO = 4  THE STEP IS AT THE LOWER BOUND STPMIN.
C         INFO = 5  THE STEP IS AT THE UPPER BOUND STPMAX.
C         INFO = 6  ROUNDING ERRORS PREVENT FURTHER PROGRESS.
C                   THERE MAY NOT BE A STEP WHICH SATISFIES THE
C                   SUFFICIENT DECREASE AND CURVATURE CONDITIONS.
C                   TOLERANCES MAY BE TOO SMALL.

      IF (INFO .EQ. -1) THEN
C       RETURN TO FETCH FUNCTION AND GRADIENT
        IFLAG=1
        RETURN
      ENDIF
      IF (INFO .NE. 1) GO TO 90
C
C     TEST IF DESCENT DIRECTION IS OBTAINED FOR METHODS 2 AND 3
C     ---------------------------------------------------------
C
      GG= DDOT(N,G,1,G,1)
      GG0= DDOT(N,G,1,GOLD,1)
      BETAPR= (GG-GG0)/GNORM**2
      IF (IREST.EQ.1.AND.NRST.GT.N) THEN
        NRST=0
        NEW=.TRUE.
        GO TO 75
      ENDIF
C
      IF (METHOD.EQ.1) THEN
        GO TO 75
      ELSE
        DG1=-GG + BETAPR*DGOUT
        IF (DG1.lt. 0.0d0 ) GO TO 75
        IF (IPRINT(1).GE.0) write(6,*) 'no descent'
        IDES= IDES + 1
        IF(IDES.GT.5) GO TO 95
        GO TO 72
      ENDIF
C
C     DETERMINE CORRECT BETA VALUE FOR METHOD CHOSEN
C     ----------------------------------------------
C
C     IM =   NUMBER OF TIMES BETAPR WAS NEGATIVE FOR METHOD 2 OR
C            NUMBER OF TIMES BETAPR WAS 0 FOR METHOD 3
C
C     NDES = NUMBER OF LINE SEARCH ITERATIONS AFTER WOLFE CONDITIONS
C            WERE SATISFIED
C
  75  NFUN= NFUN + NFEV
      NDES= NDES + IDES
      BETAFR= GG/GNORM**2
      IF (NRST.EQ.0) THEN
        BETA= ZERO
      ELSE
        IF (METHOD.EQ.1) BETA=BETAFR
        IF (METHOD.EQ.2) BETA=BETAPR
        IF ((METHOD.EQ.2.OR.METHOD.EQ.3).AND.BETAPR.LT.0) IM=IM+1
        IF (METHOD.EQ.3) BETA=MAX(ZERO,BETAPR)
      ENDIF
C
C     COMPUTE THE NEW DIRECTION
C     --------------------------
C
      DO 78 I=1,N
  78  D(I) = -G(I) +BETA*D(I)
      DG0= DGOLD*STP
C
C     RETURN TO DRIVER FOR TERMINATION TEST
C     -------------------------------------
C
      GNORM=DSQRT(DDOT(N,G,1,G,1))
      IFLAG=2
      RETURN

  80  CONTINUE
C
C Call subroutine for printing output
C
      IF(IPRINT(1).GE.0) CALL CGBD(IPRINT,ITER,NFUN,
     *     GNORM,N,X,F,G,STP,FINISH,NDES,IM,BETAFR,BETAPR,BETA)
      IF (FINISH) THEN
         IFLAG = 0
         RETURN
      END IF
      GO TO 8
C
C     ----------------------------------------
C     END OF MAIN ITERATION LOOP. ERROR EXITS.
C     ----------------------------------------
C
  90  IFLAG=-1
      IF(LP.GT.0) WRITE(LP,100) INFO
      RETURN
  95  IFLAG=-2
      IF(LP.GT.0) WRITE(LP,135) I
      RETURN
  96  IFLAG= -3
      IF(LP.GT.0) WRITE(LP,140)
C
C     FORMATS
C     -------
C
 100  FORMAT(/' IFLAG= -1 ',/' LINE SEARCH FAILED. SEE'
     .          ' DOCUMENTATION OF ROUTINE CVSMOD',/' ERROR RETURN'
     .          ' OF LINE SEARCH: INFO= ',I2,/
     .          ' POSSIBLE CAUSE: FUNCTION OR GRADIENT ARE INCORRECT')
 135  FORMAT(/' IFLAG= -2',/' DESCENT WAS NOT OBTAINED')
 140  FORMAT(/' IFLAG= -3',/' IMPROPER INPUT PARAMETERS (N',
     .       ' IS NOT POSITIVE)')
 145  FORMAT(/'  GTOL IS LESS THAN OR EQUAL TO 1.D-04',
     .       / ' IT HAS BEEN RESET TO 1.D-02')
      RETURN
      END
C
C     LAST LINE OF ROUTINE CGFAM
C     ***************************
C
C
C**************************************************************************
      SUBROUTINE CGBD(IPRINT,ITER,NFUN,
     *           GNORM,N,X,F,G,STP,FINISH,NDES,IM,BETAFR,BETAPR,BETA)
C
C     ---------------------------------------------------------------------
C     THIS ROUTINE PRINTS MONITORING INFORMATION. THE FREQUENCY AND AMOUNT
C     OF OUTPUT ARE CONTROLLED BY IPRINT.
C     ---------------------------------------------------------------------
C
      DOUBLE PRECISION X(N),G(N),F,GNORM,STP,BETAFR,BETAPR,BETA
      INTEGER IPRINT(2),ITER,NFUN,LP,MP,N,NDES,IM
      LOGICAL FINISH
      COMMON /CGDD/MP,LP
C
      IF (ITER.EQ.0)THEN
           PRINT*
           WRITE(MP,10)
           WRITE(MP,20) N
           WRITE(MP,30) F,GNORM
                 IF (IPRINT(2).GE.1)THEN
                     WRITE(MP,40)
                     WRITE(MP,50) (X(I),I=1,N)
                     WRITE(MP,60)
                     WRITE(MP,50) (G(I),I=1,N)
                 ENDIF
           WRITE(MP,10)
           WRITE(MP,70)
      ELSE
          IF ((IPRINT(1).EQ.0).AND.(ITER.NE.1.AND..NOT.FINISH))RETURN
          IF (IPRINT(1).NE.0)THEN
               IF(MOD(ITER-1,IPRINT(1)).EQ.0.OR.FINISH)THEN
                     IF(IPRINT(2).GT.1.AND.ITER.GT.1) WRITE(MP,70)
                     WRITE(MP,80)ITER,NFUN,F,GNORM,STP,BETA
               ELSE
                     RETURN
               ENDIF
          ELSE
               IF( IPRINT(2).GT.1.AND.FINISH) WRITE(MP,70)
               WRITE(MP,80)ITER,NFUN,F,GNORM,STP,BETA
          ENDIF
          IF (IPRINT(2).EQ.2.OR.IPRINT(2).EQ.3)THEN
                  WRITE(MP,40)
                  WRITE(MP,50)(X(I),I=1,N)
              IF (IPRINT(2).EQ.3)THEN
                  WRITE(MP,60)
                  WRITE(MP,50)(G(I),I=1,N)
              ENDIF
          ENDIF
          IF (FINISH) WRITE(MP,100)
      ENDIF
C
 10   FORMAT('*************************************************')
 20   FORMAT(' N=',I5,//,'INITIAL VALUES:')
 30   FORMAT(' F= ',1PD10.3,'   GNORM= ',1PD10.3)
 40   FORMAT(/,' VECTOR X= ')
 50   FORMAT(6(2X,1PD10.3/))
 60   FORMAT(' GRADIENT VECTOR G= ')
 70   FORMAT(/'   I  NFN',4X,'FUNC',7X,'GNORM',6X,
     *   'STEPLEN',4x,'BETA',/,
     *   ' ----------------------------------------------------')
 80   FORMAT(I4,1X,I3,2X,2(1PD10.3,2X),1PD8.1,2x,1PD8.1)
100   FORMAT(/' SUCCESSFUL CONVERGENCE (NO ERRORS).'
     *          ,/,' IFLAG = 0')
C
      RETURN
      END
C
C     LAST LINE OF CGBD
C*************************************************************************
C
C
C   ----------------------------------------------------------
C     DATA
C   ----------------------------------------------------------
C
C     MP = UNIT NUMBER WHICH DETERMINES WHERE TO WRITE REGULAR OUTPUT
C     LP = UNIT NUMBER WHICH DETERMINES WHERE TO WRITE ERROR OUPUT
C
      BLOCK DATA CGCD
      COMMON /CGDD/MP,LP
      INTEGER LP,MP
      DATA MP,LP/6,6/
      END
C
C
C   ----------------------------------------------------------
C
C     LAST LINE OF CGFAM
C*************************************************************************


c ---------------------------------------------------------------
      SUBROUTINE DHYDRO(P,TKV,ZSFC,NLVL,ZH,IER)
      IMPLICIT NONE

c NCL: zh = hydro (p,tkv,zsfc)

c use the hydrostatic eqn to get geopotential height
c .   it is assumed that p(1) and tkv(1) contain the
c .   surface quantities corresponding to zsfc.

c .   missing data not allowed
C input

C no. levels; error code
      INTEGER NLVL,IER
C pres (Pa)
C temp (K) at each "p"
C sfc geopotential height (gpm)
      DOUBLE PRECISION P(NLVL),TKV(NLVL),ZSFC
C output

C calculated geopotential (gpm)
      DOUBLE PRECISION ZH(NLVL)
C local

      INTEGER NL
      DOUBLE PRECISION G,RDAIR,RDAG,TVBAR

c     --------
      IER = 0
      IF (NLVL.LT.1) THEN
C unrealistic nlvl value
          IER = -1
          RETURN
      END IF

C gravity at 45 deg lat used by the WMO
      G = 9.80665D0
C gas const dry air (j/{kg-k})
      RDAIR = 287.04D0
      RDAG = RDAIR/G

c calculate geopotential height if initial z available [hydrostatic eq]

      ZH(1) = ZSFC
      DO NL = 2,NLVL
C same as [ln(p(nl)+ln(p(nl-1)]
          TVBAR = (TKV(NL)*DLOG(P(NL))+TKV(NL-1)*DLOG(P(NL-1)))/
     +            DLOG(P(NL)*P(NL-1))
          ZH(NL) = ZH(NL-1) + RDAG*TVBAR*DLOG(P(NL-1)/P(NL))
      END DO

      RETURN
      END


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine current(jz_intra,jz_inter)
  use global_variables
  implicit none
  integer :: ikr,ikz
  real(8) :: jz_intra,jz_inter
  complex(8) :: zfact

  call set_ddeps_dkz

  jz_intra = 0d0
  jz_inter = 0d0
!$omp parallel
!$omp do private(ikz, ikr) reduction(+:jz_intra,jz_inter)
  do ikz = -NKz,NKz
  do ikr = 1,NKr
    jz_intra = jz_intra + ddeps_dkz(ikr,ikz)*abs(zCt(2,ikr,ikz))**2*kr(ikr)
    jz_inter = jz_inter + 2d0*real(conjg(zCt(1,ikr,ikz))*zCt(2,ikr,ikz))*kr(ikr)
  end do
  end do
!$omp end parallel
  jz_intra = jz_intra*2d0/((2d0*pi)**3)*(2d0*pi*dkr*dkz)
  jz_inter = jz_inter*piz_vc*2d0/((2d0*pi)**3)*(2d0*pi*dkr*dkz)

  return
end subroutine current


	SUBROUTINE svdcmp_sp(a,w,v)
	USE nrtype
 USE nrutil, ONLY : assert_eq,nrerror,outerprod
	USE Debug_module
 USE   nr, ONLY : pythag
	IMPLICIT NONE
	REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
	REAL(SP), DIMENSION(:), INTENT(OUT) :: w
	REAL(SP), DIMENSION(:,:), INTENT(OUT) :: v
	INTEGER(I4B) :: i,its,j,k,l,m,n,nm
	REAL(SP) :: anorm,c,f,g,h,s,scale,x,y,z
	REAL(SP), DIMENSION(size(a,1)) :: tempm
	REAL(SP), DIMENSION(size(a,2)) :: rv1,tempn
	m=size(a,1)
	n=assert_eq(size(a,2),size(v,1),size(v,2),size(w),'svdcmp_sp')
	g=0.0
	scale=0.0
	do i=1,n
		l=i+1
		rv1(i)=scale*g
		g=0.0
		scale=0.0
		if (i <= m) then
			scale=sum(abs(a(i:m,i)))
			if (scale /= 0.0) then
				a(i:m,i)=a(i:m,i)/scale
				s=dot_product(a(i:m,i),a(i:m,i))
				f=a(i,i)
				g=-sign(sqrt(s),f)
				h=f*g-s
				a(i,i)=f-g
				tempn(l:n)=matmul(a(i:m,i),a(i:m,l:n))/h
				a(i:m,l:n)=a(i:m,l:n)+outerprod(a(i:m,i),tempn(l:n))
				a(i:m,i)=scale*a(i:m,i)
			end if
		end if
		w(i)=scale*g
		g=0.0
		scale=0.0
		if ((i <= m) .and. (i /= n)) then
			scale=sum(abs(a(i,l:n)))
			if (scale /= 0.0) then
				a(i,l:n)=a(i,l:n)/scale
				s=dot_product(a(i,l:n),a(i,l:n))
				f=a(i,l)
				g=-sign(sqrt(s),f)
				h=f*g-s
				a(i,l)=f-g
				rv1(l:n)=a(i,l:n)/h
				tempm(l:m)=matmul(a(l:m,l:n),a(i,l:n))
				a(l:m,l:n)=a(l:m,l:n)+outerprod(tempm(l:m),rv1(l:n))
				a(i,l:n)=scale*a(i,l:n)
			end if
		end if
	end do
	anorm=maxval(abs(w)+abs(rv1))
	do i=n,1,-1
		if (i < n) then
			if (g /= 0.0) then
				v(l:n,i)=(a(i,l:n)/a(i,l))/g
				tempn(l:n)=matmul(a(i,l:n),v(l:n,l:n))
				v(l:n,l:n)=v(l:n,l:n)+outerprod(v(l:n,i),tempn(l:n))
			end if
			v(i,l:n)=0.0
			v(l:n,i)=0.0
		end if
		v(i,i)=1.0
		g=rv1(i)
		l=i
	end do
	do i=min(m,n),1,-1
		l=i+1
		g=w(i)
		a(i,l:n)=0.0
		if (g /= 0.0) then
			g=1.0_sp/g
			tempn(l:n)=(matmul(a(l:m,i),a(l:m,l:n))/a(i,i))*g
			a(i:m,l:n)=a(i:m,l:n)+outerprod(a(i:m,i),tempn(l:n))
			a(i:m,i)=a(i:m,i)*g
		else
			a(i:m,i)=0.0
		end if
		a(i,i)=a(i,i)+1.0_sp
	end do
	do k=n,1,-1
		do its=1,30
			do l=k,1,-1
				nm=l-1
				if ((abs(rv1(l))+anorm) == anorm) exit
				if ((abs(w(nm))+anorm) == anorm) then
					c=0.0
					s=1.0
					do i=l,k
						f=s*rv1(i)
						rv1(i)=c*rv1(i)
						if ((abs(f)+anorm) == anorm) exit
						g=w(i)
						h=pythag(f,g)
						w(i)=h
						h=1.0_sp/h
						c= (g*h)
						s=-(f*h)
						tempm(1:m)=a(1:m,nm)
						a(1:m,nm)=a(1:m,nm)*c+a(1:m,i)*s
						a(1:m,i)=-tempm(1:m)*s+a(1:m,i)*c
					end do
					exit
				end if
			end do
			z=w(k)
			if (l == k) then
				if (z < 0.0) then
					w(k)=-z
					v(1:n,k)=-v(1:n,k)
				end if
				exit
			end if
			if (its == 30) then
 Debug_errorflags(flag_svdcmp)=1
   return
   end if
			x=w(l)
			nm=k-1
			y=w(nm)
			g=rv1(nm)
			h=rv1(k)
			f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0_sp*h*y)
			g=pythag(f,1.0_sp)
			f=((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x
			c=1.0
			s=1.0
			do j=l,nm
				i=j+1
				g=rv1(i)
				y=w(i)
				h=s*g
				g=c*g
				z=pythag(f,h)
				rv1(j)=z
				c=f/z
				s=h/z
				f= (x*c)+(g*s)
				g=-(x*s)+(g*c)
				h=y*s
				y=y*c
				tempn(1:n)=v(1:n,j)
				v(1:n,j)=v(1:n,j)*c+v(1:n,i)*s
				v(1:n,i)=-tempn(1:n)*s+v(1:n,i)*c
				z=pythag(f,h)
				w(j)=z
				if (z /= 0.0) then
					z=1.0_sp/z
					c=f*z
					s=h*z
				end if
				f= (c*g)+(s*y)
				x=-(s*g)+(c*y)
				tempm(1:m)=a(1:m,j)
				a(1:m,j)=a(1:m,j)*c+a(1:m,i)*s
				a(1:m,i)=-tempm(1:m)*s+a(1:m,i)*c
			end do
			rv1(l)=0.0
			rv1(k)=f
			w(k)=x
		end do
	end do
	END SUBROUTINE svdcmp_sp

	SUBROUTINE svdcmp_dp(a,w,v)
	USE nrtype
 USE nrutil, ONLY : assert_eq,nrerror,outerprod
	USE Debug_module
 USE   nr, ONLY : pythag
	IMPLICIT NONE
	REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: a
	REAL(DP), DIMENSION(:), INTENT(OUT) :: w
	REAL(DP), DIMENSION(:,:), INTENT(OUT) :: v
	INTEGER(I4B) :: i,its,j,k,l,m,n,nm
	REAL(DP) :: anorm,c,f,g,h,s,scale,x,y,z
	REAL(DP), DIMENSION(size(a,1)) :: tempm
	REAL(DP), DIMENSION(size(a,2)) :: rv1,tempn
	m=size(a,1)
	n=assert_eq(size(a,2),size(v,1),size(v,2),size(w),'svdcmp_dp')
	g=0.0
	scale=0.0
	do i=1,n
		l=i+1
		rv1(i)=scale*g
		g=0.0
		scale=0.0
		if (i <= m) then
			scale=sum(abs(a(i:m,i)))
			if (scale /= 0.0) then
				a(i:m,i)=a(i:m,i)/scale
				s=dot_product(a(i:m,i),a(i:m,i))
				f=a(i,i)
				g=-sign(sqrt(s),f)
				h=f*g-s
				a(i,i)=f-g
				tempn(l:n)=matmul(a(i:m,i),a(i:m,l:n))/h
				a(i:m,l:n)=a(i:m,l:n)+outerprod(a(i:m,i),tempn(l:n))
				a(i:m,i)=scale*a(i:m,i)
			end if
		end if
		w(i)=scale*g
		g=0.0
		scale=0.0
		if ((i <= m) .and. (i /= n)) then
			scale=sum(abs(a(i,l:n)))
			if (scale /= 0.0) then
				a(i,l:n)=a(i,l:n)/scale
				s=dot_product(a(i,l:n),a(i,l:n))
				f=a(i,l)
				g=-sign(sqrt(s),f)
				h=f*g-s
				a(i,l)=f-g
				rv1(l:n)=a(i,l:n)/h
				tempm(l:m)=matmul(a(l:m,l:n),a(i,l:n))
				a(l:m,l:n)=a(l:m,l:n)+outerprod(tempm(l:m),rv1(l:n))
				a(i,l:n)=scale*a(i,l:n)
			end if
		end if
	end do
	anorm=maxval(abs(w)+abs(rv1))
	do i=n,1,-1
		if (i < n) then
			if (g /= 0.0) then
				v(l:n,i)=(a(i,l:n)/a(i,l))/g
				tempn(l:n)=matmul(a(i,l:n),v(l:n,l:n))
				v(l:n,l:n)=v(l:n,l:n)+outerprod(v(l:n,i),tempn(l:n))
			end if
			v(i,l:n)=0.0
			v(l:n,i)=0.0
		end if
		v(i,i)=1.0
		g=rv1(i)
		l=i
	end do
	do i=min(m,n),1,-1
		l=i+1
		g=w(i)
		a(i,l:n)=0.0
		if (g /= 0.0) then
			g=1.0_dp/g
			tempn(l:n)=(matmul(a(l:m,i),a(l:m,l:n))/a(i,i))*g
			a(i:m,l:n)=a(i:m,l:n)+outerprod(a(i:m,i),tempn(l:n))
			a(i:m,i)=a(i:m,i)*g
		else
			a(i:m,i)=0.0
		end if
		a(i,i)=a(i,i)+1.0_dp
	end do
	do k=n,1,-1
		do its=1,30
			do l=k,1,-1
				nm=l-1
				if ((abs(rv1(l))+anorm) == anorm) exit
				if ((abs(w(nm))+anorm) == anorm) then
					c=0.0
					s=1.0
					do i=l,k
						f=s*rv1(i)
						rv1(i)=c*rv1(i)
						if ((abs(f)+anorm) == anorm) exit
						g=w(i)
						h=pythag(f,g)
						w(i)=h
						h=1.0_dp/h
						c= (g*h)
						s=-(f*h)
						tempm(1:m)=a(1:m,nm)
						a(1:m,nm)=a(1:m,nm)*c+a(1:m,i)*s
						a(1:m,i)=-tempm(1:m)*s+a(1:m,i)*c
					end do
					exit
				end if
			end do
			z=w(k)
			if (l == k) then
				if (z < 0.0) then
					w(k)=-z
					v(1:n,k)=-v(1:n,k)
				end if
				exit
			end if
			if (its == 30) then
 Debug_errorflags(flag_svdcmp)=1
   return
   end if
			x=w(l)
			nm=k-1
			y=w(nm)
			g=rv1(nm)
			h=rv1(k)
			f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0_dp*h*y)
			g=pythag(f,1.0_dp)
			f=((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x
			c=1.0
			s=1.0
			do j=l,nm
				i=j+1
				g=rv1(i)
				y=w(i)
				h=s*g
				g=c*g
				z=pythag(f,h)
				rv1(j)=z
				c=f/z
				s=h/z
				f= (x*c)+(g*s)
				g=-(x*s)+(g*c)
				h=y*s
				y=y*c
				tempn(1:n)=v(1:n,j)
				v(1:n,j)=v(1:n,j)*c+v(1:n,i)*s
				v(1:n,i)=-tempn(1:n)*s+v(1:n,i)*c
				z=pythag(f,h)
				w(j)=z
				if (z /= 0.0) then
					z=1.0_dp/z
					c=f*z
					s=h*z
				end if
				f= (c*g)+(s*y)
				x=-(s*g)+(c*y)
				tempm(1:m)=a(1:m,j)
				a(1:m,j)=a(1:m,j)*c+a(1:m,i)*s
				a(1:m,i)=-tempm(1:m)*s+a(1:m,i)*c
			end do
			rv1(l)=0.0
			rv1(k)=f
			w(k)=x
		end do
	end do
	END SUBROUTINE svdcmp_dp


      double precision function  fdisc(blockno,xc,yc)
      implicit none

      double precision xc,yc, xp, yp, zp, rp
      integer blockno

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision alpha, beta
      common /torus_comm/ alpha, beta

      integer example
      common /example_comm/ example

      double precision init_radius
      common /initradius_comm/ init_radius

      integer*8 cont, get_context
      double precision th, r0,x0,y0,z0,r
      double precision xc1, yc1

      cont = get_context()

      call fclaw2d_map_c2m(cont,
     &      blockno,xc,yc,xp,yp,zp)

      r0 = init_radius
      if (example .eq. 0 .or. example .eq. 2) then
          th = pi2*(0.25 + 1.d0/32.d0)
          x0 = cos(th)
          y0 = sin(th)
          z0 = alpha
      elseif (example .eq. 1) then
          xc1 = 0.5
          yc1 = 0.125
          call mapc2m_torus2(xc1,yc1,x0,y0,z0)
      endif

c     # Distance from thc
      r = sqrt((xp-x0)**2 + (yp-y0)**2 + (zp-z0)**2)

      fdisc = r - r0

      end


module intersect_triangle
use math
implicit none

private
public :: intersect_triangle_ray, intersect_triangle_plane, intersect_triangles

contains

subroutine intersect_triangle_ray(v0, v1, v2, origin, ray, eps, &
                                  test_cull, t, u, v, success)
    !> Compute the intersection of a triangle with a ray.
    !> v0 - Vertex 0 of triangle.
    !> v1 - Vertex 1 of triangle.
    !> v2 - Vertex 2 of triangle.
    !> origin - Ray origin.
    !> ray - Ray direction (unit vector).
    !> eps - Nondimensional tolerance used when a ray intersects near the
    !> edges of a triangle.
    !> test_cull - Option to cull back facing triangles.
    !> t - Intersection parameter on ray.
    !> u - Barycentric parameter on triangle.
    !> v - Barycentric parameter on triangle.
    !> success - Logical to specify if an intersection was found at all.

    !f2py intent(in) v0, v1, v2, origin, ray, eps, test_cull
    !f2py intent(out) t, u, v, success

    ! Input
    logical, intent(in) :: test_cull
    double precision, intent(in) :: eps
    double precision, intent(in) :: v0(0:2), v1(0:2), v2(0:2)
    double precision, intent(in) :: origin(0:2), ray(0:2)

    ! Output
    logical, intent(out) :: success
    double precision, intent(out) :: t, u, v

    ! Working
    double precision :: det, inv_det
    double precision :: e1(0:2), e2(0:2), pvec(0:2), tvec(0:2), qvec(0:2)

    t = 0.0d0
    u = 0.0d0
    v = 0.0d0
    success = .true.

    e1 = v1 - v0
    e2 = v2 - v0
    pvec = cross(ray, e2)
    det = dot_product(e1, pvec)
    if (test_cull) then
        if (det .le. eps) then
            success = .false.
            return
        end if
        tvec = origin - v0
        u = dot_product(tvec, pvec)
        if ((u .le. -eps) .or. (u .ge. det + eps)) then
            success = .false.
            return
        end if
        qvec = cross(tvec, e1)
        v = dot_product(ray, qvec)
        if ((v .le. -eps) .or. (u + v .ge. det + eps)) then
            success = .false.
            return
        end if
        t = dot_product(e2, qvec)
        inv_det = 1.0d0 / det
        t = t * inv_det
        u = u * inv_det
        v = v * inv_det
    else
        if (abs(det) .lt. eps) then
            success = .false.
            return
        end if
        inv_det = 1.0d0 / det
        tvec = origin - v0
        u = dot_product(tvec, pvec) * inv_det
        if ((u .le. -eps) .or. (u .ge. 1.0d0 + eps)) then
            success = .false.
            return
        end if
        qvec = cross(tvec, e1)
        v = dot_product(ray, qvec) * inv_det
        if ((v .le. -eps) .or. (u + v .ge. 1.0d0 + eps)) then
            success = .false.
            return
        end if
        t = dot_product(e2, qvec) * inv_det
    end if

end subroutine intersect_triangle_ray

subroutine intersect_triangles(t1, t2, tol, eps, npts, pnts)
    !> Find the intersection segment between two triangles.
    !> t1 - Vertices of triangle 1.
    !> t2 - Vertices of triangle 2.
    !> tol - Geometric tolerance.
    !> eps - Nondimensional tolerance.
    !> npts - Number of intersection points. This should be two
    !> if a valid intersection segment was found, zero otherwise.
    !> pnts - Intersection points.

    !f2py intent(in) t1, t2, tol, eps
    !f2py intent(out) npts, pnts

    ! Input
    double precision, intent(in) :: tol, eps
    double precision, intent(in) :: t1(0:2, 0:2), t2(0:2, 0:2)

    ! Ouput
    integer, intent(out) :: npts
    double precision, intent(out) :: pnts(0:1, 0:2)

    ! Working
    logical :: test
    integer :: i
    double precision :: d0, di, t, u, v
    double precision :: vn1(0:2), vn2(0:2), verts(0:2, 0:2)
    double precision :: edges(0:2, 0:2), e1(0:2), e2(0:2)
    double precision :: v0(0:2), v1(0:2), v2(0:2)
    double precision ::  p0(0:2), ray(0:2), p12(0:2)

    npts = 0
    pnts(:, :) = 0.0d0

    e1 = t1(1, :) - t1(0, :)
    e2 = t1(2, :) - t1(0, :)
    vn1 = cross(e1, e2)
    e1 = t2(1, :) - t2(0, :)
    e2 = t2(2, :) - t2(0, :)
    vn2 = cross(e1, e2)

    test = .false.
    d0 = dot_product(vn1, t2(0, :) - t1(0, :))
    do i = 1, 2
        di = dot_product(vn1, t2(i, :) - t1(0, :))
        if (d0 * di .le. 0.0d0) then
            test = .true.
            exit
        end if
    end do
    if (test .eqv. .false.) then
        return
    end if

    test = .false.
    d0 = dot_product(vn2, t1(0, :) - t2(0, :))
    do i = 1, 2
        di = dot_product(vn2, t1(i, :) - t2(0, :))
        if (d0 * di .le. 0.0d0) then
            test = .true.
            exit
        end if
    end do
    if (test .eqv. .false.) then
        return
    end if

    ! Intersect edges of triangle 1 with triangle 2.
    verts(:, :) = 0.0d0
    edges(:, :) = 0.0d0
    edges(0, :) = t1(1, :) - t1(0, :)
    verts(0, :) = t1(0, :)
    edges(1, :) = t1(2, :) - t1(0, :)
    verts(1, :) = t1(0, :)
    edges(2, :) = t1(2, :) - t1(1, :)
    verts(2, :) = t1(1, :)
    v0 = t2(0, :)
    v1 = t2(1, :)
    v2 = t2(2, :)
    do i = 0, 2
        p0 = verts(i, :)
        ray = edges(i, :)
        call intersect_triangle_ray(v0, v1, v2, p0, ray, eps, .false., &
                                    t, u, v, test)
        if ((test .eqv. .true.) .and. &
            (t .ge. -eps) .and. (t .le. 1.0d0 + eps)) then
            pnts(npts, :) = p0 + t * ray
            npts = npts + 1
            if (npts .eq. 2) then
                p12 = pnts(1, :) - pnts(0, :)
                di = norm(p12)
                if ((di .le. tol) .and. (i .lt. 2)) then
                    npts = npts - 1
                elseif (di .gt. tol) then
                    return
                elseif ((di .le. tol) .and. (i .eq. 2)) then
                    npts = npts - 1
                end if
            end if
        end if
    end do

    ! Intersect edges of triangle 2 with triangle 1.
    edges(0, :) = t2(1, :) - t2(0, :)
    verts(0, :) = t2(0, :)
    edges(1, :) = t2(2, :) - t2(0, :)
    verts(1, :) = t2(0, :)
    edges(2, :) = t2(2, :) - t2(1, :)
    verts(2, :) = t2(1, :)
    v0 = t1(0, :)
    v1 = t1(1, :)
    v2 = t1(2, :)
    do i = 0, 2
        p0 = verts(i, :)
        ray = edges(i, :)
        call intersect_triangle_ray(v0, v1, v2, p0, ray, eps, &
                                    .false., t, u, v, test)
        if ((test .eqv. .true.) .and. &
            (t .ge. -eps) .and. (t .le. 1.0d0 + eps)) then
            pnts(npts, :) = p0 + t * ray
            npts = npts + 1
            if (npts .eq. 2) then
                p12 = pnts(1, :) - pnts(0, :)
                di = norm(p12)
                if ((di .le. tol) .and. (i .lt. 2)) then
                    npts = npts - 1
                elseif (di .gt. tol) then
                    return
                elseif ((di .le. tol) .and. (i .eq. 2)) then
                    npts = npts - 1
                end if
            end if
        end if
    end do
    ! No intersection found.
    npts = 0
    pnts(:, :) = 0.0d0
end subroutine intersect_triangles

subroutine intersect_triangle_plane(t, p0, pnorm, gtol, itol, ni, pi)
    !> Find the intersection segment of a triangle and a plane.
    !> t - Vertices of triangle.
    !> p0 - Origin of plane.
    !> pnorm - Unit normal vector of plane.
    !> gtol - Geometric tolerance.
    !> itol - Intersection tolerance for checking minimum length of
    !> intersection segment.
    !> ni - Number of intersection points. This should be two if a valid
    !> intersection segment was found, zero otherwise.
    !> pi - Intersection points.

    !f2py intent(in) t, p0, pnorm, gtol, itol
    !f2py intent(out) ni, pi

    !Input
    double precision, intent(in) :: gtol, itol
    double precision, intent(in) :: t(0:2, 0:2), p0(0:2), pnorm(0:2)

    ! Output
    integer, intent(out) :: ni
    double precision, intent(out) :: pi(0:1, 0:2)

    ! Working
    logical :: test
    integer :: i
    double precision :: d0, d1, di, denom, ui, mag
    double precision :: verts(0:2, 0:2), edges(0:2, 0:2), p(0:2), v(0:2)
    double precision :: v1(0:2), v2(0:2), tri_norm(0:2)

    ni = 0
    pi(:, :) = 0.0d0

    ! Check for parallel triangle and plane. Return no intersection if
    ! they're parallel.
    v1 = t(1, :) - t(0, :)
    v2 = t(2, :) - t(0, :)
    tri_norm = cross(v1, v2)
    mag = norm(tri_norm)
    tri_norm = tri_norm / mag
    if (1.0d0 - dabs(dot_product(pnorm, tri_norm)) .le. 1.0d-12) then
        return
    end if

    ! Test for possible intersection.
    test = .false.
    d0 = dot_product(pnorm, t(0, :) - p0)
    do i = 1, 2
        di = dot_product(pnorm, t(i, :) - p0)
        if (d0 * di .le. 0.0d0) then
            test = .true.
            exit
        end if
    end do
    if (test .eqv. .false.) then
        return
    end if

    ! Build array of vertices and edges.
    edges(0, :) = t(1, :) - t(0, :)
    verts(0, :) = t(0, :)
    edges(1, :) = t(2, :) - t(0, :)
    verts(1, :) = t(0, :)
    edges(2, :) = t(2, :) - t(1, :)
    verts(2, :) = t(1, :)

    ! Intersect edges with plane.
    do i = 0, 2
        d0 = dot_product(pnorm, verts(i, :) - p0)
        d1 = dot_product(pnorm, verts(i, :) + edges(i, :) - p0)
        if ((dabs(d0) .le. gtol) .and. (dabs(d1) .le. gtol)) then
            pi(0, :) = verts(i, :)
            pi(1, :) = verts(i, :) + edges(i, :)
            ni = 2
            return
        end if
        if (d0 * d1 .le. 0.0d0) then
            ! Find intersection
            denom = dot_product(pnorm, edges(i, :))
            ui = dot_product(pnorm, p0 - verts(i, :)) / denom
            if (ui .lt. 0.0d0) then
                ui = 0.0d0
            end if
            if (ui .gt. 1.0d0) then
                ui = 1.0d0
            end if
            p = verts(i, :) + ui * edges(i, :)
            pi(ni, :) = p
            ni = ni + 1
            if (ni .eq. 2) then
                v = pi(1, :) - pi(0, :)
                di = norm(v)
                if ((di .le. itol) .and. (i .lt. 2)) then
                    ni = ni - 1
                elseif ((di .le. itol) .and. (i .eq. 2)) then
                    ni = 0
                    pi(:, :) = 0.0d0
                    return
                else
                    return
                end if
            end if
        end if
    end do
    ni = 0
end subroutine intersect_triangle_plane

end module intersect_triangle


!
! This PMMF is used in the convecting vortex regression test.
!
module pmmf_sinusoidal_convecting_vortex
#include <messenger.h>
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ZERO, HALF, ONE, TWO, THREE, FOUR, FIVE, EIGHT, PI
    use type_prescribed_mesh_motion_function,  only: prescribed_mesh_motion_function_t
    implicit none
    private

    !>  sinusoidal_convecting_vortex mesh motion.
    !!
    !!  @author Eric Wolf
    !!  @date   3/15/2017
    !!
    !!
    !-------------------------------------------------------------------------------
    type, extends(prescribed_mesh_motion_function_t), public :: sinusoidal_convecting_vortex_pmmf
        private

    contains

        procedure   :: init
        procedure   :: compute_pos
        procedure   :: compute_vel

    end type sinusoidal_convecting_vortex_pmmf
    !********************************************************************************

contains

    !>
    !!
    !!  @author Eric Wolf
    !!  @date   3/15/2017
    !!
    !-------------------------------------------------------------------------
    subroutine init(self)
        class(sinusoidal_convecting_vortex_pmmf),  intent(inout)  :: self

        !
        ! Set function name
        !
        call self%set_name("sinusoidal_convecting_vortex")

        !
        ! Set function options to default settings
        !
        call self%add_option('L_X',20._rk)
        call self%add_option('L_Y',15._rk)
        call self%add_option('L_Z',1._rk)
        call self%add_option('GRID_MODE_X',1._rk)
        call self%add_option('GRID_MODE_Y',1._rk)
        call self%add_option('GRID_MODE_Z',1._rk)
        call self%add_option('GRID_FREQ_X',TWO*PI)
        call self%add_option('GRID_FREQ_Y',FOUR*PI)
        call self%add_option('GRID_FREQ_Z',1._rk)
        call self%add_option('GRID_AMP_X',2._rk)
        call self%add_option('GRID_AMP_Y',1.5_rk)
        call self%add_option('GRID_AMP_Z',0._rk)

    end subroutine init
    !*************************************************************************

    !>
    !!
    !!  @author Eric Wolf
    !!  @date   3/15/2017
    !!
    !!
    !-----------------------------------------------------------------------------------------
    function compute_pos(self,time,node) result(val)
        class(sinusoidal_convecting_vortex_pmmf),     intent(inout)   :: self
        real(rk),                   intent(in)      :: time
        real(rk),                   intent(in)      :: node(3)

        integer(ik)                                 :: ivar
        real(rk)                                    :: val(3)

        real(rk)                                    :: L_X, L_Y, L_Z, &
                                                        GRID_MODE_X, GRID_MODE_Y, GRID_MODE_Z, &
                                                        GRID_FREQ_X, GRID_FREQ_Y, GRID_FREQ_Z, &
                                                        GRID_AMP_X, GRID_AMP_Y, GRID_AMP_Z
        L_X = self%get_option_value('L_X')
        L_Y = self%get_option_value('L_Y')
        L_Z = self%get_option_value('L_Z')
        GRID_MODE_X = self%get_option_value('GRID_MODE_X')
        GRID_MODE_Y = self%get_option_value('GRID_MODE_Y')
        GRID_MODE_Z = self%get_option_value('GRID_MODE_Z')
        GRID_FREQ_X = self%get_option_value('GRID_FREQ_X')
        GRID_FREQ_Y = self%get_option_value('GRID_FREQ_Y')
        GRID_FREQ_Z = self%get_option_value('GRID_FREQ_Z')
        GRID_AMP_X = self%get_option_value('GRID_AMP_X')
        GRID_AMP_Y = self%get_option_value('GRID_AMP_Y')
        GRID_AMP_Z = self%get_option_value('GRID_AMP_Z')

        val(1) = node(1) + &
            GRID_AMP_X* &
            sin(GRID_MODE_X*TWO*PI*node(1)/L_X)* &
            sin(GRID_MODE_Y*TWO*PI*node(2)/L_Y)* &
            sin(GRID_FREQ_X*time)

        val(2) = node(2) + &
            GRID_AMP_Y* &
            sin(GRID_MODE_X*TWO*PI*node(1)/L_X)* &
            sin(GRID_MODE_Y*TWO*PI*node(2)/L_Y)* &
            sin(GRID_FREQ_Y*time)

        val(3) = node(3)

    end function compute_pos
    !**********************************************************************************

    !>
    !!
    !!  @author Eric Wolf
    !!  @date   3/15/2017
    !!
    !!
    !-----------------------------------------------------------------------------------------
    function compute_vel(self,time,node) result(val)
        class(sinusoidal_convecting_vortex_pmmf),     intent(inout)   :: self
        real(rk),                   intent(in)      :: time
        real(rk),                   intent(in)      :: node(3)

        integer(ik)                                 :: ivar
        real(rk)                                    :: val(3)
        real(rk)                                    :: L_X, L_Y, L_Z, &
                                                        GRID_MODE_X, GRID_MODE_Y, GRID_MODE_Z, &
                                                        GRID_FREQ_X, GRID_FREQ_Y, GRID_FREQ_Z, &
                                                        GRID_AMP_X, GRID_AMP_Y, GRID_AMP_Z
        L_X = self%get_option_value('L_X')
        L_Y = self%get_option_value('L_Y')
        L_Z = self%get_option_value('L_Z')
        GRID_MODE_X = self%get_option_value('GRID_MODE_X')
        GRID_MODE_Y = self%get_option_value('GRID_MODE_Y')
        GRID_MODE_Z = self%get_option_value('GRID_MODE_Z')
        GRID_FREQ_X = self%get_option_value('GRID_FREQ_X')
        GRID_FREQ_Y = self%get_option_value('GRID_FREQ_Y')
        GRID_FREQ_Z = self%get_option_value('GRID_FREQ_Z')
        GRID_AMP_X = self%get_option_value('GRID_AMP_X')
        GRID_AMP_Y = self%get_option_value('GRID_AMP_Y')
        GRID_AMP_Z = self%get_option_value('GRID_AMP_Z')

        val(1) =  &
            GRID_AMP_X* &
            sin(GRID_MODE_X*TWO*PI*node(1)/L_X)* &
            sin(GRID_MODE_Y*TWO*PI*node(2)/L_Y)* &
            GRID_FREQ_X*cos(GRID_FREQ_X*time)

        val(2) =  &
            GRID_AMP_Y* &
            sin(GRID_MODE_X*TWO*PI*node(1)/L_X)* &
            sin(GRID_MODE_Y*TWO*PI*node(2)/L_Y)* &
            GRID_FREQ_Y*cos(GRID_FREQ_Y*time)

        val(3) = ZERO
    end function compute_vel
    !**********************************************************************************

end module pmmf_sinusoidal_convecting_vortex


c
c	Calculate the mlt location of the bulge centroid and the terms
c	a8 and a9
c
c	corrected bulge centriod calculation per error in interpretation
c	of Moldwin et al equation for bulge centriod location in MLT.
c	Moldwin spotted error in paper and fix was determined 8/14/96
c
	subroutine bulge(amlt,akp,a8,a9,centroid)
c
	real amlt,akp,x,a8,a9
	real absx,centroid,ahour_rad
	real ahrrad,along,salong,b1,b2,b3,b4,b5
	data ahour_rad/0.26179939/
	data ahrrad/2.6179939e-1/

c	  print*,'Entering bulge:',amlt,akp,a8,a9,centroid
c
c  Allow for mlt rotation of the buldge with Kpmax
c	centroid=0.103*akp*akp-2.19*akp+23.5
c  GCPM centroid
	centroid=47.0/(akp+3.9)+11.3
	x=amlt-centroid
	if (x.lt.-12.0) x=x+24.0
	if (x.gt.12.0) x=x-24.0
	absx=abs(x)*ahrrad
c
c  The plasmapause location and steepness are based on Carpenter and
c  Anderson, 1992.  The values of a8 and a9 are used to define these
c  locations, respectively.  They are somewhat interdependent, however,
c  so the consequence of there being a magnetic local time dependence
c  for the plasmapause steepness is that both a8 and a9 must be
c  expressed as functions of MLT.  Figure 9(a) measurements were used
c  to obtain these fits.  Carpenter and Anderson's Section 3: Summary
c  equation #3 was not used, because it systemmatically increases
c  across 12 hours to 15 hours rather than peaking near 12 hours
c  as discussed in the text and is evident in their Figure 9(a).
c  As a result of fitting a sine wave function to Figure 9(a) of
c  Carpenter and Anderson [1992] the following is obtained
c		DELpp=0.0362*sin(mlt/12*pi-1.7015)
c  This fitted function is now shifted slightly to earlier MLT
c  (by 0.4992 MLT) and used for finding fits for a8 and a9.
c
c  a8=(b1*akp+b2)...
c  a9=b3*akp+b4
c
c  mlt     kp     b2     -b1     b3     b4
c  6.499   0      5.736  0.458  -2.75  49.0
c  6.499   2      5.736  0.451  -5.0   49.0
c  6.499   4      5.736  0.454  -4.3   49.0
c  6.499   6      5.736  0.456  -3.7   49.0
c  6.499   8      5.736  0.459  -3.3   49.0
c  6.499   kp   a8=-0.4589*kp+5.7464               fitted curve
c  6.499   kp   a9=0.2464*kp^2-5.2214*kp+48.8114   fitted curve
c
c 12.499   0      5.76   0.48   -2.75  45.0
c 12.499   2      5.76   0.455  -4.0   45.0
c 12.499   4      5.76   0.464  -3.8   45.0
c 12.499   6      5.76   0.4899 -3.3   45.0
c 12.499   8      5.76   0.5005 -2.69  45.0
c 12.499   kp   a8=-0.5019*kp+5.8256               fitted curve
c 12.499   kp   a9=0.2707*kp**2-4.9077*kp+45.2297  fitted curve
c
c a8=b1*kp+b2  where b1 and b2 have a sine wave variation
	along=amlt*ahour_rad+1.5707963
	salong=sin(along)
	b1= 0.043*salong-0.4589
	b2=-0.361*salong+5.7464
c** "Steady State" Density formulation
c	a8=(b1*akp+b2)*(1+exp(-0.03*absx**3+0.05*absx**2
c     &		-0.57*absx+0.05))
c** "Typical" Density formulation
c	a8=(b1*akp+b2)*(1.0+0.3421*exp(-(absx/0.9)**2))
c** GCPM formulation
	a8=(b1*akp+b2)*(1.0+exp(-1.5*absx*absx+0.08*absx-0.7))
c**
c
c a9=b3*kp**2+b4*kp+b5  where b3,b4, and b5 have a sine wave variation
	b3=-0.0243*salong+0.2464
	b4=-0.3137*salong-5.2214
	b5= 3.5817*salong+48.8114
	a9=b3*akp*akp + b4*akp+b5

c	  print*,'from bulge:',a8,a9,centroid
c
	return
	end


module THIRDBODIES
! Description:
!    Contains subroutines for computing the perturbing accelerations due to
!    a third body in the CR3BP, and its Cartesian state.
!
! Author:
!    Davide Amato
!    Space Dynamics Group - Technical University of Madrid
!    d.amato@upm.es
!
! ==============================================================================

use KINDS, only: ik,dk,qk
implicit none

contains

function QACC3B_ND(r3,r2,mu1,mu2)
! Description:
!    Computes non-dimensional perturbation acceleration due to a third body
!    'mu2' when the main body is 'mu1'. Quadruple precision.
!
! ==============================================================================

! VARIABLES
implicit none
! Arguments
real(qk),intent(in)  ::  r3(1:3)    ! Position vector of the particle, ND.
real(qk),intent(in)  ::  r2(1:3)    ! main->3body position vector, ND.
real(qk),intent(in)  ::  mu1,mu2    ! Gravitational parameters of main and third body [km,km^3/s].
! Function definition
real(qk)  ::  QACC3B_ND(1:3)
! Locals
real(qk)  ::  r23(1:3)              ! 3body->particle position vector, ND.
real(qk)  ::  r2N,r23N

! ==============================================================================

! Compute position wrt third body
r23(:) = r3(:) - r2(:)
! Compute ND acceleration
r2N = sqrt(dot_product(r2,r2))
r23N = sqrt(dot_product(r23,r23))
QACC3B_ND = - (mu2/mu1)*(r23/r23N**3 + r2/r2N**3)

end function QACC3B_ND

function DACC3B_ND(r3,r2,mu1,mu2)
! Description:
!    Computes non-dimensional perturbation acceleration due to a third body
!    'mu2' when the main body is 'mu1'.
!
! ==============================================================================

! VARIABLES
implicit none
! Arguments
real(dk),intent(in)  ::  r3(1:3)    ! Position vector of the particle, ND.
real(dk),intent(in)  ::  r2(1:3)    ! main->3body position vector, ND.
real(qk),intent(in)  ::  mu1,mu2    ! Gravitational parameters of main and third body [km,km^3/s].
! Function definition
real(dk)  ::  DACC3B_ND(1:3)
! Locals
real(dk)  ::  r23(1:3)              ! 3body->particle position vector, ND.
real(dk)  ::  r2N,r23N

! ==============================================================================

! Compute position wrt third body
r23(:) = r3(:) - r2(:)
! Compute ND acceleration
r2N = sqrt(dot_product(r2,r2))
r23N = sqrt(dot_product(r23,r23))
DACC3B_ND = - (mu2/mu1)*(r23/r23N**3 + r2/r2N**3)

end function DACC3B_ND

function QPOS_VEL_CIRC(t,w,sma)
! Description:
!    Computes the position and velocity of a planet in a circular orbit with mean
!    motion "w", semi-major axis "sma" at time "t". Quadruple precision.
!
! ==============================================================================

real(qk),intent(in)  ::  t,w,sma
real(qk)  ::  QPOS_VEL_CIRC(1:6)
real(qk)  ::  lon

lon = w*t
QPOS_VEL_CIRC(1:3) = sma*[cos(lon),sin(lon),0._qk]
QPOS_VEL_CIRC(4:6) = sma*w*[-sin(lon),cos(lon),0._qk]

end function QPOS_VEL_CIRC

function DPOS_VEL_CIRC(t,w,sma)
! Description:
!    Computes the position and velocity of a planet in a circular orbit with mean
!    motion "w", semi-major axis "sma" at time "t". Double precision.
! ==============================================================================

real(dk),intent(in)  ::  t,w,sma
real(dk)  ::  DPOS_VEL_CIRC(1:6)
real(dk)  ::  lon

lon = w*t
DPOS_VEL_CIRC(1:3) = sma*[cos(lon),sin(lon),0._dk]
DPOS_VEL_CIRC(4:6) = sma*w*[-sin(lon),cos(lon),0._dk]

end function DPOS_VEL_CIRC

end module THIRDBODIES


      SUBROUTINE MB04TX( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A,
     $                   LDA, E, LDE, Q, LDQ, Z, LDZ, MNEI )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To separate the pencils s*E(eps)-A(eps) and s*E(inf)-A(inf) in
C     s*E(eps,inf)-A(eps,inf) using Algorithm 3.3.3 in [1].
C
C     On entry, it is assumed that the M-by-N matrices A and E have
C     been obtained after applying the Algorithms 3.2.1 and 3.3.1 to
C     the pencil s*E - A as described in [1], i.e.
C
C                        | s*E(eps,inf)-A(eps,inf) |      X      |
C        Q'(s*E - A)Z  = |-------------------------|-------------|
C                        |             0           | s*E(r)-A(r) |
C
C     Here the pencil s*E(eps,inf)-A(eps,inf) is in staircase form.
C     This pencil contains all Kronecker column indices and infinite
C     elementary divisors of the pencil s*E - A.
C     The pencil s*E(r)-A(r) contains all Kronecker row indices and
C     finite elementary divisors of s*E - A.
C     Furthermore, the submatrices having full row and column rank in
C     the pencil s*E(eps,inf)-A(eps,inf) are assumed to be
C     triangularized.
C
C     On exit, the result then is
C
C                        Q'(s*E - A)Z =
C
C          | s*E(eps)-A(eps) |        X        |      X      |
C          |-----------------|-----------------|-------------|
C          |        0        | s*E(inf)-A(inf) |      X      |
C          |===================================|=============|
C          |                                   |             |
C          |                 0                 | s*E(r)-A(r) |
C
C     Note that the pencil s*E(r)-A(r) is not reduced further.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPDATQ  LOGICAL
C             Indicates whether the user wishes to accumulate in a
C             matrix Q the orthogonal row transformations, as follows:
C             = .FALSE.: Do not form Q;
C             = .TRUE.:  The given matrix Q is updated by the orthogonal
C                        row transformations used in the reduction.
C
C     UPDATZ  LOGICAL
C             Indicates whether the user wishes to accumulate in a
C             matrix Z the orthogonal column transformations, as
C             follows:
C             = .FALSE.: Do not form Z;
C             = .TRUE.:  The given matrix Z is updated by the orthogonal
C                        column transformations used in the reduction.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             Number of rows of A and E.  M >= 0.
C
C     N       (input) INTEGER
C             Number of columns of A and E.  N >= 0.
C
C     NBLCKS  (input/output) INTEGER
C             On entry, the number of submatrices having full row rank
C             (possibly zero) in A(eps,inf).
C             On exit, the input value has been reduced by one, if the
C             last submatrix is a 0-by-0 (empty) matrix.
C
C     INUK    (input/output) INTEGER array, dimension (NBLCKS)
C             On entry, this array contains the row dimensions nu(k),
C             (k=1, 2, ..., NBLCKS) of the submatrices having full row
C             rank in the pencil s*E(eps,inf)-A(eps,inf).
C             On exit, this array contains the row dimensions nu(k),
C             (k=1, 2, ..., NBLCKS) of the submatrices having full row
C             rank in the pencil s*E(eps)-A(eps).
C
C     IMUK    (input/output) INTEGER array, dimension (NBLCKS)
C             On entry, this array contains the column dimensions mu(k),
C             (k=1, 2, ..., NBLCKS) of the submatrices having full
C             column rank in the pencil s*E(eps,inf)-A(eps,inf).
C             On exit, this array contains the column dimensions mu(k),
C             (k=1, 2, ..., NBLCKS) of the submatrices having full
C             column rank in the pencil s*E(eps)-A(eps).
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, this array contains the matrix A to be reduced.
C             On exit, it contains the transformed matrix A.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,M).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, this array contains the matrix E to be reduced.
C             On exit, it contains the transformed matrix E.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,M).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,*)
C             On entry, if UPDATQ = .TRUE., then the leading M-by-M
C             part of this array must contain a given matrix Q (e.g.
C             from a previous call to another SLICOT routine), and on
C             exit, the leading M-by-M part of this array contains the
C             product of the input matrix Q and the row transformation
C             matrix that has transformed the rows of the matrices A
C             and E.
C             If UPDATQ = .FALSE., the array Q is not referenced and
C             can be supplied as a dummy array (i.e. set parameter
C             LDQ = 1 and declare this array to be Q(1,1) in the calling
C             program).
C
C     LDQ     INTEGER
C             The leading dimension of array Q. If UPDATQ = .TRUE.,
C             LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1.
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,*)
C             On entry, if UPDATZ = .TRUE., then the leading N-by-N
C             part of this array must contain a given matrix Z (e.g.
C             from a previous call to another SLICOT routine), and on
C             exit, the leading N-by-N part of this array contains the
C             product of the input matrix Z and the column
C             transformation matrix that has transformed the columns of
C             the matrices A and E.
C             If UPDATZ = .FALSE., the array Z is not referenced and
C             can be supplied as a dummy array (i.e. set parameter
C             LDZ = 1 and declare this array to be Z(1,1) in the calling
C             program).
C
C     LDZ     INTEGER
C             The leading dimension of array Z. If UPDATZ = .TRUE.,
C             LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1.
C
C     MNEI    (output) INTEGER array, dimension (4)
C             MNEI(1) = MEPS = row    dimension of s*E(eps)-A(eps),
C             MNEI(2) = NEPS = column dimension of s*E(eps)-A(eps),
C             MNEI(3) = MINF = row    dimension of s*E(inf)-A(inf),
C             MNEI(4) = NINF = column dimension of s*E(inf)-A(inf).
C
C     REFERENCES
C
C     [1] Beelen, Th.
C         New Algorithms for Computing the Kronecker structure of a
C         Pencil with Applications to Systems and Control Theory.
C         Ph.D.Thesis, Eindhoven University of Technology,
C         The Netherlands, 1987.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997.
C     Supersedes Release 2.0 routine MB04FX by Th.G.J. Beelen,
C     Philips Glass Eindhoven, Holland.
C
C     REVISIONS
C
C     June 13, 1997, V. Sima.
C     November 24, 1997, A. Varga: initialization of MNEI to 0, instead
C                                  of ZERO.
C
C     KEYWORDS
C
C     Generalized eigenvalue problem, Kronecker indices, orthogonal
C     transformation, staircase form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      LOGICAL           UPDATQ, UPDATZ
      INTEGER           LDA, LDE, LDQ, LDZ, M, N, NBLCKS
C     .. Array Arguments ..
      INTEGER           IMUK(*), INUK(*), MNEI(4)
      DOUBLE PRECISION  A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*)
C     .. Local Scalars ..
      INTEGER           CA, CE, CJA, CJE, IP, ISMUK, ISNUK, K, MEPS,
     $                  MINF, MUK, MUKP1, MUP, MUP1, NEPS, NINF, NUK,
     $                  NUP, RA, RJE, SK1P1, TK1P1, TP1
      DOUBLE PRECISION  SC, SS
C     .. External Subroutines ..
      EXTERNAL          DROTG, MB04TU
C     .. Executable Statements ..
C
      MNEI(1) = 0
      MNEI(2) = 0
      MNEI(3) = 0
      MNEI(4) = 0
      IF ( M.LE.0 .OR. N.LE.0 )
     $   RETURN
C
C     Initialisation.
C
      ISMUK = 0
      ISNUK = 0
C
      DO 20 K = 1, NBLCKS
         ISMUK = ISMUK + IMUK(K)
         ISNUK = ISNUK + INUK(K)
   20 CONTINUE
C
C     MEPS, NEPS are the dimensions of the pencil s*E(eps)-A(eps).
C     MEPS = Sum(k=1,...,nblcks) NU(k),
C     NEPS = Sum(k=1,...,nblcks) MU(k).
C     MINF, NINF are the dimensions of the pencil s*E(inf)-A(inf).
C
      MEPS = ISNUK
      NEPS = ISMUK
      MINF = 0
      NINF = 0
C
C     MUKP1 = mu(k+1).  N.B. It is assumed that mu(NBLCKS + 1) = 0.
C
      MUKP1 = 0
C
      DO 120 K = NBLCKS, 1, -1
         NUK = INUK(K)
         MUK = IMUK(K)
C
C        Reduce submatrix E(k,k+1) to square matrix.
C        NOTE that always NU(k) >= MU(k+1) >= 0.
C
C        WHILE ( NU(k) >  MU(k+1) ) DO
   40    IF ( NUK.GT.MUKP1 ) THEN
C
C           sk1p1 = sum(i=k+1,...,p-1) NU(i)
C           tk1p1 = sum(i=k+1,...,p-1) MU(i)
C           ismuk = sum(i=1,...,k) MU(i)
C           tp1   = sum(i=1,...,p-1) MU(i) = ismuk + tk1p1.
C
            SK1P1 = 0
            TK1P1 = 0
C
            DO 100 IP = K + 1, NBLCKS
C
C              Annihilate the elements originally present in the last
C              row of E(k,p+1) and A(k,p).
C              Start annihilating the first MU(p) - MU(p+1) elements by
C              applying column Givens rotations plus interchanging
C              elements.
C              Use original bottom diagonal element of A(k,k) as pivot.
C              Start position of pivot in A = (ra,ca).
C
               TP1 = ISMUK + TK1P1
               RA  = ISNUK + SK1P1
               CA  = TP1
C
               MUP  = IMUK(IP)
               NUP  = INUK(IP)
               MUP1 = NUP
C
               DO 60 CJA = CA, CA + MUP - NUP - 1
C
C                 CJA = current column index of pivot in A.
C
                  CALL DROTG( A(RA,CJA), A(RA,CJA+1), SC, SS )
C
C                 Apply transformations to A- and E-matrix.
C                 Interchange columns simultaneously.
C                 Update column transformation matrix Z, if needed.
C
                  CALL MB04TU( RA-1, A(1,CJA), 1, A(1,CJA+1), 1, SC,
     $                         SS )
                  A(RA,CJA+1) = A(RA,CJA)
                  A(RA,CJA) = ZERO
                  CALL MB04TU( RA, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS )
                  IF( UPDATZ ) CALL MB04TU( N, Z(1,CJA), 1, Z(1,CJA+1),
     $                                      1, SC, SS )
   60          CONTINUE
C
C              Annihilate the remaining elements originally present in
C              the last row of E(k,p+1) and A(k,p) by alternatingly
C              applying row and column rotations plus interchanging
C              elements.
C              Use diagonal elements of E(p,p+1) and original bottom
C              diagonal element of A(k,k) as pivots, respectively.
C              (re,ce) and (ra,ca) are the starting positions of the
C              pivots in E and A.
C
               CE = TP1 + MUP
               CA = CE - MUP1 - 1
C
               DO 80 RJE = RA + 1, RA + MUP1
C
C                 (RJE,CJE) = current position pivot in E.
C
                  CJE = CE + 1
                  CJA = CA + 1
C
C                 Determine the row transformations.
C                 Apply these transformations to E- and A-matrix.
C                 Interchange the rows simultaneously.
C                 Update row transformation matrix Q, if needed.
C
                  CALL DROTG( E(RJE,CJE), E(RJE-1,CJE), SC, SS )
                  CALL MB04TU( N-CJE, E(RJE,CJE+1), LDE, E(RJE-1,CJE+1),
     $                         LDE, SC, SS )
                  E(RJE-1,CJE) = E(RJE,CJE)
                  E(RJE,CJE) = ZERO
                  CALL MB04TU( N-CJA+1, A(RJE,CJA), LDA, A(RJE-1,CJA),
     $                         LDA, SC, SS )
                  IF( UPDATQ ) CALL MB04TU( M, Q(1,RJE), 1,
     $                                      Q(1,RJE-1), 1, SC, SS )
C
C                 Determine the column transformations.
C                 Apply these transformations to A- and E-matrix.
C                 Interchange the columns simultaneously.
C                 Update column transformation matrix Z, if needed.
C
                  CALL DROTG( A(RJE,CJA), A(RJE,CJA+1), SC, SS )
                  CALL MB04TU( RJE-1, A(1,CJA), 1, A(1,CJA+1), 1, SC,
     $                         SS )
                  A(RJE,CJA+1) = A(RJE,CJA)
                  A(RJE,CJA) = ZERO
                  CALL MB04TU( RJE, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS )
                  IF( UPDATZ ) CALL MB04TU( N, Z(1,CJA), 1, Z(1,CJA+1),
     $                                      1, SC, SS )
   80          CONTINUE
C
               SK1P1 = SK1P1 + NUP
               TK1P1 = TK1P1 + MUP
C
  100       CONTINUE
C
C           Reduce A=A(eps,inf) and E=E(eps,inf) by ignoring their last
C           row and right most column. The row and column ignored
C           belong to the pencil s*E(inf)-A(inf).
C           Redefine blocks in new A and E.
C
            MUK = MUK - 1
            NUK = NUK - 1
            ISMUK = ISMUK - 1
            ISNUK = ISNUK - 1
            MEPS = MEPS - 1
            NEPS = NEPS - 1
            MINF = MINF + 1
            NINF = NINF + 1
C
            GO TO 40
         END IF
C        END WHILE 40
C
         IMUK(K) = MUK
         INUK(K) = NUK
C
C        Now submatrix E(k,k+1) is square.
C
C        Consider next submatrix (k:=k-1).
C
         ISNUK = ISNUK - NUK
         ISMUK = ISMUK - MUK
         MUKP1 = MUK
  120 CONTINUE
C
C     If mu(NBLCKS) = 0, then the last submatrix counted in NBLCKS is
C     a 0-by-0 (empty) matrix. This "matrix" must be removed.
C
      IF ( IMUK(NBLCKS).EQ.0 ) NBLCKS = NBLCKS - 1
C
C     Store dimensions of the pencils s*E(eps)-A(eps) and
C     s*E(inf)-A(inf) in array MNEI.
C
      MNEI(1) = MEPS
      MNEI(2) = NEPS
      MNEI(3) = MINF
      MNEI(4) = NINF
C
      RETURN
C *** Last line of MB04TX ***
      END


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file shags.f
c
c     this file contains code and documentation for subroutines
c     shags and shagsi
c
c ... files which must be loaded with shags.f
c
c     sphcom.f, hrfft.f, gaqd.f
c
c     subroutine shags(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,
c    1                    wshags,lshags,work,lwork,ierror)
c
c     subroutine shags performs the spherical harmonic analysis
c     on the array g and stores the result in the arrays a and b.
c     the analysis is performed on a gaussian grid in colatitude
c     and an equally spaced grid in longitude.  the associated
c     legendre functions are stored rather than recomputed as they
c     are in subroutine shagc.  the analysis is described below
c     at output parameters a,b.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are compu
c            in radians in theta(1),...,theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid poi
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     isym   = 0  no symmetries exist about the equator. the analysis
c                 is performed on the entire sphere.  i.e. on the
c                 array g(i,j) for i=1,...,nlat and j=1,...,nlon.
c                 (see description of g below)
c
c            = 1  g is antisymmetric about the equator. the analysis
c                 is performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the analysis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the analysis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c
c            = 2  g is symmetric about the equator. the analysis is
c                 performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the analysis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the analysis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c     nt     the number of analyses.  in the program that calls shags,
c            the arrays g,a and b can be three dimensional in which
c            case multiple analyses will be performed.  the third
c            index is the analysis index which assumes the values
c            k=1,...,nt.  for a single analysis set nt=1. the
c            discription of the remaining parameters is simplified
c            by assuming that nt=1 or that the arrays g,a and b
c            have only two dimensions.
c
c     g      a two or three dimensional array (see input parameter
c            nt) that contains the discrete function to be analyzed.
c            g(i,j) contains the value of the function at the gaussian
c            point theta(i) and longitude point phi(j) = (j-1)*2*pi/nlon
c            the index ranges are defined above at the input parameter
c            isym.
c
c     idg    the first dimension of the array g as it appears in the
c            program that calls shags. if isym equals zero then idg
c            must be at least nlat.  if isym is nonzero then idg must
c            be at least nlat/2 if nlat is even or at least (nlat+1)/2
c            if nlat is odd.
c
c     jdg    the second dimension of the array g as it appears in the
c            program that calls shags. jdg must be at least nlon.
c
c     mdab   the first dimension of the arrays a and b as it appears
c            in the program that calls shags. mdab must be at least
c            min0((nlon+2)/2,nlat) if nlon is even or at least
c            min0((nlon+1)/2,nlat) if nlon is odd.
c
c     ndab   the second dimension of the arrays a and b as it appears
c            in the program that calls shags. ndab must be at least nlat
c
c     wshags an array which must be initialized by subroutine shagsi.
c            once initialized, wshags can be used repeatedly by shags
c            as long as nlat and nlon remain unchanged.  wshags must
c            not be altered between calls of shags.
c
c     lshags the dimension of the array wshags as it appears in the
c            program that calls shags. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshags must be at least
c
c            nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
c
c     work   a real work space which need not be saved
c
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls shags. define
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c
c            if isym is zero then lwork must be at least
c
c                  nlat*nlon*(nt+1)
c
c            if isym is nonzero then lwork must be at least
c
c                  l2*nlon*(nt+1)
c
c     **************************************************************
c
c     output parameters
c
c     a,b    both a,b are two or three dimensional arrays (see input
c            parameter nt) that contain the spherical harmonic
c            coefficients in the representation of g(i,j) given in the
c            discription of subroutine shags. for isym=0, a(m,n) and
c            b(m,n) are given by the equations listed below. symmetric
c            versions are used when isym is greater than zero.
c
c     definitions
c
c     1. the normalized associated legendre functions
c
c     pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m)))
c                       *sin(theta)**m/(2**n*factorial(n)) times the
c                       (n+m)th derivative of (x**2-1)**n with respect
c                       to x=cos(theta).
c
c     2. the fourier transform of g(i,j).
c
c     c(m,i)          = 2/nlon times the sum from j=1 to j=nlon of
c                       g(i,j)*cos((m-1)*(j-1)*2*pi/nlon)
c                       (the first and last terms in this sum
c                       are divided by 2)
c
c     s(m,i)          = 2/nlon times the sum from j=2 to j=nlon of
c                       g(i,j)*sin((m-1)*(j-1)*2*pi/nlon)
c
c
c     3. the gaussian points and weights on the sphere
c        (computed by subroutine gaqd).
c
c        theta(1),...,theta(nlat) (gaussian pts in radians)
c        wts(1),...,wts(nlat) (corresponding gaussian weights)
c
c
c     4. the maximum (plus one) longitudinal wave number
c
c            mmax = min0(nlat,(nlon+2)/2) if nlon is even or
c            mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
c
c
c     then for m=0,...,mmax-1 and n=m,...,nlat-1 the arrays a,b
c     are given by
c
c     a(m+1,n+1)     =  the sum from i=1 to i=nlat of
c                       c(m+1,i)*wts(i)*pbar(m,n,theta(i))
c
c     b(m+1,n+1)      = the sum from i=1 to nlat of
c                       s(m+1,i)*wts(i)*pbar(m,n,theta(i))
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of isym
c            = 4  error in the specification of nt
c            = 5  error in the specification of idg
c            = 6  error in the specification of jdg
c            = 7  error in the specification of mdab
c            = 8  error in the specification of ndab
c            = 9  error in the specification of lshags
c            = 10 error in the specification of lwork
c
c
c ****************************************************************
c
c     subroutine shagsi(nlat,nlon,wshags,lshags,work,lwork,dwork,ldwork,
c    +                  ierror)
c
c     subroutine shagsi initializes the array wshags which can then
c     be used repeatedly by subroutines shags. it precomputes
c     and stores in wshags quantities such as gaussian weights,
c     legendre polynomial coefficients, and fft trigonometric tables.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are compu
c            in radians in theta(1),...,theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid poi
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     wshags an array which must be initialized by subroutine shagsi.
c            once initialized, wshags can be used repeatedly by shags
c            as long as nlat and nlon remain unchanged.  wshags must
c            not be altered between calls of shags.
c
c     lshags the dimension of the array wshags as it appears in the
c            program that calls shags. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshags must be at least
c
c            nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
c
c     work   a real work space which need not be saved
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls shagsi. lwork must be at least
c            4*nlat*(nlat+2)+2 in the routine calling shagsi
c
C*PL*ERROR* Comment line too long
c     dwork   a double precision work array that does not have to be saved.
c
c     ldwork  the length of dwork in the calling routine.  ldwork must
c             be at least nlat*(nlat+4)
c
c     output parameter
c
c     wshags an array which must be initialized before calling shags or
c            once initialized, wshags can be used repeatedly by shags or
c            as long as nlat and nlon remain unchanged.  wshags must not
c            altered between calls of shasc.
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of lshags
c            = 4  error in the specification of lwork
c            = 5  error in the specification of ldwork
c            = 6  failure in gaqd to compute gaussian points
c                 (due to failure in eigenvalue routine)
c
c
c ****************************************************************
      SUBROUTINE DSHAGS(NLAT,NLON,MODE,NT,G,IDG,JDG,A,B,MDAB,NDAB,
     +                  WSHAGS,LSHAGS,WORK,LWORK,IERROR)
      DOUBLE PRECISION G
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION WSHAGS
      DOUBLE PRECISION WORK
c     subroutine shags performs the spherical harmonic analysis on
c     a gaussian grid on the array(s) in g and returns the coefficients
c     in array(s) a,b. the necessary legendre polynomials are fully
c     stored in this version.
c
      DIMENSION G(IDG,JDG,1),A(MDAB,NDAB,1),B(MDAB,NDAB,1),
     +          WSHAGS(LSHAGS),WORK(LWORK)
c     check input parameters
      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
      IERROR = 3
      IF (MODE.LT.0 .OR. MODE.GT.2) RETURN
c     set m limit for pmn
      L = MIN0((NLON+2)/2,NLAT)
c     set gaussian point nearest equator pointer
      LATE = (NLAT+MOD(NLAT,2))/2
c     set number of grid points for analysis/synthesis
      LAT = NLAT
      IF (MODE.NE.0) LAT = LATE
      IERROR = 4
      IF (NT.LT.1) RETURN
      IERROR = 5
      IF (IDG.LT.LAT) RETURN
      IERROR = 6
      IF (JDG.LT.NLON) RETURN
      IERROR = 7
      IF (MDAB.LT.L) RETURN
      IERROR = 8
      IF (NDAB.LT.NLAT) RETURN
      L1 = L
      L2 = LATE
      IERROR = 9
c     check permanent work space length
c
      LP = NLAT* (3* (L1+L2)-2) + (L1-1)* (L2* (2*NLAT-L1)-3*L1)/2 +
     +     NLON + 15
      IF (LSHAGS.LT.LP) RETURN
      IERROR = 10
c     check temporary work space length
      IF (MODE.EQ.0 .AND. LWORK.LT.NLAT*NLON* (NT+1)) RETURN
      IF (MODE.NE.0 .AND. LWORK.LT.L2*NLON* (NT+1)) RETURN
      IERROR = 0
c     set starting address for gaussian wts ,fft values,
c     and fully stored legendre polys in wshags
      IWTS = 1
      IFFT = NLAT + 2*NLAT*LATE + 3* (L* (L-1)/2+ (NLAT-L)* (L-1)) + 1
      IPMN = IFFT + NLON + 15
c     set pointer for internal storage of g
      IW = LAT*NLON*NT + 1
      CALL DSHAGS1(NLAT,NLON,L,LAT,MODE,G,IDG,JDG,NT,A,B,MDAB,NDAB,
     +             WSHAGS(IWTS),WSHAGS(IFFT),WSHAGS(IPMN),LATE,WORK,
     +             WORK(IW))
      RETURN
      END

      SUBROUTINE DSHAGS1(NLAT,NLON,L,LAT,MODE,GS,IDG,JDG,NT,A,B,MDAB,
     +                   NDAB,WTS,WFFT,PMN,LATE,G,WORK)
      DOUBLE PRECISION GS
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION WTS
      DOUBLE PRECISION WFFT
      DOUBLE PRECISION PMN
      DOUBLE PRECISION G
      DOUBLE PRECISION WORK
      DOUBLE PRECISION SFN
      DOUBLE PRECISION T1
      DOUBLE PRECISION T2
      DIMENSION GS(IDG,JDG,NT),A(MDAB,NDAB,NT),B(MDAB,NDAB,NT),
     +          G(LAT,NLON,NT)
      DIMENSION WFFT(1),PMN(LATE,1),WTS(NLAT),WORK(1)
c     set gs array internally in shags1
      DO 100 K = 1,NT
          DO 100 J = 1,NLON
              DO 100 I = 1,LAT
                  G(I,J,K) = GS(I,J,K)
  100 CONTINUE

c     do fourier transform
      DO 101 K = 1,NT
          CALL DHRFFTF(LAT,NLON,G(1,1,K),LAT,WFFT,WORK)
  101 CONTINUE

c     scale result
      SFN = 2.0D0/DBLE(NLON)
      DO 102 K = 1,NT
          DO 102 J = 1,NLON
              DO 102 I = 1,LAT
                  G(I,J,K) = SFN*G(I,J,K)
  102 CONTINUE

c     compute using gaussian quadrature
c     a(n,m) = s (ga(theta,m)*pnm(theta)*sin(theta)*dtheta)
c     b(n,m) = s (gb(theta,m)*pnm(theta)*sin(theta)*dtheta)
c     here ga,gb are the cos(phi),sin(phi) coefficients of
c     the fourier expansion of g(theta,phi) in phi.  as a result
c     of the above fourier transform they are stored in array
c     g as follows:
c     for each theta(i) and k= l-1
c     ga(0),ga(1),gb(1),ga(2),gb(2),...,ga(k-1),gb(k-1),ga(k)
c     correspond to
C*PL*ERROR* Comment line too long
c     g(i,1),g(i,2),g(i,3),g(i,4),g(i,5),...,g(i,2l-4),g(i,2l-3),g(i,2l-2)
c     whenever 2*l-2 = nlon exactly
c     initialize coefficients to zero
      DO 103 K = 1,NT
          DO 103 NP1 = 1,NLAT
              DO 103 MP1 = 1,L
                  A(MP1,NP1,K) = 0.0D0
                  B(MP1,NP1,K) = 0.0D0
  103 CONTINUE
c     set mp1 limit on b(mp1) calculation
      LM1 = L
      IF (NLON.EQ.L+L-2) LM1 = L - 1

      IF (MODE.EQ.0) THEN
c     for full sphere (mode=0) and even/odd reduction:
c     overwrite g(i) with (g(i)+g(nlat-i+1))*wts(i)
c     overwrite g(nlat-i+1) with (g(i)-g(nlat-i+1))*wts(i)
          NL2 = NLAT/2
          DO 104 K = 1,NT
              DO 104 J = 1,NLON
                  DO 105 I = 1,NL2
                      IS = NLAT - I + 1
                      T1 = G(I,J,K)
                      T2 = G(IS,J,K)
                      G(I,J,K) = WTS(I)* (T1+T2)
                      G(IS,J,K) = WTS(I)* (T1-T2)
  105             CONTINUE
c     adjust equator if necessary(nlat odd)
                  IF (MOD(NLAT,2).NE.0) G(LATE,J,K) = WTS(LATE)*
     +                G(LATE,J,K)
  104     CONTINUE
c     set m = 0 coefficients first
          MP1 = 1
          M = 0
          MML1 = M* (2*NLAT-M-1)/2
          DO 106 K = 1,NT
              DO 106 I = 1,LATE
                  IS = NLAT - I + 1
                  DO 107 NP1 = 1,NLAT,2
c     n even
                      A(1,NP1,K) = A(1,NP1,K) + G(I,1,K)*PMN(I,MML1+NP1)
  107             CONTINUE
                  DO 108 NP1 = 2,NLAT,2
c     n odd
                      A(1,NP1,K) = A(1,NP1,K) +
     +                             G(IS,1,K)*PMN(I,MML1+NP1)
  108             CONTINUE
  106     CONTINUE
c     compute m.ge.1  coefficients next
          DO 109 MP1 = 2,LM1
              M = MP1 - 1
              MML1 = M* (2*NLAT-M-1)/2
              MP2 = MP1 + 1
              DO 110 K = 1,NT
                  DO 111 I = 1,LATE
                      IS = NLAT - I + 1
c     n-m even
                      DO 112 NP1 = MP1,NLAT,2
                          A(MP1,NP1,K) = A(MP1,NP1,K) +
     +                                   G(I,2*M,K)*PMN(I,MML1+NP1)
                          B(MP1,NP1,K) = B(MP1,NP1,K) +
     +                                   G(I,2*M+1,K)*PMN(I,MML1+NP1)
  112                 CONTINUE
c     n-m odd
                      DO 113 NP1 = MP2,NLAT,2
                          A(MP1,NP1,K) = A(MP1,NP1,K) +
     +                                   G(IS,2*M,K)*PMN(I,MML1+NP1)
                          B(MP1,NP1,K) = B(MP1,NP1,K) +
     +                                   G(IS,2*M+1,K)*PMN(I,MML1+NP1)
  113                 CONTINUE
  111             CONTINUE
  110         CONTINUE
  109     CONTINUE
          IF (NLON.EQ.L+L-2) THEN
c     compute m=l-1, n=l-1,l,...,nlat-1 coefficients
              M = L - 1
              MML1 = M* (2*NLAT-M-1)/2
              DO 114 K = 1,NT
                  DO 114 I = 1,LATE
                      IS = NLAT - I + 1
                      DO 124 NP1 = L,NLAT,2
                          MN = MML1 + NP1
                          A(L,NP1,K) = A(L,NP1,K) +
     +                                 0.5D0*G(I,NLON,K)*PMN(I,MN)
  124                 CONTINUE
c     n-m  odd
                      LP1 = L + 1
                      DO 125 NP1 = LP1,NLAT,2
                          MN = MML1 + NP1
                          A(L,NP1,K) = A(L,NP1,K) +
     +                                 0.5D0*G(IS,NLON,K)*PMN(I,MN)
  125                 CONTINUE
  114         CONTINUE
          END IF

      ELSE

c     half sphere
c     overwrite g(i) with wts(i)*(g(i)+g(i)) for i=1,...,nlate/2
          NL2 = NLAT/2
          DO 116 K = 1,NT
              DO 116 J = 1,NLON
                  DO 115 I = 1,NL2
                      G(I,J,K) = WTS(I)* (G(I,J,K)+G(I,J,K))
  115             CONTINUE
c     adjust equator separately if a grid point
                  IF (NL2.LT.LATE) G(LATE,J,K) = WTS(LATE)*G(LATE,J,K)
  116     CONTINUE

c     set m = 0 coefficients first
          MP1 = 1
          M = 0
          MML1 = M* (2*NLAT-M-1)/2
          MS = 1
          IF (MODE.EQ.1) MS = 2
          DO 117 K = 1,NT
              DO 117 I = 1,LATE
                  DO 117 NP1 = MS,NLAT,2
                      A(1,NP1,K) = A(1,NP1,K) + G(I,1,K)*PMN(I,MML1+NP1)
  117     CONTINUE

c     compute m.ge.1  coefficients next
          DO 118 MP1 = 2,LM1
              M = MP1 - 1
              MML1 = M* (2*NLAT-M-1)/2
              MS = MP1
              IF (MODE.EQ.1) MS = MP1 + 1
              DO 119 K = 1,NT
                  DO 119 I = 1,LATE
                      DO 119 NP1 = MS,NLAT,2
                          A(MP1,NP1,K) = A(MP1,NP1,K) +
     +                                   G(I,2*M,K)*PMN(I,MML1+NP1)
                          B(MP1,NP1,K) = B(MP1,NP1,K) +
     +                                   G(I,2*M+1,K)*PMN(I,MML1+NP1)
  119         CONTINUE
  118     CONTINUE

          IF (NLON.EQ.L+L-2) THEN
c     compute n=m=l-1 coefficients last
              M = L - 1
              MML1 = M* (2*NLAT-M-1)/2
c     set starting n for mode even
              NS = L
c     set starting n for mode odd
              IF (MODE.EQ.1) NS = L + 1
              DO 120 K = 1,NT
                  DO 120 I = 1,LATE
                      DO 120 NP1 = NS,NLAT,2
                          MN = MML1 + NP1
                          A(L,NP1,K) = A(L,NP1,K) +
     +                                 0.5D0*G(I,NLON,K)*PMN(I,MN)
  120         CONTINUE
          END IF

      END IF

      RETURN
      END
      SUBROUTINE DSHAGSI(NLAT,NLON,WSHAGS,LSHAGS,WORK,LWORK,DWORK,
     +                   LDWORK,IERROR)
      DOUBLE PRECISION WSHAGS
      DOUBLE PRECISION WORK
c
c     this subroutine must be called before calling shags or shsgs with
c     fixed nlat,nlon. it precomputes the gaussian weights, points
c     and all necessary legendre polys and stores them in wshags.
c     these quantities must be preserved when calling shags or shsgs
c     repeatedly with fixed nlat,nlon.  dwork must be of length at
c     least nlat*(nlat+4) in the routine calling shagsi.  This is
c     not checked.  undetectable errors will result if dwork is
c     smaller than nlat*(nlat+4).
c
      DIMENSION WSHAGS(LSHAGS),WORK(LWORK)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DWORK(LDWORK)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
c     set triangular truncation limit for spherical harmonic basis
      L = MIN0((NLON+2)/2,NLAT)
c     set equator or nearest point (if excluded) pointer
      LATE = (NLAT+1)/2
      L1 = L
      L2 = LATE
c     check permanent work space length
      IERROR = 3
      LP = NLAT* (3* (L1+L2)-2) + (L1-1)* (L2* (2*NLAT-L1)-3*L1)/2 +
     +     NLON + 15
      IF (LSHAGS.LT.LP) RETURN
      IERROR = 4
c     check temporary work space
      IF (LWORK.LT.4*NLAT* (NLAT+2)+2) RETURN
      IERROR = 5
c     check double precision temporary space
      IF (LDWORK.LT.NLAT* (NLAT+4)) RETURN
      IERROR = 0
C*PL*ERROR* Comment line too long
c     set preliminary quantites needed to compute and store legendre polys
      LDW = NLAT* (NLAT+4)
      CALL DSHAGSP(NLAT,NLON,WSHAGS,LSHAGS,DWORK,LDWORK,IERROR)
      IF (IERROR.NE.0) RETURN
c     set legendre poly pointer in wshags
      IPMNF = NLAT + 2*NLAT*LATE + 3* (L* (L-1)/2+ (NLAT-L)* (L-1)) +
     +        NLON + 16
      CALL DSHAGSS1(NLAT,L,LATE,WSHAGS,WORK,WSHAGS(IPMNF))
      RETURN
      END
      SUBROUTINE DSHAGSS1(NLAT,L,LATE,W,PMN,PMNF)
      DOUBLE PRECISION W
      DOUBLE PRECISION PMN
      DOUBLE PRECISION PMNF
      DIMENSION W(1),PMN(NLAT,LATE,3),PMNF(LATE,1)
c     compute and store legendre polys for i=1,...,late,m=0,...,l-1
c     and n=m,...,l-1
      DO I = 1,NLAT
          DO J = 1,LATE
              DO K = 1,3
                  PMN(I,J,K) = 0.0D0
              END DO
          END DO
      END DO
      DO 100 MP1 = 1,L
          M = MP1 - 1
          MML1 = M* (2*NLAT-M-1)/2
c     compute pmn for n=m,...,nlat-1 and i=1,...,(l+1)/2
          MODE = 0
          CALL DLEGIN(MODE,L,NLAT,M,W,PMN,KM)
c     store above in pmnf
          DO 101 NP1 = MP1,NLAT
              MN = MML1 + NP1
              DO 102 I = 1,LATE
                  PMNF(I,MN) = PMN(NP1,I,KM)
  102         CONTINUE
  101     CONTINUE
  100 CONTINUE
      RETURN
      END
      SUBROUTINE DSHAGSP(NLAT,NLON,WSHAGS,LSHAGS,DWORK,LDWORK,IERROR)
      DOUBLE PRECISION WSHAGS
      DIMENSION WSHAGS(LSHAGS)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DWORK(LDWORK)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
c     set triangular truncation limit for spherical harmonic basis
      L = MIN0((NLON+2)/2,NLAT)
c     set equator or nearest point (if excluded) pointer
      LATE = (NLAT+MOD(NLAT,2))/2
      L1 = L
      L2 = LATE
      IERROR = 3
c     check permanent work space length
      IF (LSHAGS.LT.NLAT* (2*L2+3*L1-2)+3*L1* (1-L1)/2+NLON+15) RETURN
      IERROR = 4
c     if (lwork.lt.4*nlat*(nlat+2)+2) return
      IF (LDWORK.LT.NLAT* (NLAT+4)) RETURN
      IERROR = 0
c     set pointers
      I1 = 1
      I2 = I1 + NLAT
      I3 = I2 + NLAT*LATE
      I4 = I3 + NLAT*LATE
      I5 = I4 + L* (L-1)/2 + (NLAT-L)* (L-1)
      I6 = I5 + L* (L-1)/2 + (NLAT-L)* (L-1)
      I7 = I6 + L* (L-1)/2 + (NLAT-L)* (L-1)
c     set indices in temp work for double precision gaussian wts and pts
      IDTH = 1
c     idwts = idth+2*nlat
c     iw = idwts+2*nlat
      IDWTS = IDTH + NLAT
      IW = IDWTS + NLAT
      CALL DSHAGSP1(NLAT,NLON,L,LATE,WSHAGS(I1),WSHAGS(I2),WSHAGS(I3),
     +              WSHAGS(I4),WSHAGS(I5),WSHAGS(I6),WSHAGS(I7),
     +              DWORK(IDTH),DWORK(IDWTS),DWORK(IW),IERROR)
      IF (IERROR.NE.0) IERROR = 6
      RETURN
      END

      SUBROUTINE DSHAGSP1(NLAT,NLON,L,LATE,WTS,P0N,P1N,ABEL,BBEL,CBEL,
     +                    WFFT,DTHETA,DWTS,WORK,IER)
      DOUBLE PRECISION WTS
      DOUBLE PRECISION P0N
      DOUBLE PRECISION P1N
      DOUBLE PRECISION ABEL
      DOUBLE PRECISION BBEL
      DOUBLE PRECISION CBEL
      DOUBLE PRECISION WFFT
      DOUBLE PRECISION FN
      DOUBLE PRECISION FM
      DIMENSION WTS(NLAT),P0N(NLAT,LATE),P1N(NLAT,LATE),ABEL(1),BBEL(1),
     +          CBEL(1),WFFT(1),DTHETA(NLAT),DWTS(NLAT)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION PB,DTHETA,DWTS,WORK(*)

      INDX(M,N) = (N-1)* (N-2)/2 + M - 1
      IMNDX(M,N) = L* (L-1)/2 + (N-L-1)* (L-1) + M - 1
      CALL DHRFFTI(NLON,WFFT)

c     compute double precision gaussian points and weights
c     lw = 4*nlat*(nlat+2)
      LW = NLAT* (NLAT+2)
      CALL DGAQD(NLAT,DTHETA,DWTS,WORK,LW,IER)
      IF (IER.NE.0) RETURN

c     store gaussian weights single precision to save computation
c     in inner loops in analysis
      DO 100 I = 1,NLAT
          WTS(I) = DWTS(I)
  100 CONTINUE
c     initialize p0n,p1n using double precision dnlfk,dnlft
      DO 101 NP1 = 1,NLAT
          DO 101 I = 1,LATE
              P0N(NP1,I) = 0.0D0
              P1N(NP1,I) = 0.0D0
  101 CONTINUE
c     compute m=n=0 legendre polynomials for all theta(i)
      NP1 = 1
      N = 0
      M = 0
      CALL DDNLFK(M,N,WORK)
      DO 103 I = 1,LATE
          CALL DDNLFT(M,N,DTHETA(I),WORK,PB)
          P0N(1,I) = PB
  103 CONTINUE
c     compute p0n,p1n for all theta(i) when n.gt.0
      DO 104 NP1 = 2,NLAT
          N = NP1 - 1
          M = 0
          CALL DDNLFK(M,N,WORK)
          DO 105 I = 1,LATE
              CALL DDNLFT(M,N,DTHETA(I),WORK,PB)
              P0N(NP1,I) = PB
  105     CONTINUE
c     compute m=1 legendre polynomials for all n and theta(i)
          M = 1
          CALL DDNLFK(M,N,WORK)
          DO 106 I = 1,LATE
              CALL DDNLFT(M,N,DTHETA(I),WORK,PB)
              P1N(NP1,I) = PB
  106     CONTINUE
  104 CONTINUE
c
c     compute and store swarztrauber recursion coefficients
c     for 2.le.m.le.n and 2.le.n.le.nlat in abel,bbel,cbel
      DO 107 N = 2,NLAT
          FN = DBLE(N)
          MLIM = MIN0(N,L)
          DO 107 M = 2,MLIM
              FM = DBLE(M)
              IMN = INDX(M,N)
              IF (N.GE.L) IMN = IMNDX(M,N)
              ABEL(IMN) = SQRT(((2*FN+1)* (FM+FN-2)* (FM+FN-3))/
     +                    (((2*FN-3)* (FM+FN-1)* (FM+FN))))
              BBEL(IMN) = SQRT(((2*FN+1)* (FN-FM-1)* (FN-FM))/
     +                    (((2*FN-3)* (FM+FN-1)* (FM+FN))))
              CBEL(IMN) = SQRT(((FN-FM+1)* (FN-FM+2))/
     +                    (((FN+FM-1)* (FN+FM))))
  107 CONTINUE
      RETURN
      END


c
      subroutine gwtbox(alatbo,jg)
      implicit none
      integer j,jg
      real    pi,sit,weight
      real    alatbo(*)
      real*8 zslat
c
      pi=2.*asin(1.)
      alatbo(1)=90.0
      zslat=1.0
      do j=1,jg*2
         if (j.le.jg) then
            call gwtlt1(sit,weight,j,jg)
         else
            call gwtlt1(sit,weight,jg*2+1-j,jg)
            sit=-sit
         end if
         zslat=zslat-weight
         if (zslat.lt.-1.0) zslat=-1.0
         alatbo(j+1)=real(asin(zslat)*180.0/pi)
      end do
      end


      SUBROUTINE sncndn(uu,emmc,sn,cn,dn)
      REAL cn,dn,emmc,sn,uu,CA
      PARAMETER (CA=.0003)
      INTEGER i,ii,l
      REAL a,b,c,d,emc,u,em(13),en(13)
      LOGICAL bo
      emc=emmc
      u=uu
      if(emc.ne.0.)then
        bo=(emc.lt.0.)
        if(bo)then
          d=1.-emc
          emc=-emc/d
          d=sqrt(d)
          u=d*u
        endif
        a=1.
        dn=1.
        do 11 i=1,13
          l=i
          em(i)=a
          emc=sqrt(emc)
          en(i)=emc
          c=0.5*(a+emc)
          if(abs(a-emc).le.CA*a)goto 1
          emc=a*emc
          a=c
11      continue
1       u=c*u
        sn=sin(u)
        cn=cos(u)
        if(sn.eq.0.)goto 2
        a=cn/sn
        c=a*c
        do 12 ii=l,1,-1
          b=em(ii)
          a=c*a
          c=dn*c
          dn=(en(ii)+a)/(b+a)
          a=c/b
12      continue
        a=1./sqrt(c**2+1.)
        if(sn.lt.0.)then
          sn=-a
        else
          sn=a
        endif
        cn=c*sn
2       if(bo)then
          a=dn
          dn=cn
          cn=a
          sn=sn/d
        endif
      else
        cn=1./cosh(u)
        dn=cn
        sn=tanh(u)
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/sncndn.for


**==solvx.spg  processed by SPAG 4.50J  at 14:50 on 30 Jun 1995
      FUNCTION SOLVX(F,E,H)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL ax0 , ax1 , ax2 , DENz , DYNam , E , F , H , PB , plink ,
     &     PREss , qx , rx , SOLVX , thetax , x
      INTEGER k
C*** End of declarations inserted by SPAG
      COMMON /SLV   / DENz , PREss , PB , DYNam

c suppress compiler warning
      x = F

C     CALCULATE COMPRESSION
      ax2 = 2.*DENz*(H-E)/PB
      ax1 = -5.*PREss/PB
      ax0 = 4.*DYNam/PB
      qx = ax2*ax2/9. - ax1/3.
      rx = (3.*ax0-ax1*ax2)/6. + (ax2**3)/27.
      plink = rx/qx**1.5
      IF ( plink.LE.0.997 ) THEN
         thetax = ACOS(plink)/3.
         SOLVX = SQRT(qx)*(COS(thetax)+1.732*SIN(thetax)) - ax2/3.
         RETURN
      ENDIF
      x = (-ax1+SQRT(ax1*ax1-4.*ax2*ax0))/(2.*ax2)
      DO 100 k = 1 , 4
         x = (-ax1+SQRT(ax1*ax1-4.*ax2*(ax0+x**3)))/(2.*ax2)
 100  CONTINUE
      SOLVX = x
      RETURN
      END


subroutine src1(meqn,mbc,mx,xlower,dx,q,maux,aux,t,dt)

    ! Called to update q by solving source term equation
    ! $q_t = \psi(q)$ over time dt starting at time t.
    !
    ! This default version integrates manning friction or other friction terms if present

    ! Version from 1D branch of GeoClaw originally from Dave George

    ! Also handles radial source term, if desired.
    ! Note: assumes radial about lower boundary, wall bc should be imposed

    use geoclaw_module, only: dry_tolerance, grav, DEG2RAD
    use geoclaw_module, only: friction_forcing
    use geoclaw_module, only: frictioncoeff => friction_coefficient
    use geoclaw_module, only: earth_radius, coordinate_system
    use grid_module, only: xcell

    implicit none
    integer, intent(in) :: mbc,mx,meqn,maux
    real(kind=8), intent(in) :: xlower,dx,t,dt
    real(kind=8), intent(in) ::  aux(maux,1-mbc:mx+mbc)
    real(kind=8), intent(inout) ::  q(meqn,1-mbc:mx+mbc)

    !Locals
    real(kind=8) :: gamma, u, tanxR
    integer :: i

      if (frictioncoeff.gt.0.d0 .and. friction_forcing) then
          ! integrate source term based on Manning formula
            do i=1,mx
               if (q(1,i)<=dry_tolerance) then
                  q(2,i) = 0.0
               else
                  gamma= dsqrt(q(2,i)**2)*(grav*frictioncoeff**2)/(q(1,i)**(7.0/3.0))
                  q(2,i)= q(2,i)/(1.d0 + dt*gamma)
              endif
            enddo
        endif

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

    !if (radial) then  ! OLD
    if (coordinate_system == -1) then
        ! radial source term for SWE:
        do i=1,mx
            if (q(1,i) .gt. dry_tolerance) then
                ! x is radial coordinate in meters, x>=0,
                ! u = radial velocity
                q(1,i) = q(1,i) - dt/xcell(i) * q(2,i)
                u = q(2,i)/q(1,i)
                q(2,i) = q(2,i) - dt/xcell(i) * q(1,i)*u**2
            endif
         enddo
     endif

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

    if (coordinate_system == 2) then
        ! source term for x = latitude in degrees -90 <= x <= 90,
        ! u = velocity in latitude direction (m/s) on sphere:
        do i=1,mx
            if (q(1,i) .gt. dry_tolerance) then
                tanxR = tan(xcell(i)*DEG2RAD) / earth_radius
                q(1,i) = q(1,i) + dt * tanxR * q(2,i)
                u = q(2,i)/q(1,i)
                q(2,i) = q(2,i) + dt * tanxR * q(1,i)*u**2
            endif
         enddo
     endif

end subroutine src1


      function shield(reyn)
c
c     + + + PURPOSE + + +
c
c     Function SHIELD generates parameters (shield parameters)
c     by interpolating values from a table (shield diagram)
c     for given Reynolds numbers.
c
c     Called from: SRS TRNCAP, YALIN
c     Author(s): Ascough II, R. van der Zweep, V. Lopes
c     Reference in User Guide:
c
c     Version:
c     Date recoded:
c     Recoded by: Jim Ascough II
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      real reyn
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     reyn -
c
c     + + + COMMON BLOCKS + + +
c
c     + + + LOCAL VARIABLES + + +
c
      real y(8), r(8), shield, slope, ycr
      integer i
c
c     + + + LOCAL DEFINITIONS + + +
c
c     Real Variables
c
c     y(8)   -
c     r(8)   -
c     shield -
c     slope  -
c     ycr    -
c
c     Integer Variables
c
c     i -
c
c     + + + SAVES + + +
c
      save
c
c     + + + SUBROUTINES CALLED + + +
c
c     + + + DATA INITIALIZATIONS + + +
c
      data y /0.0772, 0.0579, 0.04, 0.035, 0.034, 0.045, 0.055, 0.057/
      data r /1.0, 2.0, 4.0, 8.0, 12.0, 100.0, 400.0, 1000.0/
c
c     + + + END SPECIFICATIONS + + +
c
c
      if (reyn.lt.r(1)) then
        i = 2
        slope = (alog(y(i))-alog(y(i-1))) / (alog(r(i))-alog(r(i-1)))
        ycr = alog(y(1)) - slope * (alog(r(1))-alog(reyn))
      else if (reyn.gt.r(8)) then
        i = 8
        slope = (alog(y(i))-alog(y(i-1))) / (alog(r(i))-alog(r(i-1)))
        ycr = y(8) + slope * (alog(reyn)-alog(r(8)))
c
      else
c
        do 10 i = 2, 8
c
          if (reyn.ge.r(i-1).and.reyn.le.r(i)) then
            slope = (alog(y(i))-alog(y(i-1))) / (alog(r(i))-
     1          alog(r(i-1)))
            ycr = alog(y(i-1)) + slope * (alog(reyn)-alog(r(i-1)))
            go to 20
          end if
c
   10   continue
c
      end if
c
   20 shield = exp(ycr)
c
      return
      end