      MODULE MOD_COLLI

      USE MOD_ERROR

      CONTAINS

      SUBROUTINE COLLI(N, ENLTE, TL, ENE, NCHARG, ELEVEL, EINST, CRATE,
     $                 EION, COCO, KEYCOL, WEIGHT, ALTESUM, NATOM, NOM, KODAT,
     $                 POPHIIL, POPHML, POPHIL, LEVEL, JOBNUM, DP)

!     COLLISIONAL TRANSITION RATES STORED IN MATRIX CRATE
!     BOUND-BOUND: DEPENDING ON THE ELEMENT (HE, H)
!     BOUND-FREE: NOT DEPENDING ON THE ELEMENT (HE, H)
!     CALLED BY NONLTEPOP, COMA

CMH   ENLTE: LTE POPULATION NUMBER FOR EACH LEVEL

      USE HYD_COL_RATE
      USE PHYS
      USE MATH
      USE COMMON_BLOCK

      implicit real*8(a-h,o-z)
      integer,intent(in) :: N, NCHARG, NATOM, NOM, KODAT
      real*8,intent(in)  :: ENLTE,TL,ENE,ELEVEL,EINST,EION,COCO,WEIGHT
      real*8,intent(in)  :: ALTESUM

      REAL*8, INTENT(IN) :: POPHIIL, POPHML, POPHIL

      REAL*8, INTENT(OUT) :: CRATE(N, N)

      DIMENSION EINST(N,N)
      DIMENSION ENLTE(N),NCHARG(N),ELEVEL(N),WEIGHT(N)
      DIMENSION EION(N),ALTESUM(4,N)
      DIMENSION COCO(N,N,4)
      DIMENSION NOM(N)
      DIMENSION KODAT(10)
      CHARACTER*4 KEYCOL(N,N)
C***  C1 = H * C / K
      DATA C1 /1.4388D0/ ! (CGS, cm / K)

      REAL*8, DIMENSION(10) :: Temp

      DATA Temp /3D3, 5D3, 7D3, 1D4, 2D4, 3D4, 6.5D4, 1D5, 1.5D5, 2D5/

      INTEGER, INTENT(IN) :: JOBNUM

      INTEGER, INTENT(IN) :: DP

      REAL*8 :: CRJohnUite, CRJohnNorm, CRJeff, RatioJJ, RatioUJ, NewRate

      REAL*8, DIMENSION(6) :: CRUite

      REAL*8 :: ElecProtHydTerm

      LOGICAL :: TRAN_COND, DEPTH_COND

      CHARACTER*10, DIMENSION(N), INTENT(IN) :: LEVEL

      IF (ALLOCATED(ACR)) ACR(DP, 1 : N, 1 : N) = 0.0D0

CMH	collisional electron detachmant of Hminus
CMH	CE: cross section for collisions of Hminus with electrons
CMH	CP: cross section for collisions of Hminus with protons

      THETA = 5040./TL
      THETART = SQRT(THETA)
      THETA32 = THETA*THETART
      THETA13 = THETA**(1./3.)

!      CE = 10*(10.**(-8.7))/THETA32
!      CP = 10*10.**(-7.4)*THETA13

      CE = (10.**(-8.7))/THETA32
      CP = 10.**(-7.4)*THETA13
      CH = 10.**(-10.9+0.5*THETA)/THETA32

      if (natom.gt.30) stop "colli - natom"
      TROOT=SQRT(TL)
      T32=TL*TROOT

      IF (JOBNUM .EQ. 0) THEN

      OPEN(UNIT = 357, FILE = 'Uitenbroek_H_CE.dat', ACTION = 'READ')
      OPEN(UNIT = 358, FILE = 'Uitenbroek_H_CI.dat', ACTION = 'READ')

      OPEN(UNIT = 457, FILE = 'col_rates.out', ACTION = 'WRITE', STATUS = 'REPLACE')

      DO m = 1, 10; WRITE(457, '(13x,F7.0,$)') Temp(m); ENDDO

      WRITE(457, '(/)')

      DO nl = 0, 8

         DO nu = nl + 1, 9

          WRITE(457,'(I2,2x,I2,$)') nu, nl

          x = 1.0D0 - (ISQ(nl + 1) / ISQ(nu + 1))

          DO m = 1, 10

             CRJohnNorm = HYDCOLRATE(nl + 1, nu + 1, Temp(m))
             CRJohnUite = CRJohnNorm * DEXP(x * DABS(HYD_LEV_ENERGY(nl + 1)) / boltz / Temp(m)) / DSQRT(Temp(m))

             WAVENUM = ELEVEL(nu + 2) - ELEVEL(nl + 2)
             WN2 = WAVENUM * WAVENUM

             T32 = Temp(m) * DSQRT(Temp(m))

             CRJeff = 3.24D0 * EINST(nu + 2, nl + 2) / WN2 / T32 / (C1 * WAVENUM / Temp(m))**1.68D0

             CRJeff = CRJeff * ENLTE(nu + 2) / ENLTE(nl + 2)

             IF (m .LE. 6) THEN

                IF (m .EQ. 1) READ(357, '(6(ES9.3,2x))') CRUite(1), CRUite(2), CRUite(3), CRUite(4), CRUite(5), CRUite(6)

                CRUite(m) = CRUite(m) * 1D6

                RatioUJ = CRUite(m) / CRJohnUite

             ENDIF

             RatioJJ = CRJeff / CRJohnNorm

             IF (m .LE. 6)                 WRITE(457, '(4x,ES7.1,2x,ES7.1,$)') RatioUJ,  RatioJJ
             IF (m .GT. 6 .AND. m. NE. 10) WRITE(457, '(4x,A7,2x,ES7.1,$)')   '   -   ', RatioJJ
             IF (m .EQ. 10)                WRITE(457, '(4x,A7,2x,ES7.1)')     '   -   ', RatioJJ

          ENDDO

         ENDDO

      ENDDO

      WRITE(457, '(/)')

      nu = 10

      DO nl = 0, 9

          WRITE(457,'(I2,2x,I2,$)') nl, nu

          DO m = 1, 10

             CRJohnNorm = HYDCOLRATE(nl + 1, nu + 1, Temp(m))
             CRJohnUite = CRJohnNorm * DEXP(DABS(HYD_LEV_ENERGY(nl + 1)) / boltz / Temp(m)) / DSQRT(Temp(m))

             TROOT = DSQRT(Temp(m))

             G = .1
             EDGE = EION(nl + 2) - ELEVEL(nl + 2)
             EXPFAC = EXP(-C1 * EDGE / Temp(m))
             CRJeff = G * 1.08E-5 * TROOT * EINST(nl + 2, nu + 2) * EXPFAC / EDGE

             IF (ALTESUM(1, nl + 2) .GT. 0.0D0) THEN
                X = 1000.0D0 / Temp(m)
                FOFT = (ALTESUM(3, nl + 2) * X + ALTESUM(2, nl + 2)) * X
                FOFT = 10.0D0**FOFT
                AOFT = ALTESUM(1, nl + 2) * FOFT
                OMSUM = 4.06D0 / TROOT * EXPFAC / EDGE / EDGE / EDGE * AOFT
                CRJeff = CRJeff + OMSUM
             ENDIF

             IF (m .LE. 6) THEN

                IF (m. EQ. 1) READ(358, '(6(ES9.3,2x))') CRUite(1), CRUite(2), CRUite(3), CRUite(4), CRUite(5), CRUite(6)

                CRUite(m) = CRUite(m) * 1D6

                RatioUJ = CRUite(m) / CRJohnUite

             ENDIF

             RatioJJ = CRJeff / CRJohnNorm

             IF (m .LE. 6)                 WRITE(457, '(4x,ES7.1,2x,ES7.1,$)') RatioUJ,  RatioJJ
             IF (m .GT. 6 .AND. m .NE. 10) WRITE(457, '(4x,A7,2x,ES7.1,$)')   '   -   ', RatioJJ
             IF (m .EQ. 10)                WRITE(457, '(4x,A7,2x,ES7.1)')     '   -   ', RatioJJ

          ENDDO

      ENDDO

      CLOSE(357)
      CLOSE(358)
      CLOSE(457)

      ENDIF

      CRATE(1 : N, 1 : N) = 0D0

C***  LOOP OVER ALL TRANSITIONS  ---------------------------------------
      DO 1 NUP = 2, N

	DO 1 LOW = 1, NUP - 1

      IF (NOM(LOW) .NE. NOM(NUP)) GOTO 14
      IF (NCHARG(LOW).NE.NCHARG(NUP)) GOTO 8

C***  LINE TRANSITION   *******************************************************
      WAVENUM=ELEVEL(NUP)-ELEVEL(LOW)
      WN2=WAVENUM*WAVENUM
      WN3=WN2*WAVENUM
C***  ******************************************************************
C***  HELIUM  ==========================================================
      IF (NOM(LOW) .EQ. KODAT(1)) THEN
C***  HE I  *******************************************************************
C***  OMEGA(UP-LOW) IS CALCULATED DEPENDING ON KEYWORD KEYCOL  *********
       IF (NCHARG(LOW).EQ.0) THEN
C***  'JEFF': OPTICALLY PERMITTED  TRANSITIONS. JEFFERIES P. 118 (EQ. 6.24)
         IF (KEYCOL(NUP,LOW) .EQ. 'JEFF') THEN
C                                  ====
              OMEGA=3.24*EINST(NUP,LOW)/WN2/T32/(C1*WAVENUM/TL)**1.68

C***  'BFK ': OPTICALLY FORBIDDEN TRANSITIONS BETWEEN N=2, N=1 OR WITHIN N=2:
C***          BERRINGTON, FON + KINGSTON ('BFK') 1982, MNRAS 200, 347
         ELSE IF (KEYCOL(NUP,LOW) .EQ. 'BFK1') THEN
C                                       ====
              PBFK=COCO(NUP,LOW,1)/TROOT
     +                          +COCO(NUP,LOW,2)+COCO(NUP,LOW,3)*TROOT
     +                          +COCO(NUP,LOW,4)*T32
              OMEGA=PBFK*WEIGHT(LOW)/WEIGHT(NUP)

         ELSE IF (KEYCOL(NUP,LOW) .EQ. 'BFK2') THEN
C                                       ====
              PBFK=COCO(NUP,LOW,1)/TL
     +                          +COCO(NUP,LOW,2)/TROOT+COCO(NUP,LOW,3)
     +                          +COCO(NUP,LOW,4)*TL
              OMEGA=PBFK*WEIGHT(LOW)/WEIGHT(NUP)

C***  'BKMS' OR 'BKGR':
C***            FORBIDDEN TRANSITIONS BETWEEN N.GT.2, N=1 OR N.GT.3, N.NE.1:
C***        BENSON + KULANDER ('BK..') 1972, SOLAR PHYSICS 27, 305 (FORMULA 3)
C***        '..MS': MIHALAS + STONE (REF. 11)
C***        '..GR': GREEN (REF. 7)
C***        ATTENTION: COCO(.,.,3) := 1.-ALPHA !!!!!!!!!!!!!!!!!
          ELSE IF (KEYCOL(NUP,LOW) .EQ. 'BKMS'
C                                        ====
     $        .OR. KEYCOL(NUP,LOW) .EQ. 'BKGR') THEN
C                                        ====
              OMEGA=COCO(NUP,LOW,1)*TL**COCO(NUP,LOW,2)*
     *               EXP(COCO(NUP,LOW,3)*C1*WAVENUM/TL)*WEIGHT(LOW)/
     /               WEIGHT(NUP)

C***  'UPS.': OPTICALLY FORBIDDEN TRANSITIONS BETWEEN N.GT.2, N.NE.1:
C***        EFFECTIVE COLLISIONAL STRENGTH (UPSILON) FROM WERNER SCHMUTZ
          ELSE IF (KEYCOL(NUP,LOW) .EQ. 'UPS0') THEN
C                                        ====
            OMEGA=.0

          ELSE IF (KEYCOL(NUP,LOW) .EQ. 'UPS1') THEN
C                                        ====
              UPSILON=0.05
              OMEGA=8.6287E-6*UPSILON/WEIGHT(NUP)/TROOT

          ELSE IF (KEYCOL(NUP,LOW) .EQ. 'UPS2') THEN
C                                        ====
              UPSILON=1.
              OMEGA=8.6287E-6*UPSILON/WEIGHT(NUP)/TROOT

C***  'NONE': TRANSITIONS (FROM N.GT.4) WITH UNKNOWN COLLISIONAL COEFFICIENTS
C***          (COLLISIONAL CROSS SECTION SIGMA(LOW,UP) IS SET TO  PI*A0**2)
          ELSE IF (KEYCOL(NUP,LOW) .EQ. 'NONE') THEN
C                                        ====
              OMEGA=5.465E-11*TROOT*(1.+C1*WAVENUM/TL)*WEIGHT(LOW)/
     /               WEIGHT(NUP)

C***  'ZERO': NO COLLISIONAL TRANSITION
          ELSE IF (KEYCOL(NUP,LOW) .EQ. 'ZERO') THEN
C                                        ====
              OMEGA=0.

          ELSE
C***  NO/UNKNOWN KEYWORD 'KEYCOL' DECODED

              write (6,*) ' HE I: WRONG KEYWORD KEYCOL '
			STOP 'ERROR'
          ENDIF
C***  HE II  ******************************************************************
       ELSE IF (NCHARG(LOW).EQ.1) THEN
C***  OMEGA (UP-LOW) ACCORDING TO JEFFERIES P. 119 (EQ. 6.25)
          OMEGA=4.06*EINST(NUP,LOW)/WN3/TROOT
C***  HE III  *****************************************************************
       ELSE
          write (6,*) '  HE III - LINE TRANSITION  '
          STOP 'ERROR'
       ENDIF
C***  ******************************************************************
C***  HYDROGEN  ========================================================
      ELSE IF (NOM(LOW) .EQ. KODAT(2)) THEN
C***  H I  *************************************************************
       IF (NCHARG(LOW) .EQ. 0) THEN

C***  OMEGA (UP-LOW) ACCORDING TO JEFFERIES P. 118 (EQ. 6.24)
          OMEGA=3.24*EINST(NUP,LOW)/WN2/T32/(C1*WAVENUM/TL)**1.68

!     OMEGA (UP-LOW) according to L. C. Johnson, "Approximations For Collisional
!     And Radiative Transition Rates In Atomic Hydrogen", 1972, ApJ, 174 : 227 - 236
          OMEGA = HYDCOLRATE(LOW - 1, NUP - 1, TL) * ENLTE(LOW) / ENLTE(NUP)

