      REAL             FUNCTION SCPLTE(EM)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1998-10-29 SCPLTE Krogh  Moved external statement up for mangle.
c>> 1996-03-30 SCPLTE Krogh   Changed MAX to MAXT
C>> 1994-10-27 SCPLTE Snyder  Correct missing type declarations
C>> 1994-10-20 SCPLTE Krogh  Changes to use M77CON
C>> 1994-05-16 SCPLTE Snyder  Make SP and DP codes alike using CHGTYP
C>> 1989-06-16 SCPLTE Snyder  Remove implied DO from DATA stmts for CFT
C>> 1985-08-02 SCPLTE Lawson  Initial code.
c--S replaces "?": ?CPLTE, ?ERM1
C
C     Complete elliptic integral E(EM). Method given by
C     W.J.CODY, Math. of Comp.,Vol.19, (1965), pp. 105-111.
C     Data are taken from Cody's table in reverse order.
C     We are using N = 5 or 9 for single precision and
C     N = 10 for double precision.
C
C     C.L.LAWSON & STELLA CHAN,JPL,1983 JUNE.
C
C     ----------------------------------------------------
C
C     POLY DEGREE     NEGATIVE LOG BASE 10 OF MAX ABS
C                     ERROR OF APPROXIMATION
C
C         N           FOR K           FOR E
C         -           -----           -----
C         5            9.50            9.44
C         9           15.87           15.84
C        10           17.45           17.42
C
C     ----------------------------------------------------
C
      EXTERNAL R1MACH
      REAL             C(10,3), D(10,3), R1MACH
      REAL             EM, EMP, FAC, HALF, ONE, S3, S4, U, ZERO
      INTEGER J, M, MAXT
C
      SAVE M, MAXT, FAC
C
      DATA ZERO,ONE,HALF / 0.E0, 1.E0 ,.5E0 /
C
      DATA M / 0 /
c
      DATA C / 7.65296060328E-03, 3.06623474572E-02,
     *         3.17611455247E-02, 5.75669984841E-02,
     *         4.43152874726E-01, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,

     *         3.25192015506390418E-04, 4.30253777479311659E-03,
     *         1.17858410087339355E-02, 1.18419259955012494E-02,
     *         9.03552773754088184E-03, 1.17167669446577228E-02,
     *         2.18361314054868967E-02, 5.68052233293082895E-02,
     *         4.43147180583368137E-01, 0.0E0,

     *         1.4946621757181326771E-04,2.4685033304607227339E-03,
     *         8.6384421736040744302E-03,1.0770635039866455473E-02,
     *         7.8204040609595541727E-03,7.5950934225594322802E-03,
     *         1.1569595745295402175E-02,2.1831811676130481568E-02,
     *         5.6805194567559156648E-02,4.4314718056088952648E-01/
C
      DATA D / 2.12479182845E-03, 2.18360211693E-02,
     *         5.42605244487E-02, 9.35649078307E-02,
     *         2.49999202736E-01, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,

     *         7.20316963457154599E-05, 1.86453791840633632E-03,
     *         1.00879584943751004E-02, 2.26603098916041221E-02,
     *         3.28110691727210618E-02, 4.26725101265917523E-02,
     *         5.85927071842652739E-02, 9.37499951163670673E-02,
     *         2.49999999997461423E-01, 0.0E0,

     *         3.1859195655501571800E-05,9.8983328462253847867E-04,
     *         6.4321465864383017666E-03,1.6804023346363384981E-02,
     *         2.6145014700313878932E-02,3.3478943665761626232E-02,
     *         4.2717890547383095644E-02,5.8593661255531491732E-02,
     *         9.3749999721203140658E-02,2.4999999999990177208E-01/
C
      IF (M .EQ. 0) THEN
        IF (R1MACH(3) .LT. 6.31e-17) THEN
C         -LOG10(6.31E-17) = 17.2
          M = 3
          MAXT = 10
        ELSE IF (R1MACH(3) .LT. 6.31E-9) THEN
C         -LOG10(6.31E-9) = 8.2
          M = 2
          MAXT = 9
        ELSE
          M = 1
          MAXT = 5
        END IF
        FAC = ONE + 2 * R1MACH(3)
      END IF
      IF (EM .GT. ONE) THEN
        CALL SERM1('SCPLTE',1,0,'UNDEFINED FOR EM .GT. ONE',
     *             'EM',EM,'.')
        U = ZERO
      ELSE IF (EM .LT. ZERO) THEN
        CALL SERM1('SCPLTE',2,0,'UNDEFINED FOR EM .LT. ZERO',
     *             'EM',EM,'.')
        U = ZERO
      ELSE
        EMP = HALF + (HALF- EM)
        IF (EMP .EQ. ZERO) THEN
          U = ONE
          GO TO 10
        END IF
        S3 = EMP * C(1,M)
        S4 = EMP * D(1,M)
        DO 100 J = 2, MAXT
          S3 = (S3 + C(J,M)) * EMP
          S4 = (S4 + D(J,M)) * EMP
  100   CONTINUE
        U = ONE + S3 + LOG(ONE/EMP) * S4
      END IF
C
  10  SCPLTE = U * FAC
      RETURN
C
      END


*> \brief \b SLAS2
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLAS2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SLAS2( F, G, H, SSMIN, SSMAX )
*
*       .. Scalar Arguments ..
*       REAL               F, G, H, SSMAX, SSMIN
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SLAS2  computes the singular values of the 2-by-2 matrix
*>    [  F   G  ]
*>    [  0   H  ].
*> On return, SSMIN is the smaller singular value and SSMAX is the
*> larger singular value.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] F
*> \verbatim
*>          F is REAL
*>          The (1,1) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[in] G
*> \verbatim
*>          G is REAL
*>          The (1,2) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[in] H
*> \verbatim
*>          H is REAL
*>          The (2,2) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[out] SSMIN
*> \verbatim
*>          SSMIN is REAL
*>          The smaller singular value.
*> \endverbatim
*>
*> \param[out] SSMAX
*> \verbatim
*>          SSMAX is REAL
*>          The larger singular value.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup auxOTHERauxiliary
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  Barring over/underflow, all output quantities are correct to within
*>  a few units in the last place (ulps), even in the absence of a guard
*>  digit in addition/subtraction.
*>
*>  In IEEE arithmetic, the code works correctly if one matrix element is
*>  infinite.
*>
*>  Overflow will not occur unless the largest singular value itself
*>  overflows, or is within a few ulps of overflow. (On machines with
*>  partial overflow, like the Cray, overflow may occur if the largest
*>  singular value is within a factor of 2 of overflow.)
*>
*>  Underflow is harmless if underflow is gradual. Otherwise, results
*>  may correspond to a matrix modified by perturbations of size near
*>  the underflow threshold.
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE SLAS2( F, G, H, SSMIN, SSMAX )
*
*  -- LAPACK auxiliary routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      REAL               F, G, H, SSMAX, SSMIN
*     ..
*
*  ====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E0 )
      REAL               ONE
      PARAMETER          ( ONE = 1.0E0 )
      REAL               TWO
      PARAMETER          ( TWO = 2.0E0 )
*     ..
*     .. Local Scalars ..
      REAL               AS, AT, AU, C, FA, FHMN, FHMX, GA, HA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*
      FA = ABS( F )
      GA = ABS( G )
      HA = ABS( H )
      FHMN = MIN( FA, HA )
      FHMX = MAX( FA, HA )
      IF( FHMN.EQ.ZERO ) THEN
         SSMIN = ZERO
         IF( FHMX.EQ.ZERO ) THEN
            SSMAX = GA
         ELSE
            SSMAX = MAX( FHMX, GA )*SQRT( ONE+
     $              ( MIN( FHMX, GA ) / MAX( FHMX, GA ) )**2 )
         END IF
      ELSE
         IF( GA.LT.FHMX ) THEN
            AS = ONE + FHMN / FHMX
            AT = ( FHMX-FHMN ) / FHMX
            AU = ( GA / FHMX )**2
            C = TWO / ( SQRT( AS*AS+AU )+SQRT( AT*AT+AU ) )
            SSMIN = FHMN*C
            SSMAX = FHMX / C
         ELSE
            AU = FHMX / GA
            IF( AU.EQ.ZERO ) THEN
*
*              Avoid possible harmful underflow if exponent range
*              asymmetric (true SSMIN may not underflow even if
*              AU underflows)
*
               SSMIN = ( FHMN*FHMX ) / GA
               SSMAX = GA
            ELSE
               AS = ONE + FHMN / FHMX
               AT = ( FHMX-FHMN ) / FHMX
               C = ONE / ( SQRT( ONE+( AS*AU )**2 )+
     $             SQRT( ONE+( AT*AU )**2 ) )
               SSMIN = ( FHMN*C )*AU
               SSMIN = SSMIN + SSMIN
               SSMAX = GA / ( C+C )
            END IF
         END IF
      END IF
      RETURN
*
*     End of SLAS2
*
      END


module like

use params
use utils1
implicit none

contains

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

subroutine slikelihood(Cube,slhood)

	implicit none

	double precision Cube(nest_nPar),slhood
	double precision a,b,pi
	integer i,j

	pi = 4d0 * atan(1d0)

	do i = 1, sdim
		Cube(i) = spriorran(i, 1) + ( spriorran(i, 2) - spriorran(i, 1) ) * Cube(i)
	enddo

	a = 0d0
	b = 0d0
	do i = 1, sdim
		a = a + Cube(i)**2
		b = b + cos( 2 * pi * Cube(i) )
	enddo
	a = -0.2 * sqrt( a / sdim )
	b = b / sdim

	slhood = 20d0 * exp(a) + exp(b) - 20d0 - exp(1d0)

end subroutine slikelihood

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

end module like


C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      FUNCTION SPLDED(NDIM,X,NDERIV,COEF,XMIN,XMAX,NODES,IERROR)
      DOUBLE PRECISION SPLDED
      DOUBLE PRECISION X
      DOUBLE PRECISION COEF
      DOUBLE PRECISION XMIN
      DOUBLE PRECISION XMAX
      DOUBLE PRECISION DX
      DOUBLE PRECISION DXIN
      DOUBLE PRECISION XRNG
      DOUBLE PRECISION SUM
      DOUBLE PRECISION BASM
      DIMENSION X(NDIM),NDERIV(NDIM),COEF(*),XMIN(NDIM),XMAX(NDIM),
     +          NODES(NDIM)
      COMMON /SPLCOMD/DX(4),DXIN(4),MDIM,IB(4),IBMN(4),IBMX(4)
      SAVE
C
C The restriction for NDIM to be .LE. 4 can be eliminated by increasing
C the above dimensions.
C
      IERROR = 0
      MDIM = NDIM
      IF (MDIM.LT.1 .OR. MDIM.GT.4) GO TO 105
      IIBMX = 1
      DO 101 IDIM = 1,MDIM
          NOD = NODES(IDIM)
          IF (NOD.LT.4) GO TO 106
          XRNG = XMAX(IDIM) - XMIN(IDIM)
          IF (XRNG.EQ.0.D0) GO TO 107
          IF (NDERIV(IDIM).LT.0 .OR. NDERIV(IDIM).GT.2) GO TO 108
C
C  DX(IDIM) is the node spacing along the IDIM coordinate.
C
          DX(IDIM) = XRNG/DBLE(NOD-1)
          DXIN(IDIM) = 1.D0/DX(IDIM)
C
C  Compute indices of basis functions which are nonzero at X.
C
          IT = DXIN(IDIM)* (X(IDIM)-XMIN(IDIM))
C
C  IBMN must be in the range 0 to NODES-2.
C
          IBMN(IDIM) = MIN0(MAX0(IT-1,0),NOD-2)
C
C  IBMX must be in the range 1 to NODES-1.
C
          IBMX(IDIM) = MAX0(MIN0(IT+2,NOD-1),1)
          IIBMX = IIBMX* (IBMX(IDIM)-IBMN(IDIM)+1)
          IB(IDIM) = IBMN(IDIM)
  101 CONTINUE
C
      SUM = 0.D0
      IIB = 0
C
C  Begining of basis index loop - traverse all indices corresponding
C  to basis functions which are nonzero at X.
C
  102 IIB = IIB + 1
C
C  The indices are in IB and are passed through common to BASCMP.
C
      CALL BASCMPD(X,NDERIV,XMIN,NODES,ICOF,BASM)
C
C  BASCMP computes ICOF and BASM where BASM is the value at X of the
C  N-dimensional basis function corresponding to COEF(ICOF).
C
      SUM = SUM + COEF(ICOF)*BASM
      IF (IIB.GE.IIBMX) GO TO 104
C
C  Increment the basis indices.
C
      DO 103 IDIM = 1,MDIM
          IB(IDIM) = IB(IDIM) + 1
          IF (IB(IDIM).LE.IBMX(IDIM)) GO TO 102
          IB(IDIM) = IBMN(IDIM)
  103 CONTINUE
