      SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
*  -- LAPACK routine (instrumented to count operations, version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      CHARACTER          COMPZ
      INTEGER            INFO, LDZ, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), E( * ), WORK( * )
      COMPLEX*16         Z( LDZ, * )
*     ..
*     Common block to return operation count and iteration count
*     ITCNT is initialized to 0, OPS is only incremented
*     .. Common blocks ..
      COMMON             / LATIME / OPS, ITCNT
*     ..
*     .. Scalars in Common ..
      DOUBLE PRECISION   ITCNT, OPS
*     ..
*
*  Purpose
*  =======
*
*  ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a
*  symmetric tridiagonal matrix using the implicit QL or QR method.
*  The eigenvectors of a full or band complex Hermitian matrix can also
*  be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this
*  matrix to tridiagonal form.
*
*  Arguments
*  =========
*
*  COMPZ   (input) CHARACTER*1
*          = 'N':  Compute eigenvalues only.
*          = 'V':  Compute eigenvalues and eigenvectors of the original
*                  Hermitian matrix.  On entry, Z must contain the
*                  unitary matrix used to reduce the original matrix
*                  to tridiagonal form.
*          = 'I':  Compute eigenvalues and eigenvectors of the
*                  tridiagonal matrix.  Z is initialized to the identity
*                  matrix.
*
*  N       (input) INTEGER
*          The order of the matrix.  N >= 0.
*
*  D       (input/output) DOUBLE PRECISION array, dimension (N)
*          On entry, the diagonal elements of the tridiagonal matrix.
*          On exit, if INFO = 0, the eigenvalues in ascending order.
*
*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)
*          On entry, the (n-1) subdiagonal elements of the tridiagonal
*          matrix.
*          On exit, E has been destroyed.
*
*  Z       (input/output) COMPLEX*16 array, dimension (LDZ, N)
*          On entry, if  COMPZ = 'V', then Z contains the unitary
*          matrix used in the reduction to tridiagonal form.
*          On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
*          orthonormal eigenvectors of the original Hermitian matrix,
*          and if COMPZ = 'I', Z contains the orthonormal eigenvectors
*          of the symmetric tridiagonal matrix.
*          If COMPZ = 'N', then Z is not referenced.
*
*  LDZ     (input) INTEGER
*          The leading dimension of the array Z.  LDZ >= 1, and if
*          eigenvectors are desired, then  LDZ >= max(1,N).
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
*          If COMPZ = 'N', then WORK is not referenced.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  the algorithm has failed to find all the eigenvalues in
*                a total of 30*N iterations; if INFO = i, then i
*                elements of E have not converged to zero; on exit, D
*                and E contain the elements of a symmetric tridiagonal
*                matrix which is unitarily similar to the original
*                matrix.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, THREE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0,
     $                   THREE = 3.0D+0 )
      COMPLEX*16         CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
      INTEGER            MAXIT
      PARAMETER          ( MAXIT = 30 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,
     $                   LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,
     $                   NM1, NMAXIT
      DOUBLE PRECISION   ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
     $                   S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANST, DLAPY2
      EXTERNAL           LSAME, DLAMCH, DLANST, DLAPY2
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLAE2, DLAEV2, DLARTG, DLASCL, DLASRT, XERBLA,
     $                   ZLASET, ZLASR, ZSWAP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SIGN, SQRT
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
*
      IF( LSAME( COMPZ, 'N' ) ) THEN
         ICOMPZ = 0
      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
         ICOMPZ = 1
      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
         ICOMPZ = 2
      ELSE
         ICOMPZ = -1
      END IF
      IF( ICOMPZ.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
     $         N ) ) ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZSTEQR', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
      IF( N.EQ.1 ) THEN
         IF( ICOMPZ.EQ.2 )
     $      Z( 1, 1 ) = CONE
         RETURN
      END IF
*
*     Determine the unit roundoff and over/underflow thresholds.
*
      OPS = OPS + 6
      EPS = DLAMCH( 'E' )
      EPS2 = EPS**2
      SAFMIN = DLAMCH( 'S' )
      SAFMAX = ONE / SAFMIN
      SSFMAX = SQRT( SAFMAX ) / THREE
      SSFMIN = SQRT( SAFMIN ) / EPS2
*
*     Compute the eigenvalues and eigenvectors of the tridiagonal
*     matrix.
*
      IF( ICOMPZ.EQ.2 )
     $   CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ )
*
      NMAXIT = N*MAXIT
      JTOT = 0
*
*     Determine where the matrix splits and choose QL or QR iteration
*     for each block, according to whether top or bottom diagonal
*     element is smaller.
*
      L1 = 1
      NM1 = N - 1
*
   10 CONTINUE
      IF( L1.GT.N )
     $   GO TO 160
      IF( L1.GT.1 )
     $   E( L1-1 ) = ZERO
      IF( L1.LE.NM1 ) THEN
         DO 20 M = L1, NM1
            TST = ABS( E( M ) )
            IF( TST.EQ.ZERO )
     $         GO TO 30
            OPS = OPS + 4
            IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+
     $          1 ) ) ) )*EPS ) THEN
               E( M ) = ZERO
               GO TO 30
            END IF
   20    CONTINUE
      END IF
      M = N
*
   30 CONTINUE
      L = L1
      LSV = L
      LEND = M
      LENDSV = LEND
      L1 = M + 1
      IF( LEND.EQ.L )
     $   GO TO 10
*
*     Scale submatrix in rows and columns L to LEND
*
      OPS = OPS + 2*( LEND-L+1 )
      ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) )
      ISCALE = 0
      IF( ANORM.EQ.ZERO )
     $   GO TO 10
      IF( ANORM.GT.SSFMAX ) THEN
         ISCALE = 1
         OPS = OPS + 2*( LEND-L ) + 1
         CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
     $                INFO )
         CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
     $                INFO )
      ELSE IF( ANORM.LT.SSFMIN ) THEN
         ISCALE = 2
         OPS = OPS + 2*( LEND-L ) + 1
         CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
     $                INFO )
         CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
     $                INFO )
      END IF
*
*     Choose between QL and QR iteration
*
      IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
         LEND = LSV
         L = LENDSV
      END IF
*
      IF( LEND.GT.L ) THEN
*
*        QL Iteration
*
*        Look for small subdiagonal element.
*
   40    CONTINUE
         IF( L.NE.LEND ) THEN
            LENDM1 = LEND - 1
            DO 50 M = L, LENDM1
               TST = ABS( E( M ) )**2
               OPS = OPS + 4
               IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+
     $             SAFMIN )GO TO 60
   50       CONTINUE
         END IF
*
         M = LEND
*
   60    CONTINUE
         IF( M.LT.LEND )
     $      E( M ) = ZERO
         P = D( L )
         IF( M.EQ.L )
     $      GO TO 80
*
*        If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
*        to compute its eigensystem.
*
         IF( M.EQ.L+1 ) THEN
            IF( ICOMPZ.GT.0 ) THEN
               OPS = OPS + 22
               CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
               WORK( L ) = C
               WORK( N-1+L ) = S
               OPS = OPS + 12*N
               CALL ZLASR( 'R', 'V', 'B', N, 2, WORK( L ),
     $                     WORK( N-1+L ), Z( 1, L ), LDZ )
            ELSE
               OPS = OPS + 15
               CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )
            END IF
            D( L ) = RT1
            D( L+1 ) = RT2
            E( L ) = ZERO
            L = L + 2
            IF( L.LE.LEND )
     $         GO TO 40
            GO TO 140
         END IF
*
         IF( JTOT.EQ.NMAXIT )
     $      GO TO 140
         JTOT = JTOT + 1
*
*        Form shift.
*
         OPS = OPS + 12
         G = ( D( L+1 )-P ) / ( TWO*E( L ) )
         R = DLAPY2( G, ONE )
         G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
*
         S = ONE
         C = ONE
         P = ZERO
*
*        Inner loop
*
         MM1 = M - 1
         OPS = OPS + 18*( M-L )
         DO 70 I = MM1, L, -1
            F = S*E( I )
            B = C*E( I )
            CALL DLARTG( G, F, C, S, R )
            IF( I.NE.M-1 )
     $         E( I+1 ) = R
            G = D( I+1 ) - P
            R = ( D( I )-G )*S + TWO*C*B
            P = S*R
            D( I+1 ) = G + P
            G = C*R - B
*
*           If eigenvectors are desired, then save rotations.
*
            IF( ICOMPZ.GT.0 ) THEN
               WORK( I ) = C
               WORK( N-1+I ) = -S
            END IF
*
   70    CONTINUE
*
*        If eigenvectors are desired, then apply saved rotations.
*
         IF( ICOMPZ.GT.0 ) THEN
            MM = M - L + 1
            OPS = OPS + 12*N*( MM-1 )
            CALL ZLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ),
     $                  Z( 1, L ), LDZ )
         END IF
*
         OPS = OPS + 1
         D( L ) = D( L ) - P
         E( L ) = G
         GO TO 40
*
*        Eigenvalue found.
*
   80    CONTINUE
         D( L ) = P
*
         L = L + 1
         IF( L.LE.LEND )
     $      GO TO 40
         GO TO 140
*
      ELSE
*
*        QR Iteration
*
*        Look for small superdiagonal element.
*
   90    CONTINUE
         IF( L.NE.LEND ) THEN
            LENDP1 = LEND + 1
            DO 100 M = L, LENDP1, -1
               OPS = OPS + 4
               TST = ABS( E( M-1 ) )**2
               IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+
     $             SAFMIN )GO TO 110
  100       CONTINUE
         END IF
*
         M = LEND
*
  110    CONTINUE
         IF( M.GT.LEND )
     $      E( M-1 ) = ZERO
         P = D( L )
         IF( M.EQ.L )
     $      GO TO 130
*
*        If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
*        to compute its eigensystem.
*
         IF( M.EQ.L-1 ) THEN
            IF( ICOMPZ.GT.0 ) THEN
               OPS = OPS + 22
               CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
               WORK( M ) = C
               WORK( N-1+M ) = S
               OPS = OPS + 12*N
               CALL ZLASR( 'R', 'V', 'F', N, 2, WORK( M ),
     $                     WORK( N-1+M ), Z( 1, L-1 ), LDZ )
            ELSE
               OPS = OPS + 15
               CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )
            END IF
            D( L-1 ) = RT1
            D( L ) = RT2
            E( L-1 ) = ZERO
            L = L - 2
            IF( L.GE.LEND )
     $         GO TO 90
            GO TO 140
         END IF
*
         IF( JTOT.EQ.NMAXIT )
     $      GO TO 140
         JTOT = JTOT + 1
*
*        Form shift.
*
         OPS = OPS + 12
         G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
         R = DLAPY2( G, ONE )
         G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
*
         S = ONE
         C = ONE
         P = ZERO
*
*        Inner loop
*
         LM1 = L - 1
         OPS = OPS + 18*( L-M )
         DO 120 I = M, LM1
            F = S*E( I )
            B = C*E( I )
            CALL DLARTG( G, F, C, S, R )
            IF( I.NE.M )
     $         E( I-1 ) = R
            G = D( I ) - P
            R = ( D( I+1 )-G )*S + TWO*C*B
            P = S*R
            D( I ) = G + P
            G = C*R - B