C***	H-MINUS  ************************************************************
       ELSE IF (NCHARG(LOW) .EQ. -1) THEN
        print *,'colli: negative hydrogen found'
        stop
C***  H II  ************************************************************
       ELSE
          write (6,*) 'H II - LINE TRANSITION'
          STOP 'ERROR'
       ENDIF
C***  ******************************************************************
C***  METALS: INDEX GE 3
      ELSE IF (NOM(LOW) .GE. 3) THEN
C***  ALL IONIZATION STAGES
C***  UPSILON TEMPERATURE INDEPENDENT
C***  OMEGA (UP-LOW) ACCORDING TO JEFFERIES P. 118 (EQ. 6.24)
C
         IF (KEYCOL(NUP,LOW) .EQ. 'CARB') THEN
C                                  ====
            UPSILON=COCO(NUP,LOW,1)
            IF (UPSILON.LE.0.) THEN
               write (6,*) 'SI - UPSILON .LE. 0'
               STOP 'ERROR'
            ENDIF
            OMEGA=8.6287E-6*UPSILON/WEIGHT(NUP)/TROOT
         ELSE
C***  OMEGA (UP-LOW) ACCORDING TO JEFFERIES P. 119 (EQ. 6.25)
            OMEGA=4.06*EINST(NUP,LOW)/WN3/TROOT
         ENDIF
C***  *****************************************************
	ELSE

          write(6, *) 'LINE TRANSITION OF UNKNOWN ELEMENT'
          PRINT*,     'LINE TRANSITION OF UNKNOWN ELEMENT'
          PRINT*,     'THE CODE WANTS HELIUM TO BE THE SECOND ELEMENT IN THE DATOM FILE'

          STOP 'ERROR'

      ENDIF

C***  *************************************************************************
C***  COLLISION RATE COEFFICIENTS CRATE
CMH   FOR LINE TRANSITIONS

      CRATE(NUP, LOW) = ENE * OMEGA

!=============================================================================
!     2 - > 3 (LyAlpha) COLLISIONS TEST:

!      TRAN_COND = LOW .EQ. 2 .AND. NUP .EQ. 3

!      DEPTH_COND = (DP .GE. 60) .OR. (DP .GE. 42 .AND. DP .LE. 52)

!      IF (TRAN_COND .AND. DEPTH_COND) CRATE(NUP, LOW) = CRATE(NUP, LOW) * 1D+10
!=============================================================================

      CRATE(LOW, NUP) = CRATE(NUP, LOW) * ENLTE(NUP) / ENLTE(LOW)

      GOTO 1

    8 CONTINUE
C***  COLLISIONAL IONIZATION   ************************************************
C***  CHARGE DIFFERENCE MUST BE 1
      IF (NCHARG(NUP) .NE. NCHARG(LOW)+1 ) GOTO 14
C***  UPPER LEVEL MUST BE A GROUND STATE
      IF (NCHARG(NUP) .NE. NCHARG(NUP-1)+1) GOTO 14
C***  OMEGA(LOW-UP) ACCORDING TO JEFFERIES P. 121 (EQ. 6.39)
C***  G = FACTOR DEPENDING ON THE CHARGE OF THE ION (=UPPER LEVEL)
      G=.3
      IF (NCHARG(NUP) .EQ. 2) G=.2
      IF (NCHARG(NUP) .EQ. 1) G=.1
      EDGE = EION(LOW)-ELEVEL(LOW)
      EXPFAC=EXP(-C1*EDGE/TL)
      OMEGA=G*1.08E-5*TROOT*EINST(LOW,NUP)*EXPFAC/EDGE
C***  ADD THE COLLISIONS  TO ADDITIONAL UPPER LEVELS WHICH ARE ASSUMED IN LTE.
C***  NOTE: THE SUMMATION HAS BEEN PERFORMED IN ADVANCE, AND IS IMPLICITELY
C*** CONTAINED IN THE PARAMETERS 'ALTESUM' ENTERING NOW FROM THE ATOMIC DATA
C***  FILE.
      IF (ALTESUM(1,LOW) .GT. .0) THEN

         X=1000./TL
         FOFT=(ALTESUM(3,LOW)*X+ALTESUM(2,LOW))*X
         FOFT=10.**FOFT
         AOFT=ALTESUM(1,LOW)*FOFT
         OMSUM=4.06/TROOT*EXPFAC/EDGE/EDGE/EDGE * AOFT
         OMEGA=OMEGA+OMSUM

      ENDIF

!     OMEGA (LOW-UP) according to L. C. Johnson, "Approximations For Collisional
!     And Radiative Transition Rates In Atomic Hydrogen", 1972, ApJ, 174 : 227 - 236
      IF (LEVEL(NUP) .EQ. 'H II......') OMEGA = HYDCOLRATE(LOW - 1, NUP - 1, TL)

CMH   print a warning if negative values
      IF (ENE .LT. 0.0 .OR. POPHIIL .LT. 0.0 .OR. ENE * OMEGA .LT. 0.0) PRINT*, 'colli: warning!: ', TL, ENE, POPHIIL, cp, ce, OMEGA

C***  BOUND-FREE COLLISIONAL RATE COEFFICIENTS: CRATE
      CRATE(LOW, NUP) = ENE * OMEGA

      CRATE(NUP, LOW) = CRATE(LOW, NUP) * ENLTE(LOW) / ENLTE(NUP)

CMH****************************************************************
CMH	Transition from negative hydrogen to neutral hydrogen
CMH     LOW = 1: negative hydrogen
CMH	UP  = 2:  neutral hydrogen
!RT     three processes are important for this transition
CMH	H- + e- = H + e- + e- (CE * ENE)
CMH	H- + p+ = H + H       (CP * POPHIIL)
!RT     H- + H  = H + H + e   (CH * POPHIL)
CMH     POPHIIL: population number of protons (HII)
!RT     POPHIL:  population number of neutral hydrogen (HI)
CMH****************************************************************

      Hminfac = 1.0D0

      IF (LEVEL(LOW) .EQ. 'H MINUS..1' .AND. LEVEL(NUP) .EQ. 'H I......1') THEN

         ElecProtHydTerm = Hminfac * (CE * ENE + CP * POPHIIL + CH * POPHIL)
!         ElecProtHydTerm = Hminfac * (CE * ENE + CP * POPHIIL)

         CRATE(LOW, NUP) = CRATE(LOW, NUP) + ElecProtHydTerm
         CRATE(NUP, LOW) = CRATE(NUP, LOW) + ElecProtHydTerm * ENLTE(LOW) / ENLTE(NUP)

CMH****************************************************************
CMH	Transition from protons (H II) to neutral hydrogen
CMH     LOW =  2: neutral hydrogen, ground level
CMH     UP  = 12: protons
CMH	POPHML: POPNUM of Hminus
CMH	Hminus collision rates with protons:
CMH	H- + p+ = H + H (CP * POPHML)

      ELSEIF (LEVEL(LOW) .EQ. 'H I......1' .AND. LEVEL(NUP) .EQ. 'H II......') THEN

!     The ionization of neutral hydrogen

         HminTerm = Hminfac * CP * POPHML

         CRATE(NUP, LOW) = CRATE(NUP, LOW) + HminTerm

CMH	transition up = 12 to low=2 is
CMH	1. the recombination of protons to neutral hydrogen and
CMH	2. the ionization of negative hydrogen due to proton collision

         CRATE(LOW, NUP) = CRATE(LOW, NUP) + HminTerm * ENLTE(NUP) / ENLTE(LOW)

      ENDIF

      GOTO 1

C***  LEVELS BELONG TO DIFFERENT ELEMENTS,
C***  CHARGE DIFFERENCE NOT 1  OR UPPER LEVEL NO GROUND STATE: ZERO RATE

   14 CRATE(NUP, LOW) = 0D0; CRATE(LOW, NUP) = 0D0

    1 CONTINUE
C***  ENDLOOP  ---------------------------------------------------------

C***  DIAGONAL ELEMENTS ARE SET TO ZERO
      FORALL (J = 1 : N) CRATE(J, J) = 0D0

      IF (ALLOCATED(ACR)) ACR(DP, 1 : N, 1 : N) = CRATE(1 : N, 1 : N)

      RETURN

      END SUBROUTINE

      END MODULE


      SUBROUTINE SB04RX( RC, UL, M, A, LDA, LAMBD1, LAMBD2, LAMBD3,
     $                   LAMBD4, D, TOL, IWORK, DWORK, LDDWOR, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve a system of equations in quasi-Hessenberg form
C     (Hessenberg form plus two consecutive offdiagonals) with two
C     right-hand sides.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     RC      CHARACTER*1
C             Indicates processing by columns or rows, as follows:
C             = 'R':  Row transformations are applied;
C             = 'C':  Column transformations are applied.
C
C     UL      CHARACTER*1
C             Indicates whether A is upper or lower Hessenberg matrix,
C             as follows:
C             = 'U':  A is upper Hessenberg;
C             = 'L':  A is lower Hessenberg.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The order of the matrix A.  M >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,M)
C             The leading M-by-M part of this array must contain a
C             matrix A in Hessenberg form.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,M).
C
C     LAMBD1, (input) DOUBLE PRECISION
C     LAMBD2, These variables must contain the 2-by-2 block to be
C     LAMBD3, multiplied to the elements of A.
C     LAMBD4
C
C     D       (input/output) DOUBLE PRECISION array, dimension (2*M)
C             On entry, this array must contain the two right-hand
C             side vectors of the quasi-Hessenberg system, stored
C             row-wise.
C             On exit, if INFO = 0, this array contains the two solution
C             vectors of the quasi-Hessenberg system, stored row-wise.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used to test for near singularity of
C             the triangular factor R of the quasi-Hessenberg matrix.
C             A matrix whose estimated condition number is less
C             than 1/TOL is considered to be nonsingular.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (2*M)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDDWOR,2*M+3)
C             The leading 2*M-by-2*M part of this array is used for
C             computing the triangular factor of the QR decomposition
C             of the quasi-Hessenberg matrix. The remaining 6*M elements
C             are used as workspace for the computation of the
C             reciprocal condition estimate.
C
C     LDDWOR  INTEGER
C             The leading dimension of array DWORK.
C             LDDWOR >= MAX(1,2*M).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             = 1:  if the quasi-Hessenberg matrix is (numerically)
C                   singular. That is, its estimated reciprocal
C                   condition number is less than or equal to TOL.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTORS
C
C     D. Sima, University of Bucharest, May 2000.
C
C     REVISIONS
C
C     -
C
C     Note that RC, UL, M, LDA, and LDDWOR must be such that the value
C     of the LOGICAL variable OK in the following statement is true.
C
C      OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR.
C             ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) )
C           .AND.
C           ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR.
C             ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) )
C           .AND.
C           ( M.GE.0 )
C           .AND.
C           ( LDA.GE.MAX( 1, M ) )
C           .AND.
C           ( LDDWOR.GE.MAX( 1, 2*M ) )
C
C     These conditions are not checked by the routine.
C
C     KEYWORDS
C
C     Hessenberg form, orthogonal transformation, real Schur form,
C     Sylvester equation.
C
C     ******************************************************************
C
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         RC, UL
      INTEGER           INFO, LDA, LDDWOR, M
      DOUBLE PRECISION  LAMBD1, LAMBD2, LAMBD3, LAMBD4, TOL
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), D(*), DWORK(LDDWOR,*)
C     .. Local Scalars ..
      CHARACTER         TRANS
      INTEGER           J, J1, J2, M2, MJ, ML
      DOUBLE PRECISION  C, R, RCOND, S
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DLARTG, DLASET, DROT, DSCAL, DTRCON,
     $                  DTRSV
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN, MOD
C     .. Executable Statements ..
C
      INFO = 0
C
C     For speed, no tests on the input scalar arguments are made.
C     Quick return if possible.
C
      IF ( M.EQ.0 )
     $   RETURN
C
      M2 = M*2
      IF ( LSAME( UL, 'U' ) ) THEN
C
         DO 20 J = 1, M
            J2 = J*2
            ML = MIN( M, J + 1 )
            CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1),
     $                   LDDWOR )
            CALL DCOPY( ML, A(1,J), 1, DWORK(1,J2-1), 2 )
            CALL DSCAL( ML, LAMBD1, DWORK(1,J2-1), 2 )
            CALL DCOPY( ML, A(1,J), 1, DWORK(2,J2-1), 2 )
            CALL DSCAL( ML, LAMBD3, DWORK(2,J2-1), 2 )
            CALL DCOPY( ML, A(1,J), 1, DWORK(1,J2), 2 )
            CALL DSCAL( ML, LAMBD2, DWORK(1,J2), 2 )
            CALL DCOPY( ML, A(1,J), 1, DWORK(2,J2), 2 )
            CALL DSCAL( ML, LAMBD4, DWORK(2,J2), 2 )
C
            DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + ONE
            DWORK(J2,J2) = DWORK(J2,J2) + ONE
   20    CONTINUE
C
         IF ( LSAME( RC, 'R' ) ) THEN
            TRANS = 'N'
C
C           A is an upper Hessenberg matrix, row transformations.
C
            DO 40 J = 1, M2 - 1
               MJ = M2 - J
               IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN
                  IF ( DWORK(J+3,J).NE.ZERO ) THEN
                     CALL DLARTG( DWORK(J+2,J), DWORK(J+3,J), C, S, R )
                     DWORK(J+2,J) = R
                     DWORK(J+3,J) = ZERO
                     CALL DROT( MJ, DWORK(J+2,J+1), LDDWOR,
     $                          DWORK(J+3,J+1), LDDWOR, C, S )
                     CALL DROT( 1, D(J+2), 1, D(J+3), 1, C, S )
                  END IF
               END IF
               IF ( J.LT.M2-1 ) THEN
                  IF ( DWORK(J+2,J).NE.ZERO ) THEN
                     CALL DLARTG( DWORK(J+1,J), DWORK(J+2,J), C, S, R )
                     DWORK(J+1,J) = R
                     DWORK(J+2,J) = ZERO
                     CALL DROT( MJ, DWORK(J+1,J+1), LDDWOR,
     $                          DWORK(J+2,J+1), LDDWOR, C, S )
                     CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S )
                  END IF
               END IF
               IF ( DWORK(J+1,J).NE.ZERO ) THEN
                  CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R )
                  DWORK(J,J)   = R
                  DWORK(J+1,J) = ZERO
                  CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1),
     $                       LDDWOR, C, S )
                  CALL DROT( 1, D(J), 1, D(J+1), 1, C, S )
               END IF
   40       CONTINUE
C
         ELSE
            TRANS = 'T'