C
C  End of basis index loop.
C
  104 SPLDED = SUM
      RETURN
C
C  Errors.
C
  105 CONTINUE
      IERROR = 101
      CALL CFAERR(IERROR,
     +    ' SPLFED or SPLDED - NDIM is less than 1 or greater than 4   '
     +            ,60)
      GO TO 109
  106 CONTINUE
      IERROR = 102
      CALL CFAERR(IERROR,
     +    ' SPLFED or SPLDED - NODES(IDIM) is less than  4for some IDIM'
     +            ,60)
      GO TO 109
  107 CONTINUE
      IERROR = 103
      CALL CFAERR(IERROR,
     +    ' SPLFED or SPLDED - XMIN(IDIM) = XMAX(IDIM) for some IDIM   '
     +            ,60)
      GO TO 109
  108 CONTINUE
      IERROR = 104
      CALL CFAERR(IERROR,
     +' SPLDED - NDERIV(IDIM) IS less than 0 or greater than 2 for some
     +IDIM  ',70)
C
  109 STOP
      END


program ch1201
    ! Simple Function Usage
    implicit none

    real :: x

    print *, 'type in an angle (in radians)'
    read *, x
    print *, 'sine of ', x, ' = ', sin(x)
end program


submodule(Mod_CauchyElement) SUPCauchyElement_NH

   implicit none

contains

    !-------------RHS------------
   module subroutine sup_rhs_U_NH(e,nd,tn,dvol,gdev,gpress,elrhs)
      !-----------------------------------------------------------------------
      !
      ! This routine computes the rhs terms
      !    -0.5*(d(v_i)/dx_j+d(v_j)/dx_i),S_ij) - (d(v_i)/dx_i),p)
      !
      !-----------------------------------------------------------------------
      implicit none

      class(FiniteElement)       :: e
      integer(ip), intent(in)    :: nd,tn
      real(rp),    intent(in)    :: dvol,gdev(tn),gpress(1)
      real(rp),    intent(inout) :: elrhs(nd,e%pnode)
      integer(ip)                :: inode
      real(rp)                   :: Bi(nd,tn)
      real(rp)                   :: rhs(nd),G(nd)

      do inode=1,e%pnode

          rhs = 0.0_rp

          !-grad(v_i)(S_ij)
          call sld_calculateBt(e,nd,tn,inode,Bi)
          rhs = rhs - matmul(Bi,gdev)

          !-div(v_i)(P)
          call sld_calculateB_inditial(e,nd,inode,G)
          rhs = rhs - G*gpress(1)

          !Assembly
          elrhs(:,inode) = elrhs(:,inode) + rhs*dvol
      end do

   end subroutine sup_rhs_U_NH

   module subroutine sup_rhs_S_NH(e,nd,tn,dvol,mu,J,b,gdev,elrhs)
      !-----------------------------------------------------------------------
      !
      ! This routine computes the elemental material matrix
      !       (xi_ij,0.5*(b-(b_ii/nd)*ii)) - (xi_ij,(J/2mu)S_ij)
      !
      !-----------------------------------------------------------------------
      implicit none

      class(FiniteElement), intent(in)    :: e
      integer(ip),          intent(in)    :: nd,tn
      real(rp),             intent(in)    :: mu,dvol,J,gdev(tn),b(nd,nd)
      real(rp),             intent(inout) :: elrhs(tn,e%pnode)
      integer(ip) :: inode,jnode
      real(rp)    :: ii(tn,tn),i(nd,nd),b_ii
      real(rp)    :: N(tn),C(nd,nd),AU2(nd,nd),Cvoigt(tn)
      real(rp)    :: AU1(tn),rhs(tn),rhs2(tn)

      call getDiagTensor2Txy(nd,tn,ii)
      call get2ndIITensor(nd,i)

      call trace(nd,b,b_ii)

      !Stress tensor term: (b-(b_ii/nd)*ii)
      C = (b - (b_ii/nd)*i)
      !C = b

      call getVoigtStress(tn,nd,C,Cvoigt)

      !-A(U): -(J/2mu)S_ij)+0.5(b-(b_ii/nd)*ii)
      AU1 = 0.5_rp*(Cvoigt-(J/mu)*gdev)*dvol
      N   = matmul(ii,AU1)

      do inode=1,e%pnode

          rhs  = 0.0_rp

          !Testing against shape function
          rhs = e%shape(inode,e%igaus)*N

          !Assembly
          elrhs(:,inode) = elrhs(:,inode) + rhs(:)

      end do

   end subroutine sup_rhs_S_NH

   module subroutine sup_rhs_P_NH(e,nd,tn,dvol,mu,lam,J,b,gpress,elrhs,divdisp)
      !-----------------------------------------------------------------------
      !
      ! This routine computes the elemental material matrix
      !   (q_h,-(J/lam)*p + log(J) + (mu/lam)*((b_ii/nd)-1.0_rp))
      !
      !-----------------------------------------------------------------------
      implicit none

      class(FiniteElement), intent(in)    :: e
      integer(ip),          intent(in)    :: nd,tn
      real(rp),             intent(in)    :: mu,lam,J,dvol,gpress(1),b(nd,nd),divdisp
      real(rp),             intent(inout) :: elrhs(1,e%pnode)
      integer(ip)                         :: inode,jnode
      real(rp)                            :: N,b_ii,AU,rhs

      call trace(nd,b,b_ii)

      !-A(U)
      AU = -(J/lam)*gpress(1)+(mu/lam)*((b_ii/nd)-1.0_rp)
      AU = AU + log(J) !+ divdisp

      do inode=1,e%pnode

          rhs = 0.0_rp
          rhs = e%shape(inode,e%igaus)*AU*dvol

          !Assembly
          elrhs(1,inode) = elrhs(1,inode) + rhs

      end do

   end subroutine sup_rhs_P_NH

   !-------------LHS------------

   module subroutine sup_elmVS_NH(e,nd,tn,dvol,elmat)
      !-----------------------------------------------------------------------
      !
      ! This routine computes the elemental material matrix
      !                (d(v_i)/dx_j),S_ij)
      !
      !-----------------------------------------------------------------------
      implicit none

      class(FiniteElement), intent(in)    :: e
      integer(ip),          intent(in)    :: nd,tn
      real(rp),             intent(in)    :: dvol
      real(rp),             intent(inout) :: elmat(nd,e%pnode,tn,e%pnode)
      integer(ip)                         :: inode,jnode
      real(rp)                            :: Baux(nd,tn),B(nd,tn)

      do inode=1,e%pnode

          call sld_calculateBt(e,nd,tn,inode,B)

          do jnode=1,e%pnode

              Baux = 0.0_rp

              Baux = B*e%shape(jnode,e%igaus)*dvol

              elmat(1:nd,inode,1:tn,jnode) = elmat(1:nd,inode,1:tn,jnode) + Baux(1:nd,1:tn)

          end do
      end do

   end subroutine sup_elmVS_NH

   module subroutine sup_elmVP_NH(e,nd,dvol,elmat)
      !-----------------------------------------------------------------------
      !
      ! This routine computes the elemental material matrix
      !                (d(v_i)/dx_i),p)
      !
      !-----------------------------------------------------------------------
      implicit none

      class(FiniteElement), intent(in) :: e
      integer(ip), intent(in)          :: nd
      real(rp),    intent(in)          :: dvol
      real(rp),    intent(inout)       :: elmat(nd,e%pnode,1,e%pnode)
      integer(ip)                      :: inode,jnode
      real(rp)                         :: G(nd),GN(nd)

      do inode=1,e%pnode

          call sld_calculateB_inditial(e,nd,inode,G)

          do jnode=1,e%pnode

              GN = 0.0_rp
              GN = G*e%shape(jnode,e%igaus)*dvol

              elmat(1:nd,inode,1,jnode) = elmat(1:nd,inode,1,jnode) + GN(:)

          end do
      end do

   end subroutine sup_elmVP_NH

   module subroutine sup_elmEU_NH(e,nd,tn,dvol,J,mu,Finv,Fmat,gdev,elmat)
      !-----------------------------------------------------------------------
      !
      ! This routine computes the elemental material matrix
      !  (xi_ij,(-F_iK*du_j/dx_K+1/nd*F_lK*du_l/dx_K*ii_ij)
      !       +(J/mu)F^-1_lK*du_l/dx_K*S_ij)
      !
      !-----------------------------------------------------------------------
      implicit none

      class(FiniteElement), intent(in)    :: e
      integer(ip),          intent(in)    :: nd,tn
      real(rp),             intent(in)    :: mu,J,dvol,Finv(nd,nd),Fmat(nd,nd),gdev(tn)
      real(rp),             intent(inout) :: elmat(tn,e%pnode,nd,e%pnode)
      integer(ip) :: inode,jnode
      real(rp)    :: B(tn,nd),B1(tn,nd),Bt(tn,nd)
      real(rp)    :: Bts(tn,nd),N,aux1,aux2

      aux1 = 1.0_rp/nd
      aux2 = J/(2.0_rp*mu)

      do inode=1,e%pnode

          ! xi_ij
          N  = e%shape(inode,e%igaus)*dvol

          do jnode=1,e%pnode

              B   = 0.0_rp
              B1  = 0.0_rp
              Bt  = 0.0_rp
              Bts = 0.0_rp

              !  -(F_jK*du_i/dx_K+F_iK*du_j/dx_K)
              call sld_calculate_2Fdu(e,nd,tn,jnode,Fmat,B1)

              !  (1/nd*F_lK*du_l/dx_K*ii_ij)
              call sld_calculate_traceFdu(e,nd,tn,jnode,Fmat,Bt)

              B = (-0.5_rp*B1 + aux1*Bt)*N

              !(J/2mu)F^-1_Kl*du_l/dX_K*S_ij
              call sld_calculate_traceFduS(e,nd,tn,jnode,Finv,gdev,Bts)
              B = B + aux2*N*Bts

              elmat(1:tn,inode,1:nd,jnode) = elmat(1:tn,inode,1:nd,jnode) + B(:,:)

          end do
      end do

   end subroutine sup_elmEU_NH

   module subroutine sup_elmES_NH(e,nd,tn,dvol,J,mu,elmat)
      !-----------------------------------------------------------------------
      !
      ! This routine computes the elemental material matrix
      !         (xi_ij,(J/2mu)*S_ij)
      !
      !-----------------------------------------------------------------------
      implicit none

      class(FiniteElement), intent(in)    :: e
      integer(ip),          intent(in)    :: nd,tn
      real(rp),             intent(in)    :: dvol,J,mu
      real(rp),             intent(inout) :: elmat(tn,e%pnode,tn,e%pnode)
      integer(ip) :: inode,jnode
      real(rp)    :: ii(tn,tn)
      real(rp)    :: Ni,Nj
      real(rp)    :: NN(tn,tn),aux

      aux = J/(2.0_rp*mu)

      call getDiagTensor2Txy(nd,tn,ii)
      ii = aux*ii*dvol

      do inode=1,e%pnode

          Ni = e%shape(inode,e%igaus)

          do jnode=1,e%pnode

              Nj = e%shape(jnode,e%igaus)

              NN = Ni*Nj*ii

              elmat(1:tn,inode,1:tn,jnode) = elmat(1:tn,inode,1:tn,jnode) + NN(1:tn,1:tn)

          end do
      end do

   end subroutine sup_elmES_NH

   module subroutine sup_elmQU_NH(e,nd,dvol,J,mu,lam,Finv,Fmat,gpress,elmat)
      !-----------------------------------------------------------------------
      !
      ! This routine computes the elemental material matrix
      !   (q_h,((Jp/lam)-1)*F^-1_Kl-(2mu/lam*nd)*F_lK)*du_l/dx_K)
      !
      !-----------------------------------------------------------------------
      implicit none

      class(FiniteElement), intent(in) :: e
      integer(ip), intent(in)          :: nd
      real(rp),    intent(in)          :: dvol,mu,lam,J,gpress(1)
      real(rp),    intent(in)          :: Finv(nd,nd),Fmat(nd,nd)
      real(rp),    intent(inout)       :: elmat(1,e%pnode,nd,e%pnode)
      integer(ip)                      :: inode,jnode
      real(rp)                         :: Ni(nd),mat(nd,nd)
      real(rp)                         :: B(nd),Baux(nd)

      do inode=1,e%pnode

          Ni = 0.0_rp
          Ni = e%shape(inode,e%igaus)*dvol

          do jnode=1,e%pnode

              B = 0.0_rp

              mat = (J/lam)*gpress(1)*Finv
              mat = mat - Finv
              call sld_calculate_tracePressFinv(e,nd,jnode,mat,Baux)

              B = Baux

              mat = 0.0_rp
              mat=-((2.0*mu)/(lam*nd))*Fmat
              call sld_calculate_tracePressFmat(e,nd,jnode,mat,Baux)
              B = B + Baux

              elmat(1,inode,1:nd,jnode) = elmat(1,inode,1:nd,jnode) + Ni*B(1:nd)

          end do
      end do

   end subroutine sup_elmQU_NH

   module subroutine sup_elmQP_NH(e,nd,dvol,J,lam,elmat)
      !-----------------------------------------------------------------------
      !
      ! This routine computes the elemental material matrix
      !                     (q_h,(J/lam)*p)
      !
      !-----------------------------------------------------------------------
      implicit none

      class(FiniteElement), intent(in) :: e
      integer(ip), intent(in)          :: nd
      real(rp),    intent(in)          :: dvol,J,lam
      real(rp),    intent(inout)       :: elmat(1,e%pnode,1,e%pnode)
      integer(ip)                      :: inode,jnode
      real(rp)                         :: Ni,Nj

      do inode=1,e%pnode

          Ni = e%shape(inode,e%igaus)

          do jnode=1,e%pnode

              Nj = e%shape(jnode,e%igaus)

              elmat(1,inode,1,jnode) = elmat(1,inode,1,jnode) + (J/lam)*Ni*Nj*dvol

          end do
      end do

   end subroutine sup_elmQP_NH