*
*           If eigenvectors are desired, then save rotations.
*
            IF( ICOMPZ.GT.0 ) THEN
               WORK( I ) = C
               WORK( N-1+I ) = S
            END IF
*
  120    CONTINUE
*
*        If eigenvectors are desired, then apply saved rotations.
*
         IF( ICOMPZ.GT.0 ) THEN
            MM = L - M + 1
            OPS = OPS + 12*N*( MM-1 )
            CALL ZLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ),
     $                  Z( 1, M ), LDZ )
         END IF
*
         OPS = OPS + 1
         D( L ) = D( L ) - P
         E( LM1 ) = G
         GO TO 90
*
*        Eigenvalue found.
*
  130    CONTINUE
         D( L ) = P
*
         L = L - 1
         IF( L.GE.LEND )
     $      GO TO 90
         GO TO 140
*
      END IF
*
*     Undo scaling if necessary
*
  140 CONTINUE
      IF( ISCALE.EQ.1 ) THEN
         OPS = OPS + 2*( LENDSV-LSV ) + 1
         CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
     $                D( LSV ), N, INFO )
         CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ),
     $                N, INFO )
      ELSE IF( ISCALE.EQ.2 ) THEN
         OPS = OPS + 2*( LENDSV-LSV ) + 1
         CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
     $                D( LSV ), N, INFO )
         CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ),
     $                N, INFO )
      END IF
*
*     Check for no convergence to an eigenvalue after a total
*     of N*MAXIT iterations.
*
      IF( JTOT.EQ.NMAXIT ) THEN
         DO 150 I = 1, N - 1
            IF( E( I ).NE.ZERO )
     $         INFO = INFO + 1
  150    CONTINUE
         RETURN
      END IF
      GO TO 10
*
*     Order eigenvalues and eigenvectors.
*
  160 CONTINUE
      IF( ICOMPZ.EQ.0 ) THEN
*
*        Use Quick Sort
*
         CALL DLASRT( 'I', N, D, INFO )
*
      ELSE
*
*        Use Selection Sort to minimize swaps of eigenvectors
*
         DO 180 II = 2, N
            I = II - 1
            K = I
            P = D( I )
            DO 170 J = II, N
               IF( D( J ).LT.P ) THEN
                  K = J
                  P = D( J )
               END IF
  170       CONTINUE
            IF( K.NE.I ) THEN
               D( K ) = D( I )
               D( I ) = P
               CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
            END IF
  180    CONTINUE
      END IF
      RETURN
*
*     End of ZSTEQR
*
      END


module prob_module

    use bl_types

    ! Here we hold the specific problem parameters
    real(dp_t), parameter :: uadv = 1.d0
    real(dp_t), parameter :: vadv = 0.d0
    real(dp_t), parameter :: wadv = 0.d0
    real(dp_t), parameter ::   mu = 2.d-2

end module prob_module


subroutine initialisation()
  use Globals
  use Utils

  implicit none

  real(8), dimension(gp_q, gp_q) :: aux_q

  allocate(shock_z(agents,periods))
  allocate(shock_q(agents,periods))
  allocate(shock_g(agents,periods))
  allocate(shock_mu(agents,periods))
  allocate(shock_lm(agents,periods))

  ! Set seed for fair price iteration
  call setseed(12345)

  ! Assigned
  open(unit=1, file='assigned.txt')
  read(1,*) mu    ! Average duration UI
  read(1,*) b_0   ! Default replacement ratio
  read(1,*) b_bar ! Benefits cap
  read(1,*) theta ! Capital share of output in aggregate production function
  read(1,*) delta ! Capital depreciation
  read(1,*) tau   ! Proportional tax on labor income
  close(1)

  ! Calibrated
  open(unit=2, file='calibrated.txt')
  read(2,*) alpha           ! Utility cost of working
  read(2,*) beta            ! Discount factor
  read(2,*) gamma_bar       ! Average search cost
  read(2,*) epsilon_gamma   ! Standard deviation search cost
  read(2,*) rho_z           ! Persistence productivity process
  read(2,*) sigma_epsilon   ! Standard deviation productivity process
  read(2,*) sigma_q         ! Standard deviation match quality process
  read(2,*) lambda_e        ! Probability of finding another job for employed agents
  read(2,*) lambda_u        ! Probability of finding a job for unemployed agents
  read(2,*) lambda_n        ! Probability of finding a job for OLD agents
  read(2,*) sigma           ! Probability of losing a job for employed agents
  close(2)

  ! Grid for assets
  a_values = loggrid(min_a, max_a, gp_a)

  ! Productivity process
  call tauchen(rho_z, sigma_epsilon, cover_z, gp_z, z_values, z_trans)
  z_values = exp(z_values)
  z_ssdist = my_ss(z_trans,gp_z)
  call realise_shocks(agents, periods, z_trans, gp_z, shock_z)

  ! Match quality process
  call tauchen(0.d0, sigma_q, cover_q, gp_q, q_values, aux_q)
  q_values = exp(q_values)
  q_trans = aux_q(1,:)
  call realise_shocks(agents, periods, aux_q, gp_q, shock_q)

  ! Search cost process
  gamma_values(1) = gamma_bar - epsilon_gamma
  gamma_values(2) = gamma_bar
  gamma_values(3) = gamma_bar + epsilon_gamma
  gamma_trans = 1.d0/real(gp_gamma)

  ! call random_integers(agents,periods,1,3,shock_g)

  ! UI process, 1: Entilted, 0: Not entailted
  IB_trans(1,1) = 1.d0 - mu
  IB_trans(1,0) = mu
  IB_trans(0,1) = 0.d0
  IB_trans(0,0) = 1.d0

  ! Guess inital prices
  KLratio = 119.60
  call Prices(KLratio, int_rate, wage)

  ! Guess average z and T
  average_z = 2.33
  T = 1.28

  ! Generate shocks
  call random_number(shock_lm)
  call realise_iid(agents, periods, mu, shock_mu)
  call random_integers(agents, periods, 1, gp_gamma, shock_g)
end subroutine initialisation

!===== REALISE SHOCKS =============================================================================
subroutine realise_shocks(agents, periods, trans_matrix, gp_tm, shocks)
  ! Computes the realised shock implied by trans_matrix, and returns it in shocks
  use Utils
  implicit none

  integer, intent(in) :: agents, periods, gp_tm
  integer :: ind_ag, ind_p, ind_sh
  integer, dimension(agents, periods), intent(out) :: shocks
  real(8) :: aux_sum
  real(8), dimension(gp_tm) :: ss_dist, aux_vec
  real(8), dimension(gp_tm,gp_tm), intent(in) :: trans_matrix
  real(8), dimension(agents, periods) :: aux_shocks

  call random_number(aux_shocks)

  ! Find steady state distribution
  ss_dist = my_ss(trans_matrix, gp_tm)

  ! Simulate for all periods
  do ind_ag = 1, agents
  do ind_p = 1, periods
    ! Chose auxiliary vector for first period
    if (ind_p.eq.1) then
      aux_vec = ss_dist
    else
      aux_vec = trans_matrix(shocks(ind_ag,ind_p-1),:)
    end if
    ! Find out shock
    aux_sum = 0.d0
    do ind_sh = 1, gp_tm
      aux_sum  = aux_sum + aux_vec(ind_sh)
      if (aux_sum.ge.aux_shocks(ind_ag,ind_p)) exit
    end do
    shocks(ind_ag,ind_p) = ind_sh
  end do
  end do
end subroutine realise_shocks

!===== REALISE SIMPLE IID SHOCKS ==================================================================
subroutine realise_iid(agents, periods, param_value, shocks)
  ! Computes the realised shock of an iid process

  implicit none

  integer, intent(in) :: agents, periods
  integer :: ind_ag, ind_p
  integer, dimension(agents, periods), intent(out) :: shocks
  real(8), intent(in) :: param_value
  real(8), dimension(agents, periods) :: aux_shocks

  shocks = 0

  call random_number(aux_shocks)

  do ind_ag = 1, agents
  do ind_p = 1, periods
    if (aux_shocks(ind_ag,ind_p).le.param_value) then
      shocks(ind_ag,ind_p) = 1
    end if
  end do
  end do
end subroutine realise_iid

!===== RANDOM INTEGERS ============================================================================
subroutine random_integers(rows, columns, lb, ub, int_matrix)
  ! Returns a int_matrix(rows, columns) of random integer number numbers in [lb,ub]
  integer, intent(in) :: rows, columns, lb, ub
  integer, dimension(rows, columns), intent(out) :: int_matrix
  real(8), dimension(rows, columns) :: aux_mat

  call random_number(aux_mat)

  int_matrix = lb + floor(real(ub+1-lb)*aux_mat)
end subroutine random_integers