C
C           A is an upper Hessenberg matrix, column transformations.
C
            DO 60 J = 1, M2 - 1
               MJ = M2 - J
               IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN
                  IF ( DWORK(MJ+1,MJ-2).NE.ZERO ) THEN
                     CALL DLARTG( DWORK(MJ+1,MJ-1), DWORK(MJ+1,MJ-2), C,
     $                            S, R )
                     DWORK(MJ+1,MJ-1) = R
                     DWORK(MJ+1,MJ-2) = ZERO
                     CALL DROT( MJ, DWORK(1,MJ-1), 1, DWORK(1,MJ-2), 1,
     $                          C, S )
                     CALL DROT( 1, D(MJ-1), 1, D(MJ-2), 1, C, S )
                  END IF
               END IF
               IF ( J.LT.M2-1 ) THEN
                  IF ( DWORK(MJ+1,MJ-1).NE.ZERO ) THEN
                     CALL DLARTG( DWORK(MJ+1,MJ), DWORK(MJ+1,MJ-1), C,
     $                            S, R )
                     DWORK(MJ+1,MJ)   = R
                     DWORK(MJ+1,MJ-1) = ZERO
                     CALL DROT( MJ, DWORK(1,MJ), 1, DWORK(1,MJ-1), 1, C,
     $                          S )
                     CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S )
                  END IF
               END IF
               IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN
                  CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S,
     $                         R )
                  DWORK(MJ+1,MJ+1) = R
                  DWORK(MJ+1,MJ)   = ZERO
                  CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C,
     $                       S )
                  CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S )
               END IF
   60       CONTINUE
C
         END IF
      ELSE
C
         DO 80 J = 1, M
            J2 = J*2
            J1 = MAX( J - 1, 1 )
            ML = MIN( M - J + 2, M )
            CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1),
     $                   LDDWOR )
            CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2-1,J2-1), 2 )
            CALL DSCAL( ML, LAMBD1, DWORK(J1*2-1,J2-1), 2 )
            CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2,J2-1), 2 )
            CALL DSCAL( ML, LAMBD3, DWORK(J1*2,J2-1), 2 )
            CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2-1,J2), 2 )
            CALL DSCAL( ML, LAMBD2, DWORK(J1*2-1,J2), 2 )
            CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2,J2), 2 )
            CALL DSCAL( ML, LAMBD4, DWORK(J1*2,J2), 2 )
C
            DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + ONE
            DWORK(J2,J2) = DWORK(J2,J2) + ONE
   80    CONTINUE
C
         IF ( LSAME( RC, 'R' ) ) THEN
            TRANS = 'N'
C
C           A is a lower Hessenberg matrix, row transformations.
C
            DO 100 J = 1, M2 - 1
               MJ = M2 - J
               IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN
                  IF ( DWORK(MJ-2,MJ+1).NE.ZERO ) THEN
                     CALL DLARTG( DWORK(MJ-1,MJ+1), DWORK(MJ-2,MJ+1), C,
     $                            S, R )
                     DWORK(MJ-1,MJ+1) = R
                     DWORK(MJ-2,MJ+1) = ZERO
                     CALL DROT( MJ, DWORK(MJ-1,1), LDDWOR,
     $                          DWORK(MJ-2,1), LDDWOR, C, S )
                     CALL DROT( 1, D(MJ-1), 1, D(MJ-2), 1, C, S )
                  END IF
               END IF
               IF ( J.LT.M2-1 ) THEN
                  IF ( DWORK(MJ-1,MJ+1).NE.ZERO ) THEN
                     CALL DLARTG( DWORK(MJ,MJ+1), DWORK(MJ-1,MJ+1), C,
     $                           S, R )
                     DWORK(MJ,MJ+1)   = R
                     DWORK(MJ-1,MJ+1) = ZERO
                     CALL DROT( MJ, DWORK(MJ,1), LDDWOR, DWORK(MJ-1,1),
     $                          LDDWOR, C, S )
                     CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S )
                  END IF
               END IF
               IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN
                  CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S,
     $                        R )
                  DWORK(MJ+1,MJ+1) = R
                  DWORK(MJ,MJ+1)   = ZERO
                  CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1),
     $                       LDDWOR, C, S)
                  CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S )
               END IF
  100       CONTINUE
C
         ELSE
            TRANS = 'T'
C
C           A is a lower Hessenberg matrix, column transformations.
C
            DO 120 J = 1, M2 - 1
               MJ = M2 - J
               IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN
                  IF ( DWORK(J,J+3).NE.ZERO ) THEN
                     CALL DLARTG( DWORK(J,J+2), DWORK(J,J+3), C, S, R )
                     DWORK(J,J+2) = R
                     DWORK(J,J+3) = ZERO
                     CALL DROT( MJ, DWORK(J+1,J+2), 1, DWORK(J+1,J+3),
     $                          1, C, S )
                     CALL DROT( 1, D(J+2), 1, D(J+3), 1, C, S )
                  END IF
               END IF
               IF ( J.LT.M2-1 ) THEN
                  IF ( DWORK(J,J+2).NE.ZERO ) THEN
                     CALL DLARTG( DWORK(J,J+1), DWORK(J,J+2), C, S, R )
                     DWORK(J,J+1) = R
                     DWORK(J,J+2) = ZERO
                     CALL DROT( MJ, DWORK(J+1,J+1), 1, DWORK(J+1,J+2),
     $                          1, C, S )
                     CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S )
                  END IF
               END IF
               IF ( DWORK(J,J+1).NE.ZERO ) THEN
                  CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R )
                  DWORK(J,J)   = R
                  DWORK(J,J+1) = ZERO
                  CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C,
     $                       S )
                  CALL DROT( 1, D(J), 1, D(J+1), 1, C, S )
               END IF
  120       CONTINUE
C
         END IF
      END IF
C
      CALL DTRCON( '1-norm', UL, 'Non-unit', M2, DWORK, LDDWOR, RCOND,
     $             DWORK(1,M2+1), IWORK, INFO )
      IF ( RCOND.LE.TOL ) THEN
         INFO = 1
      ELSE
         CALL DTRSV( UL, TRANS, 'Non-unit', M2, DWORK, LDDWOR, D, 1 )
      END IF
C
      RETURN
C *** Last line of SB04RX ***
      END