end submodule SUPCauchyElement_NH


! The parallel summation of elements of a 1D array, which has been distributed
! between all ranks as evenly as possible.
!
! Compile and run:
!
! $ mpifort -g -O0 -Wall -Wextra -Wpedantic -fcheck=all -fbacktrace parallel_sum.f90
! $ mpirun -np 4 --oversubscribe ./a.out < in16.txt
! 136
! $ mpirun -np 7 --oversubscribe ./a.out < in17.txt
! 153
!
! 2021-11-08 Note: students get confused if they are asked to broadcast the size
! of a local subarray.  It is better to broadcast the size of the full array and
! let all processes calculate sizes and index ranges locally.
program parallel_sum
    use mpi_f08
    implicit none
    integer :: my_rank, n_ranks, rank, full_size, net_sum, b, e
    integer, allocatable :: arr(:)
    type(MPI_Comm)   :: comm
    type(MPI_Status) :: status

    call MPI_Init()

    ! Once the environment has been established you can assign the
    ! MPI_COMM_WORLD name to a communicator variable to avoid typing it.
    comm = MPI_COMM_WORLD

    call MPI_Comm_rank(comm, my_rank)
    call MPI_Comm_size(comm, n_ranks)

    ! Read in and broadcast the array size to other ranks.  In a more general
    ! case, when the array cannot be divided evenly between all the ranks, it
    ! is better to send the full size to them all so as each of them can
    ! compute the local size and the beginning index of the subarray.
    if (my_rank == 0) then
        read *, full_size
        do rank = 1, n_ranks - 1
            call MPI_Send(full_size, 1, MPI_INTEGER, rank, 0, comm)
        end do
    else
        call MPI_Recv(full_size, 1, MPI_INTEGER, 0, 0, comm, status)
    end if

    ! Create local sub-arrays with through indexing.
    call partition_uneven(my_rank, n_ranks, full_size, b, e)
    allocate(arr(b:e))

    ! Read in and distribute the full array.
    if (my_rank == 0) then
        block
            integer, allocatable :: full_arr(:)
            allocate(full_arr(full_size))
            read *, full_arr(:)
            ! Send subarrays to all processes but zero.
            do rank = 1, n_ranks - 1
                call partition_uneven(rank, n_ranks, full_size, b, e)
                call MPI_Send(full_arr(b), e - b + 1, MPI_INTEGER, rank, 0, comm)
            end do
            ! Direct copy at rank 0.
            call partition_uneven(0, n_ranks, full_size, b, e)
            arr(b:e) = full_arr(b:e)
            deallocate(full_arr)
        end block
    else
        call MPI_Recv(arr(b), e - b + 1, MPI_INTEGER, 0, 0, comm, status)
    end if

    ! Calculate local sums.
    net_sum = sum(arr(:))
    deallocate(arr)

    ! Add up sums at rank 0 and print the result.
    if (my_rank == 0) then
        block
            integer :: full_sum
            full_sum = net_sum ! copy at rank 0
            do rank = 1, n_ranks - 1
                call MPI_Recv(net_sum, 1, MPI_INTEGER, rank, 0, comm, status)
                full_sum = full_sum + net_sum
            end do
            print "(i0)", full_sum
        end block
    else
        call MPI_Send(net_sum, 1, MPI_INTEGER, 0, 0, comm)
    end if

    call MPI_Finalize()

contains

    ! For the given rank `id` from the total number of processes `n_ids`
    ! partition an array of `size` elements and find the beginning and ending
    ! indices `b` and `e`.  This version only works when the partition is even,
    ! that is, the remainder is zero.
    subroutine partition_even(id, n_ids, size, b, e)
        integer, intent(in)    :: id, n_ids, size
        integer, intent(inout) :: b, e
        integer :: q

        q = size / n_ids ! quotient
        b = 1 + q * (id    )
        e =     q * (id + 1)
        return
    end subroutine partition_even

    ! This version works for uneven partitions (the general case).
    subroutine partition_uneven(id, n_ids, size, b, e)
        integer, intent(in)    :: id, n_ids, size
        integer, intent(inout) :: b, e
        integer :: r, q

        r = modulo(size, n_ids) ! remainder
        q = (size - r) / n_ids  ! quotient
        b = 1 + q * (id    ) + min(r, id    )
        e =     q * (id + 1) + min(r, id + 1)
        return
    end subroutine partition_uneven

end program parallel_sum


        SUBROUTINE  LS_GEOP ( lsfrpt, isurf, ipt, iret )
C************************************************************************
C*                                                                      *
C* LS_GEOP                                                              *
C*                                                                      *
C* This subroutine decodes the group 4a(3)hhh, which contains the       *
C* geopotential height of an agreed standard isobaric surface.          *
C*                                                                      *
C* LS_GEOP  ( LSFRPT, ISURF, IPT, IRET )                                *
C*                                                                      *
C* Input parameters:                                                    *
C*      LSFRPT         CHAR*	         Report array                   *
C*      ISURF          CHAR*1	         WMO Table 0264 code figure     *
C*					                                *
C* Input and Output parameters:                                         *
C*      IPT            INTEGER           On input, points to 'a'; on    *
C*                                       output, points to the last h   *
C*                                       in the group 4ahhh             *
C*					                                *
C* Output parameters:                                                   *
C*      RIVALS(IRGHTM) REAL              Geopotential height            *
C*      RIVALS(IRPRLC) REAL              Standard isobaric surface for  *
C*                                       the geopotential               *
C*	IRET           INTEGER           Return code                    *
C*				   	 0 = normal return 	        *
C*                                                                      *
C**                                                                     *
C* Log:							                *
C* R. Hollern/NCEP      11/96                                           *
C* R. Hollern/NCEP       1/98   Changed interface, cleaned up code      *
C* A. Hardy/GSC          1/98	Reordered calling sequence              *
C************************************************************************
        INCLUDE          'GEMPRM.PRM'
        INCLUDE          'lscmn.cmn'
C*
        CHARACTER*(*)     lsfrpt
C*
        CHARACTER         fld3*3,   isurf*1
C------------------------------------------------------------------------
        iret = 0
        iflg = 0

        fld3 = lsfrpt ( ipt+1:ipt+3 )
        ipt = ipt + 3
        CALL  ST_INTG ( fld3, ival, ier )
C
        IF ( ier .ne. 0 ) RETURN
C
        rval = FLOAT ( ival )
C
        IF ( isurf .eq. '8' ) THEN
C
C*          Decoding the 850 mb surface.
C
            hgtm = rval + 1000.
            prlc = 850.
            iflg = 1
          ELSE IF ( isurf .eq. '7' ) THEN
C
C*          Decoding the 700 mb surface.
C
            IF ( rval .lt. 500 ) THEN
                hgtm = rval + 3000.
              ELSE
                hgtm = rval + 2000.
            END IF
            prlc = 700.
            iflg = 1
          ELSE IF ( isurf .eq. '1' ) THEN
C
C*          Decoding the 1000 mb surface.
C
            hgtm = rval
            prlc = 1000.
            iflg = 1
          ELSE IF ( isurf .eq. '2' ) THEN
C
C*          Decoding the 925 mb surface.
C
            hgtm = rval
            prlc = 925.
            iflg = 1
          ELSE IF ( isurf .eq. '5' ) THEN
C
C*          500 mb surface (cannot tell if height below 5000m).
C
        END IF
C
        IF ( iflg .eq. 1 ) THEN
            rivals ( irhgtm ) = hgtm
            rivals ( irprlc ) = prlc
        ENDIF
C*
        RETURN
        END


 module Mod_nsm_ComputeTaus
   use typre
   use Mod_PointerSetter
   use Mod_nsm_BaseElmope
   use Mod_nsm_ComputeTauSmoothing
   implicit none
   private
   public SetPointersComputeTaus, timom_static, tidiv_static

   type, extends(PointerSetter) :: SPComputeTaus
contains
      procedure :: SpecificSet => SpecificSetComputeTaus
   end type
   type(SPComputeTaus) :: SetPointersComputeTaus

   !Tau Smoothing
   real(rp), allocatable :: elSmoothedTau(:,:)
   !TransientSubgridScales
   real(rp) :: timom_static, tidiv_static
   !For ALE
   logical  :: isALE
   real(rp) :: gpvelnor

contains

   !----------------------------------------------------------------------------
   !Setting Pointers

   subroutine SpecificSetComputeTaus(d)
      implicit none
      class(SPComputeTaus) :: d

      call a%Mesh%GetALE(isALE)
      !Taus are computed as usual
      if (a%kfl_Tausm == 0 .or. (a%istep == 1)) then
         ProcHook_ComputeTaus => ComputeTaus
      !Taus are interpolated from an elementary array
      elseif (a%kfl_Tausm >= 1) then
         call ConcatenateProcedures(ProcHook_Initializations,AllocSmoothedTau)
         call ConcatenateProcedures(ProcHook_Finalizations,DeallocSmoothedTau)
         call ConcatenateProcedures(ProcHook_Gathers,GatherTau)
         call ConcatenateProcedures(ProcHook_ComputeTaus,InterpolateTau)
      endif
      if (a%kfl_tacsg == 1) then
         call ConcatenateProcedures(ProcHook_ComputeTaus,TransientTaus)
      endif
   end subroutine

   !-------------------------------------------------------------------
   !Compute Tau values
   subroutine ComputeTaus
      implicit none

      !If Fixed -MeshALE or ALE, compute tau with the real velocity (u, instead of u-vmesh)
      if (isALE) then
         call vecnor(gpvel,e%ndime,gpvelnor,2)
         call ComputeTau(e,acden,acvis,gpvelnor,a%staco,chale,timom)
      else
         call ComputeTau(e,acden,acvis,gpvno,a%staco,chale,timom)
      endif
      if (a%kfl_advco == 1) then
         call vecnor(a%advco,e%ndime,gpvelnor,2)
         call ComputeTau(e,acden,acvis,gpvelnor,a%staco,chale,timom)
      endif
      call ComputeTauDiv(e,a%staco(4),chale,timom,tidiv)
   end subroutine

   !To interpolate the tau values from smoothed array Tausmo
   subroutine AllocSmoothedTau
      implicit none

      call a%Memor%alloc(2,e%mnode,elSmoothedTau,'elSmoothedTau','nsm_EndElmope')
   end subroutine

   subroutine DeallocSmoothedTau
      implicit none

      call a%Memor%dealloc(2,e%mnode,elSmoothedTau,'elSmoothedTau','nsm_EndElmope')
   end subroutine

   subroutine GatherTau
      implicit none

      call e%gather(2,elSmoothedTau,a%Tausmo)
   end subroutine

   subroutine InterpolateTau
      implicit none
      real(rp) :: gptau(2)

      call e%interpg(2,elSmoothedTau,gptau)
      timom = gptau(1)
      tidiv = gptau(2)
   end subroutine

   !Computes the transient stabilization parameter
   subroutine TransientTaus
      !timom is the transient one, the static one goes to timom_static
      timom_static = timom
      call ComputeTransientTau(ReferenceDtinv,acden,timom_static,timom)
   end subroutine

end module


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2018 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
!     this function enable to determine the discharge coefficient of bleed
!     tappings
!
      subroutine cd_bleedtapping(ps2,ps1,ps1pt1,nummer,curve,x_tab,y_tab
     &     ,cd)