subroutine SHRotateCoef(x, cof, rcof, dj, lmax, exitstatus)
!------------------------------------------------------------------------------
!
!   This subroutine will rotate a set of spherical harmonic coefficients (see
!   documentation in SHRotateRealCoef for a description of how rotation angles
!   are defined.) All angles are measured in radians, and spherical harmonic
!   coefficients are fully normalized as in Edmonds, 1960. Note that Euler
!   angles are different in Goldstein and Edmonds.
!
!   This routine uses the "y-convention" where rotations are about the y axis
!   instead of the x axis.
!
!   djpi2 must be called before using this routine.
!
!   Calling Parameters
!
!       IN
!           x       Array of dimension 3 containing the three Euler angles
!                   in radians.
!           dj      Roation matrix with dimension (lmax+1, lmax+1, lmax+1).
!           cof     Indexed spherical harmonic coefficients with dimensions
!                   (2, (lmax+1)*(lmax+2)/2).
!           lmax    Maximum spherical harmonic degree.
!
!       OUT
!           rcof    Indexed rotated spherical harmonic coefficients with
!                   dimensions (2, (lmax+1)*(lmax+2)/2).
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   History:
!       1.  Based on routine from Guy Masters (July16, 1993)
!       2.  Modified by Mark Simons (July 25, 1993)
!       3.  Turned into readable f95 code by Mark Wieczorek (August, 2003)
!
!   Copyright (c) 2016, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    implicit none

    real*8, intent(in) :: cof(:,:), dj(:,:,:), x(3)
    real*8, intent(out) :: rcof(:,:)
    integer, intent(in) :: lmax
    integer, intent(out), optional :: exitstatus
    real*8 :: sum(2), temp(2,lmax+1), temp2(2,lmax+1), cgam(lmax+1), &
              sgam(lmax+1), calf(lmax+1), salf(lmax+1), cbet(lmax+1), &
              sbet(lmax+1), pi2, alpha, beta, gamma
    integer ::  ind, lp1, l, mp1, jp1, isgn, ii, indx

    if (present(exitstatus)) exitstatus = 0

    if (size(cof(:,1)) < 2 .or. size(cof(1,:)) < ((lmax+1)*(lmax+2))/2) then
        print*, "Error --- SHRotateCoef"
        print*, "COEF must be dimensioned (2, (LMAX+1)*(LMAX+2)/2) " // &
                "where LMAX is ", lmax
        print*, "Input array is dimensioned ", size(cof(:,1)),  size(cof(1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(rcof(:,1)) < 2 .or. size(rcof(1,:)) &
            < ((lmax+1)*(lmax+2))/2) then
        print*, "Error --- SHRotateCoef"
        print*, "RCOEF must be dimensioned (2, (LMAX+1)*(LMAX+2)/2) " // &
                "where LMAX is ", lmax
        print*, "Input array is dimensioned ", size(rcof(:,1)),  size(rcof(1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(dj(:,1,1)) < lmax+1 .or. size(dj(1,:,1)) < lmax+1 &
            .or. size(dj(1,1,:)) < lmax+1 ) then
        print*, "Error --- SHRotateCoef"
        print*, "DJ must be dimensioned (LMAX+1, LMAX+1, LMAX+1) " // &
                "where LMAX is ", lmax
        print*, "Input array is dimensioned ", size(dj(:,1,1)), &
                size(dj(1,:,1)), size(dj(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    rcof = 0.0d0

    pi2 = 1.570796326794895d0

    alpha = x(1)
    beta  = x(2)
    gamma = x(3)

    alpha = alpha - pi2
    gamma = gamma + pi2
    beta = -beta

    ind = 0

    ! Loop over degrees
    do lp1 = 1, lmax+1
        l = lp1-1
        cbet(lp1) = cos(l*beta)
        sbet(lp1) = sin(l*beta)
        cgam(lp1) = cos(l*gamma)
        sgam(lp1) = sin(l*gamma)
        calf(lp1) = cos(l*alpha)
        salf(lp1) = sin(l*alpha)

        ! Alpha rotation
        do mp1 = 1, lp1
            indx = ind+mp1
            temp(1,mp1) = cof(1,indx) * calf(mp1) - cof(2,indx) * salf(mp1)
            temp(2,mp1) = cof(2,indx) * calf(mp1) + cof(1,indx) * salf(mp1)

        end do

        ! B rotation and beta rotation
        do jp1 = 1, lp1
            sum(1) = dj(jp1,1,lp1) * temp(1,1)
            sum(2) = 0.d0
            isgn = 1 - 2 * mod((lp1-jp1),2)

            do mp1 = 2, lp1
                isgn = -isgn
                ii = (3-isgn) / 2
                sum(ii) = sum(ii) + 2.d0 * dj(jp1,mp1,lp1) * temp(ii,mp1)
            end do

            temp2(1,jp1) = sum(1) * cbet(jp1) - sum(2) * sbet(jp1)
            temp2(2,jp1) = sum(2) * cbet(jp1) + sum(1) * sbet(jp1)

        end do

        ! Inverse B rotation and gamma rotation
        do jp1 = 1, lp1
            sum(1) = dj(1,jp1,lp1) * temp2(1,1)
            sum(2) = 0.d0
            isgn = 1 - 2*mod((lp1-jp1),2)

            do mp1 = 2,lp1
                isgn = -isgn
                ii = (3-isgn) / 2
                sum(ii) = sum(ii) + 2.d0 * dj(mp1,jp1,lp1) * temp2(ii,mp1)

            end do

            indx = ind + jp1
            rcof(1,indx) = sum(1) * cgam(jp1) - sum(2) * sgam(jp1)
            rcof(2,indx) = sum(2) * cgam(jp1) + sum(1) * sgam(jp1)

        end do

        ind = ind+lp1

    end do

end subroutine SHRotateCoef


submodule (complex_transform_routines) complex_initialization_routines

contains

    module subroutine cfft1i(n, wsave, lensav, ierror)
        !
        ! cfft1i: initialization for cfft1b and cfft1f.
        !
        !  Purpose:
        !
        !  cfft1i initializes array wsave for use in its companion routines
        !  cfft1b and cfft1f. Routine cfft1i must be called before the first
        !  call to cfft1b or cfft1f, and after whenever the value of integer
        !  n changes.
        !
        !  Parameters:
        !
        !  input,
        !  n, the length of the sequence to be
        !  transformed.  the transform is most efficient when n is a product
        !  of small primes.
        !
        !  input
        !  lensav, the dimension of the wsave array.
        !  lensav must be at least 2*n + int(log(real(n))) + 4.
        !
        !  output,
        !  wsave(lensav), containing the prime factors
        !  of n and  also containing certain trigonometric values which will be used
        !  in routines cfft1b or cfft1f.
        !
        !  output
        !  ierror, error_flag.
        !  0, successful exit;
        !  2, input parameter lensav not big enough.
        !
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer (ip), intent (in)  :: n
        real (wp),    intent (out) :: wsave(lensav)
        integer (ip), intent (in)  :: lensav
        integer (ip), intent (out) :: ierror
        !--------------------------------------------------------------
        ! Local variables
        !--------------------------------------------------------------
        integer (ip) :: iw1, iw2
        !--------------------------------------------------------------

        !
        !==> Check validity of input arguments
        !
        if ( size(wsave) < get_complex_1d_saved_workspace_length(n) ) then
            ierror = 2
            call fft_error_handler('cfftmi ', 3)
        else
            ierror = 0
        end if

        !
        !==> Perform transform
        !
        if (n == 1) return

        ! Set workspace indices
        iw1 = 2*n+1
        iw2 = iw1 + 1

        call initialize_factors_and_trig_tables(n, wsave, wsave(iw1), wsave(iw2))

    end subroutine cfft1i

    module subroutine cfft2i(l, m, wsave, lensav, ierror)
        !
        ! cfft2i: initialization for cfft2b and cfft2f.
        !
        !  purpose:
        !
        !  cfft2i initializes real array wsave for use in its companion
        !  routines cfft2f and cfft2b for computing two-dimensional fast
        !  fourier transforms of complex data.  prime factorizations of l and m,
        !  together with tabulations of the trigonometric functions, are
        !  computed and stored in array wsave.
        !
        !  on 10 may 2010, this code was modified by changing the value
        !  of an index into the wsave array.
        !
        !  input
        !  integer l, the number of elements to be transformed
        !  in the first dimension. the transform is most efficient when l is a
        !  product of small primes.
        !
        !  integer m, the number of elements to be transformed
        !  in the second dimension. the transform is most efficient when m is a
        !  product of small primes.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least
        !
        !  2*(l+m) + int(log(real(l)))+ int(log(real(m))) + 8.
        !
        !  output
        !  real wsave(lensav), contains the prime factors of l
        !  and m, and also certain trigonometric values which will be used in
        !  routines cfft2b or cfft2f.
        !
        !  integer  ierror, error_flag.
        !  0, successful exit;
        !  2, input parameter lensav not big enough;
        !  20, input error returned by lower level routine.
        !
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer (ip), intent (in)  :: l
        integer (ip), intent (in)  :: m
        real (wp),    intent (out) :: wsave(lensav)
        integer (ip), intent (in)  :: lensav
        integer (ip), intent (out) :: ierror
        !--------------------------------------------------------------
        ! Local variables
        !--------------------------------------------------------------
        integer (ip) local_error_flag
        !--------------------------------------------------------------

        !
        !==> Check validity of input arguments
        !
        if (size(wsave) < get_complex_2d_saved_workspace_length(l, m)) then
            ierror = 2
            call fft_error_handler('cfft2i', 4)
            return
        else
            ierror = 0
        end if

        associate( lnsv => get_complex_1d_saved_workspace_length(l) )

            call cfftmi(l, wsave(1:), lnsv, local_error_flag)

        end associate

        ! Check error_flag
        if ( local_error_flag /= 0) then
            ierror = 20
            call fft_error_handler('cfft2i',-5)
            return
        end if

        associate( &
            iw => get_1d_saved_workspace_length(l) - 1, &
            lnsv => get_1d_saved_workspace_length(m) &
            )

            call cfftmi(m, wsave(iw:), lnsv, local_error_flag)

        end associate

        ! Check error_flag
        if (local_error_flag /= 0) then
            ierror = 20
            call fft_error_handler('cfft2i',-5)
        end if

    end subroutine cfft2i

    module subroutine cfftmi(n, wsave, lensav, ierror)
        !
        !  cfftmi: initialization for cfftmb and cfftmf.
        !
        !  purpose:
        !
        !  cfftmi initializes array wsave for use in its companion routines
        !  cfftmb and cfftmf.  cfftmi must be called before the first call
        !  to cfftmb or cfftmf, and after whenever the value of integer n changes.
        !
        !  parameters:
        !
        !  integer n, the length of each sequence to be
        !  transformed.  the transform is most efficient when n is a product of
        !  small primes.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least 2*n + int(log(real(n))) + 4.
        !
        !  real wsave(lensav), containing the prime factors
        !  of n and also containing certain trigonometric values which will be used in
        !  routines cfftmb or cfftmf.
        !
        !  integer ierror, error_flag.
        !  0, successful exit;
        !  2, input parameter lensav not big enough.
        !
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer (ip), intent (in)  :: n
        real (wp),    intent (out) :: wsave(lensav)
        integer (ip), intent (in)  :: lensav
        integer (ip), intent (out) :: ierror
        !--------------------------------------------------------------
        ! Local variables
        !--------------------------------------------------------------
        integer (ip) :: iw1, iw2
        !--------------------------------------------------------------

        !
        !==> Check validity of input arguments
        !
        if (lensav < get_complex_nd_saved_workspace_length(n) ) then
            ierror = 2
            call fft_error_handler('cfftmi ', 3)
            return
        else
            ierror = 0
        end if

        !
        !==>  Perform transform
        !
        if (n == 1) return

        ! Set workspace index pointer
        iw1 = 2*n+1
        iw2 = iw1 + 1

        call initialize_factors_and_trig_tables(n, wsave, wsave(iw1), wsave(iw2:))

    end subroutine cfftmi

    pure subroutine initialize_factors_and_trig_tables(n, wa, fnf, fac)
        !
        ! Purpose:
        !
        ! Sets up factors and trig tables
        !
        !--------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------
        integer (ip), intent (in)  :: n
        real (wp),    intent (out) :: wa(*)
        real (wp),    intent (out) :: fnf
        real (wp),    intent (out) :: fac(*)
        !--------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------
        integer (ip) :: ido, iip, iw, k1, l1, l2, nf
        !--------------------------------------------------

        !
        !==> Get the factorization of n.
        !
        call compute_factorization(n, nf, fac)
        fnf = real(nf, kind=wp)
        iw = 1
        l1 = 1
        !
        !==> Set up the trigonometric tables.
        !
        do k1 = 1, nf
            iip = int(fac(k1), kind=ip)
            l2 = l1 * iip
            ido = n / l2
            call compute_trig_table(ido, iip, wa(iw))
            iw = iw + (iip - 1) * (2*ido)
            l1 = l2
        end do

    end subroutine initialize_factors_and_trig_tables

    pure subroutine compute_factorization(n, nf, fac)
        !
        ! Purpose:
        !
        ! Factors of an integer for wp-kind float precision computations.
        !
        !  Parameters:
        !
        !  n, the number for which factorization and other information is needed.
        !
        !  nf, the number of factors.
        !
        !  fac(*), a list of factors of n.
        !
        !--------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------
        integer (ip), intent (in)  :: n
        integer (ip), intent (out) :: nf
        real (wp),    intent (out) :: fac(*)
        !--------------------------------------------------
        ! Local variables
        !--------------------------------------------------
        integer (ip) :: j, nl, nq, nr, ntry
        !--------------------------------------------------

        ntry = 0
        nl = n
        nf = 0
        j = 0

        do while (1 < nl)
            j = j + 1
            select case (j)
                case (1)
                    ntry = 4
                case (2:3)
                    ntry = j
                case (4)
                    ntry = 5
                case default
                    ntry = ntry + 2
            end select

            inner_loop: do
                nq = nl / ntry
                nr = nl - ntry * nq

                if ( nr /= 0 ) then
                    exit inner_loop
                end if

                nf = nf + 1
                fac(nf) = real(ntry, kind=wp)
                nl = nq

            end do inner_loop
        end do

    end subroutine compute_factorization

    pure subroutine compute_trig_table(ido, iip, wa)
        !
        ! Purpose:
        !
        ! Computes trigonometric tables for wp-kind float precision arithmetic.
        !
        !--------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------
        integer (ip), intent (in)  :: ido
        integer (ip), intent (in)  :: iip
        real (wp),    intent (out) :: wa(ido,iip-1,2)
        !--------------------------------------------------
        ! Local variables
        !--------------------------------------------------
        integer (ip)         :: i, j !! Counters
        real (wp), parameter :: TWO_PI = TWO * acos(-ONE)
        real (wp)            :: argz, arg1, arg2, arg3, arg4
        !--------------------------------------------------

        argz = TWO_PI/iip
        arg1 = TWO_PI/( ido * iip)

        do j = 2, iip
            arg2 = real(j - 1, kind=wp) * arg1
            do i = 1, ido
                arg3 = real(i - 1, kind=wp) * arg2
                wa(i,j-1,1) = cos(arg3)
                wa(i,j-1,2) = sin(arg3)
            end do
            if (5 < iip) then
                arg4 = real(j - 1, kind=wp) * argz
                wa(1,j-1,1) = cos(arg4)
                wa(1,j-1,2) = sin(arg4)
            end if
        end do

    end subroutine compute_trig_table

end submodule complex_initialization_routines


!RUN: %f18 -fdebug-dump-symbols %s | FileCheck %s

! Size and alignment of intrinsic types
subroutine s1
  integer(1) :: a_i1  !CHECK: a_i1 size=1 offset=0:
  integer(8) :: b_i8  !CHECK: b_i8 size=8 offset=8:
  real(2)    :: c_r2  !CHECK: c_r2 size=2 offset=16:
  real(2)    :: d_r2  !CHECK: d_r2 size=2 offset=18:
  real(8)    :: e_r8  !CHECK: e_r8 size=8 offset=24:
  real(4)    :: f_r4  !CHECK: f_r4 size=4 offset=32:
  complex(8) :: g_c8  !CHECK: g_c8 size=16 offset=40:
  complex(4) :: h_c4  !CHECK: h_c4 size=8 offset=56:
  logical    :: i_l4  !CHECK: i_l4 size=4 offset=64:
end

! Character
subroutine s2
  character(10)        :: c1 !CHECK: c1 size=10 offset=0:
  character(1)         :: c2 !CHECK: c2 size=1 offset=10:
  character(10,kind=2) :: c3 !CHECK: c3 size=20 offset=12:
end

! Descriptors
subroutine s3(n)
  integer :: n
  real, pointer :: x !CHECK: x, POINTER size=24 offset=8:
  character(n)  :: y !CHECK: y size=24 offset=32:
end

! Descriptors for arrays
subroutine s4
  integer, allocatable :: z0        !CHECK: z0, ALLOCATABLE size=24 offset=
  integer, allocatable :: z1(:)     !CHECK: z1, ALLOCATABLE size=48 offset=
  integer, allocatable :: z2(:,:)   !CHECK: z2, ALLOCATABLE size=72 offset=
  integer, allocatable :: z3(:,:,:) !CHECK: z3, ALLOCATABLE size=96 offset=
end

! Descriptors with length parameters
subroutine s5(n)
  integer :: n
  type :: t1(l)
    integer, len :: l
    real :: a(l)
  end type
  type :: t2(l1, l2)
    integer, len :: l1
    integer, len :: l2
    real :: b(l1, l2)
  end type
  type(t1(n))   :: x1 !CHECK: x1 size=48 offset=
  type(t2(n,n)) :: x2 !CHECK: x2 size=56 offset=
  !CHECK: a size=48 offset=0:
  !CHECK: b size=72 offset=0:
end


! BSD 3-Clause License
!
!  Copyright (c) 2021, Fabio Durastante, Lidia Aceto
!  All rights reserved.
!
!  Redistribution and use in source and binary forms, with or without
!  modification, are permitted provided that the following conditions are met:
!
!  1. Redistributions of source code must retain the above copyright notice, this
!     list of conditions and the following disclaimer.
!
!  2. Redistributions in binary form must reproduce the above copyright notice,
!     this list of conditions and the following disclaimer in the documentation
!     and/or other materials provided with the distribution.
!
!  3. Neither the name of the copyright holder nor the names of its
!     contributors may be used to endorse or promote products derived from
!     this software without specific prior written permission.
!
!  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
!  AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
!  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
!  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
!  FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
!  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
!  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
!  CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
!  OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
!  OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
program mainarditest
   ! This test program produces information relative to the error analysis in
   ! double and quadruple precision.
   use iso_fortran_env
   use wrightmod
   implicit none

   ! Parameters
   integer, parameter      :: N = 25
   real(real64)  :: D_PI = 3.141592653589793_real64
   real(real128) :: T_PI = 3.1415926535897932384626433832795_real128

   write(output_unit,'("Test for closed forms of the Mainardi function.")')
   ! Test in double precision
   call mainarditest1()

   ! Test in quadruple precision for λ = -0.5 μ = 0.5
   call mainarditest2(17)
   call mainarditest2(23)
   call mainarditest2(30)
   call mainarditest2(37)

   ! Test in quadruple precision for λ = 0 μ = 0
   call mainarditest3(17)
   call mainarditest3(23)
   call mainarditest3(30)
   call mainarditest3(37)

contains

   subroutine mainarditest1()
      ! This subroutine implements the numerical test of accuracy for the
      ! routine in double precision with respect to a known function.

      ! Values
      real(real64) :: x(N), true(N)
      real(real64), allocatable :: w(:)
      real(real64) lambda, mu, h
      real(real64) :: t = 1.0_real64
      ! Auxiliary variables
      integer i

      h = 10.0_real64/(real(N,real64)-1.0)
      do i=1,N
         x(i) = -5.0_real64 + real((i-1),real64)*h
      end do

      write(output_unit,'("(real64) With λ = -0.5 μ = 0.5 W = exp(-z^2/4)sqrt(pi)")')
      lambda = -0.5_real64
      mu = 0.5_real64
      w = wright(x, t, lambda, mu)
      true = exp(-(abs(x)**2)/4.0_real64)/sqrt(D_PI)
      open (unit = 99, file = "mainardi1.out")
      do i=1,N
         write(99,'(f20.16,",",f20.16,",",f20.16)')x(i),w(i),true(i)
      end do
      close(99)

      deallocate(w)

   end subroutine mainarditest1

   subroutine mainarditest2(qnodes)
      ! This subroutine implements the numerical test of accuracy for the
      ! routine in triple precision with respect to a known function.
      integer, optional :: qnodes

      ! Values
      real(real128) :: x(N), true(N)
      real(real128), allocatable :: w(:)
      real(real128) lambda, mu, h
      real(real128) :: t = 1.0_real128
      ! Auxiliary variables
      integer i
      character(len=10) :: file_id
      character(len=50) :: file_name

      h = 10.0_real128/(real(N,real128)-1.0)
      do i=1,N
         x(i) = -5.0_real128 + real((i-1),real64)*h
      end do

      write(output_unit,'("(real128) With λ = -0.5 μ = 0.5 W = exp(-z^2/4)sqrt(pi)")')
      lambda = -0.5_real128
      mu = 0.5_real128
      w = wright(x, t, lambda, mu, qnodes)
      true = exp(-(abs(x)**2)/4.0_real128)/sqrt(T_PI)

      open (unit = 99, file = "mainardi2.out")
      do i=1,N
         write(99,'(f20.16,",",f40.36,",",f40.36)')x(i),w(i),true(i)
      end do
      close(99)

      if ( present(qnodes) ) then
         write(file_id,'(i2)')qnodes
      else
         write(file_id,'("37")')
      end if
      file_name = "mainardi-m12-quadruple-" // trim(file_id) // ".out"

      open (unit = 99, file = trim(file_name))
      do i=1,N
         write(99,'(f20.16,",",f40.36)')x(i),abs(w(i)-true(i))/true(i)
      end do
      close(99)

      deallocate(w)

   end subroutine mainarditest2

   subroutine mainarditest3(qnodes)
      ! This subroutine implements the numerical test of accuracy for the
      ! routine in triple precision with respect to a known function.
      integer, optional :: qnodes

      ! Values
      real(real128) :: x(N), true(N)
      real(real128), allocatable :: w(:)
      real(real128) lambda, mu, h
      real(real128) :: t = 1.0_real128
      ! Auxiliary variables
      integer i
      character(len=10) :: file_id
      character(len=50) :: file_name

      h = 10.0_real128/(real(N,real128)-1.0)
      do i=1,N
         x(i) = -5.0_real128 + real((i-1),real64)*h
      end do

      write(output_unit,'("(real128) With λ = 0 μ = 1.0 W = exp(-|z|)")')
      lambda = 0.0_real128
      mu = 1.0_real128
      w = wright(x, t, lambda, mu, qnodes)
      true = exp(-abs(x))

      open (unit = 99, file = "mainardi3.out")
      do i=1,N
         write(99,'(f20.16,",",f40.36,",",f40.36)')x(i),w(i),true(i)
      end do
      close(99)

      if ( present(qnodes) ) then
         write(file_id,'(i2)')qnodes
      else
         write(file_id,'("37")')
      end if
      file_name = "mainardi-m0-quadruple-" // trim(file_id) // ".out"

      open (unit = 99, file = trim(file_name))
      do i=1,N
         write(99,'(f20.16,",",f40.36)')x(i),abs(w(i)-true(i))/true(i)
      end do
      close(99)

      deallocate(w)

   end subroutine mainarditest3

end program


! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
! test for implied-shape array

program test
  implicit none
  integer, parameter :: n = 26
  real, parameter :: a1(5:*) = sin((/1.1, 2.2, 3.3, 4.4, 5.5/)) * 1.234
  real, dimension(*), parameter :: a2 = a1
  character(len=*), parameter :: a3(*) = (/character(len=5) ::                 &
                                           "a", "bb", "ccc", "dddd", "eeeee"/)
  integer, parameter :: a4(5:*, *) = reshape((/1, 10, 100, 1000, 10000,        &
                                               2, 20, 200, 2000, 20000/),      &
                                             (/2, 5/))
  integer, parameter :: a5(*, *) = reshape((/1, 10, 100, 1000, 10000,          &
                                             2, 20, 200, 2000, 20000/),        &
                                           (/2, 5/))
  integer, parameter :: a6(*, *, *) = reshape((/1, 2, 3, 4, 5, 6, 7, 8/),      &
                                              (/2, 2, 2/))
  integer :: rslt(n), expt(n)

  expt = (/                    &
           5, 9, 5,            &
           1, 5, 5,            &
           1, 5, 5,            &
           5, 1, 6, 5, 10,     &
           1, 1, 2, 5, 10,     &
           1, 1, 1, 2, 2, 2, 8 &
          /)

  rslt(1:9) = (/                                  &
                lbound(a1), ubound(a1), size(a1), &
                lbound(a2), ubound(a2), size(a2), &
                lbound(a3), ubound(a3), size(a3)  &
               /)
  rslt(10:14) = (/ lbound(a4, dim=1), lbound(a4, dim=2), &
                   ubound(a4, dim=1), ubound(a4, dim=2), size(a4) /)
  rslt(15:19) = (/ lbound(a5, dim=1), lbound(a5, dim=1), &
                   ubound(a5, dim=1), ubound(a5, dim=2), size(a5) /)
  rslt(20:26) = (/ lbound(a6, dim=1), lbound(a6, dim=2), &
                   lbound(a6, dim=3), ubound(a6, dim=1), &
                   ubound(a6, dim=2), ubound(a6, dim=3), size(a6) /)

  call check(rslt, expt, n)

end program test


c     DRDINT1F
c>> 2000-12-03 DRDINT1F Krogh  Declared WORK as WORK(1) in DINTF.
c>> 1994-11-02 DRDINT1F Krogh  Changes to use M77CON
c>> 1994-08-08 DRDINT1F Snyder Took '0' out of formats for C conversion
c>> 1993-05-05 DRDINT1F Krogh  Adjusted to simplify conversion to C.
c>> 1987-12-09 DRDINT1F Snyder Initial Code.
c--D replaces "?": DR?INT1f, ?INT1, ?INTF
c
c     DEMO DRIVER for 1 dimensional quadrature subprogram DINT1.
c
c     Compute the integral for X = 0.0 to X = PI of SIN(X), then
c     subtract 2.0 from the ANSWER.  The result should be zero.
c
c     The integrand is evaluated by the subprogram DINTF.
c
c
      double precision A, B, ANSWER, WORK(1)
      integer IOPT(10)
10    format (/
     1' DRDINT1F:'/
     2' Compute the integral for X = 0.0 to X = PI of SIN(X), then'/
     3' subtract 2.0 from the ANSWER.  The result should be zero.')
20    format (/' ANSWER          =',G15.8/
     1         ' ERROR ESTIMATE  =',G15.8/
     2         ' STATUS FLAG     =',I6/
     3         ' FUNCTION VALUES =',I6)
c
      print 10
      A = 0.0D0
      B = 4.0D0 * ATAN(1.0D0)
      IOPT(2) = 10
      IOPT(3) = 0
      IOPT(4) = 0
c
      call DINT1 (A, B, ANSWER, WORK, IOPT)
      ANSWER = ANSWER - 2.0d0
      print 20, ANSWER, WORK(1), IOPT(1), IOPT(3)
      stop
      end
c   End of DRDINT1F

      subroutine DINTF (ANSWER, WORK, IFLAG)
c
c     Subroutine to provide integrand for DINT1.
c
      double precision ANSWER, WORK(1)
      integer IFLAG
c
c     IFLAG is not used in this example.
c
      answer = sin(work(1))
      return
c
      end


!---------------------------------------------------------------------!
!                                PHAML                                !
!                                                                     !
! The Parallel Hierarchical Adaptive MultiLevel code for solving      !
! linear elliptic partial differential equations of the form          !
! (PUx)x + (QUy)y + RU = F on 2D polygonal domains with mixed         !
! boundary conditions, and eigenvalue problems where F is lambda*U.   !
!                                                                     !
! PHAML is public domain software.  It was produced as part of work   !
! done by the U.S. Government, and is not subject to copyright in     !
! the United States.                                                  !
!                                                                     !
!     William F. Mitchell                                             !
!     Applied and Computational Mathematics Division                  !
!     National Institute of Standards and Technology                  !
!     william.mitchell@nist.gov                                       !
!     http://math.nist.gov/phaml                                      !
!                                                                     !
!---------------------------------------------------------------------!

!----------------------------------------------------
! This file contains the user supplied external subroutines that define
! the PDE(s) to be solved, and other required external subroutines.
!   pdecoefs bconds boundary_point boundary_npiece boundary_param iconds trues
!   truexs trueys update_usermod phaml_integral_kernel
!
! This version illustrates a singularity on an L shaped domain.
!----------------------------------------------------

!          --------
subroutine pdecoefs(x,y,cxx,cxy,cyy,cx,cy,c,rs)
!          --------

!----------------------------------------------------
! This subroutine returns the coefficient and right hand side of the PDE
! at the point (x,y)
!
! The PDE is
!
!    -( cxx(x,y) * u  )  -( cyy(x,y) * u  ) + c(x,y) * u = rs(x,y)
!                   x  x                y  y
!
! For eigenvalue problems, the right hand side is lambda * u * rs(x,y)
!
! cxy, cx and cy are not currently used and should not be set.  They are
! for future expansion.
!
! NOTE: BE CAREFUL TO GET THE SIGNS RIGHT
! e.g. cxx=cyy=1 means rs=-(uxx+uyy)
!
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x,y
real(my_real), intent(out) :: cxx(:,:),cxy(:,:),cyy(:,:),cx(:,:),cy(:,:), &
                              c(:,:),rs(:)
!----------------------------------------------------

!----------------------------------------------------
! Local variables

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

!----------------------------------------------------
! Begin executable code

cxx(1,1) = 1.0_my_real
cyy(1,1) = 1.0_my_real
c(1,1) = 0.0_my_real
rs(1) = 0.0_my_real

cxy=0; cx=0; cy=0

end subroutine pdecoefs

!          ------
subroutine bconds(x,y,bmark,itype,c,rs)
!          ------

!----------------------------------------------------
! This subroutine returns the boundary conditions at the point (x,y).
!
! Each boundary condition is either
!
!    u = rs(x,y) or  u  + c(x,y)*u = rs(x,y)
!                     n
!
! itype indicates which type of condition applies to each point, using
! symbolic constants from module phaml.  It is DIRICHLET for the first
! condition, NATURAL for the second condition with c==0, and MIXED for
! the second condition with c/=0.
!
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x,y
integer, intent(in) :: bmark
integer, intent(out) :: itype(:)
real(my_real), intent(out) :: c(:,:),rs(:)
!----------------------------------------------------

!----------------------------------------------------
! Non-module procedures used are:

interface

   function trues(x,y,comp,eigen) ! real (my_real)
   use phaml
   real (my_real), intent(in) :: x,y
   integer, intent(in) :: comp,eigen
   real (my_real) :: trues
   end function trues

end interface

!----------------------------------------------------
! Local variables

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

!----------------------------------------------------
! Begin executable code

! Dirichlet boundary conditions

itype = DIRICHLET
c = 0.0_my_real
rs(1) = trues(x,y,1,1)

end subroutine bconds

!        ------
function iconds(x,y,comp,eigen)
!        ------

!----------------------------------------------------
! This routine returns the initial condition for a time dependent problem.
! It can also be used for the initial guess for a nonlinear problem, or
! systems of equations solved by sucessive substitution.
! comp,eigen is which solution to use from a coupled system of PDEs or multiple
! eigenvectors from an eigenvalue problem, and is ignored in this example.
! For problems where there are no initial conditions, it is a dummy.
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real(my_real) :: iconds

!----------------------------------------------------
! Begin executable code

iconds = 0.0_my_real

end function iconds

!        -----
function trues(x,y,comp,eigen) ! real (my_real)
!        -----

!----------------------------------------------------
! This is the true solution of the differential equation, if known.
! comp,eigen is which solution to use from a coupled system of PDEs or multiple
! eigenvectors from an eigenvalue problem, and is ignored in this example.
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real (my_real) :: trues
!----------------------------------------------------
! Local variables

real (my_real) :: r,theta1
!----------------------------------------------------
! Begin executable code

! singularity at the origin, reflecting the reentrant corner

r = sqrt(x*x+y*y)
theta1 = atan2(y,x)
if (theta1 < 0.0_my_real) theta1 = theta1 + 8.0_my_real*atan(1.0_my_real)
trues = r**(2.0_my_real/3.0_my_real)*sin(2.0_my_real*theta1/3.0_my_real)

end function trues

!        -----
function truexs(x,y,comp,eigen) ! real (my_real)
!        -----

!----------------------------------------------------
! Modules used are:

use phaml
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real (my_real) :: truexs
!----------------------------------------------------
! Local variables

real (my_real) :: r,theta1,c
!----------------------------------------------------
! Begin executable code

! singularity at the origin, reflecting the reentrant corner

r = sqrt(x*x+y*y)
theta1 = atan2(y,x)
if (theta1 < 0.0_my_real) theta1 = theta1 + 8.0_my_real*atan(1.0_my_real)
c = 2.0_my_real/3.0_my_real
truexs = c*r**(c-2)*(x*sin(c*theta1) - y*cos(c*theta1))

end function truexs

!        -----
function trueys(x,y,comp,eigen) ! real (my_real)
!        -----

!----------------------------------------------------
! Modules used are:

use phaml
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real (my_real) :: trueys
!----------------------------------------------------
! Local variables

real (my_real) :: r,theta1,c
!----------------------------------------------------
! Begin executable code

! singularity at the origin, reflecting the reentrant corner

r = sqrt(x*x+y*y)
theta1 = atan2(y,x)
if (theta1 < 0.0_my_real) theta1 = theta1 + 8.0_my_real*atan(1.0_my_real)
c = 2.0_my_real/3.0_my_real
trueys = c*r**(c-2)*(y*sin(c*theta1) + x*cos(c*theta1))

end function trueys

!          --------------
subroutine boundary_point(ipiece,s,x,y)
!          --------------

!----------------------------------------------------
! This routine defines the boundary of the domain.  It returns the point
! (x,y) with parameter s on piece ipiece.
! If boundary_npiece <= 0 it is a dummy and the domain is given by triangle
! data files.
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

integer, intent(in) :: ipiece
real(my_real), intent(in) :: s
real(my_real), intent(out) :: x,y

!----------------------------------------------------
! Begin executable code

! Dummy version

x = 0.0_my_real
y = 0.0_my_real

end subroutine boundary_point

!        ---------------
function boundary_npiece(hole)
!        ---------------

!----------------------------------------------------
! This routine gives the number of pieces in the boundary definition.
! If boundary_npiece <= 0 the domain is given by triangle data files.
!----------------------------------------------------

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

implicit none

!----------------------------------------------------
! Dummy arguments

integer, intent(in) :: hole
integer :: boundary_npiece
!----------------------------------------------------
! Begin executable code

boundary_npiece = 0

end function boundary_npiece

!          --------------
subroutine boundary_param(start,finish)
!          --------------

!----------------------------------------------------
! This routine gives the range of parameter values for each piece of the
! boundary.
! If boundary_npiece <= 0 it is a dummy and the domain is given by triangle
! data files.
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(out) :: start(:), finish(:)
!----------------------------------------------------
! Begin executable code

! Dummy version

start = 0.0_my_real
finish = 0.0_my_real

end subroutine boundary_param

!          --------------
subroutine update_usermod(phaml_solution)
!          --------------

use phaml
type(phaml_solution_type), intent(in) :: phaml_solution

! Dummy version.  See examples/elliptic/usermod.f90 for a functional example.

end subroutine update_usermod

!        ---------------------
function phaml_integral_kernel(kernel,x,y)
!        ---------------------

use phaml
integer, intent(in) :: kernel
real(my_real), intent(in) :: x,y
real(my_real) :: phaml_integral_kernel

! Identity function

phaml_integral_kernel = 1.0

end function phaml_integral_kernel

!        ----------
function regularity(x,y)
!        ----------

use phaml
real(my_real), intent(in) :: x(3),y(3)
real(my_real) :: regularity

! This function gives a priori knowledge about the regularity (a.k.a.
! smoothness) of the solution to guide the selection between h and p
! refinement in the APRIORI hp-adaptive strategy.

! In theory, this routine should return the largest value of m such that,
! within the triangle whose vertices are given in (x,y), the solution is in
! the Hilbert space H^m, i.e. it has m continuous derivatives.  For
! multicomponent solutions, it should return the worst (i.e. smallest)
! such m among the components.

! In practice, it can be used to guide refinement in other a priori known
! trouble areas, such as sharp peaks, boundary layers and wave fronts.  The
! actual use is that p refinement is performed if the current degree of the
! triangle given by (x,y) is less than the returned value, and h refinement
! is performed otherwise.

! Hint: you can determine if a point (s,t) is inside a triangle by computing
! the barycentric coordinates of the point and verifying that all three are
! nonnegative, as follows:
!  det = x(1)*(y(2)-y(3))+x(2)*(y(3)-y(1))+x(3)*(y(1)-y(2))
!  zeta(1) = (s*(y(2)-y(3)) + t*(x(3)-x(2)) + (x(2)*y(3)-x(3)*y(2)))/det
!  zeta(2) = (s*(y(3)-y(1)) + t*(x(1)-x(3)) + (x(3)*y(1)-x(1)*y(3)))/det
!  zeta(3) = (s*(y(1)-y(2)) + t*(x(2)-x(1)) + (x(1)*y(2)-x(2)*y(1)))/det
!  if (all(zeta >= -1000*epsilon(0.0_my_real))) then
!     the point (s,t) is in the triangle
!  else
!     the point (s,t) is not in the triangle
!  endif
! In the comparison we use a value slightly less than 0 to account for
! roundoff errors.

! For the L domain, there is a singularity at the reentrant corner with
! regularity 2/3.  Since the reentrant corner (0,0) is a vertex, we just
! need to see if one of the vertices is the origin.

if (any(x == 0.0_my_real .and. y == 0.0_my_real)) then
   regularity = 1 + 2.0_my_real/3.0_my_real
else
   regularity = huge(0.0_my_real)
endif

end function regularity


submodule (m_searching) sm_BinarySearch

implicit none

contains

  !====================================================================!
  module procedure binarySearch_i1D!(this,v) result(iout)
    !! Search for the value i in an integer vector
    !! Assumes this is sorted!
  !====================================================================!
!  integer(i32) :: this(:) !! Vector to search within
!  integer(i32) :: v !! Number to find in the vector
!  integer(i32) :: iout !! Location of i in this. Returns -1 if not present
  integer(i32) :: i0, i1
  i0 = 1
  i1 = size(this)
  iout = binarySearch_i1D_limits(this, v, i0, i1)
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure binarySearch_id1D!(this,v) result(iout)
    !! Search for the value i in an integer vector
    !! Assumes this is sorted!
  !====================================================================!
!  integer(i64) :: this(:) !! Vector to search within
!  integer(i64) :: v !! Number to find in the vector
!  integer(i32) :: iout !! Location of i in this. Returns -1 if not present
  integer(i32) :: i0, i1
  i0 = 1
  i1 = size(this)
  iout = binarySearch_id1D_limits(this, v, i0, i1)
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure binarySearch_r1D!(this,v) result(iout)
    !! Search for the value i in an integer vector
    !! Assumes this is sorted!
  !====================================================================!
!  real(r32) :: this(:) !! Vector to search within
!  real(r32) :: v !! Number to find in the vector
!  integer(i32) :: iout !! Location of i in this. Returns -1 if not present
  integer(i32) :: i0, i1
  i0 = 1
  i1 = size(this)
  iout = binarySearch_r1D_limits(this, v, i0, i1)
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure binarySearch_d1D!(this,v) result(iout)
    !! Search for the value i in an integer vector
    !! Assumes this is sorted!
  !====================================================================!
!  real(r64) :: this(:) !! Vector to search within
!  real(r64) :: v !! Number to find in the vector
!  integer(i32) :: iout !! Location of i in this. Returns -1 if not present
  integer(i32) :: i0, i1
  i0 = 1
  i1 = size(this)
  iout = binarySearch_d1D_limits(this, v, i0, i1)
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure binarySearch_i1D_limits!(this,v,imin,imax) result(iout)
    !! Search for the value i in an integer vector
    !! Assumes this is sorted!
  !====================================================================!
!  integer(i32) :: this(:) !! Vector to search within
!  integer(i32) :: v !! Number to find in the vector
!  integer(i32) :: imin !! Left integer
!  integer(i32) :: imax !! Right integer
!  integer(i32) :: iout !! Location of i in this. Returns -1 if not present

  if (imax < imin) then
    iout=-1
    return
  else
    ! Cut the search in half
    iout=(imax+imin)/2
    ! Three-Way Comparison
    if (this(iout) > v) then
      ! Result is in lower subset
      iout=binarySearch_i1D_limits(this,v,imin,iout-1)
    elseif (this(iout) < v) then
      ! Result is in upper subset
      iout=binarySearch_i1D_limits(this,v,iout+1,imax)
    else
      ! Result has been found
      return
    endif
  endif
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure binarySearch_id1D_limits!(this,v,imin,imax) result(iout)
    !! Search for the value i in an integer vector
    !! Assumes this is sorted!
  !====================================================================!
!  integer(i64) :: this(:) !! Vector to search within
!  integer(i64) :: v !! Number to find in the vector
!  integer(i32) :: imin !! Left integer
!  integer(i32) :: imax !! Right integer
!  integer(i32) :: iout !! Location of i in this. Returns -1 if not present

  if (imax < imin) then
    iout=-1
    return
  else
    ! Cut the search in half
    iout=(imax+imin)/2
    ! Three-Way Comparison
    if (this(iout) > v) then
      ! Result is in lower subset
      iout=binarySearch_id1D_limits(this,v,imin,iout-1)
    elseif (this(iout) < v) then
      ! Result is in upper subset
      iout=binarySearch_id1D_limits(this,v,iout+1,imax)
    else
      ! Result has been found
      return
    endif
  endif
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure binarySearch_r1D_limits!(this,v,imin,imax) result(iout)
    !! Search for the value i in an integer vector
    !! Assumes this is sorted!
  !====================================================================!
!  real(r32) :: this(:) !! Vector to search within
!  real(r32) :: v !! Number to find in the vector
!  integer(i32) :: imin !! Left integer
!  integer(i32) :: imax !! Right integer
!  integer(i32) :: iout !! Location of i in this. Returns -1 if not present

  if (imax < imin) then
    iout=-1
    return
  else
    ! Cut the search in half
    iout=(imax+imin)/2
    ! Three-Way Comparison
    if (this(iout) > v) then
      ! Result is in lower subset
      iout=binarySearch_r1D_limits(this,v,imin,iout-1)
    elseif (this(iout) < v) then
      ! Result is in upper subset
      iout=binarySearch_r1D_limits(this,v,iout+1,imax)
    else
      ! Result has been found
      return
    endif
  endif
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure binarySearch_d1D_limits!(this,v,imin,imax) result(iout)
    !! Search for the value i in an integer vector
    !! Assumes this is sorted!
  !====================================================================!
!  real(r64) :: this(:) !! Vector to search within
!  real(r64) :: v !! Number to find in the vector
!  integer(i32) :: imin !! Left integer
!  integer(i32) :: imax !! Right integer
!  integer(i32) :: iout !! Location of i in this. Returns -1 if not present

  if (imax < imin) then
    iout=-1
    return
  else
    ! Cut the search in half
    iout=(imax+imin)/2
    ! Three-Way Comparison
    if (this(iout) > v) then
      ! Result is in lower subset
      iout=binarySearch_d1D_limits(this,v,imin,iout-1)
    elseif (this(iout) < v) then
      ! Result is in upper subset
      iout=binarySearch_d1D_limits(this,v,iout+1,imax)
    else
      ! Result has been found
      return
    endif
  endif
  end procedure
  !====================================================================!
end submodule


module initial_conditions

  use shared_data

  implicit none

  contains

  subroutine set_ic ! NB: nx, t_end etc is set in control.f90

    u = 0.0_num
    v = 0.0_num

  end subroutine set_ic

  subroutine shear_test_ic

    real(num) :: x,y, rho_s, delta_s

    rho_s = 42.0_num
    delta_s = 0.05_num

    do iy = -1,ny+1
    do ix = -1,nx+1
      x = xc(ix)
      y = yc(iy)
      if (y <= 0.5_num) then
        u(ix,iy) =  tanh(rho_s * (y-0.25_num))
      else
        u(ix,iy) = tanh(rho_s * (0.75_num -y))
      endif
      v(ix,iy) = delta_s * sin(2.0_num * pi * x)
    enddo
    enddo

    rho = 1.0_num

  end subroutine shear_test_ic

  subroutine minion_test_ic

    real(num) :: x,y

    do iy = -1,ny+1
    do ix = -1,nx+1
      x = xc(ix)
      y = yc(iy)
      u(ix,iy) = 1.0_num - 2.0_num * cos(2.0_num*pi*x)*sin(2.0_num*pi*y)
      v(ix,iy) = 1.0_num + 2.0_num * sin(2.0_num*pi*x)*cos(2.0_num*pi*y)
    enddo
    enddo

    do iy = 1, ny
    do ix = 1, nx
      divu(ix,iy) = (u(ix+1,iy) - u(ix-1,iy))/dx/2.0_num &
        & + (v(ix,iy+1) - v(ix,iy-1))/dy/2.0_num
    enddo
    enddo

    rho = 1.0_num

  end subroutine minion_test_ic

  subroutine vardens_adv_test_ic

    real(num) :: x,y,r

    u = 0.0_num
    v = 1.0_num

    rho = 1.0_num
    do iy = -1,ny+1
    do ix = -1,nx+1
      x = xc(ix)-0.5_num
      y = yc(iy)-0.5_num
      r = sqrt(x**2 + y**2)
      if (r <= 0.1_num) rho(ix,iy) = 2.0_num
    enddo
    enddo
    print *, 'rho on grid',sum(rho(1:nx,1:ny)*dx*dy)

    print *,'max numerical divu in ICs',maxval(abs(divu))
  end subroutine vardens_adv_test_ic

  subroutine rti1_ic

    real(num) :: x, y
    real(num) :: d, rho0, rho1
    real(num) :: fwtm , amp

    amp = 0.1_num

    d = x_max - x_min
    fwtm = 0.1_num *d
!    fwtm = 0.01_num * d
    rho0 = 1.0_num
    rho1 = 7.0_num

    u = 0.0_num
    v = 0.0_num

    rho = rho0

    do ix = -1, nx+1
    do iy = -1, ny+2
      x = xc(ix)
      y = yc(iy) + amp * d * (cos(2.0_num * pi * x / d))
      y = y * 1.818_num / fwtm
      rho(ix,iy) = rho0 + 0.5_num * (rho1-rho0) * (1.0_num + tanh(y))
    enddo
    enddo

  end subroutine rti1_ic

  subroutine blob1_ic

    real(num) :: x,y,r

    ! this should probabally be de-singularised with a tanh profile on rho=rho(r)

    u = 0.0_num
    v = 0.0_num

    grav_x = 0.0_num
    grav_y = -1.0_num

    rho = 1.0_num

    do iy = -1,ny+1
    do ix = -1,nx+1
      x = xc(ix)-0.5_num
      y = yc(iy)-0.5_num
      r = sqrt(x**2 + y**2)
      if (r <= 0.1_num) rho(ix,iy) = 0.8_num !0.5_num
    enddo
    enddo

    print *, 'rho on grid',sum(rho(1:nx,1:ny)*dx*dy)

  end subroutine blob1_ic

  subroutine circular_drop_ic

    real(num) :: x,y,r

    ! this should probabally be de-singularised with a tanh profile on rho=rho(r)

    u = 0.0_num
    v = 0.0_num

    grav_x = 0.0_num
    grav_y = -1.0_num

    rho = 1.0_num

    do iy = -1,ny+1
    do ix = -1,nx+1
      x = xc(ix)-0.5_num
      y = yc(iy)-0.75_num
      r = sqrt(x**2 + y**2)
      if (r <= 0.15_num) rho(ix,iy) = 1000.0_num
    enddo
    enddo

    print *, 'rho on grid',sum(rho(1:nx,1:ny)*dx*dy)

  end subroutine circular_drop_ic

end module initial_conditions


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Originally created by James McDonagh at the University of Manchester 2015, in the Popelier group      !
! Components of the module are acknowledged to Dr Tanja van Mourik University of St Andrews             !
! Licensed under MIT License                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! Originally created by James.
! Version 1.1
! CHANGE LOG
! Version 1  : Functions for calculating strutcural parameters
! Version 1.1: Modular format and incorporation in the Hermes program.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module module_functions

use module_constants

  implicit none

contains

  function bond_vector(v1,v2)
    !Dummy arguements
    real, dimension(3) :: v1,v2
    !Function argument
    real, dimension(3) :: bond_vector
    !local
    integer :: i

    do i=1,3
       bond_vector(i)=v2(i)-v1(i)
    end do

  end function bond_vector

!************************************************************************

  function dist(x1, y1, z1, x2, y2, z2)	! Calculates the distance between two coordinates given as separate values
    implicit none                       ! Function originally created by Rob Coates Univeristy of Manchester 2015

    real, dimension(3) :: vector
    real :: distance2, dist, x1, y1, z1, x2, y2, z2
    integer :: i

    i = 0
    distance2 = 0
    dist = 0
    vector = 0

    vector(1) = x1 - x2
    vector(2) = y1 - y2
    vector(3) = z1 - z2

    do i = 1,3,1
       distance2 = distance2 + (vector(i)**2.0)
    end do

    dist = sqrt(distance2)

  end function dist

!************************************************************************

  Function norm(v)

    !dummy arguments
    real, dimension (3) :: v
    !function result
    real :: norm

    norm=sqrt(v(1)*v(1) + v(2)*v(2) + v(3)*v(3))
!    Print*, "norm is = ", norm                ! JMcD DIAGNOSTIC PRINT

  end Function norm

!************************************************************************

  function normalise(vector,normal)
    !Dummy arguments
    real, dimension(3) :: vector
    real :: normal
    !fucntion argument
    real, dimension(3) ::normalise
    !local
    integer :: inc

    do inc=1,3,1
       normalise(inc)=vector(inc)/normal
    end do

  end function normalise

!************************************************************************

  function vector_cross(bvec1,bvec2)
    !Dummy arguments
    real, dimension(3) :: bvec1, bvec2
    !Function argument
    real, dimension(3) :: vector_cross

    vector_cross(1)=(bvec1(2)*bvec2(3)-bvec1(3)*bvec2(2))
    vector_cross(2)=(bvec1(3)*bvec2(1)-bvec1(1)*bvec2(3))
    vector_cross(3)=(bvec1(1)*bvec2(2)-bvec1(2)*bvec2(1))

  end function vector_cross

!************************************************************************

  function vector_dot(v1,v2)
    !Dummy arguments
    real, dimension(3) :: v1, v2
    !function argument
    real :: vector_dot

    vector_dot=v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)

  end function vector_dot

!************************************************************************

  function perdist(x1, y1, z1, x2, y2, z2, boxlen)	    ! Calculates the distance between two coordinates in periodic Boundary conditions
    implicit none                                       ! Function originally created by Rob Coates University of Manchester 2015

    real, dimension(3) :: vector
    real :: distance2, distance, x1, y1, z1, x2, y2, z2, boxlen, perdist, halfboxlen
    integer :: i

    i = 0
    distance2 = 0
    distance = 0
    vector = 0

    vector(1) = x1 - x2
    vector(2) = y1 - y2
    vector(3) = z1 - z2
    halfboxlen = boxlen*0.5

    do i = 1,3,1					! R.C. takes into account periodic boundry conditions
       if (vector(i).gt.halfboxlen) then
           vector(i) = vector(i) - boxlen
!       else if(vector(i).lt.-halfboxlen) then
!           vector(i) = vector(i) + boxlen
       else
          cycle
       end if
    end do

    do i = 1,3,1
       distance2 = distance2 + (vector(i)**2.0)
    end do

    distance = sqrt(distance2)
    perdist = distance

  end function perdist

!************************************************************************

function distancemicro(x1, y1, z1, x2, y2, z2, bl)	! Calculates the distance between two coordinates
  implicit none

  real, dimension(3) :: vector
  real :: distance2, distancemicro, x1, y1, z1, x2, y2, z2, bl
  integer :: i

  i = 0
  distance2 = 0
  distancemicro = 0
  vector = 0

  vector(1) = x1 - x2
  vector(2) = y1 - y2
  vector(3) = z1 - z2

  do i = 1,3,1					!takes into account periodic boundry conditions
     if (vector(i).GT.(bl*0.5)) then
     vector(i) = vector(i) - bl
  else
     cycle
  end if
end do

do i = 1,3,1
   distance2 = distance2 + (vector(i)**2.0)
end do

distancemicro = sqrt(distance2)

end function distancemicro

!************************************************************************

function distmicro(x1, y1, z1, x2, y2, z2)	! Calculates the distance between two coordinates
  implicit none

  real, dimension(3) :: vector
  real :: distance2, distmicro, x1, y1, z1, x2, y2, z2
  integer :: i

  i = 0
  distance2 = 0
  distmicro = 0
  vector = 0

  vector(1) = x1 - x2
  vector(2) = y1 - y2
  vector(3) = z1 - z2

  do i = 1,3,1
     distance2 = distance2 + (vector(i)**2.0)
  end do

  distmicro = sqrt(distance2)

end function distmicro

!************************************************************************

end module module_functions


!---------------------------------------------------------------------!
!                                PHAML                                !
!                                                                     !
! The Parallel Hierarchical Adaptive MultiLevel code for solving      !
! linear elliptic partial differential equations of the form          !
! (PUx)x + (QUy)y + RU = F on 2D polygonal domains with mixed         !
! boundary conditions, and eigenvalue problems where F is lambda*U.   !
!                                                                     !
! PHAML is public domain software.  It was produced as part of work   !
! done by the U.S. Government, and is not subject to copyright in     !
! the United States.                                                  !
!                                                                     !
!     William F. Mitchell                                             !
!     Applied and Computational Mathematics Division                  !
!     National Institute of Standards and Technology                  !
!     william.mitchell@nist.gov                                       !
!     http://math.nist.gov/phaml                                      !
!                                                                     !
!---------------------------------------------------------------------!

!----------------------------------------------------
! This file contains the main program supplied by the user.
! This version illustrates an eigenvalue problem, the Schroedinger
! Equation for a simple harmonic oscillator.
!----------------------------------------------------

!       ------------
program phaml_master
!       ------------

!----------------------------------------------------
! This is the main program.
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Local variables:

integer :: nvert,num_eval,nproc
real(my_real) :: lambda0
type(phaml_solution_type) :: pde1

!----------------------------------------------------
! Begin executable code

nvert = 1000
lambda0 = -huge(0.0_my_real)
num_eval = 1
nproc=4
call phaml_create(pde1,nproc,eq_type=EIGENVALUE)
call phaml_solve_pde(pde1,                     &
                     max_vert=nvert,             &
                     sequential_vert=250,        &
                     print_grid_when=PHASES,     &
                     print_grid_who=MASTER,      &
                     print_error_when=PHASES,    &
                     print_error_who=MASTER,     &
                     print_error_what=ENERGY_LINF_ERR, &
                     print_errest_what=ENERGY_LINF_ERREST, &
                     print_eval_when=PHASES,     &
                     print_eval_who=MASTER,      &
                     mg_tol=MG_NO_TOL,           &
                     mg_cycles=10,               &
                     scale_evec=SCALE_M,         &
                     lambda0 = lambda0,          &
                     num_eval = num_eval)
call phaml_destroy(pde1)

end program phaml_master


program t
  integer :: i = 10
  integer, dimension(10) :: a, b

  do i = 1,10,1
    a(i) = i
    b(i) = -i
  end do
  where ( a > 3 )
    a = 3
    b = 4
  elsewhere (a < 2)
    a = 5
    b = 6
  end where

  print *, a

end program t


      SUBROUTINE MFFTB9(C,FAC)
*
*   PURPOSE:
*       ELEMENTARY COOLEY-TUKEY RADIX 3 STEP APPLIED TO A VECTOR-OF
*       2-VECTORS-OF-COMPLEX C[IMS,NM [IVS,NV [IES,NE]]].
*       SEE REF.[1] FOR NOTATIONS.
*       THIS ROUTINE CAN BE USED ONLY BY ROUTINE MFFTIM, WHICH CONTROLS
*       ITS OPERATION THROUGH THE MFFTPA COMMON
*
*   DUMMY ARGUMENTS :
*
*   C   ARRAY BEING FOURIER  TRANSFORMED
*   FAC PHASE FACTORS, PREPARED BY MFFTP; NOT MODIFIED IN OUTPUT
*
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /MFFTPA/  IMS,IVS,IES,NM,NV,NE,MX,LX,MLIM,MSTEP,LLIM,LSTEP,
     $ NUSTEP,IVLIM,ILIM,MD2LIM,LD2LIM
      INTEGER NUSTEP
      DOUBLE COMPLEX C(0:NUSTEP-1,0:2),FAC(0:*)
      DOUBLE COMPLEX T0,T1,T2,F1,F2
      REAL *8 SIN60
      PARAMETER ( SIN60 =  8.6602540378443864E-1)

       STOP 'IL FAUT VERIFIER MTFFB9'
	   RETURN
	  IF(LX.NE.1)THEN
          DO 200 MU=0,MLIM,MSTEP
            DO 150 IV=MU,MU+IVLIM,IVS
              ILAMF=0
              DO 100 ILAM=IV,IV+ILIM
                T0=C(ILAM,1)*FAC(ILAMF)+C(ILAM,2)*FAC(ILAMF+NUSTEP)
                T2=(C(ILAM,1)*FAC(ILAMF)-C(ILAM,2)*FAC(ILAMF+NUSTEP))*
     $             SIN60
                T1=C(ILAM,0)-0.5*T0
                C(ILAM,0)=C(ILAM,0)+T0
                C(ILAM,1)=(T1+DCMPLX(-DIMAG(T2),DREAL(T2)))
                C(ILAM,2)=(T1-DCMPLX(-DIMAG(T2),DREAL(T2)))
                ILAMF=ILAMF+1
100           CONTINUE
150         CONTINUE
200       CONTINUE
      ELSE
          DO 400 MU=0,MLIM,MSTEP
            DO 350 IV=MU,MU+IVLIM,IVS
              DO 300 ILAM=IV,IV+ILIM
                T0=C(ILAM,1)+C(ILAM,2)
                T2=(C(ILAM,1)-C(ILAM,2))*SIN60
                T1=C(ILAM,0)-0.5*T0
                C(ILAM,0)=C(ILAM,0)+T0
                C(ILAM,1)=(T1+DCMPLX(-DIMAG(T2),DREAL(T2)))
                C(ILAM,2)=(T1-DCMPLX(-DIMAG(T2),DREAL(T2)))
300           CONTINUE
350         CONTINUE
400       CONTINUE
      ENDIF
      END


      SUBROUTINE MFFTP(N,W,ID,IERR)
*
*     THIS SUBROUTINE PREPARES TABLES FOR USE BY THE MFFT
*     ROUTINES. THE PARAMETERS ARE
*
*     N : IS THE ORDER OF THE TRANSFORM;
*
*     W : ARRAY OF LENGTH AT LEAST 4*N+14  WORDS IF ID=0,
*      AND 4*N*(ID+1)+14 IF ID > 0 ; THIS ARRAY IS FILLED
*      BY THE PRESENT ROUTINE, AND SHOULD NOT BE MODIFIED BY THE
*      USER; IT IS REQUIRED BY ALL THE OPERATING ROUTINES;
*      THE ROUTINES MFFTIS AND MFFTDS
*      REQUIRE THAT W HAS BEEN FILLED BY A CALL TO MFFTP WITH
*      ID .GT. 0 ; ALL THE ROUTINES DO NOT MODIFY THE CONTENTS
*      OF W ;
*      WARNING: DIFFERENT PORTIONS OF W ARE HANDLED AS COMPLEX OR
*               INTEGER VARIABLES BY DIFFERENT ROUTINES.
*
*     ID : IF ID .EQ. 0 THE TABLES ARE SET FOR A NORMAL
*      TRANSFORM; IF ID .GT. 0 THE TABLES ARE SET FOR BOTH
*      A NORMAL AND A "SPECIAL" TRANSFORM (I.E. OPTIMIZED FOR SMALL
*      FIRST DIMENSION DATA ARRAYS, SEE REF.[2]); IN THIS CASE IT
*      SHOULD BE EQUAL TO THE FIRST DIMENSION OF THE ARRAY TO BE
*      TRANSFORMED, AS DECLARED IN THE CALLING PROGRAM.
*
*     IERR : ERROR CODE : =0 : SUCCESSFUL
*                       : =2 : FACTORIZATION ERROR
*
*
*************************************************************
*
*      REFERENCE INFORMATION : LAYOUT OF W
*
*  IN ALL CASES
*
* WORD ADDRESS      TYPE    N. OF EL. WORD LENGTH   PURPOSE
*
*  0                INTEGER      14      14     FACTORIZATION OF N
*
*  14               COMPLEX     N       2*N     EXP(I*P/(2*N)*K),K=
*                                               0,N-1
*  3*N+14           INTEGER     N        N      PERMUTATION INDEX:KOFI
*  2*N+14           INTEGER     N        N      PERMUTATION INDEX:IOFK
*
*  ONLY IF ID .GT. 0
*
*  4*N+14           COMPLEX    N*ID     2*N*ID  TABLES FOR MFFTDS
*  4*N+2*N*ID+14    COMPLEX    N*ID     2*N*ID  TABLES FOR MFFTIS
*
*
*
*******************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMPLEX W(-7:*)

*...  FACTORIZATION OF N IN W(-7)..W(-1)
      CALL MFFTP1(W(-7),N,IERR)
      IF(IERR.NE.0)RETURN
*
*     PREPARATION OF PERMUTATION INDEXES IN W(N)..W(2*N-1)
*     WARNING : W(0)..W(N-1) USED AS A WORK SPACE
      CALL MFFTP2(W(N),W(0),W(-7),N)
*
*     PREPARATION OF PHASE FACTOR TABLE IN W(0)..W(N-1)
      W(0)=1.0
      PI2DN=ATAN(1.)*8./N
      DO 1  I=1,N-1
        W(I)=DCMPLX(COS(PI2DN*I),SIN(PI2DN*I))
1     CONTINUE
*
*     IF TABLES FOR SPECIAL TRANSFORM ARE REQUESTED
      IF(ID.GT.0)THEN
        CALL MFFTP4(W(0),W(2*N),W(-7),N,ID)
      ENDIF
*
      END


      subroutine imppro
c
c     + + + PURPOSE + + +
c
c     Channel water surface profile analysis subroutine.
c     SR IMPPRO uses the standard step method to obtain
c     the water surface profile and energy slopes at each
c     node in the channel.
c
c     Called from: IMPINT
c     Author(s): A. Fogel
c     Reference in User Guide:
c
c     Version:
c     Date recoded:
c     Recoded by:
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     + + + COMMON BLOCKS + + +
c
      include 'cimrou.inc'
c     read: b,ss,n,pypos,z,mdwit,dwt,rfrac,yc,frt,ncross
c     write: depth
c
c     + + + LOCAL VARIABLES + + +
c
      real area, hrad, cntrdp, v, vhead, theadc, y1, y2, hr23, r23, s1,
     1    chr, dz, yy1, yy2, dy, ddx, stage, thead1, s2, sfavg, floss,
     1    thdif, hhead, thead2, g, b, frt, ss, z(30), n, ydif
      integer iup, icsec, numnp1, nod, i, iter
c
c     + + + LOCAL DEFINITIONS + + +
c
c     area     - the flow area of the channel
c     b        - channel bottom width
c     chr      - channel roughness coefficient
c     cntrdp   - depth at the control section
c     ddx      - distance downstream
c     dy       - incremental change in depth
c     dz       - incremental change in downstream distance
c     floss    - friction loss
c     frt      - flow rate
c     g        - gravitational constant
c     hhead    - head variable
c     hr23     - hydraulic radius ** 2/3
c     hrad     - hydraulic radius
c     icsec    - number of cross sections
c     iter     - number of iterations
c     iup      - upstream routing flag
c     n        - manning's n
c     nod      - normal depth counter
c     numnp1   - number of points in cross section
c     r23      - 2/3 in manning's n equation
c     s1       - friction slope
c     s2       - friction slope
c     sfavg    - friction slope
c     ss       - side slopes
c     stage    - stage of the flow depth
c     thdif    - convergence head difference
c     thead1   - total head
c     thead2   - total head
c     theadc   - total head
c     v        - average flow velocity
c     vhead    - velocity head
c     y1       - flow depth
c     y2       - flow depth
c     ydif     - flow depth difference
c     yy1      - control section position
c     yy2      - control section position + 1
c     z(i)     - horizontal location
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c     calculate the hydraulic radius for the control section
c
      b = bwes
      ss = sses
      n = nes
c
      do 10 i = 1, ncross
        z(i) = zes(i)
   10 continue
c
      frt = qesr
      iup = 0
      cntrdp = yc
      g = 32.2
c
      if (iup.eq.0) then
        icsec = ncross
        depth(icsec) = cntrdp
        area = b * depth(icsec) + ss * depth(icsec) ** 2
        hrad = area / (b+2.*depth(icsec)*(ss**2+1)**0.5)
      else
        icsec = 1
        depth(icsec) = cntrdp
        area = b * depth(icsec) + ss * depth(icsec) ** 2
        hrad = area / (b+2.*depth(icsec)*(ss**2+1)**0.5)
      end if
c
c     calculate the velocity head and the total head for the control
c     section
c
      v = frt / area
      vhead = v * v / (2.0*g)
      theadc = pypos(icsec) + depth(icsec) + vhead
      y1 = depth(icsec)
      y2 = y1
c
c     calculate the friction slope using manning's equation
c
      r23 = 2.0 / 3.0
      chr = n / 1.486
      hr23 = hrad ** r23
      s1 = (v*chr/hr23) ** 2.0
c
c     begin loop over the cross sections and set up point to change depth
c     toward normal depth
c
      numnp1 = ncross - 1
c
      do 30 nod = 1, numnp1
c
        if (iup.eq.0) then
          icsec = ncross - nod
        else
          icsec = nod + 1
        end if
c
c       calculate the distance downstream (or upstream)
c
        if (iup.eq.0) then
          dz = z(icsec+1) - z(icsec)
          yy1 = pypos(icsec)
          yy2 = pypos(icsec+1)
          dy = yy2 - yy1
          ddx = sqrt(dy*dy+dz*dz)
        else
          dz = z(icsec) - z(icsec-1)
          yy1 = pypos(icsec-1)
          yy2 = pypos(icsec)
          dy = yy2 - yy1
          ddx = sqrt(dy*dy+dz*dz)
        end if
c
c       set first guess at the stage to that of the previous cross section
c       and set the depth equal to that of the previous cross section
c
        iter = 0
c
   20   iter = iter + 1
c
        if (iter.gt.mdwit) then
          write (6,1000) iter, mdwit, icsec
          stop
        end if
c
        stage = pypos(icsec) + y2
        y1 = y2
c
c       calculate the cross sectional area, hydraulic radius, and velocity
c       and total head at the cross section
c
        area = b * y1 + ss * y1 ** 2.
        hrad = area / (b+2.*y1*(ss**2.+1)**0.5)
c
        v = frt / area
        vhead = v * v / (2.0*g)
        thead1 = stage + vhead
c
c       calculate the friction slope using manning's equation
c
        hr23 = hrad ** r23
        s2 = (v*chr/hr23) ** 2.0
c
c       calculate the average friction slope over the reach and
c       the friction loss
c
        sfavg = 0.5 * (s1+s2)
        floss = sfavg * ddx
c
c       calculate the new total head
c
        if (iup.eq.0) then
          thead2 = theadc + floss
        else
          thead2 = theadc - floss
        end if
c
c       check for convergence
c
        thdif = thead2 - thead1
c
        if (abs(thdif).lt.dwt) then
          theadc = thead2
          s1 = s2
          depth(icsec) = thead2 - vhead - pypos(icsec)
          y2 = yc
          go to 30
c
        else
c
          hhead = 0.5 * (thead1+thead2)
c
c         y2 = y1*(thead2/thead1)
c
          y2 = hhead - pypos(icsec) - vhead
          ydif = y2 - y1
c
          if (abs(ydif).gt.rfrac*y1) then
            if (ydif.ge.0.0) then
              y2 = y1 + rfrac * y1
            else
              y2 = y1 - rfrac * y1
            end if
          end if
c
          go to 20
        end if
c
   30 continue
c
      return
c
 1000 format (//12x,'!!!!!!!!!!!!!!     E R R O R     !!!!!!!!!!!!!!',//
     1    7x,'WATER SURFACE PROFILE ITERATIONS (',i3,
     1    ') EXCEEDED MAXIMUM (',i3,')',/28x,'PROGRAM HALTED'/19x,
     1    'AT CROSS SECTION ',i2//12x,
     1    '!!!!!!!!!!!!!!     E R R O R     !!!!!!!!!!!!!!')
      end