! Calculates mass and energy fluxes at the boundaries of the domain
subroutine boundaries
USE declarations
implicit none

   if (M .gt. 2) then  ! more than one horizontal layer
      if (beta .gt. 0.0001)then  ! sloping snowpack
         do j = 2,M-2

            !========================================================================================================
            !=============================== West Boundary(except lower and north cells) ===============================
            !========================================================================================================
            i=1
            !=================== Mass flux due to water pressure gradients ===============================
            Fprese(i,j) = K_east(i,j) * (P(i+1,j)-P(i,j)) * &
               & ( Sx_east(i,j) / dabs(xv(i+1,j)-xv(i,j)) + &
               & Sy_east(i,j) / dabs(yv(i+1,j)-yv(i,j)))
            Fpress(i,j) = K_south(i,j) * (P(i,j-1)-P(i,j)) * &
               & ( Sx_south(i,j) / dabs(xv(i,j-1)-xv(i,j)) + &
               & Sy_south(i,j) / dabs(yv(i,j-1)-yv(i,j)))
            Fpresn(i,j) = K_north(i,j) * (P(i,j+1)-P(i,j)) * &
               & ( Sx_north(i,j) / dabs(xv(i,j+1)-xv(i,j)) + &
               & Sy_north(i,j) / dabs(yv(i,j+1)-yv(i,j)))

            if (choice_lat_BC .eq. 2 .or. choice_lat_BC .eq. 1) then
                Fpresw(i,j) = 0.0_dp
                Fgravw(i,j) = 0.0_dp
            elseif (choice_lat_BC .eq. 0) then
                Fpresw(i,j) = K_west(i,j) * (P(N-1,j)-P(i,j)) * &
                   & ( Sx_west(i,j) / dabs((xn(N,j)-xv(N-1,j)) + &
                   & (xv(i,j ) - xn(i,j)) ) + &
                   & Sy_west(i,j) / dabs( yv(N-1,j)-yv(i,j)))
                Fgravw(i,j) = K_west(i,j) * Sy_west(i,j)
            endif

            !================ Mass flux due to gravity force ==============================
            Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
            Fgravn(i,j) = K_north(i,j) * Sy_north(i,j)
            Fgravs(i,j) = -K_south(i,j) * Sy_south(i,j)

            !====================== Heat flux ==================================
            Fconds(i,j) = k_eff_south(i,j) * (T(i,j-1,1)-T(i,j,1)) * &
               & (Sy_south(i,j) / dabs(yv(i,j)-yv(i,j-1)) + &
               & Sx_south(i,j) / dabs(xv(i,j)-xv(i,j-1)))
            Fcondn(i,j) = k_eff_north(i,j) * (T(i,j+1,1)-T(i,j,1)) * &
               & (Sy_north(i,j) / dabs(yv(i,j+1)-yv(i,j)) + &
               & Sx_north(i,j) / dabs(xv(i,j+1)-xv(i,j)))
            Fconde(i,j) = k_eff_east(i,j) * (T(i+1,j,1)-T(i,j,1)) * &
               & (Sy_east(i,j) / dabs(yv(i+1,j)-yv(i,j)) + &
               & Sx_east(i,j) / dabs(xv(i+1,j)-xv(i,j)))
            Fcondw(i,j) = 0.0_dp

            !========================================================================================================
            !====================================  East Boundary (except upper and lower cells) ======================
            !========================================================================================================
            i = N-1

            !=========== Mass flux due to water pressure gradients ================================
            Fpresw(i,j) = K_west(i,j) * (P(i-1,j)-P(i,j)) * &
               & (Sx_west(i,j) / (dabs(xv(i,j)-xv(i-1,j))) + &
               & Sy_west(i,j) / (dabs(yv(i,j)-yv(i-1,j))) )
            Fpress(i,j) = K_south(i,j) * (P(i,j-1)-P(i,j)) * &
               & (Sy_south(i,j) / (dabs(yv(i,j)-yv(i,j-1))) + &
               & Sx_south(i,j) / (dabs(xv(i,j)-xv(i,j-1))))
            Fpresn(i,j) = K_north(i,j) * (P(i,j+1)-P(i,j)) * &
               & (Sy_north(i,j) / (dabs(yv(i,j+1)-yv(i,j))) + &
               & Sx_north(i,j) / (dabs(xv(i,j+1)-xv(i,j))))

            if (choice_lat_BC .eq. 2) then
               Fprese(i,j) = 0.0_dp
               Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
            elseif (choice_lat_BC .eq. 1) then
               Fprese(i,j) = 0.0_dp
               Fgrave(i,j) = 0.0_dp
            elseif (choice_lat_BC .eq. 0) then
               Fprese(i,j) = K_east(i,j) * (P(1,j)-P(i,j)) * &
                  & ( Sx_east(i,j) / dabs((xn(N,j)-xv(i,j)) + &
                  & (xv(1,j) - xn(1,j)) ) + &
                  & Sy_east(i,j) / dabs( yv(i,j)-yv(1,j)) )
               Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
            endif

            !=========== Mass flux due to gravity force =================================
            Fgravw(i,j) = K_west(i,j) * Sy_west(i,j)
            Fgravn(i,j) = K_north(i,j) * Sy_north(i,j)
            Fgravs(i,j) = -K_south(i,j) * Sy_south(i,j)

            !====================== heat flux ==========================================
            Fconds(i,j) = k_eff_south(i,j) * (T(i,j-1,1)-T(i,j,1)) * &
               & (Sy_south(i,j) / (dabs(yv(i,j)-yv(i,j-1))) + &
               & Sx_south(i,j) / (dabs(xv(i,j)-xv(i,j-1))))
            Fcondn(i,j) = k_eff_north(i,j) * (T(i,j+1,1)-T(i,j,1)) * &
               & (Sy_north(i,j) / (dabs(yv(i,j)-yv(i,j+1))) + &
               & Sx_north(i,j) / (dabs(xv(i,j)-xv(i,j+1))))
            Fconde(i,j) = 0.0_dp
            Fcondw(i,j) = k_eff_west(i,j) * (T(i-1,j,1)-T(i,j,1)) * &
               & (Sy_west(i,j) / (dabs(yv(i,j)-yv(i-1,j))) + &
               & Sx_west(i,j) / (dabs(xv(i,j)-xv(i-1,j))))

         enddo
      else   ! flat snowpack (beta == 0)
         do j = 2,M-2

            !========================================================================================================
            !=============================== West Boundary(except lower and north cells) ===============================
            !========================================================================================================
            i=1
            !============ Mass flux due to WATER PRESSURE GRADIENTS =================
            Fprese(i,j) = Sx_east(i,j) * K_east(i,j) * &
               & (P(i+1,j)-P(i,j)) / (dabs(xv(i+1,j)-xv(i,j)))
            Fpress(i,j) = Sy_south(i,j) * K_south(i,j) * &
               & (P(i,j-1)-P(i,j)) / (dabs(yv(i,j)-yv(i,j-1)))
            Fpresn(i,j) = Sy_north(i,j) * K_north(i,j) * &
               & (P(i,j+1)-P(i,j)) / (dabs(yv(i,j+1)-yv(i,j)))

             if (choice_lat_BC .eq. 2 .or. choice_lat_BC .eq. 1) then
               Fpresw(i,j) = 0.0_dp
               Fgravw(i,j) = 0.0_dp
            elseif (choice_lat_BC .eq. 0) then
                Fpresw(i,j) = K_west(i,j) * (P(N-1,j)-P(i,j)) * &
                   & (Sx_west(i,j) / dabs((xn(N,j)-xv(N-1,j)) + &
                   & (xv(i,j ) - xn(i,j)) ))
                Fgravw(i,j) = K_west(i,j) * Sy_west(i,j)
            endif
            !=================== Mass flux due to gravity force =======================
            Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
            Fgravn(i,j) = K_north(i,j) * Sy_north(i,j)
            Fgravs(i,j) = -K_south(i,j) * Sy_south(i,j)

            !====================== Heat flux ======================================
            Fconds(i,j) = Sy_south(i,j) * k_eff_south(i,j) * &
               & (T(i,j-1,1)-T(i,j,1)) / (dabs(yv(i,j)-yv(i,j-1)))
            Fcondn(i,j) = Sy_north(i,j) * k_eff_north(i,j) * &
               & (T(i,j+1,1)-T(i,j,1)) / (dabs(yv(i,j)-yv(i,j+1)))
            Fconde(i,j) = Sx_east(i,j) * k_eff_east(i,j) * &
               & (T(i+1,j,1)-T(i,j,1)) / (dabs(xv(i,j)-xv(i+1,j)))
            Fcondw(i,j) = Sx_west(i,j) * k_eff_west(i,j) * &
                  & (T(N-1,j,1)-T(i,j,1)) / dabs(xv(i+1,j)-xv(i,j))

            !========================================================================================================
            !====================================  East Boundary (except upper and lower cells) ======================
            !========================================================================================================
            i = N-1
            !========= Mass flux due to WATER PRESSURE GRADIENTS --------------------------------
            Fpresw(i,j) = Sx_west(i,j) * K_west(i,j) * (P(i-1,j)-P(i,j)) &
               & / (dabs(xv(i,j)-xv(i-1,j)))
            Fpress(i,j) = Sy_south(i,j) * K_south(i,j)*(P(i,j-1)-P(i,j)) &
               & / (dabs(yv(i,j)-yv(i,j-1)))
            Fpresn(i,j) = Sy_north(i,j) * K_north(i,j) * (P(i,j+1)-P(i,j)) &
               & / (dabs(yv(i,j)-yv(i,j+1)))

            if (choice_lat_BC .eq. 2) then
               Fprese(i,j) = 0.0_dp
               Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
            elseif (choice_lat_BC .eq. 1) then
               Fprese(i,j) = 0.0_dp
               Fgrave(i,j) = 0.0_dp
            elseif (choice_lat_BC .eq. 0) then
               Fprese(i,j) = K_east(i,j) * (P(1,j)-P(i,j)) * &
                  & ( Sx_east(i,j) / dabs((xn(N,j)-xv(i,j)) + &
                  & (xv(1,j) - xn(1,j)) ))
               Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
            endif

            !=========== Mass flux due to gravity force =================================
            Fgravw(i,j) = K_west(i,j) * Sy_west(i,j)
            Fgravn(i,j) = K_north(i,j) * Sy_north(i,j)
            Fgravs(i,j) = -K_south(i,j) * Sy_south(i,j)

            !============= Heat flux ===========================================
            Fconds(i,j) = Sy_south(i,j) * k_eff_south(i,j) * (T(i,j-1,1)-T(i,j,1))&
               & / (dabs(yv(i,j)-yv(i,j-1)))
            Fcondn(i,j) = Sy_south(i,j) * k_eff_north(i,j) * (T(i,j+1,1)-T(i,j,1))&
               & / (dabs(yv(i,j)-yv(i,j+1)))
            Fconde(i,j) = Sx_east(i,j) * k_eff_east(i,j) * &
                  & (T(1,j,1)-T(i,j,1)) / dabs(xv(i,j)-xv(i-1,j))
            Fcondw(i,j) = Sx_west(i,j) * k_eff_west(i,j) * (T(i-1,j,1)-T(i,j,1))&
               & / (dabs(xv(i,j)-xv(i-1,j)))

         enddo

      endif
   endif

   !==================================== Lower left cell ========================================
   i=1
   if (M .gt. 2) then ! more than two horizontal snow layers
      j=1
      if (beta .gt. 0.0001)then   ! sloping snowpack

            !====================== Mass flux due to water pressure gradient ======================
            Fpress(i,j) = 0.0_dp
            Fprese(i,j) = K_east(i,j) * (P(i+1,j)-P(i,j)) * &
               & ( Sx_east(i,j) / dabs(xv(i+1,j)-xv(i,j)) + &
               & Sy_east(i,j) / dabs(yv(i+1,j)-yv(i,j)))
            Fpresn(i,j) = K_north(i,j) * (P(i,j+1)-P(i,j)) * &
               & ( Sx_north(i,j) / dabs(xv(i,j+1)-xv(i,j)) + &
               & Sy_north(i,j) / dabs(yv(i,j+1)-yv(i,j)))

            if (choice_lat_BC .eq. 2 .or. choice_lat_BC .eq. 1) then
               Fpresw(i,j) = 0.0_dp
               Fgravw(i,j) = 0.0_dp
            elseif (choice_lat_BC .eq. 0) then
                Fpresw(i,j) = K_west(i,j) * (P(N-1,j)-P(i,j)) * &
                   & ( Sx_west(i,j) / dabs((xn(N,j)-xv(N-1,j)) + &
                   & (xv(i,j) - xn(i,j)) ) + &
                   & Sy_west(i,j) / dabs( yv(N-1,j)-yv(i,j)))
                Fgravw(i,j) = K_west(i,j) * Sy_west(i,j)
            endif

            !=============== Mass flux due to gravity force ==================
            Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
            Fgravn(i,j) = K_north(i,j) * Sy_north(i,j)
            Fgravs(i,j) = -K_south(i,j) * Sy_south(i,j)

            !=================== Heat flux ===============================
            if (index_ground .eq. 0) then  ! use ground temperature
               Fconds(i,j) = k_eff_south(i,j)*(Tground-T(i,j,1)) * &
                  & (Sy_south(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp) + &
                  &  Sx_south(i,j) / dabs(xv(i,j)-(xn(i+1,j)+xn(i,j))*0.5_dp))
            else ! use ground heat flux
               Fconds(i,j) = Sy_south(i,j) * Qground
            endif
            Fcondn(i,j) = k_eff_north(i,j) * (T(i,j+1,1)-T(i,j,1)) * &
               & (Sy_north(i,j) / dabs(yv(i,j+1)-yv(i,j)) + &
               & Sx_north(i,j) / dabs(xv(i,j+1)-xv(i,j)))
            Fconde(i,j) = k_eff_east(i,j) * (T(i+1,j,1)-T(i,j,1)) * &
               & (Sy_east(i,j) / dabs(yv(i+1,j)-yv(i,j)) + &
               & Sx_east(i,j) / dabs(xv(i+1,j)-xv(i,j)))
            Fcondw(i,j) = 0.0_dp

      else   ! flat snowpack (beta == 0)

            !============ Mass flux due to water pressure gradients =================================
            Fprese(i,j) = Sx_east(i,j) * K_east(i,j) * (P(i+1,j)-P(i,j)) / (dabs(xv(i+1,j)-xv(i,j)))
            Fpress(i,j) = 0.0_dp
            Fpresn(i,j) = Sy_north(i,j) * K_north(i,j) * (P(i,j+1)-P(i,j)) / (dabs(yv(i,j+1)-yv(i,j)))

            if (choice_lat_BC .eq. 2 .or. choice_lat_BC .eq. 1) then
               Fpresw(i,j) = 0.0_dp
               Fgravw(i,j) = 0.0_dp
            elseif (choice_lat_BC .eq. 0) then
               Fpresw(i,j) = K_west(i,j) * (P(N-1,j)-P(i,j)) * &
                  & (Sx_west(i,j) / dabs((xn(N,j)-xv(N-1,j)) + &
                  & (xv(i,j) - xn(i,j)) ))
               Fgravw(i,j) = K_west(i,j) * Sy_west(i,j)
            endif

            !============ Mass flux due to gravity force ===================================
            Fgrave(i,j) = -K_east(i,j)*Sy_east(i,j)
            Fgravn(i,j) = K_north(i,j)*Sy_north(i,j)
            Fgravs(i,j) = -K_south(i,j)*Sy_south(i,j)

            !====================== Heat flux ==============================================
            if (index_ground .eq. 0) then ! temperature at soil-snow
               Fconds(i,j) = Sy_south(i,j) * k_eff_south(i,j) * (Tground-T(i,j,1)) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp)
            else
               Fconds(i,j) = Sy_south(i,j) * Qground
            endif
            Fcondn(i,j) = Sy_north(i,j) * k_eff_north(i,j) * (T(i,j+1,1)-T(i,j,1)) / (dabs(yv(i,j)-yv(i,j+1)))
            Fconde(i,j) = Sx_east(i,j) * k_eff_east(i,j) * (T(i+1,j,1)-T(i,j,1)) / (dabs(xv(i,j)-xv(i+1,j)))
            Fcondw(i,j) = Sx_west(i,j) * k_eff_west(i,j) * &
                  & (T(N-1,j,1)-T(i,j,1)) / dabs(xv(i+1,j)-xv(i,j))

      endif
   endif

   !====================== Upper left cells =====================
   i=1
   if (M .gt. 2) then ! more than one layer
      j=M-1
      if (beta .gt. 0.0001) then

            !=========== Mass flux due to water pressure gradients =======================
            Fprese(i,j) = K_east(i,j)*(P(i+1,j)-P(i,j)) * &
               & (Sx_east(i,j) / (dabs(xv(i+1,j)-xv(i,j))) + &
               & Sy_east(i,j) / (dabs(yv(i+1,j)-yv(i,j))))
            Fpress(i,j) = K_south(i,j) * (P(i,j-1)-P(i,j)) * &
               & (Sy_south(i,j) / (dabs(yv(i,j)-yv(i,j-1))) + &
               & Sx_south(i,j) / (dabs(xv(i,j)-xv(i,j-1))))
            Fpresn(i,j) = 0.0_dp

            if (choice_lat_BC .eq. 2 .or. choice_lat_BC .eq. 1) then
               Fpresw(i,j) = 0.0_dp
               Fgravw(i,j) = 0.0_dp
            elseif (choice_lat_BC .eq. 0) then
               Fpresw(i,j) = K_west(i,j) * (P(N-1,j)-P(i,j)) * &
                  & ( Sx_west(i,j) / dabs((xn(N,j)-xv(N-1,j)) + &
                  & (xv(i,j) - xn(i,j))) + &
                  & Sy_west(i,j) / dabs( yv(N-1,j)-yv(i,j)) )
               Fgravw(i,j) = K_west(i,j) * Sy_west(i,j)
            endif

            !============= Mass flux due to gravity force ======================
            Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
            Fgravn(i,j) = (Qin(i)+rain(i)) * Sy_north(i,j)
            Fgravs(i,j) = -K_south(i,j) * Sy_south(i,j)

            !======================== heat flux =========================================
            Fconds(i,j) = k_eff_south(i,j) * (T(i,j-1,1)-T(i,j,1)) * &
               & (Sy_south(i,j) / dabs(yv(i,j)-yv(i,j-1)) + &
               & Sx_south(i,j) / dabs(xv(i,j)-xv(i,j-1)))
            Fcondn(i,j) = k_eff_north(i,j) * (Tss(i)-T(i,j,1)) * &
               & (Sy_north(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp) + &
               & Sx_north(i,j) / dabs(xv(i,j)-(xn(i,j+1)+xn(i+1,j+1))*0.5_dp))
            Fconde(i,j) = k_eff_east(i,j) * (T(i+1,j,1)-T(i,j,1)) * &
               & (Sy_east(i,j) / dabs(yv(i+1,j)-yv(i,j)) + &
               & Sx_east(i,j) / dabs(xv(i+1,j)-xv(i,j)))
            Fcondw(i,j) = 0.0_dp

      else   ! flat snowpack (beta == 0)

            !================= Mass flux due to water pressure gradients ================================
            Fprese(i,j) = Sx_east(i,j)*K_east(i,j)*(P(i+1,j)-P(i,j))/(dabs(xv(i+1,j)-xv(i,j)))
            Fpress(i,j) = Sy_south(i,j)*K_south(i,j)*(P(i,j-1)-P(i,j))/(dabs(yv(i,j)-yv(i,j-1)))
            Fpresn(i,j) = 0.0_dp

            if (choice_lat_BC .eq. 2 .or. choice_lat_BC .eq. 1) then
               Fpresw(i,j) = 0.0_dp
               Fgravw(i,j) = 0.0_dp
            elseif (choice_lat_BC .eq. 0) then
               Fpresw(i,j) = K_west(i,j) * (P(N-1,j)-P(i,j)) * &
                  & (Sx_west(i,j) / dabs((xn(N,j)-xv(N-1,j)) + &
                  & (xv(i,j) - xn(i,j)) ))
               Fgravw(i,j) = K_west(i,j) * Sy_west(i,j)
            endif

            !=========== Mass flux due to gravity force ================================
            Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
            Fgravn(i,j) = (Qin(i)+rain(i)) * Sy_north(i,j)
            Fgravs(i,j) = -K_south(i,j) * Sy_south(i,j)

            !======================= heat flux ==========================================
            Fconds(i,j) = Sy_south(i,j) * k_eff_south(i,j) * (T(i,j-1,1)-T(i,j,1))/(dabs(yv(i,j)-yv(i,j-1)))
            Fcondn(i,j) = Sy_north(i,j) * k_eff_north(i,j) * (Tss(i)-T(i,j,1))/(dabs(yn(i,j+1)-yn(i,j))*0.5_dp)
            Fconde(i,j) = Sx_east(i,j) * k_eff_east(i,j) * (T(i+1,j,1)-T(i,j,1))/(dabs(xv(i,j)-xv(i+1,j)))
            Fcondw(i,j) = Sx_west(i,j) * k_eff_west(i,j) * &
                  & (T(N-1,j,1)-T(i,j,1)) / dabs(xv(i+1,j)-xv(i,j))

      endif
   endif

   if (M .gt. 2) then ! more than two horizontal layers
      if (beta .gt. 0.0001) then !sloping snowpack
         do i = 2,N-2

            !==================================================================================================
            !================================ North Boundary (except west and east cells) =============================
            !==================================================================================================
            j=M-1

            !=========== Mass flux due to water pressure gradients =================================
            Fpresw(i,j) = K_west(i,j) * (P(i-1,j)-P(i,j)) * &
               & (Sx_west(i,j) / dabs(xv(i,j)-xv(i-1,j)) + &
               & Sy_west(i,j) / dabs(yv(i,j)-yv(i-1,j)))
            Fprese(i,j) = K_east(i,j) * (P(i+1,j)-P(i,j)) * &
               & (Sx_east(i,j) / dabs(xv(i+1,j)-xv(i,j)) + &
               & Sy_east(i,j) / dabs(yv(i+1,j)-yv(i,j)))
            Fpress(i,j) = K_south(i,j) * (P(i,j-1)-P(i,j)) * &
               & (Sy_south(i,j) / dabs(yv(i,j)-yv(i,j-1)) + &
               & Sx_south(i,j) / dabs(xv(i,j)-xv(i,j-1)))
            Fpresn(i,j)=0.0_dp

            !=========== Mass flux due to gravity force ================================
            Fgravw(i,j) = K_west(i,j)*Sy_west(i,j)
            Fgrave(i,j) = -K_east(i,j)*Sy_east(i,j)
            Fgravn(i,j) = (Qin(i)+rain(i))*Sy_north(i,j)
            Fgravs(i,j) = -K_south(i,j)*Sy_south(i,j)

            !====================== heat flux ===========================================
            Fconds(i,j) = k_eff_south(i,j) * (T(i,j-1,1)-T(i,j,1)) * &
               & (Sy_south(i,j) / dabs(yv(i,j)-yv(i,j-1)) + &
               & Sx_south(i,j) / dabs(xv(i,j)-xv(i,j-1)))
            Fcondn(i,j) = k_eff_north(i,j) * (Tss(i)-T(i,j,1)) * &
               & (Sy_north(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp) + &
               & Sx_north(i,j) / dabs(xv(i,j)-(xn(i,j+1)+xn(i+1,j+1))*0.5_dp))
            Fconde(i,j) = k_eff_east(i,j) * (T(i+1,j,1)-T(i,j,1)) * &
               & (Sy_east(i,j) / dabs(yv(i,j)-yv(i+1,j)) + &
               & Sx_east(i,j) / dabs(xv(i,j)-xv(i+1,j)))
            Fcondw(i,j) = k_eff_west(i,j)*(T(i-1,j,1)-T(i,j,1)) * &
               & (Sy_west(i,j) / dabs(yv(i,j)-yv(i-1,j)) + &
               & Sx_west(i,j) / dabs(xv(i,j)-xv(i-1,j)))

            !================================================================================================
            !========================== South boundary (except left and right cells) ===============================
            !================================================================================================
            j=1
            !=========== Mass flux due to water pressure gradients ===============================
             Fpresw(i,j) = K_west(i,j) * (P(i-1,j)-P(i,j)) * &
               & (Sx_west(i,j) / (dabs(xv(i,j)-xv(i-1,j))) + &
               & Sy_west(i,j) / (dabs(yv(i,j)-yv(i-1,j))))
            Fprese(i,j) = K_east(i,j) * (P(i+1,j)-P(i,j)) * &
               & (Sx_east(i,j) / (dabs(xv(i+1,j)-xv(i,j))) + &
               & Sy_east(i,j) / (dabs(yv(i+1,j)-yv(i,j))))
            Fpress(i,j) = 0.0_dp
            Fpresn(i,j) = K_north(i,j) * (P(i,j+1)-P(i,j)) * &
               & (Sy_north(i,j) / (dabs(yv(i,j+1)-yv(i,j))) + &
               & Sx_north(i,j) / (dabs(xv(i,j+1)-xv(i,j))))

            !=========== Mass flux due to gravity force =================================
            Fgravw(i,j) = K_west(i,j) * Sy_west(i,j)
            Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
            Fgravn(i,j) = K_north(i,j) * Sy_north(i,j)
            Fgravs(i,j) = -K_south(i,j) * Sy_south(i,j)

            !====================== heat flux ======================================
            if (index_ground .eq. 0) then  ! use temperature at the interface snow-soil
               Fconds(i,j) = k_eff_south(i,j) * (Tground-T(i,j,1)) * &
                  & (Sy_south(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp) + &
                  & Sx_south(i,j) / (dabs(xv(i,j)-(xn(i+1,j)+xn(i,j))*0.5_dp)) )
            else
               Fconds(i,j) = Sy_south(i,j) * Qground
            endif

            Fcondn(i,j) = k_eff_north(i,j) * (T(i,j+1,1)-T(i,j,1)) * &
               & (Sy_north(i,j) / (dabs(yv(i,j)-yv(i,j+1))) + &
               & Sx_north(i,j) / (dabs(xv(i,j)-xv(i,j+1))))
            Fconde(i,j) = k_eff_east(i,j)*(T(i+1,j,1)-T(i,j,1)) * &
               & (Sy_east(i,j) / (dabs(yv(i,j)-yv(i+1,j))) + &
               & Sx_east(i,j) / (dabs(xv(i,j)-xv(i+1,j))) )
            Fcondw(i,j) = k_eff_west(i,j) * (T(i-1,j,1)-T(i,j,1)) * &
               & (Sy_west(i,j) / (dabs(yv(i,j)-yv(i-1,j))) + &
               & Sx_west(i,j) / (dabs(xv(i,j)-xv(i-1,j))))
         enddo

      else   ! flat snowpack (beta == 0)

         do i = 2,N-2

            !==================================================================================================
            !================================ North Boundary (except west and east cells) =============================
            !==================================================================================================
            j=M-1
            !=========== Mass flux due to water pressure gradients ================================
            Fpresw(i,j) = Sx_west(i,j) * K_west(i,j) * (P(i-1,j)-P(i,j)) / &
                 & dabs(xv(i,j)-xv(i-1,j))
            Fprese(i,j) = Sx_east(i,j) * K_east(i,j) * (P(i+1,j)-P(i,j)) / &
                 & dabs(xv(i+1,j)-xv(i,j))
            Fpress(i,j) = Sy_south(i,j) * K_south(i,j) * (P(i,j-1)-P(i,j)) / &
                 & dabs(yv(i,j)-yv(i,j-1))
            Fpresn(i,j) = 0.0_dp

            !=========== Mass flux due to gravity force ================================
            Fgravw(i,j) = K_west(i,j) * Sy_west(i,j)
            Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
            Fgravn(i,j) = (Qin(i)+rain(i)) * Sy_north(i,j)
            Fgravs(i,j) = -K_south(i,j) * Sy_south(i,j)

            !====================== heat flux ===========================================
            Fconds(i,j) = Sy_south(i,j) * k_eff_south(i,j) * (T(i,j-1,1)-T(i,j,1)) / &
               & dabs(yv(i,j)-yv(i,j-1))
            Fcondn(i,j) = Sy_north(i,j) * k_eff_north(i,j) * (Tss(i)-T(i,j,1)) / &
               & (dabs(yn(i,j+1)-yn(i,j))*0.5_dp)
            Fconde(i,j) = Sx_east(i,j) * k_eff_east(i,j) * (T(i+1,j,1)-T(i,j,1)) / &
               & dabs(xv(i,j)-xv(i+1,j))
            Fcondw(i,j) = Sx_west(i,j) * k_eff_west(i,j) * (T(i-1,j,1)-T(i,j,1)) / &
               & dabs(xv(i,j)-xv(i-1,j))

            !================================================================================================
            !========================== South boundary (except left and right cells) ===============================
            !================================================================================================
            j=1
            !=========== Mass flux due to water pressure gradients ================================
            Fpresw(i,j) = Sx_west(i,j) * K_west(i,j) * (P(i-1,j)-P(i,j)) / (dabs(xv(i,j)-xv(i-1,j)))
            Fprese(i,j) = Sx_east(i,j) * K_east(i,j) * (P(i+1,j)-P(i,j)) / (dabs(xv(i+1,j)-xv(i,j)))
            Fpress(i,j) = 0.0_dp
            Fpresn(i,j) = Sy_north(i,j) * K_north(i,j) * (P(i,j+1)-P(i,j)) / (dabs(yv(i,j+1)-yv(i,j)))

            !=========== Mass flux due to gravity force =================================
            Fgravw(i,j) = K_west(i,j) * Sy_west(i,j)
            Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
            Fgravn(i,j) = K_north(i,j) * Sy_north(i,j)
            Fgravs(i,j) = -K_south(i,j) * Sy_south(i,j)

            !===================== heat flux ============================
            if (index_ground .eq. 0) then ! use of temperature at the interface soil-snow
               Fconds(i,j) = Sy_south(i,j) * k_eff_south(i,j) * (Tground-T(i,j,1)) &
                  & / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp)
            else
               Fconds(i,j) = Sy_south(i,j) * Qground
            endif
            Fcondn(i,j) = Sy_south(i,j) * k_eff_north(i,j) * (T(i,j+1,1)-T(i,j,1)) &
               & / (dabs(yv(i,j)-yv(i,j+1)))
            Fconde(i,j) = Sx_east(i,j) * k_eff_east(i,j) * (T(i+1,j,1)-T(i,j,1)) &
               & / (dabs(xv(i,j)-xv(i+1,j)))
            Fcondw(i,j) = Sx_west(i,j) * k_eff_west(i,j) * (T(i-1,j,1)-T(i,j,1)) &
               & / (dabs(xv(i+1,j)-xv(i,j)))

         enddo
      endif
   endif

   !===================================== Lower right cell ===================================

   i=N-1
   if (M .gt. 2) then ! more than one horizontal snow layer
      j=1
      if (beta .gt. 0.0001) then ! sloping snowpack

            !=========== Mass flux due to water pressure gradients =========================
            Fpresw(i,j) = K_west(i,j)*(P(i-1,j)-P(i,j)) * &
               & (Sx_west(i,j) / (dabs(xv(i,j)-xv(i-1,j))) + &
               & Sy_west(i,j) / (dabs(yv(i,j)-yv(i-1,j))))
            Fpress(i,j) = 0.0_dp
            Fpresn(i,j) = K_north(i,j)*(P(i,j+1)-P(i,j)) * &
               & (Sy_north(i,j) / (dabs(yv(i,j+1)-yv(i,j))) + &
               & Sx_north(i,j) / (dabs(xv(i,j+1)-xv(i,j))))

            if (choice_lat_BC .eq. 2) then
               Fprese(i,j) = 0.0_dp
               Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
            elseif (choice_lat_BC .eq. 1) then
               Fprese(i,j) = 0.0_dp
               Fgrave(i,j) = 0.0_dp
            elseif (choice_lat_BC .eq. 0) then
               Fprese(i,j) = K_east(i,j) * (P(1,j)-P(i,j)) * &
                  & ( Sx_east(i,j) / dabs((xn(N,j)-xv(i,j)) + &
                  & (xv(1,j) - xn(1,j)) ) + &
                  & Sy_east(i,j) / dabs( yv(i,j)-yv(1,j)))
               Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
            endif

            !=========== Mass flux due to gravity force =================================
            Fgravw(i,j) = K_west(i,j) * Sy_west(i,j)
            Fgravn(i,j) = K_north(i,j) * Sy_north(i,j)
            Fgravs(i,j) = -K_south(i,j) * Sy_south(i,j)

            !====================== heat flux =======================================
            if (index_ground .eq. 0) then ! use temperature at the interface snow-soil
               Fconds(i,j) = k_eff_south(i,j) * (Tground-T(i,j,1)) * &
                  & (Sy_south(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp) + &
                  & Sx_south(i,j) / (dabs(xv(i,j)-(xn(i+1,j)+xn(i,j))*0.5_dp)))
            else
               Fconds(i,j) = Sy_south(i,j) * Qground
            endif

            Fcondn(i,j) = k_eff_north(i,j) * (T(i,j+1,1)-T(i,j,1)) * &
               & (Sy_north(i,j) / (dabs(yv(i,j)-yv(i,j+1))) + &
               & Sx_north(i,j) / (dabs(xv(i,j)-xv(i,j+1))))
            Fconde(i,j) = 0.0_dp
            Fcondw(i,j) = k_eff_west(i,j)*(T(i-1,j,1)-T(i,j,1)) * &
               & (Sy_west(i,j) / (dabs(yv(i,j)-yv(i-1,j))) + &
               & Sx_west(i,j) / (dabs(xv(i,j)-xv(i-1,j))))

      else   ! flat snowpack (beta == 0)

            !=========== Mass flux due to water pressure gradients ================================
            Fpresw(i,j) = Sx_west(i,j) * K_west(i,j) * (P(i-1,j)-P(i,j)) / (dabs(xv(i,j)-xv(i-1,j)))
            Fpress(i,j) = 0.0_dp
            Fpresn(i,j) = Sy_north(i,j) * K_north(i,j) * (P(i,j+1)-P(i,j)) / (dabs(yv(i,j+1)-yv(i,j)))

            if (choice_lat_BC .eq. 2) then
               Fprese(i,j) = 0.0_dp
               Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
            elseif (choice_lat_BC .eq. 1) then
               Fprese(i,j) = 0.0_dp
               Fgrave(i,j) = 0.0_dp
            elseif (choice_lat_BC .eq. 0) then
               Fprese(i,j) = K_east(i,j) * (P(1,j)-P(i,j)) * &
                  & ( Sx_east(i,j) / dabs((xn(N,j)-xv(i,j)) + &
                  & (xv(1,j) - xn(1,j)) ) )
               Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
            endif

            !=========== Mass flux due to gravity force ================================
            Fgravw(i,j) = K_west(i,j) * Sy_west(i,j)
            Fgravn(i,j) = K_north(i,j) * Sy_north(i,j)
            Fgravs(i,j) = -K_south(i,j) * Sy_south(i,j)

            !===================== heat flux ============================
            if (index_ground .eq. 0) then ! use temperature at the interface snow-soil
               Fconds(i,j) = Sy_south(i,j) * k_eff_south(i,j) * (Tground-T(i,j,1)) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp)
            else
               Fconds(i,j) = Sy_south(i,j) * Qground
            endif
            Fcondn(i,j) = Sy_south(i,j) * k_eff_north(i,j) * (T(i,j+1,1)-T(i,j,1)) &
               & /(dabs(yv(i,j)-yv(i,j+1)))
            Fconde(i,j) = Sx_east(i,j) * k_eff_east(i,j) * &
                  & (T(1,j,1)-T(i,j,1)) / dabs(xv(i,j)-xv(i-1,j))
            Fcondw(i,j) = Sx_west(i,j) * k_eff_west(i,j) * (T(i-1,j,1)-T(i,j,1)) &
               & /(dabs(xv(i,j)-xv(i-1,j)))

      endif
   endif

   !================================= Upper right cell ====================================
   i=N-1
   if (M .gt. 2) then ! more than two horizontal snow layers
      j=M-1
      if (beta .gt. 0.0001) then ! sloping snowpack

         !=========== Mass flux due to water pressure gradients ================================
         Fpresw(i,j) = K_west(i,j) * (P(i-1,j)-P(i,j)) * &
            & (Sx_west(i,j) / dabs(xv(i,j)-xv(i-1,j)) + &
            & Sy_west(i,j) / dabs(yv(i,j)-yv(i-1,j)))
         Fpress(i,j) = K_south(i,j) * (P(i,j-1)-P(i,j)) * &
            & (Sy_south(i,j) / dabs(yv(i,j)-yv(i,j-1)) + &
            & Sx_south(i,j) / dabs(xv(i,j)-xv(i,j-1)))
         Fpresn(i,j) = 0.0_dp

         if (choice_lat_BC .eq. 2) then
            Fprese(i,j) = 0.0_dp
            Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
         elseif (choice_lat_BC .eq. 1) then
            Fprese(i,j) = 0.0_dp
            Fgrave(i,j) = 0.0_dp
         elseif (choice_lat_BC .eq. 0) then
            Fprese(i,j) = K_east(i,j) * (P(1,j)-P(i,j)) * &
               & ( Sx_east(i,j) / dabs((xn(N,j)-xv(N-1,j)) + &
               & (xv(1,j) - xn(1,j)) ) + &
               & Sy_east(i,j) / dabs( yv(i,j)-yv(1,j)) )
            Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
         endif
         !=========== Mass flux due to gravity force =================================
         Fgravw(i,j) = K_west(i,j) * Sy_west(i,j)
         Fgravn(i,j) = (Qin(i)+rain(i)) * Sy_north(i,j)
         Fgravs(i,j) = -K_south(i,j) * Sy_south(i,j)

         !====================== heat flux ================================
         Fconds(i,j) = k_eff_south(i,j) * (T(i,j-1,1)-T(i,j,1)) * &
            & (Sy_south(i,j) / dabs(yv(i,j)-yv(i,j-1)) + &
            & Sx_south(i,j) / dabs(xv(i,j)-xv(i,j-1)))
         Fcondn(i,j) = k_eff_north(i,j) * (Tss(i)-T(i,j,1)) * &
            & (Sy_north(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp) + &
            & Sx_north(i,j) / dabs(xv(i,j)-(xn(i,j+1)+xn(i+1,j+1))*0.5_dp))
         Fconde(i,j) = 0._dp
         Fcondw(i,j) = k_eff_west(i,j) * (T(i-1,j,1)-T(i,j,1)) * &
            & (Sy_west(i,j) / dabs(yv(i,j)-yv(i-1,j)) + &
            & Sx_west(i,j) / dabs(xv(i,j)-xv(i-1,j)))

      else   ! flat snowpack (beta == 0)

         !=========== Mass flux due to water pressure gradients ================================
         Fpresw(i,j) = Sx_west(i,j) * K_west(i,j) * (P(i-1,j)-P(i,j)) / &
            & dabs(xv(i,j)-xv(i-1,j))
         Fpress(i,j) = Sy_south(i,j) * K_south(i,j) * (P(i,j-1)-P(i,j)) / &
            & dabs(yv(i,j)-yv(i,j-1))
         Fpresn(i,j) = 0.0_dp

         if (choice_lat_BC .eq. 2) then
            Fprese(i,j) = 0.0_dp
            Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
         elseif (choice_lat_BC .eq. 1) then
            Fprese(i,j) = 0.0_dp
            Fgrave(i,j) = 0.0_dp
         elseif (choice_lat_BC .eq. 0) then
            Fprese(i,j) = K_east(i,j) * (P(1,j)-P(i,j)) * &
               & ( Sx_east(i,j) / dabs((xn(N,j)-xv(N-1,j)) + &
               & (xv(1,j) - xn(1,j)) ) )
            Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
         endif

         !=========== Mass flux due to gravity force ================================
         Fgravw(i,j) = K_west(i,j) * Sy_west(i,j)
         Fgravn(i,j) = (Qin(i)+rain(i)) * Sy_north(i,j)
         Fgravs(i,j) = -K_south(i,j) * Sy_south(i,j)

         !====================== heat flux =====================================
         Fconds(i,j) = Sy_south(i,j) * k_eff_south(i,j) * (T(i,j-1,1)-T(i,j,1)) / &
            & dabs(yv(i,j)-yv(i,j-1))
         Fcondn(i,j) = Sy_north(i,j) * k_eff_north(i,j) * (Tss(i)-T(i,j,1)) / &
            &(dabs(yn(i,j+1)-yn(i,j))*0.5_dp)
         Fconde(i,j) = Sx_east(i,j) * k_eff_east(i,j) * &
                  & (T(1,j,1)-T(i,j,1)) / dabs(xv(i,j)-xv(i-1,j))
         Fcondw(i,j) = Sx_west(i,j) * k_eff_west(i,j) * (T(i-1,j,1)-T(i,j,1)) / &
            & dabs(xv(i,j)-xv(i-1,j))

      endif
   endif

   !==================================================================================
   !======================= One snow layer ===========================================
   !==================================================================================

   !===================== Left cell ===================================
   if (M .eq. 2) then
      j=1
      i=1

      !=========== Mass flux due to water pressure gradients ================================
      if (beta .gt. 0.0001) then ! sloping snowpack
         Fprese(i,j) = K_east(i,j) * (P(i+1,j)-P(i,j)) * &
            & (Sx_east(i,j) / dabs(xv(i+1,j)-xv(i,j)) + &
            & Sy_east(i,j) / dabs(yv(i+1,j)-yv(i,j)))
         Fpress(i,j) = 0.0_dp
         Fpresn(i,j) = 0.0_dp
      else ! flat snowpack
         Fprese(i,j) = Sx_east(i,j) * K_east(i,j) * (P(i+1,j)-P(i,j)) / dabs(xv(i+1,j)-xv(i,j))
         Fpress(i,j) = 0.0_dp
         Fpresn(i,j) = 0.0_dp
      endif

      if (choice_lat_BC .eq. 2 .or. choice_lat_BC .eq. 1) then
         Fpresw(i,j) = 0.0_dp
         Fgravw(i,j) = 0.0_dp
      elseif (choice_lat_BC .eq. 0) then
         if (beta .gt. 0.0001) then ! sloping snowpack
            Fpresw(i,j) = K_west(i,j) * (P(N-1,j)-P(i,j)) * &
               & ( Sx_west(i,j) / dabs((xn(N,j)-xv(N-1,j)) + &
               & (xv(1,j) - xn(1,j)) ) + &
               & Sy_west(i,j) / dabs( yv(N-1,j)-yv(1,j)) )
         else
            Fpresw(i,j) = K_west(i,j) * (P(N-1,j)-P(i,j)) * &
               & ( Sx_west(i,j) / dabs((xn(N,j)-xv(N-1,j)) + &
               & (xv(1,j) - xn(1,j)) ) )
         endif
        Fgravw(i,j) = K_west(i,j) * Sy_west(i,j)
      endif

      !=========== Mass flux due to gravity force ================================
      Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
      Fgravn(i,j) = (Qin(i)+rain(i)) * Sy_north(i,j)
      Fgravs(i,j) = -K_south(i,j) * Sy_south(i,j)

      !====================== heat flux ========================================
      if (beta .gt. 0.0001) then ! sloping snowpack
         if (index_ground .eq. 0) then ! use temperature at the interface snow-soil
            Fconds(i,j) = k_eff_south(i,j) * (Tground-T(i,j,1)) * &
               & (Sy_south(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp) + &
               & Sx_south(i,j) / (dabs(xv(i,j)-(xn(i+1,j)+xn(i,j))*0.5_dp)))
         else
            Fconds(i,j) = Sy_south(i,j) * Qground
         endif
         Fcondn(i,j) = k_eff_north(i,j) * (Tss(i)-T(i,j,1)) * &
            & (Sy_north(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp) + &
            & Sx_north(i,j) / (dabs(xv(i,j)-(xn(i,j+1)+xn(i+1,j+1))*0.5_dp)))
         Fconde(i,j) = k_eff_east(i,j) * (T(i+1,j,1)-T(i,j,1)) * &
            & (Sy_east(i,j) / dabs(yv(i,j)-yv(i+1,j)) + &
            & Sx_east(i,j) / dabs(xv(i,j)-xv(i+1,j)))
         Fcondw(i,j) = 0.0_dp

      else
         if (index_ground .eq. 0) then ! use temperature at the interface snow-soil
            Fconds(i,j) = Sy_south(i,j) * k_eff_south(i,j) * (Tground-T(i,j,1)) / &
               & (dabs(yn(i,j+1)-yn(i,j))*0.5_dp)
         else
            Fconds(i,j) = Sy_south(i,j) * Qground
         endif
         Fcondn(i,j) = Sy_north(i,j) * k_eff_north(i,j) * (Tss(i)-T(i,j,1)) / &
            & (dabs(yn(i,j+1)-yn(i,j))*0.5_dp)
         Fconde(i,j) = Sx_east(i,j) * k_eff_east(i,j) * (T(i+1,j,1)-T(i,j,1)) / &
            & (dabs(xv(i,j)-xv(i+1,j)))
         Fcondw(i,j)=0.0_dp
      endif

   !=========================== Middle cells ==================================

      j=1
      !=========== Mass flux due to water pressure gradients =================================
      if (beta .gt. 0.0001) then ! sloping snowpack
         Fpresw(2:N-2,j) = K_west(2:N-2,j) * (P(1:N-3,j)-P(2:N-2,j)) * &
            & (Sx_west(2:N-2,j) / dabs(xv(2:N-2,j)-xv(1:N-3,j)) + &
            & Sy_west(2:N-2,j) / dabs(yv(2:N-2,j)-yv(1:N-3,j)))
         Fprese(2:N-2,j) = K_east(2:N-2,j) * (P(3:N-1,j)-P(2:N-2,j)) * &
            & (Sx_east(2:N-2,j) / dabs(xv(3:N-1,j)-xv(2:N-2,j)) + &
            & Sy_east(2:N-2,j) / dabs(yv(3:N-1,j)-yv(2:N-2,j)))
         Fpress(2:N-2,j) = 0.0_dp
         Fpresn(2:N-2,j) = 0.0_dp
      else ! flat snowpack
         Fpresw(2:N-2,j) = Sx_west(2:N-2,j) * K_west(2:N-2,j) * (P(1:N-3,j)-P(2:N-2,j)) / &
            & dabs(xv(2:N-2,j)-xv(1:N-3,j))
         Fprese(2:N-2,j) = Sx_east(2:N-2,j) * K_east(2:N-2,j) * (P(3:N-1,j)-P(2:N-2,j)) / &
            & dabs(xv(3:N-1,j)-xv(2:N-2,j))
         Fpress(2:N-2,j) = 0.0_dp
         Fpresn(2:N-2,j) = 0.0_dp
      endif

      !=========== Mass flux due to gravity force =================================
      Fgravw(2:N-2,j) = K_west(2:N-2,j) * Sy_west(2:N-2,j)
      Fgrave(2:N-2,j) = -K_east(2:N-2,j) * Sy_east(2:N-2,j)
      Fgravn(2:N-2,j) = (Qin(2:N-2)+rain(2:N-2)) * Sy_north(2:N-2,j)
      Fgravs(2:N-2,j) = -K_south(2:N-2,j) * Sy_south(2:N-2,j)

      !====================== heat flux =======================================
      if (beta.gt. 0.00001) then ! sloping snowpack
         if (index_ground .eq. 0) then ! use temperature at the interface snow-soil
            Fconds(2:N-2,j) = k_eff_south(2:N-2,j) * (Tground-T(2:N-2,j,1)) * &
               & (Sy_south(2:N-2,j) / (dabs(yn(2:N-2,j+1)-yn(2:N-2,j))*0.5_dp) + &
               & Sx_south(2:N-2,j) / (dabs(xv(2:N-2,j)-(xn(3:N-1,j)+xn(2:N-2,j))*0.5_dp)))
         else
            Fconds(2:N-2,j) = Sy_south(2:N-2,j) * Qground
         endif
         Fcondn(2:N-2,j) = k_eff_north(2:N-2,j) * (Tss(i)-T(2:N-2,j,1)) * &
            & (Sy_north(2:N-2,j) / (dabs(yn(2:N-2,j+1)-yn(2:N-2,j))*0.5_dp) + &
            & Sx_north(2:N-2,j) / (dabs(xv(2:N-2,j)-(xn(2:N-2,j+1)+xn(3:N-1,j+1)) *0.5_dp)))
         Fconde(2:N-2,j) = k_eff_east(2:N-2,j) * (T(3:N-1,j,1)-T(2:N-2,j,1)) * &
            & (Sy_east(2:N-2,j) / dabs(yv(2:N-2,j)-yv(3:N-1,j)) + &
            & Sx_east(2:N-2,j) / dabs(xv(2:N-2,j)-xv(3:N-1,j)))
         Fcondw(2:N-2,j) = k_eff_west(2:N-2,j) * (T(1:N-3,j,1)-T(2:N-2,j,1)) * &
            & (Sy_west(2:N-2,j) / dabs(yv(2:N-2,j)-yv(1:N-3,j)) + &
            & Sx_west(2:N-2,j) / dabs(xv(2:N-2,j)-xv(1:N-3,j)))
      else
         if (index_ground .eq. 0) then ! use temperature at the interface snow-soil
            Fconds(2:N-2,j) = Sy_south(2:N-2,j) * k_eff_south(2:N-2,j) * (Tground-T(2:N-2,j,1)) / &
            & (dabs(yn(2:N-2,j+1)-yn(2:N-2,j))*0.5_dp)
         else
            Fconds(2:N-2,j) = Sy_south(2:N-2,j) * Qground
         endif
         Fcondn(2:N-2,j) = Sy_north(2:N-2,j) * k_eff_north(2:N-2,j) * (Tss(2:N-2)-T(2:N-2,j,1)) / &
            & (dabs(yn(2:N-2,j+1)-yn(2:N-2,j))*0.5_dp)
         Fconde(2:N-2,j) = Sx_east(2:N-2,j) * k_eff_east(2:N-2,j) * (T(3:N-1,j,1)-T(2:N-2,j,1)) / &
            & dabs(xv(2:N-2,j)-xv(3:N-1,j))
         Fcondw(2:N-2,j) = Sx_west(2:N-2,j) * k_eff_west(2:N-2,j) * (T(1:N-3,j,1)-T(2:N-2,j,1)) / &
            & dabs(xv(2:N-2,j)-xv(1:N-3,j))
      endif

   !===================================== Right cell ==========================
      i=N-1
      j=1
      !=========== Mass flux due to water pressure gradients ================================
      if (beta .gt. 0.0001)then ! sloping snowpack
         Fpresw(i,j) = K_west(i,j) * (P(i-1,j)-P(i,j)) * &
            & (Sx_west(i,j) / dabs(xv(i,j)-xv(i-1,j)) + &
            & Sy_west(i,j) / dabs(yv(i,j)-yv(i-1,j)))
         Fpress(i,j) = 0.0_dp
         Fpresn(i,j) = 0.0_dp
      else
         Fpresw(i,j) = Sx_west(i,j) * K_west(i,j) * (P(i-1,j)-P(i,j)) / &
            & dabs(xv(i,j)-xv(i-1,j))
         Fpress(i,j) = 0.0_dp
         Fpresn(i,j) = 0.0_dp
      endif

      if (choice_lat_BC .eq. 2) then
         Fprese(i,j) = 0.0_dp
         Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
      elseif (choice_lat_BC .eq. 1) then
         Fprese(i,j) = 0.0_dp
         Fgrave(i,j) = 0.0_dp
      elseif (choice_lat_BC .eq. 0) then
         if (beta .gt. 0.0001) then ! sloping snowpack
            Fprese(i,j) = K_east(i,j) * (P(1,j)-P(i,j)) * &
               & ( Sx_east(i,j) / dabs((xn(N,j)-xv(N-1,j)) + &
               & (xv(1,j) - xn(1,j)) ) + &
               & Sy_east(i,j) / dabs( yv(N+1,j)-yv(1,j)) )
         else
            Fprese(i,j) = K_east(i,j) * (P(1,j)-P(i,j)) * &
               & ( Sx_east(i,j) / dabs((xn(N,j)-xv(N-1,j)) + &
               & (xv(1,j) - xn(1,j)) ))

         endif
         Fgrave(i,j) = -K_east(i,j) * Sy_east(i,j)
      endif

      !=========== Mass flux due to gravity force ================================
      Fgravw(i,j) = K_west(i,j) * Sy_west(i,j)
      Fgravn(i,j) = (Qin(i)+rain(i)) * Sy_north(i,j)
      Fgravs(i,j) = -K_south(i,j) * Sy_south(i,j)

      !====================== heat flux ========================================
      if (beta .gt. 0.0001) then ! sloping snowpack
         if (index_ground .eq. 0) then ! use temperature at the interface snow-soil
            Fconds(i,j) = k_eff_south(i,j) * (Tground-T(i,j,1)) * &
               & (Sy_south(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp) + &
               & Sx_south(i,j) / (dabs(xv(i,j)-(xn(i+1,j)+xn(i,j))*0.5_dp)))
         else
            Fconds(i,j) = Sy_south(i,j) * Qground
         endif
         Fcondn(i,j) = k_eff_north(i,j) * (Tss(i)-T(i,j,1)) * &
            & (Sy_north(i,j) / (dabs(yn(i,j+1)-yn(i,j))*0.5_dp) + &
            & Sx_north(i,j) / (dabs(xv(i,j)-(xn(i,j+1)+xn(i+1,j+1))*0.5_dp)))
         Fconde(i,j) = 0.0_dp
         Fcondw(i,j) = k_eff_west(i,j) * (T(i-1,j,1)-T(i,j,1)) * &
            & (Sy_west(i,j) / dabs(yv(i,j)-yv(i-1,j)) + &
            & Sx_west(i,j) / dabs(xv(i,j)-xv(i-1,j)))
      else ! flat snowpack
         Fconds(i,j) = Sy_south(i,j) * k_eff_south(i,j) * (Tground-T(i,j,1)) / &
            & (dabs(yn(i,j+1)-yn(i,j))*0.5_dp)
         Fcondn(i,j) = Sy_north(i,j) * k_eff_north(i,j) * (Tss(i)-T(i,j,1)) / &
            & (dabs(yn(i,j+1)-yn(i,j))*0.5_dp)
         Fconde(i,j) = 0.0_dp
         Fcondw(i,j) = Sx_west(i,j) * k_eff_west(i,j) * (T(i-1,j,1)-T(i,j,1)) / &
            & dabs(xv(i,j)-xv(i-1,j))
      endif

   endif