!
!
!     in : SImultation of the secondary air system of aero engines
!          K.J.KUTZ T.M. SPEER
!          Transactions of the ASME vol.116 April 1994
!
!     author: Yannick Muller
!
      implicit none
!
      integer nummer,id,i,number,curve,index
      real*8 x_tab(15),y_tab(15)
!
!     Fig.7 tapping with lip
!
      real*8 cdx1(9)
      data  cdx1
     &     /0.24d0,0.52d0,0.8d0,1.14d0,1.42d0,1.9d0,2.5d0,3d0,3.4d0/
!

      real*8 cdy1(9)
      data cdy1
     &     /0.167d0,0.310d0,0.467d0,0.611d0,0.711d0,0.789d0,0.833d0,
     &     0.866d0,0.888d0/
!
!    Fig.7 tapping without lip
!
      real*8 cdx2(7)
      data  cdx2
     &     /1.0d0,1.14d0,1.42d0,1.9d0,2.5d0,3.0d0,3.4d0/

      real*8 cdy2(7)
      data cdy2
     &     /0.d0,0.122d0,0.377d0,0.7d0,0.766d0,0.769d0,0.772d0/

      real*8 ps2,ps1,dab,ps2pt1,ps1pt1,cdy(15),cd,cdx(20),
     &     dabmax
!
      ps2pt1=ps2/ps1
      dabmax=100.d0
!
      if(nummer.eq.0) then
         if (curve.eq.1) then
            index=9
            write(*,*)
            write(*,*) 'Cd calculations will be performed using'
            write(*,*) 'Cd-Kurven HP3 Schlitz;Kurve Nr. 1'
            do i=1,index
               cdx(i)=cdx1(i)
               cdy(i)=cdy1(i)
            enddo
!
         elseif(curve.eq.2) then
            index=7
            write(*,*)
            write(*,*) 'Cd calculations will be performed using'
            write(*,*) 'Cd-Kurven HP3 Schlitz;Kurve Nr. 2'
            do i=1,index
               cdx(i)=cdx2(i)
               cdy(i)=cdy2(i)
            enddo
!
         elseif(curve.gt.2) then
            write(*,*)
            write(*,*) 'no characteristic available under this index'
            write(*,*) 'cd is implicitely assumed equal to 1'
            cd=1.d0
            return
         endif
!
!     psvptv  ratio between the static pressure in the main canal
!     and the total pressure in the main canal
!
!     check whether ps1/pt1 less than 1 , if not then a warning is sent and
!     the calculation will peroceed with an  "oversized" dab
!
         if(abs(1.d0-ps2pt1).le.dabmax*(1.d0-ps1pt1)) then
            dab=(1.d0-ps2pt1)/(1.d0-ps1pt1)
         else
            dab=dabmax
            write(*,*) 'in cd_bleedtapping.f: ps1/pt1=',ps1pt1
            write(*,*) 'the calculation will proceed with DAB=100.'
         endif
!
!     determination of cd with the caracteristics
!
         call ident(cdx,dab,index,id)
         if(id.eq.0) then
            cd=cdy(1)
         elseif(id.ge.index) then
            cd=cdy(index)
         else
            cd=cdy(id)+(cdy(id+1)-cdy(id))
     &           *(dab-cdx(id))/(cdx(id+1)-cdx(id))
         endif
!
      else
         if(abs(1.d0-ps2pt1).le.dabmax*(1.d0-ps1pt1)) then
            dab=(1.d0-ps2pt1)/(1.d0-ps1pt1)
         else
            dab=dabmax
            write(*,*) 'in cd_bleedtapping.f: ps1/pt1=',ps1pt1
            write(*,*) 'the calculation will proceed with DAB=100.'
         endif

         call ident(x_tab,dab,nummer,id)
         if(id.eq.0) then
            cd=y_tab(1)
         elseif(id.ge.nummer) then
            cd=y_tab(nummer)
         else
            cd=y_tab(id)+(y_tab(id+1)-y_tab(id))
     &           *(dab-x_tab(id))/(x_tab(id+1)-x_tab(id))
         endif
      endif
      return
      end


! This is a fortran95 implementation of the game of tic-tac-toe.
! - Objective was to use less than 100 lines.
! - No attention has been devoted to efficiency.
! - Indentation by findent: https://sourceforge.net/projects/findent/
! - This is free software, use as you like at own risk.
! - Compile: gfortran -o tictactoe tictactoe.f90
! - Run: ./tictactoe
! Comments to: wvermin at gmail dot com
module tic
   implicit none
   integer :: b(9)
contains
   logical function iswin(p)
      integer,intent(in) :: p
      iswin = &
         all(b([1,2,3])==p).or.all(b([4,5,6])==p).or.all(b([7,8,9])==p).or.&
         all(b([1,4,7])==p).or.all(b([2,5,8])==p).or.all(b([3,6,9])==p).or.&
         all(b([1,5,9])==p).or.all(b([3,5,7])==p)
   end function iswin
   subroutine printb(mes)
      character(len=*) :: mes
      integer          :: i,j
      character        :: s(0:2) = ['.','X','O']
      print "(3a3,'   ',3i3)",(s(b(3*i+1:3*i+3)),(j,j=3*i+1,3*i+3),i=0,2)
      if(mes /= ' ') print "(/,a)",mes
   end subroutine printb
   integer recursive function minmax(player,bestm) result(bestv)
      integer :: player,bestm,move,v,bm,win=1000,inf=100000
      real    :: x
      if (all(b .ne. 0)) then
         bestv = 0
      else
         bestv = -inf
         do move=1,9
            if (b(move) == 0) then
               b(move) = player
               if (iswin(player)) then
                  v = win
               else
                  call random_number(x)
                  v = -minmax(3-player,bm) - int(10*x)
               endif
               if (v > bestv) then
                  bestv = v
                  bestm = move
               endif
               b(move) = 0
               if (v == win) exit
            endif
         enddo
      endif
   end function minmax
end module tic
program tictactoe
   ! computer: player=1, user: player=2
   use tic
   implicit none
   integer :: move,ios,v,bestmove,ply,player=2,k,values(8)
   integer,allocatable :: seed(:)
   call date_and_time(values=values)
   call random_seed(size=k)
   allocate(seed(k))
   seed = values(8)+1000*values(7)+60*1000*values(6)+60*60*1000*values(5)
   call random_seed(put=seed)
   mainloop: do
      b = 0
      call printb('You have O, I have X. You enter 0: game ends.')
      plyloop: do ply=0,4
         if (player == 2 .or. ply >0 ) then  ! user move
            write(*,"(/,a)",advance='no'),'Your move? (0..9) '
            getloop: do
               readloop: do
                  read (*,*,iostat=ios),move
                  if (ios == 0 .and. move  >= 0 .and. move <= 9) exit readloop
                  write(*,"(a)",advance='no'),'huh? Try again (0..9): '
               enddo readloop
               if (  move  == 0) exit mainloop
               if (b(move) == 0) exit getloop
               write(*,"(a)",advance='no'),'Already occupied, again (0..9): '
            enddo getloop
            b(move) = 2
            if(iswin(2)) then   ! this should not happen
               call printb('***** You win *****')
               exit plyloop
            endif
         endif
         v = minmax(1,bestmove)   ! computer move
         b(bestmove) = 1
         if(iswin(1)) then
            call printb('***** I win *****')
            exit plyloop
         endif
         write(*,"(/,a,i3)"), 'My move: ',bestmove
         call printb(' ')
      enddo plyloop
      if(ply == 5) write(*,"('***** Draw *****',/)")
      player = 3-player
   enddo mainloop
end program


!> \brief Implements Slater Koster table and the first derivatives
!> \details as in the paper "Automatic Generation of Matrix Element Derivatives for Tight Binding Models" \n
!> A. M. Elena and M. Meister, Phys. Rev. B, 72, 165107 (2005)
!> \author Alin M Elena
!> \date 25th of January, 2005
!
module m_SlaterKoster
  use m_Constants
  use m_Types
  use m_Useful
  use m_TightBinding
  implicit none
!
  private
!
  public :: hmn
  public :: DhmnXYZ
!
contains
!
  function hmn (r, l, m, n, orba, orbb, gen, tb, sol)
!--subroutine name--------------------------------!
    character (len=*), parameter :: myname = 'hmn'
!--subroutine parameters -------------------------!
    real (k_pr) :: hmn
    real (k_pr), intent (inout) :: r, l, m, n
    type (orbitalType), intent (in) :: orba, orbb
    type (modelType), intent (inout) :: tb
    type (solutionType), intent (inout) :: sol
    type (generalType), intent (inout) :: gen
!
!--internal variables ----------------------------!
    real (k_pr) :: auxs, cg1, sg1, cg2, sg2
    integer :: mp, ls, ss, sb, m1, m2, l1, l2
    real (k_pr) :: am1, am2, d1, d2, s1, s2, t1, t2, h1
!
!-------------------------------------------------!
!
    if (Abs(Abs(n)-1.0_k_pr) > epsilon(n)) then
      cg1 = vcg (Abs(orba%m), l, m, n, sol)
      cg2 = vcg (Abs(orbb%m), l, m, n, sol)
      sg1 = vsg (Abs(orba%m), l, m, n, sol)
      sg2 = vsg (Abs(orbb%m), l, m, n, sol)
    else
      cg1 = 1.0_k_pr
      cg2 = 1.0_k_pr
      sg1 = 0.0_k_pr
      sg2 = 0.0_k_pr
    end if
    ls = Min (orba%l, orbb%l)
!
    ss = orba%sp
    sb = orbb%sp
    m1 = Abs (orba%m)
    m2 = Abs (orbb%m)
    l1 = orba%l
    l2 = orbb%l
    mp = 0
    if (sol%sk%precompute) then
      sol%sk%ls = ls
      call PrecomputeSk (orba%m, orbb%m, m1, m2, l1, l2, sg1, cg1, sg2, cg2, n, sol)
    end if
!
    am1 = am (cg1, sg1, orba%m)
    am2 = am (cg2, sg2, orbb%m)
    d1 = sol%sk%wignerD(m1, 0, l1)
    d2 = sol%sk%wignerD(m2, 0, l2)
    h1 = rad (r, ss, sb, gen, tb, l1, l2, mp)
!
    auxs = 2.0_k_pr * am1 * am2 * d1 * d2 * h1
    do mp = 1, ls
      s1 = smmpl (orba%m, mp, l1, n, cg1, sg1, sol)
      s2 = smmpl (orbb%m, mp, l2, n, cg2, sg2, sol)
      t1 = tmmpl (orba%m, mp, l1, n, cg1, sg1, sol)
      t2 = tmmpl (orbb%m, mp, l2, n, cg2, sg2, sol)
      auxs = auxs + (s1*s2+t1*t2) * rad (r, ss, sb, gen, tb, l1, l2, mp)
    end do
    hmn = auxs
!
  end function hmn
!
  function HmnP (r, l, m, n, orba, orbb, ls, m1, m2, cg1, cg2, sg1, sg2, gen, tb, sol)
!--subroutine name--------------------------------!
    character (len=*), parameter :: myname = 'sppna_HmnP'
!--subroutine parameters -------------------------!
    real (k_pr) :: HmnP (1:3)
    real (k_pr), intent (inout) :: r, l, m, n
    type (orbitalType), intent (in) :: orba, orbb
    type (modelType), intent (inout) :: tb
    type (solutionType), intent (inout) :: sol
    type (generalType), intent (inout) :: gen
!--internal variables ----------------------------!
    real (k_pr) :: cg1, cg2, sg1, sg2, auxs, auxs2, auxs3
    integer :: mp, ls, ss, sb, m1, m2, l1, l2
    real (k_pr) :: am1, am2, d1, d2, s1, s2, t1, t2, h1
    real (k_pr) :: am1a, am2a, d1a, d2a, s1a (1:2), s2a (1:2), t1a (1:2), t2a (1:2), h1a
!-------------------------------------------------!
!
    ss = orba%sp
    sb = orbb%sp
    l1 = orba%l
    l2 = orbb%l
    mp = 0
!
!
    am1 = am (cg1, sg1, orba%m)
    am2 = am (cg2, sg2, orbb%m)
    am1a = AmP (cg1, sg1, orba%m)
    am2a = AmP (cg2, sg2, orbb%m)
    d1 = sol%sk%wignerD(m1, 0, l1)
    d2 = sol%sk%wignerD(m2, 0, l2)
    d1a = RotmmplP (m1, 0, l1, n, sol)
    d2a = RotmmplP (m2, 0, l2, n, sol)
!
    h1 = rad (r, ss, sb, gen, tb, l1, l2, mp)
    h1a = RadP (r, ss, sb, gen, tb, l1, l2, mp)
!
    auxs3 = 2.0_k_pr * am1 * am2 * d1 * d2 * h1a
    auxs2 = 2.0_k_pr * am1 * am2 * d1a * d2 * h1 + 2.0_k_pr * am1 * am2 * d1 * d2a * h1
    auxs = 2.0_k_pr * am1a * am2 * d1 * d2 * h1 + 2.0_k_pr * am1 * am2a * d1 * d2 * h1
    do mp = 1, ls
      s1 = smmpl (orba%m, mp, l1, n, cg1, sg1, sol)
      s2 = smmpl (orbb%m, mp, l2, n, cg2, sg2, sol)
      t1 = tmmpl (orba%m, mp, l1, n, cg1, sg1, sol)
      t2 = tmmpl (orbb%m, mp, l2, n, cg2, sg2, sol)
      s1a = SmmplP (orba%m, mp, l1, n, cg1, sg1, sol)
      s2a = SmmplP (orbb%m, mp, l2, n, cg2, sg2, sol)
      t1a = TmmplP (orba%m, mp, l1, n, cg1, sg1, sol)
      t2a = TmmplP (orbb%m, mp, l2, n, cg2, sg2, sol)
      auxs = auxs + (s1a(1)*s2+s1*s2a(1)+t1a(1)*t2+t1*t2a(1)) * rad (r, ss, sb, gen, tb, l1, l2, mp)
      auxs2 = auxs2 + (s1a(2)*s2+s1*s2a(2)+t1a(2)*t2+t1*t2a(2)) * rad (r, ss, sb, gen, tb, l1, l2, mp)
      auxs3 = auxs3 + (s1*s2+t1*t2) * RadP (r, ss, sb, gen, tb, l1, l2, mp)
    end do
    HmnP (1) = auxs
    HmnP (2) = auxs2
    HmnP (3) = auxs3
!
!
  end function HmnP
!
  function vsg (mp, l, m, n, sol)
!----------------------------------------------------!
! vsg gives you sin(mx) knowing sin(x) and cos(x)    !
! input an integer mp and n,l,m direction cosines    !
!                                                    !
! 18th of January, 2005                              !
! Alin M. Elena,Queen's University Belfast, UK       !
! Modified by                                        !
! Date                                               !
!----------------------------------------------------!
    integer, intent (in) :: mp
    real (k_pr), intent (in) :: n, l, m
    type (solutionType), intent (in) :: sol
    real (k_pr) :: vsg
    real (k_pr) :: summ !,factm
    integer :: i
!
!
    summ = 0.0_k_pr
    do i = 0, Int ((mp-1)/2.0_k_pr)
      if (mp-2*i-1 >= 0) summ = summ + (-1.0_k_pr) ** i * sol%fact(mp) / (sol%fact(2*i+1)*sol%fact(mp-2*i-1)) * &
     & (m/Sqrt(1.0_k_pr-n*n)) ** (2*i+1) * (l/Sqrt(1.0_k_pr-n*n)) ** (mp-2*i-1)
    end do
    vsg = summ
!
  end function vsg
!
!
  function vcg (mp, l, m, n, sol)
!----------------------------------------------------!
! vsg gives you sin(mx) knowing sin(x),cos(x)        !
! input an integer mp and n,l,m direction cosines    !
!                                                    !
! 18th of January, 2005                              !
! Alin M. Elena,Queen's University Belfast, UK       !
! Modified by                                        !
! Date                                               !
!----------------------------------------------------!
!
    integer, intent (in) :: mp
    real (k_pr), intent (in) :: n, l, m
    type (solutionType), intent (in) :: sol
    real (k_pr) :: vcg
    real (k_pr) :: summ !,factm
    integer :: i
!
!
!
    summ = 0.0_k_pr
    do i = 0, Int (mp/2)
      summ = summ + (-1.0_k_pr) ** i * sol%fact(mp) / (sol%fact(2*i)*sol%fact(mp-2*i)) * (m/Sqrt(1.0_k_pr-n*n)) ** (2*i) * &
     & (l/Sqrt(1.0_k_pr-n*n)) ** (mp-2*i)
    end do
    vcg = summ
  end function vcg
!
!
!
  function am (cg, sg, m)
!----------------------------------------------------!
! am implements the equation (TBP)                   !
! input an integer m, cos(mx), sin(mx)               !
!                                                    !
! 4th of February, 2005                              !
! Alin M. Elena,Queen's University Belfast, UK       !
! Modified by                                        !
! Date                                               !
!----------------------------------------------------!
    integer, intent (in) :: m
    real (k_pr), intent (in) :: cg, sg
    real (k_pr) :: am
    logical :: l = .true.
!
    if (m /= 0) then
      am = (-1.0_k_pr) ** Abs (m) * (cg*h(m, l)+sg*h(-m, l))
    else
      am = 1.0_k_pr / Sqrt (2.0_k_pr)
    end if
!
  end function am
!
  function AmP (cg, sg, m)
!----------------------------------------------------!
! AmP implements the derivatives of am with respect !
! polar coordinates                                  !
! the same as am plus an integer alpha meaning       !
! variable of derivative                             !
!                                                    !
! 4th of February, 2005                              !
! Alin M. Elena, Queen's University Belfast, UK      !
! Modified by                                        !
! Date                                               !
!----------------------------------------------------!
    integer, intent (in) :: m
    real (k_pr), intent (in) :: cg, sg
    real (k_pr) :: AmP
!
!
    AmP = Abs (m) * bm (cg, sg, m)
!
  end function AmP
!
  function bm (cg, sg, m)
!----------------------------------------------------!
! bm implements the equation (TBP)                   !
! input an integer m, cos(mx), sin(mx)               !
!                                                    !
! 4th of February, 2005                              !
! Alin M. Elena,Queen's University Belfast, UK       !
! Modified by                                        !
! Date                                               !
!----------------------------------------------------!
!
    integer, intent (in) :: m
    real (k_pr), intent (in) :: cg, sg
    real (k_pr) :: bm
    logical :: l = .true.
!
    if (m /= 0) then
      bm = (-1.0_k_pr) ** Abs (m) * (cg*h(-m, l)-sg*h(m, l))
    else
      bm = 0.0_k_pr
    end if
!
  end function bm
!
  function BmP (cg, sg, m)
!----------------------------------------------------!
! BmP implements the derivatives of am with respect !
! polar coordinates                                  !
! the same as am plus an integer alpha meaning       !
! variable of derivative                             !
!                                                    !
! 4th of February, 2005                              !
! Alin M. Elena, Queen's University Belfast, UK      !
! Modified by                                        !
! Date                                               !
!----------------------------------------------------!
!
    integer, intent (in) :: m
    real (k_pr), intent (in) :: cg, sg
    real (k_pr) :: BmP
!
    BmP = - Abs (m) * am (cg, sg, m)
  end function BmP
!
  function rotmmpl (m, mp, l, n, sol)
!--subroutine name--------------------------------!
    character (len=*), parameter :: myname = 'rotmmpl'
!--subroutine parameters -------------------------!
!----------------------------------------------------!
! rotmmpl implements the equation (TBP)              !
! input  integers m,mp,l and dp n = cos(beta)        !
!                                                    !
! 4th of February, 2005                              !
! Alin M. Elena,Queen's University  Belfast, UK      !
! Modified by Alin M Elena                                       !
! Date 31st of March 2006                                              !
!----------------------------------------------------!
    integer, intent (in) :: m, mp, l
    real (k_pr), intent (in) :: n
    type (solutionType), intent (in) :: sol
    real (k_pr) :: rotmmpl
!
    real (k_pr) :: sum
    integer :: t
    sum = 0.0_k_pr
    do t = Max (0,-m-mp), Min (l-m, l-mp)
      sum = sum + ((1+n)**(t+(m+mp)/2.0_k_pr)) * ((1-n)**(l-t-(m+mp)/2.0_k_pr)) * ((-1)**t) / &
     & (sol%fact(l-mp-t)*sol%fact(l-m-t)*sol%fact(t)*sol%fact(t+m+mp))
    end do
    rotmmpl = (2.0_k_pr**(-l)) * Sqrt (sol%fact(l+mp)*sol%fact(l-mp)*sol%fact(l+m)*sol%fact(l-m)) * sum * (-1.0_k_pr) ** (l-mp)
!
  end function rotmmpl
!
!
  function RotmmplP (m, mp, l, n, sol)
!----------------------------------------------------!
! RotmmplP implements the derivative of rotmmpl     !
! with respect to polar coordinate alpha             !
! input  integers m,mp,l and dp n = cos(beta), alpha !
!                                                    !
! 4th of February, 2005                              !
! Alin M. Elena,Queen's University  Belfast, UK      !
! Modified by                                        !
! Date                                               !
!----------------------------------------------------!
!
    integer, intent (in) :: m, mp, l
    real (k_pr), intent (in) :: n
    type (solutionType), intent (in) :: sol
    real (k_pr) :: RotmmplP
!
    real (k_pr) :: t1, t2
!       integer ::t
!
    t1 = 0.0_k_pr
    t2 = 0.0_k_pr
    if (Abs(mp-1) <= l) t1 = Sqrt (real((l+mp)*(l-mp+1), k_pr)) * sol%sk%wignerD(m, mp-1, l)
    if (Abs(mp+1) <= l) t2 = - Sqrt (real((l-mp)*(l+mp+1), k_pr)) * sol%sk%wignerD(m, mp+1, l)
    RotmmplP = 0.5_k_pr * (t1+t2)
!
  end function RotmmplP
!
!
  function tmmpl (m, mp, l, n, cg, sg, sol)
!----------------------------------------------------!
! tmmpl implements matrix T the equation (TBP)       !
! inputing an integer m,mp,l and dp n=cos(b)         !
! sin(mx)=sg,cos(mx)=cg                              !
!                                                    !
! 18th of January, 2005                              !
! Alin M. Elena,Queen's University Belfast, UK       !
! Modified by                                        !
! Date                                               !
!----------------------------------------------------!
    integer, intent (in) :: m, mp, l
    real (k_pr), intent (in) :: n, cg, sg
    type (solutionType), intent (inout) :: sol
    real (k_pr) :: tmmpl
!
    integer :: absm !, absmp
    if (m /= 0) then
      absm = Abs (m)
      tmmpl = bm (cg, sg, m) * (((-1)**mp)*sol%sk%wignerD(absm, mp, l)-sol%sk%wignerD(absm,-mp, l))
    else
      tmmpl = 0.0_k_pr
    end if
  end function tmmpl
!
!
  function TmmplP (m, mp, l, n, cg, sg, sol)
!----------------------------------------------------!
! TmmplP implements derivative of matrix T          !
! equation (TBP) with respect to polar coordinates   !
! alpha                                              !
! inputing an integer m,mp,l and dp n=cos(b)         !
! sin(mx)=sg,cos(mx)=cg                              !
!                                                    !
! 18th of January, 2005                              !
! Alin M. Elena,Queen's University Belfast, UK       !
! Modified by                                        !
! Date                                               !
!----------------------------------------------------!
!
    integer, intent (in) :: m, mp, l
    real (k_pr), intent (in) :: n, cg, sg
    type (solutionType), intent (inout) :: sol
    real (k_pr) :: TmmplP (1:2)
!
    integer :: absm
!
!
    absm = Abs (m)
!
    if (m == 0) then
      TmmplP (1) = 0.0_k_pr
      TmmplP (2) = 0.0_k_pr
    else
      TmmplP (1) = - absm * am (cg, sg, m) * (((-1)**mp)*sol%sk%wignerD(absm, mp, l)-sol%sk%wignerD(absm,-mp, l))
      TmmplP (2) = bm (cg, sg, m) * (((-1)**mp)*RotmmplP(absm, mp, l, n, sol)-RotmmplP(absm,-mp, l, n, sol))
    end if
!
  end function TmmplP
!
  function smmpl (m, mp, l, n, cg, sg, sol)
!----------------------------------------------------!
! smmpl implements matrix S the equation (TBP)       !
! inputing an integer m,mp,l and dp n=cos(b)         !
! sin(mx)=sg,cos(mx)=cg                              !
!                                                    !
! 18th of January, 2005                              !
! Alin M. Elena,Queen's University Belfast, UK       !
! Modified by                                        !
! Date                                               !
!----------------------------------------------------!
!
    integer, intent (in) :: m, mp, l
    real (k_pr), intent (in) :: n, cg, sg
    type (solutionType), intent (inout) :: sol
    real (k_pr) :: smmpl
!
    integer :: absm
!
    absm = Abs (m)
    smmpl = am (cg, sg, m) * (((-1)**mp)*sol%sk%wignerD(absm, mp, l)+sol%sk%wignerD(absm,-mp, l))
!
  end function smmpl
!
  function SmmplP (m, mp, l, n, cg, sg, sol)