return
end


program test_hwm

use hwm_interface, only : hwm_14, dwm_07

implicit none (type, external)

integer :: day = 150
real ::  &
 utsec = 12 * 3600, &
 alt_km = 400., &
 glat = -45.0, &
 glon = -85.0, &
 Ap = 80.0

real :: Qw(2), Dw(2)

call hwm_14(day, utsec, alt_km, glat, glat, Ap, Qw)

if (abs(QW(1)-(-34.1767464)) > 0.001) error stop 'Qw(1)'
if (abs(Qw(2)-(-64.3156433)) > 0.001) error stop 'Qw(2)'

call dwm_07(day, utsec, alt_km, glat, glat, Ap, Dw)
if (abs(DW(1)-(24.6438866)) > 0.001) error stop 'Dw(1)'
if (abs(DW(2)-(-10.9287968)) > 0.001) error stop 'Dw(2)'

print *, "OK: HWM14"

end program


subroutine SMM_se(parameters,moments,densities)
    use dimensions; use structural_p2;use structural_p1
    implicit none
    real(SP),dimension(moment_conditions,1),intent(out)::moments,densities
    real(SP),dimension(parameters_to_est),intent(in)::parameters
    integer::h_l
    integer,dimension(nkk,clusters,nzz,L_gender,L_PI2,f_t,generations)::a_policy,g_policy
    real(SP),dimension(nkk,clusters,nzz,L_gender,L_PI2,f_t,generations)::beq100_policy
    real(SP),dimension(nkk,clusters,f_t,L_PI2)::lfc_x
    character::pause_k
    real(SP)::c,l_fc,mu_av
    real(SP),dimension(nkk,clusters,f_t,L_PI2)::u_x

    H_av(clusters+1,clusters+1,:,:,:)=1.0_sp

    sigma=parameters(1)
    x_bar(1)=parameters(2)
    alpha_mu(1:3)=parameters(3:5)
    delta(1:f_t)=parameters(6)
    nu=parameters(7)
    lambda(1:f_t)=exp(parameters(8:9))
    share_p=parameters(10)
    subs_p=parameters(11)

    sigma_beq=sigma
    beta=0.95_sp
    omega=1.0_sp
    kappa_h=0.0_sp
    delta_h=1.0_sp

    !Utility at the floor when healthy
    do h_l=1,1
        call solve_intratemporal(p_fc,x_bar(h_l),h_l,0.0_sp,u_bar_no_f(h_l),l_fc,c)
    end do
    u_bar_no_f=u_bar_no_f(1)

    print*,beta,sigma,nu,delta(1),x_bar(1), &
           lambda,alpha_mu,share_p,subs_p

    mu=0.0_sp
    do h_l=2,clusters
        mu(h_l)=exp(alpha_mu(h_l-1))
    end do

    !Solve the model given a set of parameters
    call solve_model(a_policy,g_policy,lfc_x,u_x,beq100_policy)

    !Simulate model given the policy function to obtain moments and densities
    print*,'Simulating Model'
    call simulate_model_se(a_policy,g_policy,lfc_x,beq100_policy, &
                            moments,densities)