!----------------------------------------------------!
! SmmplP implements derivative of matrix S          !
! equation (TBP) with respect to polar coordinates   !
! alpha                                              !
! inputing an integer m,mp,l and dp n=cos(b)         !
! sin(mx)=sg,cos(mx)=cg                              !
!                                                    !
! 25th of January, 2005                              !
! Alin M. Elena,Queen's University Belfast, UK       !
! Modified by                                        !
! Date                                               !
!----------------------------------------------------!
!
!
    integer, intent (in) :: m, mp, l
    real (k_pr), intent (in) :: n, sg, cg
    type (solutionType), intent (inout) :: sol
    real (k_pr) :: SmmplP (1:2)
    integer :: absm
!
    absm = Abs (m)
!
!
    SmmplP (1) = absm * bm (cg, sg, m) * (((-1)**mp)*sol%sk%wignerD(absm, mp, l)+sol%sk%wignerD(absm,-mp, l))
    SmmplP (2) = am (cg, sg, m) * (((-1)**mp)*RotmmplP(absm, mp, l, n, sol)+RotmmplP(absm,-mp, l, n, sol))
!
  end function SmmplP
!
!==hoppings==========================================================
  function DhmnXYZ (r, l, m, n, orba, orbb, gen, tb, sol)
!--subroutine name--------------------------------!
    character (len=*), parameter :: myname = 'DhmnXYZ'
!--subroutine parameters -------------------------!
    real (k_pr) :: r, l, m, n
    type (orbitalType) :: orba, orbb
    integer :: alpha
    real (k_pr) :: dj (1:3)
    type (modelType), intent (inout) :: tb
    type (generalType), intent (inout) :: gen
    type (solutionType), intent (inout) :: sol
    real (k_pr) :: DhmnXYZ (1:3)
    real (k_pr) :: cg1, cg2, sg1, sg2
    integer :: one, two, three, j, ls, m1, m2
    one = 1
    two = 2
    three = 3
    ls = Min (orba%l, orbb%l)
    m1 = Abs (orba%m)
    m2 = Abs (orbb%m)
!
!
    if (Abs(Abs(n)-1.0_k_pr) > epsilon(n)) then
      cg1 = vcg (m1, l, m, n, sol)
      cg2 = vcg (m2, l, m, n, sol)
      sg1 = vsg (m1, l, m, n, sol)
      sg2 = vsg (m2, l, m, n, sol)
      sol%sk%ls = ls
      call PrecomputeSk (orba%m, orbb%m, m1, m2, orba%l, orbb%l, sg1, cg1, sg2, cg2, n, sol)
      dj = HmnP (r, l, m, n, orba, orbb, ls, m1, m2, cg1, cg2, sg1, sg2, gen, tb, sol)
!
      do j = 1, 3
        DhmnXYZ (j) = dj (1) * jx (j, r, l, m, n) - dj (2) * jy (j, r, l, m, n) + dj (3) * jz (j, l, m, n)
      end do
    else
! the north-south pole case
      cg1 = 0.0_k_pr
      cg2 = 0.0_k_pr
      sg1 = Sin (m1*k_pi/2.0_k_pr)
      sg2 = Sin (m2*k_pi/2.0_k_pr)
      sol%sk%ls = ls
      call PrecomputeSk (orba%m, orbb%m, m1, m2, orba%l, orbb%l, sg1, cg1, sg2, cg2, n, sol)
      dj = HmnP (r, l, m, n, orba, orbb, ls, m1, m2, cg1, cg2, sg1, sg2, gen, tb, sol)
      DhmnXYZ (2) = sign (1.0_k_pr, n) * dj (2) / r
      cg1 = 1.0_k_pr
      cg2 = 1.0_k_pr
      sg1 = 0.0_k_pr
      sg2 = 0.0_k_pr
      call PrecomputeSk (orba%m, orbb%m, m1, m2, orba%l, orbb%l, sg1, cg1, sg2, cg2, n, sol)
      dj = HmnP (r, l, m, n, orba, orbb, ls, m1, m2, cg1, cg2, sg1, sg2, gen, tb, sol)
      DhmnXYZ (1) = sign (1.0_k_pr, n) * dj (2) / r
      DhmnXYZ (3) = sign (1.0_k_pr, n) * dj (3)
!
    end if
  end function DhmnXYZ
!
  real (k_pr) function jx (alpha, r, l, m, n)
    character (len=*), parameter :: myname = 'jx'
    real (k_pr) :: r, l, m, n
    integer :: alpha
!
    select case (alpha)
    case (1)
      jx = - m / (r*(1.0_k_pr-n*n))
    case (2)
      jx = l / (r*(1.0_k_pr-n*n))
    case (3)
      jx = 0.0_k_pr
    end select
  end function jx
!
  real (k_pr) function jy (alpha, r, l, m, n)
!--subroutine name--------------------------------!
    character (len=*), parameter :: myname = 'jy'
!--subroutine parameters -------------------------!
    real (k_pr) :: r, l, m, n
    integer :: alpha
!
    select case (alpha)
    case (1)
      jy = - n * l / (r*Sqrt(1.0_k_pr-n*n))
    case (2)
      jy = - n * m / (r*Sqrt(1.0_k_pr-n*n))
    case (3)
      jy = Sqrt (1.0_k_pr-n*n) / r
    end select
!
!
  end function jy
!
!
  real (k_pr) function jz (alpha, l, m, n)
!--subroutine name--------------------------------!
    character (len=*), parameter :: myname = 'jz'
!--subroutine parameters -------------------------!
    real (k_pr) :: l, m, n
    integer :: alpha
!
    select case (alpha)
    case (1)
      jz = l
    case (2)
      jz = m
    case (3)
      jz = n
    end select
!
  end function jz
!
!
  subroutine PrecomputeSk (m1, m2, mm1, mm2, l1, l2, sg1, cg1, sg2, cg2, n, sol)
    character (len=*), parameter :: myname = "PrecomputeSk"
    real (k_pr), intent (inout) :: n, sg1, cg1, sg2, cg2
    type (solutionType), intent (inout) :: sol
    integer :: m1, m2, l1, l2, mm1, mm2
!
    integer :: j
!
    do j = - sol%sk%ls, sol%sk%ls
      sol%sk%wignerD (mm1, j, l1) = rotmmpl (mm1, j, l1, n, sol)
      sol%sk%wignerD (mm2, j, l2) = rotmmpl (mm2, j, l2, n, sol)
    end do
!
  end subroutine PrecomputeSk
!
!
!
!==end hoppings======================================================
!
end module m_SlaterKoster


subroutine check_cfl(fs)
  use variables
  use mpi
  implicit none
  real(8) Dtcr,maxvel,maxvelall
  real(8),intent(in) :: fs
  integer,dimension(2) :: mloc
  integer ierr

  ! Dtcr=Dx/(maxval(sqrt(u(1:Nx,1:Ny)**2+v(1:Nx,1:Ny)**2)+sqrt(2.d0*g*h(1:Nx,1:Ny)))) !for single node

  maxvel=(maxval(sqrt(u(1:Nx,1:Ny)**2+v(1:Nx,1:Ny)**2)+sqrt(2.d0*g*h(1:Nx,1:Ny))))
    if(maxvel>Dx/Dtmin*Fs)then
      write(*,*) "maxvel modified!!,rank=",my_rank,"T=",T
      maxvel=0.d0
      iserror=1
      u=0.d0
      v=0.d0
      h=0.d0
      Ca=0.d0
      Uc(:,:,1:4)=0.d0
      Ec(:,:,1:4)=0.d0
      Fc(:,:,1:4)=0.d0
      Cc=0.d0
      Qxc=0.d0
      Qyc=0.d0
      iswet=0.d0
      Up(:,:,1:4)=0.d0
      Ep(:,:,1:4)=0.d0
      Fp(:,:,1:4)=0.d0
      Cp=0.d0
      Qxp=0.d0
      Qyp=0.d0
    endif
  if(PETOT>1)then
    call mpi_allreduce(maxvel,maxvelall,1,MPI_DOUBLE_PRECISION,MPI_MAX,MPI_COMM_WORLD,ierr)
  else
    maxvelall=maxvel
  endif
  Dtcr=Dx/maxvelall
  Cfl=Dt/Dtcr

  if(T>dtkeeptime)then
    if(Dt>fs*Dtcr)then
      do while (Dt>Dtcr*Fs)
        ! write(*,*) "dt become 1/2"
        Dt=Dt/2.d0
        if(Dt<Dtmin)then
          if(maxvel==maxvelall)then
            write(*,*) "too small dt. rank=",my_rank,Dt
            write(*,*) "maxvel=",maxvelall,maxvel
            mloc=maxloc(sqrt(u(1:Nx,1:Ny)**2+v(1:Nx,1:Ny)**2)+sqrt(2.d0*g*h(1:Nx,1:Ny)))
            write(*,*) my_rank,mloc(1),mloc(2)
            write(*,*) "                        ",u(mloc(1),mloc(2) - 1),"                "
            write(*,*) u(mloc(1)-1,mloc(2)),u(mloc(1),mloc(2)),u(mloc(1)+1,mloc(2))
            write(*,*) "                        ",u(mloc(1),mloc(2) + 1),"                "
            write(*,*)
            write(*,*) "                        ",v(mloc(1),mloc(2) - 1),"                "
            write(*,*) v(mloc(1)-1,mloc(2)),v(mloc(1),mloc(2)),v(mloc(1)+1,mloc(2))
            write(*,*) "                        ",v(mloc(1),mloc(2) + 1),"                "
            write(*,*)
            write(*,*) "                        ",h(mloc(1),mloc(2) - 1),"                "
            write(*,*) h(mloc(1)-1,mloc(2)),h(mloc(1),mloc(2)),h(mloc(1)+1,mloc(2))
            write(*,*) "                        ",h(mloc(1),mloc(2) + 1),"                "
            write(*,*)
            write(*,*) "                        ",sfx(mloc(1),mloc(2) - 1),"                "
            write(*,*) sfx(mloc(1)-1,mloc(2)),sfx(mloc(1),mloc(2)),sfx(mloc(1)+1,mloc(2))
            write(*,*) "                        ",sfx(mloc(1),mloc(2) + 1),"                "
            write(*,*)
            write(*,*) "                        ",sfy(mloc(1),mloc(2) - 1),"                "
            write(*,*) sfy(mloc(1)-1,mloc(2)),sfy(mloc(1),mloc(2)),sfy(mloc(1)+1,mloc(2))
            write(*,*) "                        ",sfy(mloc(1),mloc(2) + 1),"                "
          endif
          ! stop
        endif
      enddo
    endif

    if(Dt<fs*Dtcr*0.5)then
      do while (Dt<fs*Dtcr*0.5)
        ! write(*,*) "dt become 2"
        Dt=Dt*2.d0
      enddo
    endif
    if(DT>Dtmax)then
      Dt=Dtmax
    endif
  endif

  ! if(Dt>fs*Dtcr)then
  !   write(*,*) "Dt is too large!!!"
  !   write(*,*) "cfl=",Cfl
  !   write(*,*) Dtcr,Dt,fs,T
  !   write(*,*) maxval(sqrt(u**2+v**2)),maxval(sqrt(2.d0*g*h))
  !   write(*,*) maxval(u(1:Nx,1:Ny)),maxval(v(1:Nx,1:Ny)),maxval(h(1:Nx,1:Ny))
  !   call fwrite_xyz("h",h)
  !   call fwrite_xyz("u",u)
  !   call fwrite_xyz("v",v)
  !   call fwrite_xyz("zb",zb)
  !   call fwrite_xyz("dzb",zb-zbini)
  !   call fwrite_xyz("ca",ca)
  !   write(*,*) "file wrote"
  !   ! read(*,*)
  !   do while (Dt>Dtcr*Fs)
  !     write(*,*) "dt become 1/2"
  !     Dt=Dt/2.d0
  !   enddo
  ! endif

end subroutine check_cfl


module modmvlr
 use iso_fortran_env
 !$ use omp_lib
 use modsparse
#if (COARRAY==1)
 use modcoeff,only:gen_coeff
#endif

 implicit none
 private
 public::mvlr

 type::typeres
  real(kind=real64),allocatable::mat(:,:)
 end type

#if (COARRAY==1)
 type,extends(gen_coeff)::mvlr
#else
 type::mvlr
#endif
  private
  integer(kind=int32)::unlog=6
  integer(kind=int32)::nphen,ntrait,neffect,ncov,neq
  integer(kind=int32)::startphen,endphen,nsubphen
  integer(kind=int32),allocatable::effect(:,:)
  integer(kind=int64),allocatable::presentpheno(:)
  real(kind=real64),allocatable::pheno(:,:)
  real(kind=real64),allocatable::resmati(:,:)
  character(len=30)::datafile,resfile
  logical,allocatable::model(:,:)
  type(typeres),allocatable::tres(:)
 contains
  private
  procedure,public::init=>init_mvlr
  procedure,public::getneq
#if (COARRAY==1)
  procedure,public::multbyv=>multbyv_mvlr
#else
  procedure,public::diag=>computediag_vect_mvlr
#endif
 end type

contains

!PUBLIC
!**GET #EQUATIONS
function getneq(this) result(neq)
 class(mvlr),intent(in)::this
 integer(kind=int32)::neq

 neq=this%neq
end function

!**INIT
subroutine init_mvlr(this,paramfile,unlog)
 class(mvlr),intent(inout)::this
 character(len=*),intent(in)::paramfile
 integer(kind=int32),intent(in),optional::unlog

 integer(kind=int32)::i,k,un,io,nsize
 integer(kind=int32),allocatable::itmp(:)
 integer(kind=int64)::i8tmp,maxcombi
 real(kind=real64),allocatable::rtmp(:)
 logical,allocatable::ltmp(:)

 if(present(unlog))this%unlog=unlog

 open(newunit=un,file=paramfile,status='old',action='read')
 read(un,*)this%datafile
 read(un,*)this%nphen
 read(un,*)this%ntrait
 read(un,*)this%neffect
 read(un,*)this%ncov
 read(un,*)this%neq
 read(un,*)this%resfile
 allocate(this%model(this%ntrait,this%neffect),itmp(this%neffect))
 this%model=.false.
 do i=1,this%ntrait
  read(un,*)itmp
  where(itmp.ne.0)this%model(i,:)=.true.
 enddo
 deallocate(itmp)
 close(un)

 write(this%unlog,'(/a,t20,a)')this%datafile,'datafile'
 write(this%unlog,'(i0,t20,a)')this%nphen,'nphen'
 write(this%unlog,'(i0,t20,a)')this%ntrait,'ntrait'
 write(this%unlog,'(i0,t20,a)')this%neffect,'neffect'
 write(this%unlog,'(i0,t20,a)')this%ncov,'ncov'
 write(this%unlog,'(i0,t20,a)')this%neq,'neq'
 write(this%unlog,'(a,t20,a)')this%resfile,'residual variance file'
 allocate(ltmp(this%neffect))
 do i=1,this%ntrait
  ltmp=this%model(i,:)
  write(this%unlog,'(<this%neffect>l1,t30,a,i0)')ltmp,'model trait ',i
 enddo
 deallocate(ltmp)

 !start and end data
 nsize=int(real(this%nphen)/num_images())
 this%startphen=nsize*(this_image()-1)+1
 this%endphen=this%startphen+nsize-1
 if(this_image().eq.num_images())this%endphen=this%nphen
 write(this%unlog,'(i0,t20,a)')this%startphen,'start pheno'
 write(this%unlog,'(i0,t20,a)')this%endphen,'end pheno'
 this%nsubphen=this%endphen-this%startphen+1

 !read data file

 allocate(this%pheno(this%ntrait,this%nsubphen),this%effect(this%neffect,this%nsubphen)&
           ,this%presentpheno(this%nsubphen))
 allocate(rtmp(this%ntrait),itmp(this%neffect))
 open(newunit=un,file=this%datafile,status='old',action='read')
 k=0
 do i=1,this%nphen
  read(un,*,iostat=io)rtmp,i8tmp,itmp
  if(i.lt.this%startphen)cycle
  if(i.gt.this%endphen)exit
  k=k+1
  this%pheno(:,k)=rtmp
  this%presentpheno(k)=i8tmp
  this%effect(:,k)=itmp
 enddo
 close(un)
 this%effect=this%effect-1

 !read residual variance file
 allocate(this%resmati(this%ntrait,this%ntrait))
 open(newunit=un,file=this%resfile,status='old',action='read')
 do i=1,this%ntrait
  read(un,*)rtmp(1:i)
  this%resmati(i,1:i)=rtmp(1:i)
  this%resmati(1:i,i)=rtmp(1:i)
 enddo
 close(un)

 !Max combi
 maxcombi=maxval(this%presentpheno)
 allocate(this%tres(maxcombi))
 do i8tmp=0,maxcombi
  if(any(this%presentpheno.eq.i8tmp))then
   allocate(this%tres(i8tmp)%mat(this%ntrait,this%ntrait))
   this%tres(i8tmp)%mat=this%resmati
   do i=1,this%ntrait
    if(ibits(i8tmp,i-1,1).eq.0)then
     this%tres(i8tmp)%mat(:,i)=0._real64
     this%tres(i8tmp)%mat(i,:)=0._real64
     this%tres(i8tmp)%mat(i,i)=1._real64
    endif
   enddo
   call invsym(this%tres(i8tmp)%mat,this%ntrait,this%ntrait)
   do i=1,this%ntrait
    if(ibits(i8tmp,i-1,1).eq.0)this%tres(i8tmp)%mat(i,i)=0._real64
   enddo
  endif
 enddo

! do i8tmp=0,maxcombi
!  if(allocated(this%tres(i8tmp)%mat))write(this%unlog,*)'ress ',this%tres(i8tmp)%mat
! enddo

 !invert resmati
! call invsym(this%resmati,this%ntrait,this%ntrait)
! write(this%unlog,*)'bbbb ',this%resmati

end subroutine

!**MULTIPLICATION BY V
#if (COARRAY==1)
subroutine multbyv_mvlr(this,x,y,starteq,endeq)
 !y=M*x=X'*Ri*X*x
 class(mvlr),intent(inout)::this
 integer(kind=int32),intent(in)::starteq,endeq
 real(kind=real64),intent(in)::x(:)
 real(kind=real64),intent(inout)::y(:)

 integer(kind=int32)::i,j,k,address
 real(kind=real64),allocatable::t1(:),t2(:),xmat(:,:),ri(:,:)
 real(kind=real64),allocatable,save::ylong(:)[:]
 !$ real(kind=real64)::time1,time2

 !$ time1=omp_get_wtime()
 if(.not.allocated(ylong))then
  !$ time2=omp_get_wtime()
  allocate(ylong(this%neq)[*])
  write(this%unlog,'(a)')' allocation of ylong'
  !$ write(this%unlog,'(a,f0.3)')'  Elapsed time(s) alloc: ',omp_get_wtime()-time2
 endif

 ylong=0._real64

 sync all

 y=0._real64

 allocate(t1(this%ntrait),t2(this%ntrait))
 allocate(xmat(this%ntrait,this%neffect),ri(this%ntrait,this%ntrait))

 !y=X'*Ri*X*x
 do i=1,this%nsubphen
  !get X
  call getX(this,xmat,i)
  !get Ri
  ri=this%tres(this%presentpheno(i))%mat
  !1) t1=X*x
  t1=0._real64
  do j=1,this%neffect
   address=this%effect(j,i)
   do k=1,this%ntrait
    t1(k)=t1(k)+xmat(k,j)*x(address+k)
   enddo
  enddo
  !2) t2=Ri*t1
  t2=0._real64
  do j=1,this%ntrait
   do k=1,this%ntrait
    t2(j)=t2(j)+ri(k,j)*t1(k)
   enddo
  enddo
  !3) y=X'*t2
  do j=1,this%neffect
   address=this%effect(j,i)
   do k=1,this%ntrait
    ylong(address+k)=ylong(address+k)+xmat(k,j)*t2(k)
   enddo
  enddo
 enddo

 deallocate(t1,t2,xmat,ri)

 sync all

 !update y
 do i=1,num_images()
  y=y+ylong(starteq:endeq)[i]
 enddo

 sync all

 !$ write(this%unlog,'(a,f0.3)')'  Elapsed time(s) multbyv: ',omp_get_wtime()-time1

end subroutine

#else
!**PRECONDITIONER
function computediag_vect_mvlr(this) result(array)
 class(mvlr),intent(inout)::this
 real(kind=real64),allocatable::array(:)

 integer(kind=int32)::i,j,k,l,m,address1,address2
 real(kind=real64)::val
 real(kind=real64),allocatable::xmat(:,:),ri(:,:)
 type(coosparse)::sparse

 allocate(xmat(this%ntrait,this%neffect),ri(this%ntrait,this%ntrait))

 if(allocated(array))deallocate(array)

 sparse=coosparse(this%neq,this%neq,int(this%neq,8),lupper=.true.)

 do i=1,this%nsubphen
  !get X
  call getX(this,xmat,i)
  !get Ri
  ri=this%tres(this%presentpheno(i))%mat

  do j=1,this%neffect
   address1=this%effect(j,i)
!   do k=1,this%neffect
    k=j
    address2=this%effect(k,i)
    do l=1,this%ntrait
!     do m=1,this%ntrait
      m=l
      val=xmat(l,j)*ri(m,l)*xmat(m,k)
      call sparse%add(address1+l,address2+m,val)
!     enddo
    enddo
!   enddo
  enddo
 enddo

 call sparse%printstats()

 array=sparse%diag()

end function

#endif

!PRIVATE
subroutine getX(this,xmat,iphen)
 type(mvlr),intent(inout)::this
 integer(kind=int32),intent(in)::iphen
 real(kind=real64),intent(inout)::xmat(:,:)

 integer(kind=int32)::i,j

 xmat=1._real64
 do j=1,this%neffect
  do i=1,this%ntrait
   if(.not.this%model(i,j))xmat(i,j)=0._real64
  enddo
 enddo

end subroutine

subroutine invsym(a,n,m)
 !Inverse of a real symmetric positive definite matrix of size n*n declared as m*m
 integer(kind=int32),intent(in)::n,m
 real(kind=real64),intent(inout)::a(:,:)

 integer(kind=int32)::info,i,j

 call dpotrf('L',n,a,m,info)
 if (info.ne.0) then
  print*,'ERROR dpotrf info: ',info
  stop
 endif
 call dpotri('L',n,a,m,info)
 if (info.eq.0) then
 !$omp parallel
 !$omp do schedule(auto)
  do i=1,n
   do j=i+1,n
    a(i,j)=a(j,i)
   enddo
  enddo
 !$omp enddo
 !$omp end parallel
 else
  print*,'ERROR dportri info: ',info
  stop
 endif

end subroutine

end module


module type_WavetableUtility

    use spherepack_precision, only: &
        ip, & ! Integer precision
        wp, & ! Working precision
        even ! Determine integer parity

    use spherepack_interfaces, only: &
        get_wavetable_size, init_wavetable

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: WavetableUtility
    public :: get_lshaec, get_lshagc, get_lshaes, get_lshags
    public :: get_lshsec, get_lshsgc, get_lshses, get_lshsgs
    public :: get_lvhaec, get_lvhagc, get_lvhaes, get_lvhags
    public :: get_lvhsec, get_lvhsgc, get_lvhses, get_lvhsgs

    type, public :: WavetableUtility
    contains
        ! Type-bound procedures
        procedure, nopass :: initialize_wavetable
        procedure, nopass :: determine_scalar_order_m
        procedure, nopass :: determine_parity
        ! Scalar forward wavetable size routines
        procedure, nopass :: get_lshaec
        procedure, nopass :: get_lshagc
        procedure, nopass :: get_lshaes
        procedure, nopass :: get_lshags
        ! Scalar backward wavetable size routines
        procedure, nopass :: get_lshsec
        procedure, nopass :: get_lshsgc
        procedure, nopass :: get_lshses
        procedure, nopass :: get_lshsgs
        ! Vector forward wavetable size routines
        procedure, nopass :: get_lvhaec
        procedure, nopass :: get_lvhagc
        procedure, nopass :: get_lvhaes
        procedure, nopass :: get_lvhags
        ! Vector backward wavetable size routines
        procedure, nopass :: get_lvhsec
        procedure, nopass :: get_lvhsgc
        procedure, nopass :: get_lvhses
        procedure, nopass :: get_lvhsgs
        procedure, nopass :: check_vector_transform_inputs
        procedure, nopass :: check_scalar_transform_inputs
    end type WavetableUtility