end subroutine


program test_UI_k
use libatoms_module
implicit none
   integer :: n, i, j
   real(dp), allocatable :: Vx(:), Vy(:), dF_dl_x(:), dF_dl_y(:), integrand_x(:), integrand_y(:)
   real(dp) :: min_x, max_x, x, l, dx
   real(dp) :: k, beta, T
   type(spline) :: V0_spline, dF_dl_spline
   integer :: n_samples = 500
   real(dp) :: min_V0, min_V0_x, max_V0_x, F, min_F_1, min_F_2, max_F
   real(dp) :: normalization, prob_left, prob_right

   call system_initialise()

   read *, n
   allocate(Vx(n), Vy(n))
   do i=1, n
      read *, Vx(i), Vy(i)
   end do
   read *, min_x, max_x
   read *, k, T
   beta = 1.0_dp/T

   ! calculate potential spline V0
   call initialise(V0_spline, Vx, Vy, (Vy(2)-Vy(1))/(Vx(2)-Vx(1)), (Vy(n)-Vy(n-1))/(Vx(n)-Vx(n-1)))
   min_V0 = 1e38
   dx = (max_x-min_x)/real(n_samples-1,dp)
   do i=1, n_samples
      x = min_x + real(i-1,dp)*dx
      if (spline_value(V0_spline,x) < min_V0) then
         min_V0_x = x
         min_V0 = spline_value(V0_spline, x)
      endif
      if (i > 1 .and. i < n_samples) then
         if (spline_value(V0_spline,x) > spline_value(V0_spline,x-dx) .and. spline_value(V0_spline,x) > spline_value(V0_spline,x+dx)) then
            max_V0_x = x
         endif
      endif
      call print ("V0 "// x//" " // spline_value(V0_spline, x) //" " // spline_deriv(V0_spline, x))
   end do

   call print("V0 min max x " // min_V0_x // " " // max_V0_x)

   ! dF/dl(l) = \integral_{-\infty}^{\infty} dx dVr/dl(x,l,k) \exp(-beta (V0(x) + Vr(x,l,k)))
   allocate(dF_dl_x(n_samples), dF_dl_y(n_samples))
   allocate(integrand_x(3*n_samples), integrand_y(3*n_samples))
   do i=1, n_samples
      l = min_x + (max_x-min_x)*real(i-1,dp)/real(n_samples-1,dp)
      dF_dl_x(i) = l

      do j=1, 3*n_samples
         x = min_x-(max_x-min_x) + 3*(max_x-min_x)*real(j-1,dp)/real(3*n_samples-1,dp)
         integrand_x(j) = x
         integrand_y(j) = dVr_dl(x,l,k) * exp(-beta*(spline_value(V0_spline,x)+Vr(x,l,k)))
! call print("dF_dl integrand_y " // (-beta*(spline_value(V0_spline,x)+Vr(x,l,k))) // " " // integrand_y(j))
      end do
      dF_dl_y(i) = TrapezoidIntegral(integrand_x, integrand_y)

      do j=1, 3*n_samples
         x = min_x-(max_x-min_x) + 3*(max_x-min_x)*real(j-1,dp)/real(3*n_samples-1,dp)
         integrand_x(j) = x
         integrand_y(j) = exp(-beta*(spline_value(V0_spline,x)+Vr(x,l,k)))
      end do
      dF_dl_y(i) = dF_dl_y(i) / TrapezoidIntegral(integrand_x, integrand_y)

   end do
   call initialise(dF_dl_spline, dF_dl_x, dF_dl_y, (dF_dl_y(2)-dF_dl_y(1))/(dF_dl_x(2)-dF_dl_x(1)), (dF_dl_y(n)-dF_dl_y(n-1))/(dF_dl_x(n)-dF_dl_x(n-1)))
   do i=1, n_samples
      x = min_x + (max_x-min_x)*real(i-1,dp)/real(n_samples-1,dp)
      call print ("dF_dl "// x//" " // spline_value(dF_dl_spline, x) // " " // spline_nintegrate(dF_dl_spline, min_V0_x, x))
   end do

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   dx = 3*(max_x-min_x)/real(3*n_samples-1,dp)
   do j=1, 3*n_samples
      x = min_x-(max_x-min_x) + real(j-1,dp)*dx
      integrand_x(j) = x
      F = spline_value(V0_spline, x)
      integrand_y(j) = exp(-beta*F)
   end do
   normalization = TrapezoidIntegral(integrand_x, integrand_y)

   do j=1, 3*n_samples
      x = min_x-(max_x-min_x) + 3*(max_x-min_x)*real(j-1,dp)/real(3*n_samples-1,dp)
      integrand_x(j) = x
      if (x <= max_V0_x) then
         integrand_y(j) = exp(-beta*spline_value(V0_spline,x))
      else
         integrand_y(j) = 0.0_dp
      endif
   end do
   prob_left = TrapezoidIntegral(integrand_x, integrand_y)/normalization

   do j=1, 3*n_samples
      x = min_x-(max_x-min_x) + 3*(max_x-min_x)*real(j-1,dp)/real(3*n_samples-1,dp)
      integrand_x(j) = x
      if (x > max_V0_x) then
         integrand_y(j) = exp(-beta*spline_value(V0_spline,x))
      else
         integrand_y(j) = 0.0_dp
      endif
   end do
   prob_right = TrapezoidIntegral(integrand_x, integrand_y)/normalization
   call print("V0 integrals: left basin probability " // prob_left // " right basin probability " // prob_right // &
      " ratio " // (prob_right/prob_left))
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   dx = 3*(max_x-min_x)/real(3*n_samples-1,dp)
   min_F_1 = 1e38_dp
   min_F_2 = 1e38_dp
   do j=1, 3*n_samples
      x = min_x-(max_x-min_x) + real(j-1,dp)*dx
      integrand_x(j) = x
      F = spline_nintegrate(dF_dl_spline, min_V0_x, x)
      if (j > 1 .and. j < 3*n_samples) then
         if (F > spline_nintegrate(dF_dl_spline, min_V0_x, x-dx) .and. F > spline_nintegrate(dF_dl_spline, min_V0_x, x+dx)) then
            max_F = F
         endif
         if (F < spline_nintegrate(dF_dl_spline, min_V0_x, x-dx) .and. F < spline_nintegrate(dF_dl_spline, min_V0_x, x+dx)) then
            if (min_F_1 < 1e37_dp) then
               min_F_2 = F
            else
               min_F_1 = F
            endif
         endif
      endif
      integrand_y(j) = exp(-beta*F)
   end do
   normalization = TrapezoidIntegral(integrand_x, integrand_y)

   do j=1, 3*n_samples
      x = min_x-(max_x-min_x) + 3*(max_x-min_x)*real(j-1,dp)/real(3*n_samples-1,dp)
      integrand_x(j) = x
      if (x <= max_V0_x) then
         integrand_y(j) = exp(-beta*spline_nintegrate(dF_dl_spline, min_V0_x, x))
      else
         integrand_y(j) = 0.0_dp
      endif
   end do
   prob_left = TrapezoidIntegral(integrand_x, integrand_y)/normalization

   do j=1, 3*n_samples
      x = min_x-(max_x-min_x) + 3*(max_x-min_x)*real(j-1,dp)/real(3*n_samples-1,dp)
      integrand_x(j) = x
      if (x > max_V0_x) then
         integrand_y(j) = exp(-beta*spline_nintegrate(dF_dl_spline, min_V0_x, x))
      else
         integrand_y(j) = 0.0_dp
      endif
   end do
   prob_right = TrapezoidIntegral(integrand_x, integrand_y)/normalization
   call print("F integrals: left basin probability " // prob_left // " right basin probability " // prob_right // &
      " ratio " // (prob_right/prob_left))
   call print("F minima: " // min_F_1 // " " // min_F_2 // " prob ratio " // exp(-beta*(min_F_2-min_F_1)) // " max " // max_F)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   call finalise(V0_spline)
   call finalise(dF_dl_spline)
   call system_finalise()

contains
   function Vr(x,l,k)
      real(dp), intent(in) :: x, l, k
      real(dp) :: Vr

      Vr = k*(x-l)**2
   end function Vr

   function dVr_dl(x,l,k)
      real(dp), intent(in) :: x, l, k
      real(dp) :: dVr_dl

      dVr_dl = -2.0_dp*k*(x-l)
   end function dVr_dl

end program


      subroutine projct(xp,yp,zp,xpj,ypj)
C...01/09/78
      common /gftrg2/bitx,bity,t(4,4)
      r=t(4,1)*xp+t(4,2)*yp+t(4,3)*zp+t(4,4)
      xpj=(t(1,1)*xp+t(1,2)*yp+t(1,3)*zp+t(1,4))/r+bitx
      ypj=(t(2,1)*xp+t(2,2)*yp+t(2,3)*zp+t(2,4))/r+bity
      return
      end


!This is Craig Bohren's bhmie code, modified by Dong-Chul Kim to
!calculate the assymetry parameter GSCA. Some additional minor
!modifications by lz4ax for interfacing with bhmie_driver.

module bhmie_module

  use kinds_module

  private
  public :: bhmie_driver

  !implicit NONE
  !using implicit types as I'm too lazy to declare all variables
  !in Bohren's routine

  !number of angles between 0 and 90 degrees; matrix elements are
  !calculated at 2*nang-1 angles, including 0, 90, and 180 degrees
  integer, parameter :: nang = 100
  real,    parameter :: ref_air = 1.0 ! air

CONTAINS

!=======================================================================
 subroutine bhmie_driver( radius, refr_ind, wavelength, &
                          Qext, Qsca, Qgsa )
!=======================================================================
!
! Purpose: bhmie driver. Calls bhmie routine to obtain the extinction
!          efficiency Qext, scattering efficiency Qsca and assymetry
!          parameter Qgsa for a particle with radius "radius" composed
!          of material with refractive index refre + j*refim
!
!-----------------------------------------------------------------------

   !use bhmie_mod, only: bhmie
   implicit NONE

!----------------------------- arguments -------------------------------

   real (kind=rkind), intent(in) :: &
                      radius,   & ! particle radius [um]
                      wavelength  ! in micron
   complex (kind=ckind), intent(in) :: &
                      refr_ind  ! particle complex refractive index

   real, intent(out) :: &
                      Qext,   & ! extinction efficiency
                      Qsca,   & ! scattering efficiency
                      Qgsa      ! assymetry parameter

!------------------------- local workspace -----------------------------

   !refractive index of the medium

   !integer :: iw, ir
   real    :: x, dum
   complex :: ref_ndx

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

  ! refractive index at specific wavelength
  ref_ndx = refr_ind / ref_air

  ! size parameter less than size
  dum = 2. * pi * ref_air / wavelength

  ! size parameter
  x = dum * radius

  !get Mie coefficients for a particle with size radius(ir) and
  call bhmie( x, ref_ndx, Qext, Qsca, Qgsa )

end subroutine bhmie_driver

! ===
!  Subroutine BHMIE calculates amplitude scattering matrix
!	elements and efficiencies for extinction, total scattering
!	and backscattering for a given size parameter and
!	relative refractive index
! ===

subroutine bhmie (x, refrel, qext, qsca, GSCA)
!subroutine bhmie (x,refrel,nang,s1,s2,qext,qsca,qback,GSCA)

  real, dimension(100) :: amu, theta, pi, tau, pi0, pi1
  complex :: d(3000), y, refrel, xi, xi0, xi1, an, bn, s1(200), s2(200), p, t
  double precision :: psi0, psi1, psi, dn, dx

!++dckim
  complex :: AN1,BN1
  GSCA=0.E0
!--dckim

!lz4ax: keep the gfortran compiler happy
  AN  = 0.0
  BN  = 0.0
  AN1 = 0.0
  BN1 = 0.0
!lz4ax:end

  dx = x
  y = x*refrel

  ! series terminated after nstop terms

  xstop = x + 4.0*x**0.3333 + 2.0
  nstop = xstop
  ymod  = cabs(y)
  nmx   = amax1(xstop, ymod) + 15
  dang  = 1.570796327/float(nang - 1)
  do 555 j=1,nang
  	theta(j) = (float(j) - 1.0)*dang
  555   amu(j)   = cos(theta(j))

  ! logarithmic derivative d(j) calculated by downward
  ! recurrence beginning with initial value 0.0 + i*0.0
  ! at j = nmx

  d(nmx) = cmplx (0.0, 0.0)
  nn = nmx - 1
  do 120 n=1,nn
  	rn = nmx - n + 1
  120	d(nmx-n) = (rn/y) - (1.0/(d(nmx-n+1) + rn/y))
  do 666 j=1,nang
  	pi0(j) = 0.0
  666	pi1(j) = 1.0
  nn = 2*nang - 1
  do 777 j=1,nn
  	s1(j) = cmplx (0.0, 0.0)
  777	s2(j) = cmplx (0.0, 0.0)

  ! Riccati-Bessel functions with real argument x
  ! calculated by upward recurrence

  psi0 = dcos(dx)
  psi1 = dsin(dx)
  chi0 = -sin(x)
  chi1 = cos(x)
  apsi0 = psi0
  apsi1 = psi1
  xi0  = cmplx (apsi0, -chi0)
  xi1  = cmplx (apsi1, -chi1)
  qsca = 0.0
  n    = 1

  200 dn = n
  rn = n
  fn = (2.0*dn + 1.0)/(rn*(rn + 1.0))
  psi = (2.0*dn - 1.0)*psi1/dx - psi0
  apsi= psi
  chi = (2.0*rn - 1.0)*chi1/x - chi0
  xi  = cmplx ( apsi, -chi)
!
!++dckim
!*** Store previous values of AN and BN for use
!    in computation of g=<cos(theta)>
          IF(N.GT.1)THEN
              AN1=AN
              BN1=BN
          ENDIF
!--dckim

  an  = (d(n)/refrel + rn/x)*apsi - apsi1
  an  = an/((d(n)/refrel + rn/x)*xi - xi1)
  bn  = (refrel*d(n) + rn/x)*apsi - apsi1
  bn  = bn/((refrel*d(n) + rn/x)*xi - xi1)
  qsca = qsca + (2.0*rn + 1.0)*(cabs(an)*cabs(an) + cabs(bn)*cabs(bn))

!++dckim
  !QSCA=QSCA+(2.*EN+1.)*(ABS(AN)**2+ABS(BN)**2)
!  GSCA=GSCA+((2.*rn+1.)/(rn*(rn+1.)))*                &
!              (REAL(AN)*REAL(BN)+AIMAG(AN)*AIMAG(BN))
!          IF(N.GT.1)THEN
!              GSCA=GSCA+((rn-1.)*(rn+1.)/rn)*         &
!             (REAL(AN1)*REAL(AN)+AIMAG(AN1)*AIMAG(AN)+  &
!              REAL(BN1)*REAL(BN)+AIMAG(BN1)*AIMAG(BN))
!          ENDIF
  GSCA=GSCA+((2.*rn+1.)/(rn*(rn+1.)))*                &
              (REAL(AN)*REAL(BN)+IMAG(AN)*IMAG(BN))
          IF(N.GT.1)THEN
              GSCA=GSCA+((rn-1.)*(rn+1.)/rn)*         &
             (REAL(AN1)*REAL(AN)+IMAG(AN1)*IMAG(AN)+  &
              REAL(BN1)*REAL(BN)+IMAG(BN1)*IMAG(BN))
          ENDIF
!--dckim

  do 789 j=1,nang
  	jj = 2*nang - j
	pi(j) = pi1(j)
	tau(j) = rn*amu(j)*pi(j) - (rn + 1.0)*pi0(j)
	p = (-1.0)**(n-1)
	s1(j) = s1(j) + fn*(an*pi(j) + bn*tau(j))
	t = (-1.0)**n
	s2(j) = s2(j) + fn*(an*tau(j) + bn*pi(j))
	if ( j.eq.jj) go to 789
	s1(jj) = s1(jj) + fn*(an*pi(j)*p + bn*tau(j)*t)
	s2(jj) = s2(jj) + fn*(an*tau(j)*t + bn*pi(j)*p)
  789 continue
  psi0 = psi1
  psi1 = psi
  apsi1 = psi1
  chi0 = chi1
  chi1 = chi
  xi1 = cmplx (apsi1, -chi1)
  n = n + 1
  rn = n
  do 999 j=1,nang
  	pi1(j) = ((2.0*rn - 1.0)/(rn - 1.0))*amu(j)*pi(j)
	pi1(j) = pi1(j) - rn*pi0(j)/(rn - 1.0)
  999	pi0(j) = pi(j)
  if (n-1-nstop) 200,300,300
!+-dckim, uncomment in the original code
!  300 qsca = (2.0/(x*x))*qsca

!++dckim
  300 GSCA=2.*GSCA/QSCA
  qsca = (2.0/(x*x))*qsca
!--dckim
  qext = (4.0/(x*x))*real(s1(1))
  qback = (4.0/(x*x))*cabs(s1(2*nang - 1))*cabs(s1(2*nang - 1))

end subroutine bhmie

end module


      SUBROUTINE VECTOR(Q,P,W)
*
*
*       KS matrix of Q times P.
*       -----------------------
*
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 Q(4),P(4),W(4)
*
*
*       Evaluate W = L(Q)P; the KS matrix of Q times P.
      W(1)=(+Q(1)*P(1)+Q(2)*P(2)+Q(3)*P(3)+Q(4)*P(4))
      W(2)=(-Q(2)*P(1)+Q(1)*P(2)+Q(4)*P(3)-Q(3)*P(4))
      W(3)=(-Q(3)*P(1)-Q(4)*P(2)+Q(1)*P(3)+Q(2)*P(4))
      W(4)=(+Q(4)*P(1)-Q(3)*P(2)+Q(2)*P(3)-Q(1)*P(4))
*
      RETURN
      END


subroutine  FINE
  use simsphere_mod
  implicit none

  integer :: incr, i, j, height
  real :: rlinear

!      INCLUDE 'modvars.h'

  j = 1
  height = 50

  u_fine(1) = ud(1)
  v_fine(1) = vd(1)
  t_fine(1) = td(1)
  q_fine(1) = qd(1)

  do i = 1,9
    do incr = 1,5
      j = j +1
      u_fine(j) = rlinear(ud(i+1),ud(i),incr)
      v_fine(j) = rlinear(vd(i+1),vd(i),incr)
      q_fine(j) = rlinear(qd(i+1),qd(i),incr)
      if (height .le. Hgt) then
        t_fine(j) = Aptemp
      else
        t_fine(j) = rlinear(td(i+1),td(i),incr)
      end if

      height = height + 50
    end do
  end do

! If below top of the mixing layer potential temp = that at 50 metres
! otherwise, average as usual to create fine scale.

  return
end

real function rlinear (top,bot,n)
  real :: top, bot
  integer :: n

  rlinear = bot + (top - bot) * n /  5
end


subroutine  TRANSM (PATH,FTABS,FTSCAT,FBSCAT)
  use simsphere_mod
  implicit none

  real :: FTABS, FTSCAT, FBSCAT, FRACP, PATH, FRACT, FRACT2
  integer :: IPATH, JPATH

!     Subroutine TRANSM calculates solar transmission by using the
!     three-way lookup table produced in GETTBL.

!      INCLUDE 'modvars.h'

! **  If the path length is very large (sun almost on the horizon) use
! **  longest path length possible, ie last number in the table. Otherwise
! **  calc trans coeff's for entries bracketing the supplied path length.
! **  FRACTP - Scaling fact for depth of atmos. FRACT & FRACT2 weighting
! **  factors for interpol'n between 2 successive path lenghts in table.

  if ( PATH .GE. 10 ) then
    FTABS = ABSTBL (46)
    FTSCAT = SCATBL (46)
    FBSCAT = BSCTBL(46)
  else
    FRACP = PS1 / 1013.25
    FRACT= 5 * ( PATH - 1 ) + 1
    IPATH = IFIX( FRACT )
    JPATH = IPATH + 1
    FRACT = ( FRACT - IPATH )
    FRACT2 = 1 - FRACT
    FTABS = FRACT2 * ABSTBL( IPATH ) + FRACT * ABSTBL( JPATH )
    FTSCAT = FRACT2 * SCATBL( IPATH ) + FRACT * SCATBL( JPATH )
    FBSCAT = FRACT2 * BSCTBL( IPATH ) + FRACT * BSCTBL( JPATH )
    FTABS = FRACP * ( FTABS - 1 ) + 1
    FTSCAT = FRACP * ( FTSCAT - 1 ) + 1
  end if

  return
end


      SUBROUTINE fft99a(a, work, trigs, inc, jump, n, lot)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER inc, jump, n, lot
      REAL(rprec), DIMENSION(*) :: a, work, trigs
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER::nh,nx,ink,ia,ib,ja,jb,l,iabase,ibbase,jabase,jbbase,k
      REAL(rprec) :: c, s
C-----------------------------------------------
c
c     SUBROUTINE fft99a - preprocessing step for fft99, isign=+1
c     (spectral to gridpoint transform)
c
      nh=n/2
      nx=n+1
      ink=inc+inc
c
c     a(0) and a(n/2)
      ia=1
      ib=n*inc+1
      ja=1
      jb=2
cdir$ ivdep
      DO 10 l=1,lot
      work(ja)=a(ia)+a(ib)
      work(jb)=a(ia)-a(ib)
      ia=ia+jump
      ib=ib+jump
      ja=ja+nx
      jb=jb+nx
   10 CONTINUE
c
c     remaining wavenumbers
      iabase=2*inc+1
      ibbase=(n-2)*inc+1
      jabase=3
      jbbase=n-1
c
      DO 30 k=3,nh,2
      ia=iabase
      ib=ibbase
      ja=jabase
      jb=jbbase
      c=trigs(n+k)
      s=trigs(n+k+1)
cdir$ ivdep
      DO 20 l=1,lot
      work(ja)=(a(ia)+a(ib))-
     *    (s*(a(ia)-a(ib))+c*(a(ia+inc)+a(ib+inc)))
      work(jb)=(a(ia)+a(ib))+
     *    (s*(a(ia)-a(ib))+c*(a(ia+inc)+a(ib+inc)))
      work(ja+1)=(c*(a(ia)-a(ib))-s*(a(ia+inc)+a(ib+inc)))+
     *    (a(ia+inc)-a(ib+inc))
      work(jb+1)=(c*(a(ia)-a(ib))-s*(a(ia+inc)+a(ib+inc)))-
     *    (a(ia+inc)-a(ib+inc))
      ia=ia+jump
      ib=ib+jump
      ja=ja+nx
      jb=jb+nx
   20 CONTINUE
      iabase=iabase+ink
      ibbase=ibbase-ink
      jabase=jabase+2
      jbbase=jbbase-2
   30 CONTINUE
c
      IF (iabase.ne.ibbase) GOTO 50
c     wavenumber n/4 (IF it exists)
      ia=iabase
      ja=jabase
cdir$ ivdep
      DO 40 l=1,lot
      work(ja)=2.0*a(ia)
      work(ja+1)=-2.0*a(ia+inc)
      ia=ia+jump
      ja=ja+nx
   40 CONTINUE
c
   50 CONTINUE

      END SUBROUTINE fft99a