contains

    subroutine initialize_wavetable(nlat, nlon, wavetable, size_func, &
        init_sub, error_flag)

        ! Dummy arguments
        integer(ip),           intent(in)  :: nlat
        integer(ip),           intent(in)  :: nlon
        real(wp), allocatable, intent(out) :: wavetable(:)
        procedure(get_wavetable_size)      :: size_func
        procedure(init_wavetable)          :: init_sub
        integer(ip),           intent(out) :: error_flag

        ! Local variables
        integer(ip) :: required_size

        ! Get required wavetable size
        required_size = size_func(nlat, nlon)

        ! Allocate memory
        allocate (wavetable(required_size), stat=error_flag)

        ! Check error flag
        if (error_flag /= 0) return

        ! Initialize wavetable
        call init_sub(nlat, nlon, wavetable, error_flag)

    end subroutine initialize_wavetable

    pure function determine_scalar_order_m(nlat, nlon) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: nlat
        integer(ip), intent(in) :: nlon
        integer(ip)             :: return_value

        if (even(nlon)) then
            return_value = min(nlat,(nlon + 2)/2)
        else
            return_value = min(nlat,(nlon + 1)/2)
        end if

    end function determine_scalar_order_m

    pure subroutine determine_parity(nlat, nlon, n1, n2)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(out) :: n1
        integer(ip), intent(out) :: n2

        ! Compute parity in nlon
        n1 = determine_scalar_order_m(nlat, nlon)

        ! Compute parity in nlat
        if (even(nlat)) then
            n2 = nlat/2
        else
            n2 = (nlat + 1)/2
        end if

    end subroutine determine_parity

    pure subroutine check_vector_transform_inputs(vector_symmetries, idvw, jdvw, &
        order_m, degree_n, nlat, nlon, number_of_syntheses, required_wavetable_size, &
        wavetable, error_flag)

        ! Dummy arguments
        integer(ip), intent(in)  :: vector_symmetries
        integer(ip), intent(in)  :: idvw
        integer(ip), intent(in)  :: jdvw
        integer(ip), intent(in)  :: order_m
        integer(ip), intent(in)  :: degree_n
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: number_of_syntheses
        integer(ip), intent(in)  :: required_wavetable_size
        real(wp),    intent(in)  :: wavetable(:)
        integer(ip), intent(out) :: error_flag

        ! Check calling arguments
        if (nlat < 3) then
            error_flag = 1
        else if (nlon < 1) then
            error_flag = 2
        else if (vector_symmetries < 0 .or. vector_symmetries > 8) then
            error_flag = 3
        else if (number_of_syntheses < 0) then
            error_flag = 4
        else if ((vector_symmetries <= 2 .and. idvw < nlat) &
            .or. &
            (vector_symmetries > 2 .and. idvw < (nlat + 1)/2)) then
            error_flag = 5
        else if (jdvw < nlon) then
            error_flag = 6
        else if (order_m < min(nlat, (nlon + 1)/2)) then
            error_flag = 7
        else if (degree_n < nlat) then
            error_flag = 8
        else if (size(wavetable) < required_wavetable_size) then
            error_flag = 9
        else
            error_flag = 0
        end if

    end subroutine check_vector_transform_inputs

    pure subroutine check_scalar_transform_inputs(scalar_symmetries, idg, jdg, &
        order_m, degree_n, nlat, nlon, number_of_syntheses, required_wavetable_size, &
        wavetable, error_flag)

        ! Dummy arguments
        integer(ip), intent(in)  :: scalar_symmetries
        integer(ip), intent(in)  :: idg
        integer(ip), intent(in)  :: jdg
        integer(ip), intent(in)  :: order_m
        integer(ip), intent(in)  :: degree_n
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: number_of_syntheses
        integer(ip), intent(in)  :: required_wavetable_size
        real(wp),    intent(in)  :: wavetable(:)
        integer(ip), intent(out) :: error_flag

        ! Local variables
        integer(ip) :: ntrunc, lat, late

        ! Set m limit for pmn
        ntrunc = min(nlat, (nlon + 2)/2)

        ! Set gaussian point nearest equator pointer
        late = (nlat + mod(nlat, 2))/2

        ! Set number of grid points for analysis/synthesis
        select case (scalar_symmetries)
            case (0)
                lat = nlat
            case default
                lat = late
        end select

        ! Check calling arguments
        if (nlat < 3) then
            error_flag = 1
        else if (nlon < 4) then
            error_flag = 2
        else if (scalar_symmetries < 0 .or. scalar_symmetries > 2) then
            error_flag = 3
        else if (number_of_syntheses < 1) then
            error_flag = 4
        else if (idg < lat) then
            error_flag = 5
        else if (jdg < nlon) then
            error_flag = 6
        else if (order_m < ntrunc) then
            error_flag = 7
        else if (degree_n < nlat) then
            error_flag = 8
        else if (size(wavetable) < required_wavetable_size) then
            error_flag = 9
        else
            error_flag = 0
        end if

    end subroutine check_scalar_transform_inputs

    pure function get_lshaec(nlat, nlon) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: nlat
        integer(ip), intent(in) :: nlon
        integer(ip)             :: return_value

        ! Local variables
        integer(ip) :: n1, n2

        call determine_parity(nlat, nlon, n1, n2)

        return_value = 2*nlat*n2+3*((n1-2)*(2*nlat-n1-1))/2+nlon+15

    end function get_lshaec

    pure function get_lshagc(nlat, nlon) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: nlat
        integer(ip), intent(in) :: nlon
        integer(ip)             :: return_value

        ! Local variables
        integer(ip) :: n1, n2

        call determine_parity(nlat, nlon, n1, n2)

        return_value = nlat*(2*n2+3*n1-2)+3*n1*(1-n1)/2+nlon+15

    end function get_lshagc

    pure function get_lshaes(nlat, nlon) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: nlat
        integer(ip), intent(in) :: nlon
        integer(ip)             :: return_value

        ! Local variables
        integer(ip) :: n1, n2

        call determine_parity(nlat, nlon, n1, n2)

        return_value = (n1 * n2 * (2*nlat-n1+1))/2 + (nlon + 15)

    end function get_lshaes

    pure function get_lshags(nlat, nlon) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: nlat
        integer(ip), intent(in) :: nlon
        integer(ip)             :: return_value

        ! Local variables
        integer(ip) :: n1, n2

        call determine_parity(nlat, nlon, n1, n2)

        return_value = nlat*(3*(n1+n2)-2)+(n1-1)*(n2*(2*nlat-n1)-3*n1)/2+nlon+15

    end function get_lshags

    pure function get_lshsec(nlat, nlon) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: nlat
        integer(ip), intent(in) :: nlon
        integer(ip)             :: return_value

        ! Local variables
        integer(ip) :: n1, n2

        call determine_parity(nlat, nlon, n1, n2)

        return_value = 2*nlat*n2+3*((n1-2)*(2*nlat-n1-1))/2+nlon+15

    end function get_lshsec

    pure function get_lshsgc(nlat, nlon) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: nlat
        integer(ip), intent(in) :: nlon
        integer(ip)             :: return_value

        ! Local variables
        integer(ip) :: n1, n2

        call determine_parity(nlat, nlon, n1, n2)

        return_value = nlat*(2*n2+3*n1-2)+3*n1*(1-n1)/2+nlon+15

    end function get_lshsgc

    pure function get_lshses(nlat, nlon) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: nlat
        integer(ip), intent(in) :: nlon
        integer(ip)             :: return_value

        ! Local variables
        integer(ip) :: n1, n2

        call determine_parity(nlat, nlon, n1, n2)

        return_value = (n1 * n2 * (2*nlat-n1+1))/2 + (nlon + 15)

    end function get_lshses

    pure function get_lshsgs(nlat, nlon) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: nlat
        integer(ip), intent(in) :: nlon
        integer(ip)             :: return_value

        ! Local variables
        integer(ip) :: n1, n2

        call determine_parity(nlat, nlon, n1, n2)

        return_value = nlat*(3*(n1+n2)-2)+(n1-1)*(n2*(2*nlat-n1)-3*n1)/2+nlon+15

    end function get_lshsgs

    pure function get_lvhaec(nlat, nlon) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: nlat
        integer(ip), intent(in) :: nlon
        integer(ip)             :: return_value

        ! Local variables
        integer(ip) :: n1, n2

        call determine_parity(nlat, nlon, n1, n2)

        return_value = 4*nlat*n2+3*max(n1-2, 0)*(2*nlat-n1-1)+nlon+15

    end function get_lvhaec

    pure function get_lvhagc(nlat, nlon) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: nlat
        integer(ip), intent(in) :: nlon
        integer(ip)             :: return_value

        ! Local variables
        integer(ip) :: n1, n2

        call determine_parity(nlat, nlon, n1, n2)

        return_value = 4*nlat*n2+3*max(n1-2, 0)*(2*nlat-n1-1)+nlon+n2+15

    end function get_lvhagc

    pure function get_lvhaes(nlat, nlon) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: nlat
        integer(ip), intent(in) :: nlon
        integer(ip)             :: return_value

        ! Local variables
        integer(ip) :: n1, n2

        call determine_parity(nlat, nlon, n1, n2)

        return_value = n1*n2*(2*nlat-n1+1)+nlon+15

    end function get_lvhaes

    pure function get_lvhags(nlat, nlon) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: nlat
        integer(ip), intent(in) :: nlon
        integer(ip)             :: return_value

        return_value = (((nlat + 1)**2) * nlat)/2 + nlon + 15

    end function get_lvhags

    pure function get_lvhsec(nlat, nlon) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip)              :: return_value

        ! Local variables
        integer(ip) :: n1, n2

        call determine_parity(nlat, nlon, n1, n2)

        return_value = 4*nlat*n2+3*max(n1-2, 0)*(2*nlat-n1-1)+nlon+15

    end function get_lvhsec

    pure function get_lvhsgc(nlat, nlon) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip)              :: return_value

        ! Local variables
        integer(ip) :: n1, n2

        call determine_parity(nlat, nlon, n1, n2)

        return_value = 4 * nlat * n2 + 3 * max(n1-2,0)*(2*nlat-n1-1) + nlon + 15

    end function get_lvhsgc

    pure function get_lvhses(nlat, nlon) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: nlat
        integer(ip), intent(in) :: nlon
        integer(ip)             :: return_value

        ! Local variables
        integer(ip) :: n1, n2

        call determine_parity(nlat, nlon, n1, n2)

        return_value = n1 * n2 * ((2*nlat) - n1 + 1) + nlon + 15

    end function get_lvhses

    pure function get_lvhsgs(nlat, nlon) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip)              :: return_value

        ! Local variables
        integer(ip)  :: imid, lmn

        imid = (nlat + 1)/2
        lmn = (nlat*(nlat + 1))/2
        return_value = 2*(imid*lmn)+nlon+15

    end function get_lvhsgs

end module type_WavetableUtility


      SUBROUTINE MRQMIN(X,Y,SIG,NDATA,A,MA,LISTA,MFIT,
     *    COVAR,ALPHA,NCA,CHISQ,FUNCS,ALAMDA)
      PARAMETER (MMAX=20)
      DIMENSION X(NDATA),Y(NDATA),SIG(NDATA),A(MA),LISTA(MA),
     *  COVAR(NCA,NCA),ALPHA(NCA,NCA),ATRY(MMAX),BETA(MMAX),DA(MMAX)
      IF(ALAMDA.LT.0.)THEN
        KK=MFIT+1
        DO 12 J=1,MA
          IHIT=0
          DO 11 K=1,MFIT
            IF(LISTA(K).EQ.J)IHIT=IHIT+1
11        CONTINUE
          IF (IHIT.EQ.0) THEN
            LISTA(KK)=J
            KK=KK+1
          ELSE IF (IHIT.GT.1) THEN
            PAUSE 'Improper permutation in LISTA'
          ENDIF
12      CONTINUE
        IF (KK.NE.(MA+1)) PAUSE 'Improper permutation in LISTA'
        ALAMDA=0.001
        CALL MRQCOF(X,Y,SIG,NDATA,A,MA,LISTA,MFIT,ALPHA,BETA,NCA,CHISQ,F
     *UNCS)
        OCHISQ=CHISQ
        DO 13 J=1,MA
          ATRY(J)=A(J)
13      CONTINUE
      ENDIF
      DO 15 J=1,MFIT
        DO 14 K=1,MFIT
          COVAR(J,K)=ALPHA(J,K)
14      CONTINUE
        COVAR(J,J)=ALPHA(J,J)*(1.+ALAMDA)
        DA(J)=BETA(J)
15    CONTINUE
      CALL GAUSSJ(COVAR,MFIT,NCA,DA,1,1)
      IF(ALAMDA.EQ.0.)THEN
        CALL COVSRT(COVAR,NCA,MA,LISTA,MFIT)
        RETURN
      ENDIF
      DO 16 J=1,MFIT
        ATRY(LISTA(J))=A(LISTA(J))+DA(J)
16    CONTINUE
      CALL MRQCOF(X,Y,SIG,NDATA,ATRY,MA,LISTA,MFIT,COVAR,DA,NCA,CHISQ,FU
     *NCS)
      IF(CHISQ.LT.OCHISQ)THEN
        ALAMDA=0.1*ALAMDA
        OCHISQ=CHISQ
        DO 18 J=1,MFIT
          DO 17 K=1,MFIT
            ALPHA(J,K)=COVAR(J,K)
17        CONTINUE
          BETA(J)=DA(J)
          A(LISTA(J))=ATRY(LISTA(J))
18      CONTINUE
      ELSE
        ALAMDA=10.*ALAMDA
        CHISQ=OCHISQ
      ENDIF
      RETURN
      END