REAL FUNCTION fun_harmonic(K1, K2)
! return the Harmonic average of K1, K2 but adjusted to take into account
!   negative K1, K2 that are used to set a zero diffusivity.
   REAL K1, K2
   REAL, PARAMETER :: toler = 1.e-15
   fun_harmonic = 2. * ABS(K1 * K2) / MAX(toler, K1 + K2)
END FUNCTION fun_harmonic

SUBROUTINE viral_4_eqn(T_new, I1_new, I2_new, V_new, T, I1, I2, V, beta, k, delta_c, p, c, dt, ntime)
! python call looks like:
!    T_new, I1_new, I2_new, V_new = viral_4_eqn(T, I1, I2, V, beta, k, delta_c, p, c, dt, ntime)

! *******************************************************************************************
! This subroutine solve the classical 4 eqn VIRAL model (The model with an eclipse phase) using an iterative explicit
! method and as such the time step size can not be too small e.g. 10 mins or dt = 10. * 60. = 600.
! don't forget there needs to be a seed of an infected person in the E group.
! have a look at eqn 2 of Modeling-the-viral-dynamics-of-SARS-CoV-2-infect.pdf
! *******************************************************************************************

! T_new, I1_new, I2_new, V_new the calculated solution variables after ntime time steps output
! T, I1, I2, V initial solution variables sent down to this subroutine
! beta, k, delta_c, p, c are the coefficients in the VIRAL equations sent down into this subroutine
! dt = time step size
! ntime = no of time steps

   IMPLICIT NONE
! dummy variables
   REAL, INTENT(OUT) :: T_new, I1_new, I2_new, V_new
   REAL, INTENT(IN) :: T, I1, I2, V, beta, k, delta_c, p, c, dt
   INTEGER, INTENT(IN) :: ntime

! local variables
   INTEGER its, nits, itime ! no of non-linear iterations
   REAL T_old, I1_old, I2_old, V_old ! previous time step values of T, I1, I2, V

! execution
   T_new = T; I1_new = I1; I2_new = I2; V_new = V
   nits = 3

   DO itime = 1, ntime
      T_old = T_new; I1_old = I1_new; I2_old = I2_new; V_old = V_new

      DO its = 1, nits
         T_new = T_old + dt * (-beta * V_new * T_new)
         I1_new = I1_old + dt * (beta * V_new * T_new - k * I1_new)
         I2_new = I2_old + dt * (k * I1_new - delta_c * I2_new)
         V_new = V_old + dt * (p * I2_new - c * V_new)
      END DO ! DO its = 1, nits
   END DO
   RETURN
END SUBROUTINE viral_4_eqn

SUBROUTINE viral_4_eqn_secondary_target(T1_new, T2_new, I_new, V_new, T1, T2, I, V, beta, lambda, delta_c, w, p, c, dt, ntime)
! python call looks like:
!    T_new, I1_new, I2_new, V_new = viral_4_eqn_secondary_target(T1, T2, I, V, beta, lambda, delta_c, w, p, c, dt, ntime)

! *******************************************************************************************
! This subroutine solve the classical 4 eqn VIRAL model based on a secondary target using an iterative explicit
! method and as such the time step size can not be too small e.g. 10 mins or dt = 10. * 60. = 600.
! don't forget there needs to be a seed of an infected person in the E group.
! have a look at eqn 3 of Modeling-the-viral-dynamics-of-SARS-CoV-2-infect.pdf
! *******************************************************************************************

! T1_new, T2_new, I_new, V_new the calculated solution variables after ntime time steps output
! T1, T2, I, V initial solution variables sent down to this subroutine
! beta, lambda, delta_c, w, p, c are the coefficients in the VIRAL equation sent down into this subroutine
! dt = time step size
! ntime = no of time steps.

   IMPLICIT NONE
! dummy variables
   REAL, INTENT(OUT) :: T1_new, T2_new, I_new, V_new
   REAL, INTENT(IN) :: T1, T2, I, V, beta, lambda, delta_c, w, p, c, dt
   INTEGER, INTENT(in) :: ntime

! local variables
   INTEGER its, nits, itime ! no of non-linear iterations
   REAL T1_old, T2_old, I_old, V_old ! previous time step values of T1, T2, I, V

! execution
   T1_new = T1; T2_new = T2; I_new = I; V_new = V
   nits = 3

   DO itime = 1, ntime
      T1_old = T1_new; T2_old = T2_new; I_old = I_new; V_old = V_new

      DO its = 1, nits
         T1_new = T1_old + dt * (-beta * V_new * T1_new)
         T2_new = T2_old + dt * (lambda - beta * V_new * T2_new)
         I_new = I_old + dt * (beta * V_new * (T1_new + T2_new) - (delta_c + w * T2_new) * I_new)
         V_new = V_old + dt * (p * I_new - c * V_new)
      END DO ! DO its = 1, nits
   END DO
   RETURN
END SUBROUTINE viral_4_eqn_secondary_target

SUBROUTINE sim_time_stepping_diffusion_calc(T_new, T_initial, ntime, nits, nits_solv_ng, relax, &
   error_solv, error_solv_ng, dx, dy, dz, dt, V_n, sigmat, sigma_s_off, kdiff, S, U, I_upwind, &
   I_harmonic, ndim_vel, nx, ny, nz, ng, ng2)
! python call looks like:
!    T_new = sim_time_stepping_diffusion_calc(T_initial, ntime, nits, nits_solv_ng, relax, error_solv,
!                                            error_solv_ng, dx, dy, dz, dt, V_n, sigmat, sigma_s_off,
!                                            kdiff, S, U, I_upwind, I_harmonic, ndim_vel, nx, ny, nz, ng, ng2)

! *******************************************************************************************
! A simplified version of the `time_stepping_diffusion_calc` for not so many groups.
! *******************************************************************************************

! ntime = no of time steps
! nits = no of non-linear iterations
! dt = time step size (can use dt = 1.e15 for steady state cals)
! NITS,NITS_NG are the max no of single group iterations and overall iterations.
! ERROR_SOLV,ERROR_SOLV_NG are the error tolerances of the solver of single group iterations and overall iterations.
! ng2 = 0 if ncol_sigma_s .ne. 0

   IMPLICIT NONE
! dummy variables
   INTEGER, INTENT(IN) :: I_upwind, I_harmonic, ndim_vel, nx, ny, nz, ng, ng2
   INTEGER, INTENT(IN) :: ntime, nits, nits_solv_ng
   REAL, INTENT(IN) :: relax, error_solv, error_solv_ng, dx, dy, dz, dt, V_n(ng)
   REAL, INTENT(OUT) :: T_new(nx, ny, nz, ng)
   REAL, INTENT(IN) :: T_initial(nx, ny, nz, ng)
   REAL, INTENT(IN) :: sigmat(nx, ny, nz, ng), sigma_s_off(nx, ny, nz, ng, ng2), kdiff(nx, ny, nz, ng)
   REAL, INTENT(IN) :: S(nx, ny, nz, ng), U(ndim_vel, nx + 1, ny + 1, nz + 1, ng)

! local variables
   INTEGER :: ncol_sigma_s
   REAL, ALLOCATABLE :: sigma_s_off_pter(:, :, :, :)
   INTEGER, ALLOCATABLE :: fin_sigma_s(:), col_sigma_s(:)

! execution
   ncol_sigma_s = 0
   ALLOCATE(fin_sigma_s(ng + 1))
   ALLOCATE(col_sigma_s(ncol_sigma_s))
   ALLOCATE(sigma_s_off_pter(nx, ny, nz, ncol_sigma_s))
   fin_sigma_s = 0

   CALL time_stepping_diffusion_calc(T_new, T_initial, ntime, nits, nits_solv_ng, relax, error_solv, &
      error_solv_ng, dx, dy, dz, dt, V_n, sigmat, sigma_s_off, sigma_s_off_pter, fin_sigma_s,       &
      col_sigma_s, kdiff, S, U, I_upwind, I_harmonic, ndim_vel, ncol_sigma_s, nx, ny, nz, ng, ng2)
   RETURN
END SUBROUTINE sim_time_stepping_diffusion_calc

SUBROUTINE time_stepping_diffusion_calc(T_new, T_initial, ntime, nits, nits_solv_ng, relax, error_solv,  &
   error_solv_ng, dx, dy, dz, dt, V_n, sigmat, sigma_s_off, sigma_s_off_pter, fin_sigma_s, col_sigma_s, &
   kdiff, S, U, I_upwind, I_harmonic, ndim_vel, ncol_sigma_s, nx, ny, nz, ng, ng2)
! python call looks like:
!    T_new = time_stepping_diffusion_calc(T_initial, ntime, nits, nits_solv_ng, relax, error_solv,
!                                        error_solv_ng, dx, dy, dz, dt, V_n, sigmat, sigma_s_off,
!                                        sigma_s_off_pter, fin_sigma_s, col_sigma_s, kdiff, S, U,
!                                        I_upwind, I_harmonic, ndim_vel, ncol_sigma_s, nx, ny, nz, ng, ng2)

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

   IMPLICIT NONE
! dummy variables
   INTEGER, INTENT(IN) :: I_upwind, I_harmonic, ndim_vel, ncol_sigma_s, nx, ny, nz, ng, ng2
   INTEGER, INTENT(IN) :: ntime, nits, nits_solv_ng
   REAL, INTENT(IN) :: relax, error_solv, error_solv_ng, dx, dy, dz, dt, V_n(ng)
   REAL, INTENT(OUT) :: T_new(nx, ny, nz, ng)
   REAL, INTENT(IN) :: T_initial(nx, ny, nz, ng)
   REAL, INTENT(IN) :: sigmat(nx, ny, nz, ng), sigma_s_off(nx, ny, nz, ng, ng2)
   REAL, INTENT(IN) :: sigma_s_off_pter(nx, ny, nz, ncol_sigma_s)
   INTEGER, INTENT(IN) :: fin_sigma_s(ng + 1), col_sigma_s(ncol_sigma_s)
   REAL, INTENT(IN) :: kdiff(nx, ny, nz, ng), S(nx, ny, nz, ng), U(ndim_vel, nx + 1, ny + 1, nz + 1, ng)

! Local variables...
   REAL, PARAMETER :: relax_ng = 1. ! Multi-group relaxation term.
   REAL, PARAMETER :: toler = 1.e-10, xi_limit = 2. ! defines TVD curve on the NVD diagram.
   LOGICAL upwind1st ! apply 1st order upwinding to advection.
   LOGICAL harmonic_ave ! perform a Harmonic average of the diffusion along the CV boundary
   INTEGER, PARAMETER :: iSwitch_FBGS = 1 ! Switch on FBGS (ISWITCH_FBGS=1 switched on FBGS and ISWITCH_FBGS=0 used forward block Gauss Siedel.)
   REAL, ALLOCATABLE :: T_old(:, :, :, :), A_mat_i_j_k(:, :, :, :)
   REAL, ALLOCATABLE :: A_mat_ip1_j_k(:, :, :, :), A_mat_im1_j_k(:, :, :, :)
   REAL, ALLOCATABLE :: A_mat_i_jp1_k(:, :, :, :), A_mat_i_jm1_k(:, :, :, :)
   REAL, ALLOCATABLE :: A_mat_i_j_kp1(:, :, :, :), A_mat_i_j_km1(:, :, :, :)
   REAL, ALLOCATABLE :: RHS_scat(:, :, :), T_new_temp_ng(:, :, :), S_inc_lim(:, :, :, :)
   INTEGER itime, its, its_ng, ii, i, jj, j, kk, k, ig, jg
   REAL diff_i, R_T_new, R_T_max_dif, R_T_max_dif_ng
   REAL A_i_j_k, A_ip1_j_k, A_im1_j_k, A_i_jp1_k, A_i_jm1_k, A_i_j_kp1, A_i_j_km1
   INTEGER iigg, ig_start, ig_finish, ig_step
   INTEGER switch_up1(3), switch_up2(3), im, jm, km, iDim, iSwitch, jSwitch, kSwitch
   INTEGER i1, i2, i3, j1, j2, j3, k1, k2, k3
   INTEGER ii1, ii2, ii3, jj1, jj2, jj3, kk1, kk2, kk3, count, iLast
   REAL denoIn1, denoIn2, ctilIn1, ctilIn2, ftilIn1, ftilIn2, T_limit1, T_limit2, U_dim(3)
   REAL RH_sig_u, T_upwind(3), T_limit(3), H_sig_u(3)

! function
   REAL fun_harmonic

   upwind1st = (I_upwind == 1)
   harmonic_ave = (I_harmonic == 1)
   ALLOCATE(T_old(nx, ny, nz, ng), A_mat_i_j_k(nx, ny, nz, ng),     &
      A_mat_ip1_j_k(nx, ny, nz, ng), A_mat_im1_j_k(nx, ny, nz, ng), &
      A_mat_i_jp1_k(nx, ny, nz, ng), A_mat_i_jm1_k(nx, ny, nz, ng), &
      A_mat_i_j_kp1(nx, ny, nz, ng), A_mat_i_j_km1(nx, ny, nz, ng), &
      RHS_scat(nx, ny, nz), T_new_temp_ng(nx, ny, nz), S_inc_lim(nx, ny, nz, ng))
   ! print *,'here1'

! Define matricies
   DO ig = 1, ng
      DO k = 2, nz - 1
         DO j = 2, ny - 1
            DO i = 2, nx - 1
               IF (harmonic_ave) THEN
                  ! max{(D_{i-1,j}*D_{I,j})/(D_{i-1,j}+D_{I,j}),0}
                  diff_i = .5 * (fun_harmonic(kdiff(i, j, k, ig), kdiff(i - 1, j, k, ig)) + &
                                 fun_harmonic(kdiff(i, j, k, ig), kdiff(i + 1, j, k, ig))) / (dx ** 2) &
                         + .5 * (fun_harmonic(kdiff(i, j, k, ig), kdiff(i, j - 1, k, ig)) + &
                                 fun_harmonic(kdiff(i, j, k, ig), kdiff(i, j + 1, k, ig))) / (dy ** 2) &
                         + .5 * (fun_harmonic(kdiff(i, j, k, ig), kdiff(i, j, k - 1, ig)) + &
                                 fun_harmonic(kdiff(i, j, k, ig), kdiff(i, j, k + 1, ig))) / (dz ** 2)

                  A_mat_i_j_k(i, j, k, ig) = diff_i + sigmat(i, j, k, ig) + (1. / (dt * V_n(ig)))
                  A_mat_ip1_j_k(i, j, k, ig) = -.5 * fun_harmonic(kdiff(i, j, k, ig), kdiff(i + 1, j, k, ig)) / (dx ** 2)
                  A_mat_im1_j_k(i, j, k, ig) = -.5 * fun_harmonic(kdiff(i, j, k, ig), kdiff(i - 1, j, k, ig)) / (dx ** 2)
                  A_mat_i_jp1_k(i, j, k, ig) = -.5 * fun_harmonic(kdiff(i, j, k, ig), kdiff(i, j + 1, k, ig)) / (dy ** 2)
                  A_mat_i_jm1_k(i, j, k, ig) = -.5 * fun_harmonic(kdiff(i, j, k, ig), kdiff(i, j - 1, k, ig)) / (dy ** 2)
                  A_mat_i_j_kp1(i, j, k, ig) = -.5 * fun_harmonic(kdiff(i, j, k, ig), kdiff(i, j, k + 1, ig)) / (dz ** 2)
                  A_mat_i_j_km1(i, j, k, ig) = -.5 * fun_harmonic(kdiff(i, j, k, ig), kdiff(i, j, k - 1, ig)) / (dz ** 2)
               ELSE ! simple mean...
                  diff_i = .5 * (MAX(kdiff(i, j, k, ig) + kdiff(i - 1, j, k, ig), 0.0) + &
                                 MAX(kdiff(i, j, k, ig) + kdiff(i + 1, j, k, ig), 0.0)) / (dx ** 2) &
                         + .5 * (MAX(kdiff(i, j, k, ig) + kdiff(i, j - 1, k, ig), 0.0) + &
                                 MAX(kdiff(i, j, k, ig) + kdiff(i, j + 1, k, ig), 0.0)) / (dy ** 2) &
                         + .5 * (MAX(kdiff(i, j, k, ig) + kdiff(i, j, k - 1, ig), 0.0) + &
                                 MAX(kdiff(i, j, k, ig) + kdiff(i, j, k + 1, ig), 0.0)) / (dz ** 2)

                  A_mat_i_j_k(i, j, k, ig) = diff_i + sigmat(i, j, k, ig) + (1. / (dt * V_n(ig)))
                  A_mat_ip1_j_k(i, j, k, ig) = -.5 * MAX(kdiff(i, j, k, ig) + kdiff(i + 1, j, k, ig), 0.0) / (dx ** 2)
                  A_mat_im1_j_k(i, j, k, ig) = -.5 * MAX(kdiff(i, j, k, ig) + kdiff(i - 1, j, k, ig), 0.0) / (dx ** 2)
                  A_mat_i_jp1_k(i, j, k, ig) = -.5 * MAX(kdiff(i, j, k, ig) + kdiff(i, j + 1, k, ig), 0.0) / (dy ** 2)
                  A_mat_i_jm1_k(i, j, k, ig) = -.5 * MAX(kdiff(i, j, k, ig) + kdiff(i, j - 1, k, ig), 0.0) / (dy ** 2)
                  A_mat_i_j_kp1(i, j, k, ig) = -.5 * MAX(kdiff(i, j, k, ig) + kdiff(i, j, k + 1, ig), 0.0) / (dz ** 2)
                  A_mat_i_j_km1(i, j, k, ig) = -.5 * MAX(kdiff(i, j, k, ig) + kdiff(i, j, k - 1, ig), 0.0) / (dz ** 2)
               ENDIF
            END DO
         END DO
      END DO
   END DO

! Discretize advection...
   IF (ndim_vel .NE. 0) THEN
      IF ((nz == 3) .AND. (ndim_vel == 3)) THEN
         PRINT *, 'incompatable nz and ndim_vel'
         STOP 292
      ENDIF

      U_dim = 0.0; T_upwind = 0.0; T_limit = 0.0; H_sig_u = 0.0; S_inc_lim = 0.0

      DO ig = 1, ng
         DO k = 2, nz
            switch_up1(3) = 1 - MIN(1, ABS(k - 2))
            switch_up2(3) = 1 - MIN(1, ABS(k - nz))
            km = k + switch_up1(3) - switch_up2(3)
            DO j = 2, ny
               switch_up1(2) = 1 - MIN(1, ABS(j - 2))
               switch_up2(2) = 1 - MIN(1, ABS(j - ny))
               jm = j + switch_up1(2) - switch_up2(2)
               DO i = 2, nx
                  ! advection upwards
                  ! Now adjust to use upwind neer the boundaries...
                  switch_up1(1) = 1 - MIN(1, ABS(i - 2))
                  switch_up2(1) = 1 - MIN(1, ABS(i - nx))
                  im = i + switch_up1(1) - switch_up2(1)
                  DO iDim = 1, ndim_vel
                     ISWITCH = 1 - MIN(1,ABS(IDIM-1)); JSWITCH = 1 - MIN(1,ABS(IDIM-2)); KSWITCH = 1 - MIN(1,ABS(IDIM-3))

                     I1 =IM - 2*ISWITCH; I2 =IM - ISWITCH; I3 =IM
                     II1=IM + ISWITCH;   II2=IM;           II3=IM - ISWITCH

                     J1 =JM - 2*JSWITCH; J2 =JM - JSWITCH; J3 =JM
                     JJ1=JM + JSWITCH;   JJ2=JM;           JJ3=JM - JSWITCH

                     K1 =KM - 2*KSWITCH; K2 =KM - KSWITCH; K3 =KM
                     KK1=KM + KSWITCH;   KK2=KM;           KK3=KM - KSWITCH

                     DENOIN1 = SIGN( MAX(ABS( T_NEW(I3,J3,K3,IG)  - T_NEW(I1,J1,K1,IG) ), TOLER),  &
                        T_NEW(I3,J3,K3,IG)  - T_NEW(I1,J1,K1,IG) )
                     DENOIN2 = SIGN( MAX(ABS( T_NEW(II3,JJ3,KK3,IG) - T_NEW(II1,JJ1,KK1,IG) ), TOLER), &
                        T_NEW(II3,JJ3,KK3,IG) - T_NEW(II1,JJ1,KK1,IG) )
                     CTILIN1 = ( T_NEW(I2,J2,K2,IG) - T_NEW(I1,J1,K1,IG) ) / DENOIN1
                     CTILIN2 = ( T_NEW(II2,JJ2,KK2,IG) - T_NEW(II1,JJ1,KK1,IG) ) / DENOIN2

                     FTILIN1 = ( 0.5*(T_NEW(I2,J2,K2,IG)+T_NEW(I3,J3,K3,IG))   - T_NEW(I1,J1,K1,IG) ) / DENOIN1 ! the mean with 0.5 coeff is the high order value of T.
                     FTILIN2 = ( 0.5*(T_NEW(II2,JJ2,KK2,IG)+T_NEW(II3,JJ3,KK3,IG)) - T_NEW(II1,JJ1,KK1,IG) ) / DENOIN2 ! the mean with 0.5 coeff is the high order value of T.

                     ! T_LIMIT(I+1) =          T(I-1) + MAX(  MIN(FTILIN, XI_LIMIT*CTILIN, 1.0), CTILIN) * DENOIN
                     ! T_LIMIT1(I+1) =          T(I-1) + MAX(  MIN(FTILIN, XI_LIMIT*CTILIN, 1.0), CTILIN) * ( T(I+1) - T(I-1) )
                     T_LIMIT1 =  T_NEW(I1,J1,K1,IG)    + MAX(  MIN(FTILIN1, XI_LIMIT*CTILIN1, 1.0), CTILIN1) &
                                 * ( T_NEW(I3,J3,K3,IG)    - T_NEW(I1,J1,K1,IG) )
                     T_LIMIT2 =  T_NEW(II1,JJ1,KK1,IG) + MAX(  MIN(FTILIN2, XI_LIMIT*CTILIN2, 1.0), CTILIN2) &
                                 * ( T_NEW(II3,JJ3,KK3,IG) - T_NEW(II1,JJ1,KK1,IG) )

                     U_DIM(IDIM)=U(IDIM,I,J,K,IG)
                     RH_SIG_U = 0.5 + 0.5*SIGN( 1.0, U_DIM(IDIM) )
                     T_UPWIND(IDIM) = RH_SIG_U * T_NEW(I-ISWITCH,J-JSWITCH,K-KSWITCH,IG)  +  (1.0-RH_SIG_U) * T_NEW(I,J,K,IG)
                     T_LIMIT(IDIM)  = RH_SIG_U * ( T_UPWIND(IDIM)*REAL(switch_up1(IDIM)) +T_LIMIT1*(1.0-REAL(switch_up1(IDIM))) ) &
                        +  (1.0-RH_SIG_U) * ( T_UPWIND(IDIM)*REAL(switch_up2(IDIM)) +T_LIMIT2*(1.0-REAL(switch_up2(IDIM))))

                     ! T_COEF(IDIM) = U_DIM(IDIM)*T_LIMIT/ ( SIGN(1.0,T_UPWIND)* MAX(TOLER, ABS(T_UPWIND) ) )
                     H_SIG_U(IDIM)=RH_SIG_U
                  END DO ! DO IDIM = 1, NDIM_VEL

                  ! A_MAT(I,J,K,IG,0,0,0)  = A_MAT(I,J,K,IG,0,0,0)   &
                  !          - (1.-H_SIG_U(1))*U_DIM(1)/DX - (1.-H_SIG_U(2))*U_DIM(2)/DY - (1.-H_SIG_U(3))*U_DIM(3)/DZ
                  ! A_MAT(I,J,K,IG,-1,0,0) = A_MAT(I,J,K,IG,-1,0,0) - H_SIG_U(1)*U_DIM(1)/DX
                  ! A_MAT(I,J,K,IG,0,-1,0) = A_MAT(I,J,K,IG,0,-1,0) - H_SIG_U(2)*U_DIM(2)/DY
                  ! A_MAT(I,J,K,IG,0,0,-1) = A_MAT(I,J,K,IG,0,0,-1) - H_SIG_U(3)*U_DIM(3)/DZ

                  ! A_MAT(I-1,J,K,IG,0,0,0)= A_MAT(I-1,J,K,IG,0,0,0)+ H_SIG_U(1)*U_DIM(1)/DX
                  ! A_MAT(I-1,J,K,IG,1,0,0)= A_MAT(I-1,J,K,IG,1,0,0)+ (1.-H_SIG_U(1))*U_DIM(1)/DX

                  ! A_MAT(I,J-1,K,IG,0,0,0)= A_MAT(I,J-1,K,IG,0,0,0)+ H_SIG_U(2)*U_DIM(2)/DY
                  ! A_MAT(I,J-1,K,IG,0,1,0)= A_MAT(I,J-1,K,IG,0,1,0)+ (1.-H_SIG_U(2))*U_DIM(2)/DY

                  ! A_MAT(I,J,K-1,IG,0,0,0)= A_MAT(I,J,K-1,IG,0,0,0)+ H_SIG_U(3)*U_DIM(3)/DZ
                  ! A_MAT(I,J,K-1,IG,0,0,1)= A_MAT(I,J,K-1,IG,0,0,1)+ (1.-H_SIG_U(3))*U_DIM(3)/DZ

                  A_MAT_I_J_K(I,J,K,IG)   = A_MAT_I_J_K(I,J,K,IG)    &
                        - (1.-H_SIG_U(1))*U_DIM(1)/DX - (1.-H_SIG_U(2))*U_DIM(2)/DY - (1.-H_SIG_U(3))*U_DIM(3)/DZ
                  A_MAT_IM1_J_K(I,J,K,IG) =  A_MAT_IM1_J_K(I,J,K,IG) - H_SIG_U(1)*U_DIM(1)/DX
                  A_MAT_I_JM1_K(I,J,K,IG) =  A_MAT_I_JM1_K(I,J,K,IG) - H_SIG_U(2)*U_DIM(2)/DY
                  A_MAT_I_J_KM1(I,J,K,IG) =  A_MAT_I_J_KM1(I,J,K,IG) - H_SIG_U(3)*U_DIM(3)/DZ

                  A_MAT_I_J_K(I-1,J,K,IG)   = A_MAT_I_J_K(I-1,J,K,IG)    + H_SIG_U(1)*U_DIM(1)/DX
                  A_MAT_IP1_J_K(I-1,J,K,IG) =  A_MAT_IP1_J_K(I-1,J,K,IG) + (1.-H_SIG_U(1))*U_DIM(1)/DX

                  A_MAT_I_J_K(I,J-1,K,IG)   = A_MAT_I_J_K(I,J-1,K,IG)    + H_SIG_U(2)*U_DIM(2)/DY
                  A_MAT_I_JP1_K(I,J-1,K,IG) =  A_MAT_I_JP1_K(I,J-1,K,IG) + (1.-H_SIG_U(2))*U_DIM(2)/DY

                  A_MAT_I_J_K(I,J,K-1,IG)   = A_MAT_I_J_K(I,J,K-1,IG)    + H_SIG_U(3)*U_DIM(3)/DZ
                  A_MAT_I_J_KP1(I,J,K-1,IG) =  A_MAT_I_J_KP1(I,J,K-1,IG) + (1.-H_SIG_U(3))*U_DIM(3)/DZ

                  ! For the vectors...
                  IF(.NOT.UPWIND1ST) THEN
                     S_INC_LIM(I,J,K,IG) = S_INC_LIM(I,J,K,IG) &
                        - U_DIM(1)*(T_UPWIND(1)-T_LIMIT(1))/DX &
                        - U_DIM(2)*(T_UPWIND(2)-T_LIMIT(2))/DY &
                        - U_DIM(3)*(T_UPWIND(3)-T_LIMIT(3))/DZ

                     S_INC_LIM(I-1,J,K,IG)   = S_INC_LIM(I-1,J,K,IG)  + U_DIM(1)*(T_UPWIND(1)-T_LIMIT(1))/DX

                     S_INC_LIM(I,J-1,K,IG)   = S_INC_LIM(I,J-1,K,IG)  + U_DIM(2)*(T_UPWIND(2)-T_LIMIT(2))/DY

                     S_INC_LIM(I,J,K-1,IG)   = S_INC_LIM(I,J,K-1,IG)  + U_DIM(3)*(T_UPWIND(3)-T_LIMIT(3))/DZ
                  ENDIF
               END DO
            END DO
         END DO
      END DO
      S_INC_LIM=S_INC_LIM + S
   ELSE ! ENDOF IF(NDIM_VEL.NE.0) THEN
      ! print *,'here1.1'
      ! print *,'NCOL_SIGMA_S,NX,NY,NZ,NG,NG2,NDIM_VEL,NITS,NITS_SOLV_NG:', &
      !          NCOL_SIGMA_S,NX,NY,NZ,NG,NG2,NDIM_VEL,NITS,NITS_SOLV_NG
      ! print *,'s=',s
      ! print *,'here 1.2'
      S_INC_LIM=S
   ENDIF ! IF(NDIM_VEL.NE.0) THEN ... ELSE...
   ! print *,'here2'

! Forward backward Gauss - Seidel...
   T_OLD = T_INITIAL
   DO ITIME=1,NTIME
      ! T_NEW = T_OLD
      DO ITS_NG=1,NITS_SOLV_NG
         R_T_MAX_DIF_NG = 0.0

         DO IIGG=0,ISWITCH_FBGS ! Switch on FBGS
            IG_START =1*(1-IIGG)  + (NG-1)*IIGG
            IG_FINISH=NG*(1-IIGG) + 2*IIGG
            IG_STEP  =1*(1-IIGG)  -  1*IIGG
            ILAST = ( 1-MIN(1, ABS(ITS_NG-NITS_SOLV_NG) ) )*IIGG ! The last backwards sweep of the last group iteration.
            IG_FINISH = IG_FINISH*(1-ILAST) + 1*ILAST
            DO IG=IG_START, IG_FINISH, IG_STEP
               RHS_SCAT=0.0
               IF(NCOL_SIGMA_S.NE.0) THEN ! Unstructured spares storage
                  DO COUNT = FIN_SIGMA_S(IG), FIN_SIGMA_S(IG+1)-1
                     JG=COL_SIGMA_S(COUNT)
                     RHS_SCAT(:,:,:) =  RHS_SCAT(:,:,:) + SIGMA_S_OFF_PTER(:,:,:,COUNT) * T_NEW(:,:,:,JG)
                  END DO
               ELSE ! Structured dense storage.
                  DO JG=1,NG
                     RHS_SCAT(:,:,:) =  RHS_SCAT(:,:,:) + SIGMA_S_OFF(:,:,:,IG,JG) * T_NEW(:,:,:,JG)
                  END DO
               ENDIF
               T_NEW_TEMP_NG(:,:,:)=T_NEW(:,:,:,IG)

               DO ITS=1,NITS
                  R_T_MAX_DIF = 0.0

                  DO KK=1,0,-1
                     DO K = 2*KK + (NZ-1)*(1-KK), 2*(KK-1) + (NZ-1)*KK , 1*KK - 1*(KK-1)
                        DO JJ=1,0,-1
                           DO J = 2*JJ + (NY-1)*(1-JJ), 2*(JJ-1) + (NY-1)*JJ , 1*JJ - 1*(JJ-1)
                              DO II=1,0,-1
                                 DO I = 2*II + (NX-1)*(1-II), 2*(II-1) + (NX-1)*II , 1*II - 1*(II-1)
                                    A_I_J_K = A_MAT_I_J_K(I,J,K,IG)
                                    A_IP1_J_K =  A_MAT_IP1_J_K(I,J,K,IG)
                                    A_IM1_J_K =  A_MAT_IM1_J_K(I,J,K,IG)
                                    A_I_JP1_K =  A_MAT_I_JP1_K(I,J,K,IG)
                                    A_I_JM1_K =  A_MAT_I_JM1_K(I,J,K,IG)

                                    A_I_J_KP1 =  A_MAT_I_J_KP1(I,J,K,IG)
                                    A_I_J_KM1=A_MAT_I_J_KM1(I,J,K,IG)

                                    R_T_NEW =                                                                                &
                                       (-A_IP1_J_K*T_NEW(I+1,J,K,IG) - A_IM1_J_K*T_NEW(I-1,J,K,IG) - A_I_JP1_K*T_NEW(I,J+1,K,IG) &
                                       - A_I_JM1_K*T_NEW(I,J-1,K,IG) - A_I_J_KP1*T_NEW(I,J,K+1,IG) - A_I_J_KM1*T_NEW(I,J,K-1,IG) &
                                       + S_INC_LIM(I,J,K,IG) + RHS_SCAT(I,J,K) + (1./(DT*V_N(IG)))*T_OLD(I,J,K,IG) ) / A_I_J_K
                                    R_T_MAX_DIF = MAX(ABS(R_T_NEW-T_NEW(I,J,K,IG) ), R_T_MAX_DIF)
                                    ! Relax the soln.
                                    T_NEW(I,J,K,IG) = RELAX*R_T_NEW + (1.-RELAX) * T_NEW(I,J,K,IG)
                                 END DO
                              END DO
                           END DO
                        END DO
                     END DO
                  END DO
                  ! print *,'its,nits,R_T_MAX_DIF:',its,nits,R_T_MAX_DIF

                  IF(R_T_MAX_DIF.LT.ERROR_SOLV) THEN
                     ! print *,'its,nits,R_T_MAX_DIF,IG:',its,nits,R_T_MAX_DIF,IG
                     EXIT
                  ENDIF
                  ! T_TOTAL(:,:,:,:,ITS)=T_NEW(:,:,:,:)
               END DO ! DO ITS=1,NITS
               ! print *,'IG,ITS,R_T_MAX_DIF,ERROR_SOLV:',IG,ITS,R_T_MAX_DIF,ERROR_SOLV

               T_NEW(:,:,:,IG) = RELAX_NG*T_NEW(:,:,:,IG) + (1.-RELAX_NG) * T_NEW_TEMP_NG(:,:,:)
               R_T_MAX_DIF_NG = MAX( R_T_MAX_DIF_NG,  MAXVAL(ABS(T_NEW_TEMP_NG(:,:,:)-T_NEW(:,:,:,IG) ))  )
               ! print *,'ig,r_t_max_dif_ng:',ig,r_t_max_dif_ng
            END DO ! DO IG=IG_START, IG_FINISH, IG_STEP
         END DO ! DO IIGG=0,ISWITCH_FBGS ! Switch on FBGS
         ! T_TOTAL(:,:,:,:,ITS_NG)=T_NEW(:,:,:,:)
         ! PRINT *,'ITS_NG,R_T_MAX_DIF_NG,ERROR_SOLV_NG:',ITS_NG,R_T_MAX_DIF_NG,ERROR_SOLV_NG

         IF(R_T_MAX_DIF_NG.LT.ERROR_SOLV_NG) EXIT
      END DO ! ITS_G=1,NITS_SOLV_NG

      T_OLD=T_NEW ! Prepare for next time step.
      ! print *,'2.1 sum(t_new):',sum(t_new)
      ! PRINT *,' '
      ! print *,'inside solver S:'
      ! call PRINT_NORMAL(S,NX,NY,NZ,NG)
      ! PRINT *,' '
      ! print *,'inside solver T_INITIAL:'
      ! call PRINT_NORMAL(T_INITIAL,NX,NY,NZ,NG)
      ! PRINT *,' '
      ! print *,'inside solver T_NEW:'
      ! call PRINT_NORMAL(T_NEW,NX,NY,NZ,NG)
      ! PRINT *,'FINISHEING SOLVER ***'
      ! stop 2821

   END DO ! DO ITIME=1,NTIME
   ! print *,'here3'
END SUBROUTINE time_stepping_diffusion_calc


! ----------------------------------------------------------------------
! ----------------------------------------------------------------------
! Slow manifolds computation in the self-coupled FitzHugh-Nagumo system
! ----------------------------------------------------------------------
! C o m p.  o f  t h e  r e p e l l i n g  s l o w  m a n i f o l d
! ----------------------------------------------------------------------
! Homotopy step 1: "away from the folded node along the fold curve"
! followed by
! Homotopy step 2: "away from the fold curve on the critical manifold"
! followed by
! Actual computation of the repelling slow manifold
! ----------------------------------------------------------------------
! Ref.: Desroches, Krauskopf and Osinga, CHAOS 18, 015107 (2008)
! ----------------------------------------------------------------------
! ----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

       DOUBLE PRECISION v, h, s, epsilon, gamma, delta, T

       ! Define the state variables
       v = U(1)
       h = U(2)
       s = U(3)

       ! Define the system parameters
       epsilon = PAR(1)
       gamma   = PAR(2)
       delta   = PAR(3)

       ! Define the integration time as a parameter
       T       = PAR(11)

       ! Define the right-hand sides
       F(1) = T * (h - (v**3 - v + 1) / 2 - gamma * s * v)
       F(2) = T * (-epsilon * (2 * h + 2.6d0 * v))
       F(3) = T * (-epsilon * delta * s)

      END SUBROUTINE FUNC

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

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

       !             epsilon  gamma  delta
       PAR(1:3) = (/ 0.015d0, 0.5d0, 0.565d0 /)
       PAR(11) = 0

       !            v        h          s
       U(1:3) = (/ -0.490d0, 0.61760d0, 0.27970d0 /)

       PAR(4) = U(1) ! v(1)
       PAR(5) = U(3) ! s(0)
       PAR(6) = U(3) ! s(1)

      END SUBROUTINE STPNT

! ----------------------------------------------------------------------
! ----------------------------------------------------------------------
      SUBROUTINE BCND(NDIM,PAR,ICP,NBC,U0,U1,FB,IJAC,DBC)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), NBC, IJAC
      DOUBLE PRECISION, INTENT(IN) :: PAR(*), U0(NDIM), U1(NDIM)
      DOUBLE PRECISION, INTENT(OUT) :: FB(NBC)
      DOUBLE PRECISION, INTENT(INOUT) :: DBC(NBC,*)

       ! Define boundary conditions */

       ! Define the critical manifold S as {(v,h,s) ; 2*h-v^3+v-1-v*s=0}
       ! (we use the fact that gamma is fixed at the value 0.5)

       FB(1) = 2*U1(2)-U1(1)**3+U1(1)-1-U1(3)*U1(1)
       FB(2) = U1(1) - PAR(4)  ! End point is on the intersection between S
       FB(3) = U1(3) - PAR(6)  ! and the plane {s=0.05/v=0.0}

       FB(4) = U0(3) - PAR(5)  ! Initial point is in a cross-section containing
                               ! the folded node: Sigma_fn={s=0.27970}

       IF(NBC==4) RETURN

       ! FB(1) and FB(5): {(v,h,s) ; s - (1 - 3*v^2=0)}
       ! together define the folded node F
       FB(5) = U1(3) - (1 - 3*U1(1)**2)

      END SUBROUTINE BCND

! ----------------------------------------------------------------------
! ----------------------------------------------------------------------
      SUBROUTINE PVLS(NDIM,U,PAR)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: PAR(*)

      DOUBLE PRECISION, EXTERNAL :: GETP

       ! Define external parameter which monitors the v- and the h-coordinate
       ! of the initial point in section Sigma_fn */
       PAR(8) = GETP("BV0", 1, U)
       PAR(9) = GETP("BV0", 2, U)
      END SUBROUTINE PVLS
! ----------------------------------------------------------------------
! ----------------------------------------------------------------------
! ----------------------------------------------------------------------
! ----------------------------------------------------------------------
      SUBROUTINE ICND
      END SUBROUTINE ICND
! ----------------------------------------------------------------------
! ----------------------------------------------------------------------
      SUBROUTINE FOPT
      END SUBROUTINE FOPT


module IR_Precision
!-----------------------------------------------------------------------------------------------------------------------------------
!!The module IR_Precision makes available some portable kind-parameters and some usefull informations to deal with them. It also
!!provides variables that contains the smallest real evaluable by the running calculator, Zero, Zero16, Zero8 and Zero4.
!!Finally the module provides a function to convert a string to number, 'cton', that accepts both reals and integers, and 2 other
!!functions that convert a number to string: 'str' that convert real and integer to string and 'strz' that convert only integer to
!!string prefixing the string with zeros.
!-----------------------------------------------------------------------------------------------------------------------------------

!-----------------------------------------------------------------------------------------------------------------------------------
implicit none
private
#ifdef r16p
public:: R16P, FR16P, DR16P, MinR16P, MaxR16P, ZeroR16
#endif
public:: R8P,  FR8P,  DR8P,  MinR8P,  MaxR8P,  ZeroR8
public:: R4P,  FR4P,  DR4P,  MinR4P,  MaxR4P,  ZeroR4
public:: R_P,  FR_P,  DR_P,  MinR_P,  MaxR_P,  Zero
public:: I8P,  FI8P,  DI8P,  MinI8P,  MaxI8P
public:: I4P,  FI4P,  DI4P,  MinI4P,  MaxI4P
public:: I2P,  FI2P,  DI2P,  MinI2P,  MaxI2P
public:: I1P,  FI1P,  DI1P,  MinI1P,  MaxI1P
public:: I_P,  FI_P,  DI_P,  MinI_P,  MaxI_P
public:: str, strz, cton
public:: IR_Print
!-----------------------------------------------------------------------------------------------------------------------------------

!-----------------------------------------------------------------------------------------------------------------------------------
!!The following are the portable kind parameters available.
!!
!!Real precision definitions:
!!
#ifdef r16p
integer, parameter:: R16P = selected_real_kind(33,4931) ! 33  digits, range $[10^{-4931}, 10^{+4931} - 1]$
#endif
integer, parameter:: R8P  = selected_real_kind(15,307)  ! 15  digits, range $[10^{-307} , 10^{+307}  - 1]$
integer, parameter:: R4P  = selected_real_kind(6,37)    ! 6   digits, range $[10^{-37}  , 10^{+37}   - 1]$
integer, parameter:: R_P  = R8P                         ! default real precision
!!
!!Integer precision definitions:
!!
integer, parameter:: I8P  = selected_int_kind(18) ! range $[-2^{63},+2^{63} - 1]$, 19 number of digits plus sign
integer, parameter:: I4P  = selected_int_kind(9)  ! range $[-2^{31},+2^{31} - 1]$, 10 number of digits plus sign
integer, parameter:: I2P  = selected_int_kind(4)  ! range $[-2^{15},+2^{15} - 1]$, 5  number of digits plus sign
integer, parameter:: I1P  = selected_int_kind(2)  ! range $[-2^{7} ,+2^{7}  - 1]$, 3  number of digits plus sign
integer, parameter:: I_P  = I4P                   ! default integer precision
!!
!!Besides the kind parameters there are also the format parameters useful for writing in a well-ascii-format numeric variables.
!!
!!Real output formats:
!!
#ifdef r16p
character(10), parameter:: FR16P = '(E42.33E4)' ! R16P  output format
#endif
character(10), parameter:: FR8P  = '(E23.15E3)' ! R8P   output format
character(9),  parameter:: FR4P  = '(E13.6E2)'  ! R4P   output format
character(10), parameter:: FR_P  = FR8P         ! R\_P  output format
!!
!!Real number of digits of output formats:
#ifdef r16p
integer, parameter:: DR16P = 42   ! R16P output format digits
#endif
integer, parameter:: DR8P  = 23   ! R8P  output format digits
integer, parameter:: DR4P  = 13   ! R4P  output format digits
integer, parameter:: DR_P  = DR8P ! R\_P  output format digits
!!
!!Real min and max values:
#ifdef r16p
real(R16P), parameter:: MinR16P = -huge(1._R16P), MaxR16P = huge(1._R16P) ! R16P min and max values
#endif
real(R8P),  parameter:: MinR8P  = -huge(1._R8P ), MaxR8P  = huge(1._R8P ) ! R8P  min and max values
real(R4P),  parameter:: MinR4P  = -huge(1._R4P ), MaxR4P  = huge(1._R4P ) ! R4P  min and max values
real(R_P),  parameter:: MinR_P  = MinR8P,         MaxR_P  = MaxR8P        ! R\_P  min and max values
!!
!!Integer output formats:
!!
character(5), parameter:: FI8P   = '(I20)'    ! I8P output format
character(8), parameter:: FI8PZP = '(I20.19)' ! I8P output format with zero prefixing
character(5), parameter:: FI4P   = '(I11)'    ! I4P output format
character(8), parameter:: FI4PZP = '(I11.10)' ! I4P output format with zero prefixing
character(4), parameter:: FI2P   = '(I6)'     ! I2P output format
character(6), parameter:: FI2PZP = '(I6.5)'   ! I2P output format with zero prefixing
character(4), parameter:: FI1P   = '(I4)'     ! I1P output format
character(6), parameter:: FI1PZP = '(I4.3)'   ! I1P output format with zero prefixing
character(5), parameter:: FI_P   = FI4P       ! I\_P output format
character(8), parameter:: FI_PZP = FI4PZP     ! I\_P output format with zero prefixing
!!
!!Integer number of digits of output formats:
integer, parameter:: DI8P = 20   ! I8P output format digits
integer, parameter:: DI4P = 11   ! I4P output format digits
integer, parameter:: DI2P = 6    ! I2P output format digits
integer, parameter:: DI1P = 4    ! I1P output format digits
integer, parameter:: DI_P = DI4P ! I\_P output format digits
!!
!!Integer min and max values:
integer(I8P), parameter:: MinI8P = -huge(1_I8P)-1_I8P, MaxI8P = huge(1_I8P) ! I8P min and max values
integer(I4P), parameter:: MinI4P = -huge(1_I4P)-1_I4P, MaxI4P = huge(1_I4P) ! I4P min and max values
integer(I2P), parameter:: MinI2P = -huge(1_I2P)-1_I2P, MaxI2P = huge(1_I2P) ! I2P min and max values
integer(I2P), parameter:: MinI1P = -huge(1_I1P)-1_I1P, MaxI1P = huge(1_I1P) ! I1P min and max values
integer(I_P), parameter:: MinI_P = MinI4P,             MaxI_P = MaxI4P      ! I\_P min and max values
!!
!!IR\_Precision module provides some global variables in order to store the smallest real evaluable by the running calculator.
!!
#ifdef r16p
real(R16P), parameter:: ZeroR16 = nearest(1._R16P,1._R16P) - nearest(1._R16P,-1._R16P)
#endif
#ifdef pgf95
real(R8P),  parameter:: ZeroR8  = 0._R8P
real(R4P),  parameter:: ZeroR4  = 0._R4P
#else
real(R8P),  parameter:: ZeroR8  = nearest(1._R8P,1._R8P) - nearest(1._R8P,-1._R8P)
real(R4P),  parameter:: ZeroR4  = nearest(1._R4P,1._R4P) - nearest(1._R4P,-1._R4P)
#endif
real(R_P),  parameter:: Zero    = ZeroR8
!-----------------------------------------------------------------------------------------------------------------------------------

!-----------------------------------------------------------------------------------------------------------------------------------
!! str overloading
interface str
  module procedure           &
#ifdef r16p
                   str_R16P, &
#endif
                   str_R8P,  &
                   str_R4P,  &
                   str_I8P,  &
                   str_I4P,  &
                   str_I2P,  &
                   str_I1P
endinterface
!! strz overloading
interface strz
  module procedure strz_I8P,  &
                   strz_I4P,  &
                   strz_I2P,  &
                   strz_I1P
endinterface
!! ctoi overloading
interface cton
  module procedure            &
#ifdef r16p
                   ctor_R16P, &
#endif
                   ctor_R8P,  &
                   ctor_R4P,  &
                   ctoi_I8P,  &
                   ctoi_I4P,  &
                   ctoi_I2P,  &
                   ctoi_I1P
endinterface
!-----------------------------------------------------------------------------------------------------------------------------------
contains
#ifdef r16p
  elemental function str_R16P(no_sign,n) result(str)
  !---------------------------------------------------------------------------------------------------------------------------------
  !!The function str\_R16P converts real to string. This function achieves casting of real to string.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  implicit none
  logical,    intent(IN), optional:: no_sign ! Flag for leaving out the sign.
  real(R16P), intent(IN)::           n       ! Real to be converted.
  character(DR16P)::                 str     ! Returned string containing input number.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  write(str,FR16P) n                ! Casting of n to string.
  if (n>0._R16P) str(1:1)='+'       ! Prefixing plus if n>0.
  if (present(no_sign)) str=str(2:) ! Leaving out the sign.
  return
  !---------------------------------------------------------------------------------------------------------------------------------
  endfunction str_R16P
#endif

  elemental function str_R8P(no_sign,n) result(str)
  !---------------------------------------------------------------------------------------------------------------------------------
  !!The function str\_R8P converts real to string. This function achieves casting of real to string.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  implicit none
  logical,   intent(IN), optional:: no_sign ! Flag for leaving out the sign.
  real(R8P), intent(IN)::           n       ! Real to be converted.
  character(DR8P)::                 str     ! Returned string containing input number.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  write(str,FR8P) n                 ! Casting of n to string.
  if (n>0._R8P) str(1:1)='+'        ! Prefixing plus if n>0.
  if (present(no_sign)) str=str(2:) ! Leaving out the sign.
  return
  !---------------------------------------------------------------------------------------------------------------------------------
  endfunction str_R8P

  elemental function str_R4P(no_sign,n) result(str)
  !---------------------------------------------------------------------------------------------------------------------------------
  !!The function str\_R4P converts real to string. This function achieves casting of real to string.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  implicit none
  logical,   intent(IN), optional:: no_sign ! Flag for leaving out the sign.
  real(R4P), intent(IN)::           n       ! Real to be converted.
  character(DR4P)::                 str     ! Returned string containing input number.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  write(str,FR4P) n                 ! Casting of n to string.
  if (n>0._R4P) str(1:1)='+'        ! Prefixing plus if n>0.
  if (present(no_sign)) str=str(2:) ! Leaving out the sign.
  return
  !---------------------------------------------------------------------------------------------------------------------------------
  endfunction str_R4P

  elemental function str_I8P(no_sign,n) result(str)
  !---------------------------------------------------------------------------------------------------------------------------------
  !!The function str\_I8P converts integer to string. This function achieves casting of integer to string.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  implicit none
  logical,      intent(IN), optional:: no_sign ! Flag for leaving out the sign.
  integer(I8P), intent(IN)::           n       ! Integer to be converted.
  character(DI8P)::                    str     ! Returned string containing input number plus padding zeros.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  write(str,FI8P) n                 ! Casting of n to string.
  str = adjustl(trim(str))          ! Removing white spaces.
  if (n>=0_I8P) str='+'//trim(str)  ! Prefixing plus if n>0.
  if (present(no_sign)) str=str(2:) ! Leaving out the sign.
  return
  !---------------------------------------------------------------------------------------------------------------------------------
  endfunction str_I8P

  elemental function str_I4P(no_sign,n) result(str)
  !---------------------------------------------------------------------------------------------------------------------------------
  !!The function str\_I4P converts integer to string. This function achieves casting of integer to string.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  implicit none
  logical,      intent(IN), optional:: no_sign ! Flag for leaving out the sign.
  integer(I4P), intent(IN)::           n       ! Integer to be converted.
  character(DI4P)::                    str     ! Returned string containing input number plus padding zeros.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  write(str,FI4P) n                 ! Casting of n to string.
  str = adjustl(trim(str))          ! Removing white spaces.
  if (n>=0_I4P) str='+'//trim(str)  ! Prefixing plus if n>0.
  if (present(no_sign)) str=str(2:) ! Leaving out the sign.
  return
  !---------------------------------------------------------------------------------------------------------------------------------
  endfunction str_I4P

  elemental function str_I2P(no_sign,n) result(str)
  !---------------------------------------------------------------------------------------------------------------------------------
  !!The function str\_I2P converts integer to string. This function achieves casting of integer to string.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  implicit none
  logical,      intent(IN), optional:: no_sign ! Flag for leaving out the sign.
  integer(I2P), intent(IN)::           n       ! Integer to be converted.
  character(DI2P)::                    str     ! Returned string containing input number plus padding zeros.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  write(str,FI2P) n                 ! Casting of n to string.
  str = adjustl(trim(str))          ! Removing white spaces.
  if (n>=0_I2P) str='+'//trim(str)  ! Prefixing plus if n>0.
  if (present(no_sign)) str=str(2:) ! Leaving out the sign.
  return
  !---------------------------------------------------------------------------------------------------------------------------------
  endfunction str_I2P

  elemental function str_I1P(no_sign,n) result(str)
  !---------------------------------------------------------------------------------------------------------------------------------
  !!The function str\_I1P converts integer to string. This function achieves casting of integer to string.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  implicit none
  logical,      intent(IN), optional:: no_sign ! Flag for leaving out the sign.
  integer(I1P), intent(IN)::           n       ! Integer to be converted.
  character(DI1P)::                    str     ! Returned string containing input number plus padding zeros.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  write(str,FI1P) n                 ! Casting of n to string.
  str = adjustl(trim(str))          ! Removing white spaces.
  if (n>=0_I1P) str='+'//trim(str)  ! Prefixing plus if n>0.
  if (present(no_sign)) str=str(2:) ! Leaving out the sign.
  return
  !---------------------------------------------------------------------------------------------------------------------------------
  endfunction str_I1P

  elemental function strz_I8P(nz_pad,n) result(str)
  !---------------------------------------------------------------------------------------------------------------------------------
  !!The function strz\_I8P converts integer to string, prefixing with the right number of zeros. This function achieves casting of
  !!integer to string.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  implicit none
  integer(I4P), intent(IN), optional:: nz_pad ! Number of zeros padding.
  integer(I8P), intent(IN)::           n      ! Integer to be converted.
  character(DI8P)::                    str    ! Returned string containing input number plus padding zeros.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  write(str,FI8PZP) n                              ! Casting of n to string.
  str=str(2:)                                      ! Leaving out the sign.
  if (present(nz_pad)) str=str(DI8P-nz_pad:DI8P-1) ! Leaving out the extra zeros padding
  return
  !---------------------------------------------------------------------------------------------------------------------------------
  endfunction strz_I8P

  elemental function strz_I4P(nz_pad,n) result(str)
  !---------------------------------------------------------------------------------------------------------------------------------
  !!The function strz\_I4P converts integer to string, prefixing with the right number of zeros. This function achieves casting of
  !!integer to string.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  implicit none
  integer(I4P), intent(IN), optional:: nz_pad ! Number of zeros padding.
  integer(I4P), intent(IN)::           n      ! Integer to be converted.
  character(DI4P)::                    str    ! Returned string containing input number plus padding zeros.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  write(str,FI4PZP) n                              ! Casting of n to string.
  str=str(2:)                                      ! Leaving out the sign.
  if (present(nz_pad)) str=str(DI4P-nz_pad:DI4P-1) ! Leaving out the extra zeros padding
  return
  !---------------------------------------------------------------------------------------------------------------------------------
  endfunction strz_I4P

  elemental function strz_I2P(nz_pad,n) result(str)
  !---------------------------------------------------------------------------------------------------------------------------------
  !!The function strz\_I2P converts integer to string, prefixing with the right number of zeros. This function achieves casting of
  !!integer to string.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  implicit none
  integer(I4P), intent(IN), optional:: nz_pad ! Number of zeros padding.
  integer(I2P), intent(IN)::           n      ! Integer to be converted.
  character(DI2P)::                    str    ! Returned string containing input number plus padding zeros.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  write(str,FI2PZP) n                              ! Casting of n to string.
  str=str(2:)                                      ! Leaving out the sign.
  if (present(nz_pad)) str=str(DI2P-nz_pad:DI2P-1) ! Leaving out the extra zeros padding
  return
  !---------------------------------------------------------------------------------------------------------------------------------
  endfunction strz_I2P

  elemental function strz_I1P(nz_pad,n) result(str)
  !---------------------------------------------------------------------------------------------------------------------------------
  !!The function strz\_I1P converts integer to string, prefixing with the right number of zeros. This function achieves casting of
  !!integer to string.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  implicit none
  integer(I4P), intent(IN), optional:: nz_pad ! Number of zeros padding.
  integer(I1P), intent(IN)::           n      ! Integer to be converted.
  character(DI1P)::                    str    ! Returned string containing input number plus padding zeros.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  write(str,FI1PZP) n                              ! Casting of n to string.
  str=str(2:)                                      ! Leaving out the sign.
  if (present(nz_pad)) str=str(DI1P-nz_pad:DI1P-1) ! Leaving out the extra zeros padding
  return
  !---------------------------------------------------------------------------------------------------------------------------------
  endfunction strz_I1P

#ifdef r16p
  function ctor_R16P(str,knd) result(n)
  !---------------------------------------------------------------------------------------------------------------------------------
  !!The function ctor\_R16P converts string to real. This function achieves casting of string to real.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  implicit none
  character(*), intent(IN):: str   ! String containing input number.
  real(R16P),   intent(IN):: knd   ! Number kind.
  real(R16P)::               n     ! Number returned.
  integer(I4P)::             E_IO  ! Input/Output debug flag.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  read(str,*,iostat=E_IO) n ! Casting of str to n.
  if (E_IO/=0) then
    write(6,'(A)')             'Conversion of string "'//str//'" to real failed'
    write(6,'(A,'//FR16P//')') 'Kind parameter ',knd
    write(6,'(A)')             'Function used "ctor_R16P"'
  endif
  return
  !---------------------------------------------------------------------------------------------------------------------------------
  endfunction ctor_R16P
#endif

  function ctor_R8P(str,knd) result(n)
  !---------------------------------------------------------------------------------------------------------------------------------
  !!The function ctor\_R8P converts string to real. This function achieves casting of string to real.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  implicit none
  character(*), intent(IN):: str   ! String containing input number.
  real(R8P),    intent(IN):: knd   ! Number kind.
  real(R8P)::                n     ! Number returned.
  integer(I4P)::             E_IO  ! Input/Output debug flag.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  read(str,*,iostat=E_IO) n ! Casting of str to n.
  if (E_IO/=0) then
    write(6,'(A)')            'Conversion of string "'//str//'" to real failed'
    write(6,'(A,'//FR8P//')') 'Kind parameter ',knd
    write(6,'(A)')            'Function used "ctor_R8P"'
  endif
  return
  !---------------------------------------------------------------------------------------------------------------------------------
  endfunction ctor_R8P

  function ctor_R4P(str,knd) result(n)
  !---------------------------------------------------------------------------------------------------------------------------------
  !!The function ctor\_R4P converts string to real. This function achieves casting of string to real.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  implicit none
  character(*), intent(IN):: str   ! String containing input number.
  real(R4P),    intent(IN):: knd   ! Number kind.
  real(R4P)::                n     ! Number returned.
  integer(I4P)::             E_IO  ! Input/Output debug flag.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  read(str,*,iostat=E_IO) n ! Casting of str to n.
  if (E_IO/=0) then
    write(6,'(A)')            'Conversion of string "'//str//'" to real failed'
    write(6,'(A,'//FR4P//')') 'Kind parameter ',knd
    write(6,'(A)')            'Function used "ctor_R4P"'
  endif
  return
  !---------------------------------------------------------------------------------------------------------------------------------
  endfunction ctor_R4P

  function ctoi_I8P(str,knd) result(n)
  !---------------------------------------------------------------------------------------------------------------------------------
  !!The function ctoi\_I8P converts string to integer. This function achieves casting of string to integer.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  implicit none
  character(*), intent(IN):: str   ! String containing input number.
  integer(I8P), intent(IN):: knd   ! Number kind.
  integer(I8P)::             n     ! Number returned.
  integer(I4P)::             E_IO  ! Input/Output debug flag.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  read(str,*,iostat=E_IO) n ! Casting of str to n.
  if (E_IO/=0) then
    write(6,'(A)')            'Conversion of string "'//str//'" to integer failed'
    write(6,'(A,'//FI8P//')') 'Kind parameter ',knd
    write(6,'(A)')            'Function used "ctoi_I8P"'
  endif
  return
  !---------------------------------------------------------------------------------------------------------------------------------
  endfunction ctoi_I8P

  function ctoi_I4P(str,knd) result(n)
  !---------------------------------------------------------------------------------------------------------------------------------
  !!The function ctoi\_I4P converts string to integer. This function achieves casting of string to integer.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  implicit none
  character(*), intent(IN):: str   ! String containing input number.
  integer(I4P), intent(IN):: knd   ! Number kind.
  integer(I4P)::             n     ! Number returned.
  integer(I4P)::             E_IO  ! Input/Output debug flag.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  read(str,*,iostat=E_IO) n ! Casting of str to n.
  if (E_IO/=0) then
    write(6,'(A)')            'Conversion of string "'//str//'" to integer failed'
    write(6,'(A,'//FI4P//')') 'Kind parameter ',knd
    write(6,'(A)')            'Function used "ctoi_I4P"'
  endif
  return
  !---------------------------------------------------------------------------------------------------------------------------------
  endfunction ctoi_I4P

  function ctoi_I2P(str,knd) result(n)
  !---------------------------------------------------------------------------------------------------------------------------------
  !!The function ctoi\_I2P converts string to integer. This function achieves casting of string to integer.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  implicit none
  character(*), intent(IN):: str   ! String containing input number.
  integer(I2P), intent(IN):: knd   ! Number kind.
  integer(I2P)::             n     ! Number returned.
  integer(I4P)::             E_IO  ! Input/Output debug flag.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  read(str,*,iostat=E_IO) n ! Casting of str to n.
  if (E_IO/=0) then
    write(6,'(A)')            'Conversion of string "'//str//'" to integer failed'
    write(6,'(A,'//FI2P//')') 'Kind parameter ',knd
    write(6,'(A)')            'Function used "ctoi_I2P"'
  endif
  return
  !---------------------------------------------------------------------------------------------------------------------------------
  endfunction ctoi_I2P

  function ctoi_I1P(str,knd) result(n)
  !---------------------------------------------------------------------------------------------------------------------------------
  !!The function ctoi\_I1P converts string to integer. This function achieves casting of string to integer.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  implicit none
  character(*), intent(IN):: str   ! String containing input number.
  integer(I1P), intent(IN):: knd   ! Number kind.
  integer(I1P)::             n     ! Number returned.
  integer(I4P)::             E_IO  ! Input/Output debug flag.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  read(str,*,iostat=E_IO) n ! Casting of str to n.
  if (E_IO/=0) then
    write(6,'(A)')            'Conversion of string "'//str//'" to integer failed'
    write(6,'(A,'//FI1P//')') 'Kind parameter ',knd
    write(6,'(A)')            'Function used "ctoi_I1P"'
  endif
  return
  !---------------------------------------------------------------------------------------------------------------------------------
  endfunction ctoi_I1P

  subroutine IR_Print()
  !---------------------------------------------------------------------------------------------------------------------------------
  !!The subroutine IR\_Print print to the standard output the kind definition of reals and integers and the utility variables.
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  implicit none
  !---------------------------------------------------------------------------------------------------------------------------------

  !---------------------------------------------------------------------------------------------------------------------------------
  write(*,'(A)')                                    ' Reals kind precision definition'
#ifdef r16p
  write(*,'(A,I2,A,I2)')                            ' R16P Kind "',R16P,'" | FR16P format "'//FR16P//'" | DR16P chars ',DR16P
#endif
  write(*,'(A,I2,A,I2)')                            ' R8P  Kind "',R8P, '" | FR8P  format "'//FR8P// '" | DR8P  chars ',DR8P
  write(*,'(A,I2,A,I2)')                            ' R4P  Kind "',R4P, '" | FR4P  format "'//FR4P//'"  | DR4P  chars ',DR4P
  write(*,'(A)')                                    ' Integers kind precision definition'
  write(*,'(A,I2,A,I2)')                            ' I8P Kind "',I8P,'" | FI8P format "'//FI8P// '" | DI8P chars ',DI8P
  write(*,'(A,I2,A,I2)')                            ' I4P Kind "',I4P,'" | FI4P format "'//FI4P// '" | DI4P chars ',DI4P
  write(*,'(A,I2,A,I2)')                            ' I2P Kind "',I2P,'" | FI2P format "'//FI2P//'"  | DI2P chars ',DI2P
  write(*,'(A,I2,A,I2)')                            ' I1P Kind "',I1P,'" | FI1P format "'//FI1P//'"  | DI1P chars ',DI1P
  write(*,'(A)')                                    ' Reals minimum and maximum values'
#ifdef r16p
  write(*,'(A,'//FR16P//',A,'       //FR16P//',A)') ' MinR16P "',MinR16P,   '" | MaxR16P "',MaxR16P,'"'
#endif
  write(*,'(A,'//FR8P// ',A,19X,A,' //FR8P// ',A)') ' MinR8P  "', MinR8P,'"',' | MaxR8P  "',MaxR8P,'"'
  write(*,'(A,'//FR4P// ',A,29X,A,' //FR4P// ',A)') ' MinR4P  "', MinR4P,'"',' | MaxR4P  "',MaxR4P,'"'
  write(*,'(A)')                                    ' Integers minimum and maximum values'
  write(*,'(A,'//FI8P// ',A,'       //FI8P// ',A)') ' MinI8P  "', MinI8P,   '" | MaxI8P  "',MaxI8P,'"'
  write(*,'(A,'//FI4P// ',A,9X,A,'  //FI4P// ',A)') ' MinI4P  "', MinI4P,'"',' | MaxI4P  "',MaxI4P,'"'
  write(*,'(A,'//FI2P// ',A,14X,A,' //FI2P// ',A)') ' MinI2P  "', MinI2P,'"',' | MaxI2P  "',MaxI2P,'"'
  write(*,'(A,'//FI1P// ',A,16X,A,' //FI1P// ',A)') ' MinI1P  "', MinI1P,'"',' | MaxI1P  "',MaxI1P,'"'
  write(*,'(A)')                                    ' Machine precions'
#ifdef r16p
  write(*,'(A,'//FR16P//')')                        ' ZeroR16 "',ZeroR16
#endif
  write(*,'(A,'//FR8P// ')')                        ' ZeroR8  "',ZeroR8
  write(*,'(A,'//FR4P// ')')                        ' ZeroR4  "',ZeroR4
  !---------------------------------------------------------------------------------------------------------------------------------
  endsubroutine IR_Print
endmodule IR_Precision


module find_mod
implicit none

private

public  :: find                 ! Find position in an array being equal to a given value

interface find
    procedure find_int_1d, find_int_2d, find_dbl_1d_tol, find_dbl_2d_tol, &
              find_dbl_pt_3d_array
end interface find

contains

function find_int_1d(array, val_to_find) result(ind)
implicit none
    integer, intent(in) :: array(:)
    integer, intent(in) :: val_to_find
    integer             :: ind, tmp_ind(1)

    tmp_ind = minloc(abs(array - val_to_find))
    ind = tmp_ind(1)

    if (abs(array(ind)-val_to_find) /= 0) ind = -1

end function find_int_1d

function find_int_2d(array, val_to_find) result(ind)
implicit none
    integer, intent(in) :: array(:,:)
    integer, intent(in) :: val_to_find
    integer             :: ind(2)

    ind = minloc(abs(array - val_to_find))

    if (abs(array(ind(1), ind(2))-val_to_find) /= 0) ind = -1

end function find_int_2d

function find_dbl_1d_tol(array, val_to_find, tol) result(ind)
implicit none
    double precision, intent(in)    :: array(:)
    double precision, intent(in)    :: val_to_find
    double precision, intent(in)    :: tol
    integer                         :: ind, tmp_ind(1)

    tmp_ind = minloc(abs(array - val_to_find))
    ind = tmp_ind(1)

    if (abs(array(ind)-val_to_find) > tol) ind = -1

end function find_dbl_1d_tol

function find_dbl_2d_tol(array, val_to_find, tol) result(ind)
implicit none
    double precision, intent(in)    :: array(:,:)
    double precision, intent(in)    :: val_to_find
    double precision, intent(in)    :: tol
    integer                         :: ind(2)

    ind = minloc(abs(array - val_to_find))

    if (abs(array(ind(1), ind(2))-val_to_find) > tol) ind = -1

end function find_dbl_2d_tol

function find_dbl_pt_3d_array(array, point_to_find, point_dim, tol) result(ind)
implicit none
    double precision, intent(in)    :: array(:,:,:)
    double precision, intent(in)    :: point_to_find(:)
    integer, intent(in)             :: point_dim    ! Which dimension of array is the point along
    double precision, intent(in)    :: tol
    integer                         :: ind(2)

    double precision, allocatable   :: error_array(:,:)
    integer                         :: k1

    if (size(array, point_dim) /= size(point_to_find)) then
        write(*,*) 'ERROR: size(array, point_dim) must be equal to size(point_to_find)'
        write(*,*) '       Returning not found'
        ind = -1
        return
    endif

    if (point_dim == 1) then
        allocate(error_array(size(array, 2), size(array, 3)))
    elseif (point_dim==2) then
        allocate(error_array(size(array, 1), size(array, 3)))
    else
        allocate(error_array(size(array, 1), size(array, 2)))
    endif
    error_array = 0.d0

    do k1=1,size(point_to_find)
        if (point_dim == 1) then
            error_array = error_array + (array(k1,:,:) - point_to_find(k1))**2
        elseif (point_dim==2) then
            error_array = error_array + (array(:, k1,:) - point_to_find(k1))**2
        else
            error_array = error_array + (array(:, :, k1) - point_to_find(k1))**2
        endif
    enddo

    ind = find_dbl_2d_tol(error_array, 0.d0, tol**2)

end function

end module


! { dg-do run }
! { dg-additional-options "-msse2" { target sse2_runtime } }
! { dg-additional-options "-mavx" { target avx_runtime } }

module SIMD5_mod
contains
  subroutine work( a, b, c,  n )
     implicit none
     integer :: i,j,n
     double precision :: a(n,n), b(n,n), c(n,n), tmp

     !$omp do simd collapse(2) private(tmp)
     do j = 1,n
        do i = 1,n
           tmp = a(i,j) + b(i,j)
           c(i,j) = tmp
        end do
     end do

  end subroutine work

  subroutine work_ref( a, b, c,  n )
     implicit none
     integer :: i,j,n
     double precision :: a(n,n), b(n,n), c(n,n), tmp

     do j = 1,n
        do i = 1,n
           tmp = a(i,j) + b(i,j)
           c(i,j) = tmp
        end do
     end do

  end subroutine work_ref

  subroutine init (a, b, n)
     integer :: i,j,n,s
     double precision :: a(n,n), b(n,n)

     s = -1

     do j = 1,n
        do i = 1,n
           a(i,j) = i*j*s
           b(i,j) = i+j
           s = -s
        end do
     end do

  end subroutine

  subroutine check (a, b, n)
    integer :: i, j, n
    double precision, parameter :: EPS = 0.0000000000000001
    double precision :: diff, a(n,n), b(n,n)
    do j = 1, n
      do i = 1, n
        diff = a(i,j) - b(i,j)
        if (diff > EPS .or. -diff > EPS) call abort
      end do
    end do
  end subroutine

end module

program SIMD5
  use SIMD5_mod
  double precision, dimension(32, 32) :: a, b, c, c_ref

  call  init(a, b, 32)

  call  work(a, b, c, 32)
  call  work_ref(a, b, c_ref, 32)

  call check(c, c_ref, 32)
end program


PROGRAM t454
  TYPE t
    COMPLEX, DIMENSION(1)  :: z
  END TYPE t
  TYPE(t) :: s0 = t( RESHAPE((/(6.0, 7.0)/), (/1/)) )
  COMPLEX, DIMENSION(1) :: C
  C = s0%z
  WRITE (*, "(2F6.3)" ) C
END
!{ dg-output "6.000 7.000" }


! $UWHPSC/codes/fortran/array1

program array1

    ! demonstrate declaring and using arrays

    implicit none
    integer, parameter :: m = 3, n=2
    real (kind=8), dimension(m,n) :: A
    real (kind=8), dimension(m) :: b
    real (kind=8), dimension(n) :: x
    integer :: i,j

    ! initialize matrix A and vector x:
    do j=1,n
        do i=1,m
            A(i,j) = i+j
            enddo
        x(j) = 1.
        enddo

    ! multiply A*x to get b:
    do i=1,m
        b(i) = 0.
        do j=1,m
            b(i) = b(i) + A(i,j)*x(j)
            enddo
        enddo

    print *, "A = "
    do i=1,m
        print *, A(i,:)   ! i'th row of A
        enddo
    print "(2d16.6)", ((A(i,j), j=1,2), i=1,3)
    print *, "x = "
    print "(d16.6)", x
    print *, "b = "
    print "(d16.6)", b

end program array1


C----------------------------------------------------------------------
C--   Stand-alone code for alpha_s cannibalised (with permission)
C--   from Andreas Vogt's QCD-PEGASUS package (hep-ph/0408244).
C--   The running coupling alpha_s is obtained at N^mLO (m = 0,1,2,3)
C--   by solving the renormalisation group equation in the MSbar scheme
C--   by a fourth-order Runge-Kutta integration.  Transitions from
C--   n_f to n_f+1 flavours are made when the factorisation scale
C--   mu_f equals the pole masses m_h (h = c,b,t).  At exactly
C--   the thresholds m_{c,b,t}, the number of flavours n_f = {3,4,5}.
C--   The top quark mass should be set to be very large to evolve with
C--   a maximum of five flavours.  The factorisation scale mu_f may be
C--   a constant multiple of the renormalisation scale mu_r.  The input
C--   factorisation scale mu_(f,0) should be less than or equal to
C--   the charm quark mass.  However, if it is greater than the
C--   charm quark mass, the value of alpha_s at mu_(f,0) = 1 GeV will
C--   be found using a root-finding algorithm.
C--
C--   Example of usage.
C--   First call the initialisation routine (only needed once):
C--
C--    IORD = 2                  ! perturbative order (N^mLO,m=0,1,2,3)
C--    FR2 = 1.D0                ! ratio of mu_f^2 to mu_r^2
C--    MUR = 1.D0                ! input mu_r in GeV
C--    ASMUR = 0.5D0             ! input value of alpha_s at mu_r
C--    MC = 1.4D0                ! charm quark mass
C--    MB = 4.75D0               ! bottom quark mass
C--    MT = 1.D10                ! top quark mass
C--    CALL INITALPHAS(IORD, FR2, MUR, ASMUR, MC, MB, MT)
C--
C--   Then get alpha_s at a renormalisation scale mu_r with:
C--
C--    MUR = 100.D0              ! renormalisation scale in GeV
C--    ALFAS = ALPHAS(MUR)
C--
C----------------------------------------------------------------------
C--   Comments to Graeme Watt <Graeme.Watt(at)cern.ch>
C----------------------------------------------------------------------

      SUBROUTINE INITALPHAS(IORD, FR2, MUR, ASMUR, MC, MB, MT)
C--   IORD = 0 (LO), 1 (NLO), 2 (NNLO), 3 (NNNLO).
C--   FR2 = ratio of mu_f^2 to mu_r^2 (must be a fixed value).
C--   MUR = input renormalisation scale (in GeV) for alpha_s.
C--   ASMUR = input value of alpha_s at the renormalisation scale MUR.
C--   MC,MB,MT = heavy quark masses in GeV.
      IMPLICIT NONE
      INTEGER IORD,IORDc,MAXF,MODE
      DOUBLE PRECISION FR2,MUR,ASMUR,MC,MB,MT,EPS,A,B,DZEROX,
     &     R0c,FR2c,MURc,ASMURc,MCc,MBc,MTc,FINDALPHASR0,R0,ASI
      COMMON / DZEROXcommon / FR2c,MURc,ASMURc,MCc,MBc,MTc,R0c,IORDc
      PARAMETER(EPS=1.D-10,MAXF=10000,MODE=1)
      EXTERNAL FINDALPHASR0

      IF (MUR*sqrt(FR2).LE.MC) THEN ! Check that MUF <= MC.
         R0 = MUR
         ASI = ASMUR
      ELSE                      ! Solve for alpha_s at R0 = 1 GeV.
C--   Copy variables to common block.
         R0c = 1.D0/sqrt(FR2)
         IORDc = IORD
         FR2c = FR2
         MURc = MUR
         ASMURc = ASMUR
         MCc = MC
         MBc = MB
         MTc = MT
C--   Now get alpha_s(R0) corresponding to alpha_s(MUR).
         A = 0.02D0              ! lower bound for alpha_s(R0)
         B = 2.00D0              ! upper bound for alpha_s(R0)
         R0 = R0c
         ASI = DZEROX(A,B,EPS,MAXF,FINDALPHASR0,MODE)
      END IF

      CALL INITALPHASR0(IORD, FR2, R0, ASI, MC, MB, MT)

      RETURN
      END

C----------------------------------------------------------------------

C--   Find the zero of this function using DZEROX.
      DOUBLE PRECISION FUNCTION FINDALPHASR0(ASI)
      IMPLICIT NONE
      INTEGER IORD
      DOUBLE PRECISION FR2, R0, ASI, MC, MB, MT, MUR, ASMUR, ALPHAS
      COMMON / DZEROXcommon / FR2, MUR, ASMUR, MC, MB, MT, R0, IORD

      CALL INITALPHASR0(IORD, FR2, R0, ASI, MC, MB, MT)
      FINDALPHASR0 = ALPHAS(MUR) - ASMUR ! solve equal to zero

      RETURN
      END

C----------------------------------------------------------------------

      SUBROUTINE INITALPHASR0(IORD, FR2, R0, ASI, MC, MB, MT)
C--   IORD = 0 (LO), 1 (NLO), 2 (NNLO), 3 (NNNLO).
C--   FR2 = ratio of mu_f^2 to mu_r^2 (must be a fixed value).
C--   R0 = input renormalisation scale (in GeV) for alphas_s.
C--   ASI = input value of alpha_s at the renormalisation scale R0.
C--   MC,MB,MT = heavy quark masses in GeV.
C--   Must have R0*sqrt(FR2) <= MC to call this subroutine.
      IMPLICIT NONE
      INTEGER IORD,NAORD,NASTPS,IVFNS,NFF
      DOUBLE PRECISION FR2,R0,ASI,MC,MB,MT,LOGFR,R20,
     &     PI,ZETA,CF,CA,TR,AS0,M20,MC2,MB2,MT2
      PARAMETER(PI = 3.1415 92653 58979 D0)

      COMMON / RZETA  / ZETA(6)
      COMMON / COLOUR / CF, CA, TR
      COMMON / ASINP  / AS0, M20
      COMMON / ASPAR  / NAORD, NASTPS
      COMMON / VARFLV / IVFNS
      COMMON / NFFIX  / NFF
      COMMON / FRRAT  / LOGFR

*
* ..QCD colour factors
*
      CA = 3.D0
      CF = 4./3.D0
      TR = 0.5 D0
*
* ..The lowest integer values of the Zeta function
*
      ZETA(1) = 0.5772 15664 90153 D0
      ZETA(2) = 1.64493 40668 48226 D0
      ZETA(3) = 1.20205 69031 59594 D0
      ZETA(4) = 1.08232 32337 11138 D0
      ZETA(5) = 1.03692 77551 43370 D0
      ZETA(6) = 1.01734 30619 84449 D0

      IVFNS = 1                 ! variable flavour-number scheme (VFNS)
C      IVFNS = 0                 ! fixed flavour-number scheme (FFNS)
      NFF = 4                   ! number of flavours for FFNS
      NAORD = IORD              ! perturbative order of alpha_s
      NASTPS = 20               ! num. steps in Runge-Kutta integration
      R20 = R0**2               ! input renormalisation scale
      MC2 = MC**2               ! mu_f^2 for charm threshold
      MB2 = MB**2               ! mu_f^2 for bottom threshold
      MT2 = MT**2               ! mu_f^2 for top threshold
      LOGFR = LOG(FR2)          ! log of ratio of mu_f^2 to mu_r^2
      M20 = R20 * FR2           ! input factorisation scale

*
* ..Stop some nonsense
*
      IF ( (IVFNS .EQ. 0) .AND. (NFF .LT. 3) ) THEN
         WRITE (6,*) 'Wrong flavour number for FFNS evolution. STOP'
         STOP
      END IF
      IF ( (IVFNS .EQ. 0) .AND. (NFF .GT. 5) ) THEN
         WRITE (6,*) 'Wrong flavour number for FFNS evolution. STOP'
         STOP
      END IF
*
      IF ( NAORD .GT. 3 ) THEN
         WRITE (6,*) 'Specified order in a_s too high. STOP'
         STOP
      END IF
*
      IF ( (IVFNS .NE. 0) .AND. (FR2 .GT. 4.001D0) ) THEN
         WRITE (6,*) 'Too low mu_r for VFNS evolution. STOP'
         STOP
      END IF
*
      IF ( (IVFNS .EQ. 1) .AND. (M20 .GT. MC2) ) THEN
         WRITE (6,*) 'Too high mu_0 for VFNS evolution. STOP'
         STOP
      END IF
*
      IF ( (ASI .GT. 2.D0) .OR. (ASI .LT. 2.D-2) ) THEN
         WRITE (6,*) 'alpha_s out of range. STOP'
         STOP
      END IF
*
      IF ( (IVFNS .EQ. 1) .AND. (MC2 .GT. MB2) ) THEN
         WRITE (6,*) 'Wrong charm-bottom mass hierarchy. STOP'
         STOP
      END IF
      IF ( (IVFNS .EQ. 1) .AND. (MB2 .GT. MT2) ) THEN
         WRITE (6,*) 'Wrong bottom-top mass hierarchy. STOP'
         STOP
      END IF
*

C--   Store the beta function coefficients in a COMMON block.
      CALL BETAFCT

C--   Store a_s = alpha_s(mu_r^2)/(4 pi) at the input scale R0.
      AS0 = ASI / (4.D0* PI)

C--   Store alpha_s at the heavy flavour thresholds in a COMMON block.
       IF (IVFNS .NE. 0) THEN
          CALL EVNFTHR (MC2, MB2, MT2)
       END IF

      RETURN
      END

C----------------------------------------------------------------------

      DOUBLE PRECISION FUNCTION ALPHAS(MUR)
      IMPLICIT NONE
      INTEGER NFF,IVFNS,NF
      DOUBLE PRECISION PI,LOGFR,AS0,M20,ASC,M2C,ASB,M2B,AST,M2T,M2,MUR,
     &     R2,ASI,ASF,R20,R2T,R2B,R2C,AS
      PARAMETER ( PI = 3.1415 92653 58979 D0 )
*
* ..Input common blocks
*
       COMMON / NFFIX  / NFF
       COMMON / VARFLV / IVFNS
       COMMON / FRRAT  / LOGFR
       COMMON / ASINP  / AS0, M20
       COMMON / ASFTHR / ASC, M2C, ASB, M2B, AST, M2T

       R2 = MUR**2
       M2 = R2 * EXP(+LOGFR)
       IF (IVFNS .EQ. 0) THEN
*
*   Fixed number of flavours
*
          NF  = NFF
          R20 = M20 * R2/M2
          ASI = AS0
          ASF = AS (R2, R20, AS0, NF)
*
       ELSE
*
* ..Variable number of flavours
*
          IF (M2 .GT. M2T) THEN
             NF = 6
             R2T = M2T * R2/M2
             ASI = AST
             ASF = AS (R2, R2T, AST, NF)
*
          ELSE IF (M2 .GT. M2B) THEN
             NF = 5
             R2B = M2B * R2/M2
             ASI = ASB
             ASF = AS (R2, R2B, ASB, NF)
*
          ELSE IF (M2 .GT. M2C) THEN
             NF = 4
             R2C = M2C * R2/M2
             ASI = ASC
             ASF = AS (R2, R2C, ASC, NF)
*
          ELSE
             NF = 3
             R20 = M20 * R2/M2
             ASI = AS0
             ASF = AS (R2, R20, AS0, NF)
*
          END IF
*
       END IF
*
* ..Final value of alpha_s
*
       ALPHAS = 4.D0*PI*ASF

       RETURN
       END
*
* =================================================================av==

* =====================================================================
*
* ..The threshold matching of the QCD coupling in the MS(bar) scheme,
*    a_s = alpha_s(mu_r^2)/(4 pi),  for  NF -> NF + 1  active flavours
*    up to order a_s^4 (NNNLO).
*
* ..The value  ASNF  of a_s for NF flavours at the matching scale, the
*    logarithm  LOGRH = ln (mu_r^2/m_H^2) -- where m_H is the pole mass
*    of the heavy quark -- and  NF  are passed as arguments to the
*    function  ASNF1.  The order of the expansion  NAORD  (defined as
*    the 'n' in N^nLO) is provided by the common-block  ASPAR.
*
* ..The matching coefficients are inverted from Chetyrkin, Kniehl and
*    Steinhauser, Phys. Rev. Lett. 79 (1997) 2184. The QCD colour
*    factors have been hard-wired in these results. The lowest integer
*    values of the Zeta function are given by the common-block  RZETA.
*
* =====================================================================
*
*
      DOUBLE PRECISION FUNCTION ASNF1 (ASNF, LOGRH, NF)
*
      IMPLICIT NONE
      INTEGER NF, NAORD, NASTPS, PRVCLL, K1, K2
      DOUBLE PRECISION ASNF,LOGRH,ZETA,CMC,CMCI30,CMCF30,CMCF31,
     &     CMCI31,ASP,LRHP

      DIMENSION CMC(3,0:3)
*
* ---------------------------------------------------------------------
*
* ..Input common-blocks
*
      COMMON / ASPAR  / NAORD, NASTPS
      COMMON / RZETA  / ZETA(6)
*
* ..Variables to be saved for the next call
*
      SAVE CMC, CMCI30, CMCF30, CMCF31, CMCI31, PRVCLL
*
* ---------------------------------------------------------------------
*
* ..The coupling-constant matching coefficients (CMC's) up to NNNLO
*   (calculated and saved in the first call of this routine)
*
       IF (PRVCLL .NE. 1) THEN
*
         CMC(1,0) =  0.D0
         CMC(1,1) =  2./3.D0
*
         CMC(2,0) = 14./3.D0
         CMC(2,1) = 38./3.D0
         CMC(2,2) =  4./9.D0
*
         CMCI30 = + 80507./432.D0 * ZETA(3) + 58933./1944.D0
     1            + 128./3.D0 * ZETA(2) * (1.+ DLOG(2.D0)/3.D0)
         CMCF30 = - 64./9.D0 * (ZETA(2) + 2479./3456.D0)
         CMCI31 =   8941./27.D0
         CMCF31 = - 409./27.D0
         CMC(3,2) = 511./9.D0
         CMC(3,3) = 8./27.D0
*
         PRVCLL = 1
*
       END IF
*
* ---------------------------------------------------------------------
*
* ..The N_f dependent CMC's, and the alpha_s matching at order NAORD
*
       CMC(3,0) = CMCI30 + NF * CMCF30
       CMC(3,1) = CMCI31 + NF * CMCF31
*
       ASNF1 = ASNF
       IF (NAORD .EQ. 0) GO TO 1
       ASP   = ASNF
*
       DO 11 K1 = 1, NAORD
         ASP = ASP * ASNF
         LRHP = 1.D0
*
       DO 12 K2 = 0, K1
         ASNF1 = ASNF1 + ASP * CMC(K1,K2) * LRHP
         LRHP = LRHP * LOGRH
*
  12   CONTINUE
  11   CONTINUE
*
* ---------------------------------------------------------------------
*
   1   RETURN
       END

*
* =================================================================av==
*
* ..The subroutine  EVNFTHR  for the evolution of  a_s = alpha_s/(4 pi)
*    from a three-flavour initial scale to the four- to six-flavour
*    thresholds (identified with the squares of the corresponding quark
*    masses).  The results are written to the common-block  ASFTHR.
*
* ..The input scale  M20 = mu_(f,0)^2  and the corresponding value
*    AS0  of a_s  are provided by  ASINP.  The fixed scale logarithm
*    LOGFR = ln (mu_f^2/mu_r^2) is specified in  FRRAT.  The alpha_s
*    matching is done by the function ASNF1.
*
* =====================================================================
*
*
       SUBROUTINE EVNFTHR (MC2, MB2, MT2)
*
       IMPLICIT NONE
       DOUBLE PRECISION MC2, MB2, MT2, M20, M2C, M2B, M2T, R20, R2C,
     1                  R2B, R2T, AS, ASNF1, AS0, ASC, ASB, AST,
     2                  ASC3, ASB4, AST5, LOGFR, SC, SB, ST
*
* ---------------------------------------------------------------------
*
* ..Input common blocks
*
       COMMON / ASINP  / AS0, M20
       COMMON / FRRAT  / LOGFR
*
* ..Output common blocks
*
       COMMON / ASFTHR / ASC, M2C, ASB, M2B, AST, M2T

* ---------------------------------------------------------------------
*
* ..Coupling constants at and evolution distances to/between thresholds
*
       R20 = M20 * EXP(-LOGFR)
*
* ..Charm
*
       M2C  = MC2
       R2C  = M2C * R20/M20
       ASC3 = AS (R2C, R20, AS0, 3)
       SC   = LOG (AS0 / ASC3)
       ASC  = ASNF1 (ASC3, -LOGFR, 3)
*
* ..Bottom
*
       M2B  = MB2
       R2B  = M2B * R20/M20
       ASB4 = AS (R2B, R2C, ASC, 4)
       SB   = LOG (ASC / ASB4)
       ASB  = ASNF1 (ASB4, -LOGFR, 4)
*
* ..Top
*
       M2T  = MT2
       R2T  = M2T * R20/M20
       AST5 = AS (R2T, R2B, ASB, 5)
       ST   = LOG (ASB / AST5)
       AST  = ASNF1 (AST5, -LOGFR, 5)

       RETURN
       END

*
* =================================================================av==
*
* ..The running coupling of QCD,
*
*         AS  =  a_s  =  alpha_s(mu_r^2)/(4 pi),
*
*    obtained by integrating the evolution equation for a fixed number
*    of massless flavours  NF.  Except at leading order (LO),  AS  is
*    obtained using a fourth-order Runge-Kutta integration.
*
* ..The initial and final scales  R20  and  R2,  the value  AS0  at
*    R20, and  NF  are passed as function arguments.  The coefficients
*    of the beta function up to  a_s^5 (N^3LO)  are provided by the
*    common-block  BETACOM.  The order of the expansion  NAORD (defined
*    as the 'n' in N^nLO) and the number of steps  NASTPS  for the
*    integration beyond LO are given by the common-block  ASPAR.
*
* =====================================================================
*
*
      DOUBLE PRECISION FUNCTION AS (R2, R20, AS0, NF)
*
      IMPLICIT NONE
      INTEGER NFMIN, NFMAX, NF, NAORD, NASTPS, K1
      DOUBLE PRECISION R2, R20, AS0, SXTH, BETA0, BETA1, BETA2, BETA3,
     &     FBETA1,FBETA2,FBETA3,A,LRRAT,DLR,XK0,XK1,XK2,XK3
      PARAMETER (NFMIN = 3, NFMAX = 6)
      PARAMETER ( SXTH = 0.16666 66666 66666 D0 )
*
* ---------------------------------------------------------------------
*
* ..Input common-blocks
*
       COMMON / ASPAR  / NAORD, NASTPS
       COMMON / BETACOM   / BETA0 (NFMIN:NFMAX), BETA1 (NFMIN:NFMAX),
     ,                   BETA2 (NFMIN:NFMAX), BETA3 (NFMIN:NFMAX)
*
* ..The beta functions FBETAn at N^nLO for n = 1, 2, and 3
*
       FBETA1(A) = - A**2 * ( BETA0(NF) + A *   BETA1(NF) )
       FBETA2(A) = - A**2 * ( BETA0(NF) + A * ( BETA1(NF)
     ,                        + A * BETA2(NF) ) )
       FBETA3(A) = - A**2 * ( BETA0(NF) + A * ( BETA1(NF)
     ,                        + A * (BETA2(NF) + A * BETA3(NF)) ) )
*
* ---------------------------------------------------------------------
*
* ..Initial value, evolution distance and step size
*
       AS = AS0
       LRRAT = LOG (R2/R20)
       DLR = LRRAT / NASTPS
*
* ..Solution of the evolution equation depending on  NAORD
*   (fourth-order Runge-Kutta beyond the leading order)
*
       IF (NAORD .EQ. 0) THEN
*
         AS = AS0 / (1.+ BETA0(NF) * AS0 * LRRAT)
*
       ELSE IF (NAORD .EQ. 1) THEN
*
       DO 2 K1 = 1, NASTPS
         XK0 = DLR * FBETA1 (AS)
         XK1 = DLR * FBETA1 (AS + 0.5 * XK0)
         XK2 = DLR * FBETA1 (AS + 0.5 * XK1)
         XK3 = DLR * FBETA1 (AS + XK2)
         AS = AS + SXTH * (XK0 + 2.* XK1 + 2.* XK2 + XK3)
  2    CONTINUE
*
       ELSE IF (NAORD .EQ. 2) THEN
*
       DO 3 K1 = 1, NASTPS
         XK0 = DLR * FBETA2 (AS)
         XK1 = DLR * FBETA2 (AS + 0.5 * XK0)
         XK2 = DLR * FBETA2 (AS + 0.5 * XK1)
         XK3 = DLR * FBETA2 (AS + XK2)
         AS = AS + SXTH * (XK0 + 2.* XK1 + 2.* XK2 + XK3)
  3    CONTINUE
*
       ELSE IF (NAORD .EQ. 3) THEN
*
       DO 4 K1 = 1, NASTPS
         XK0 = DLR * FBETA3 (AS)
         XK1 = DLR * FBETA3 (AS + 0.5 * XK0)
         XK2 = DLR * FBETA3 (AS + 0.5 * XK1)
         XK3 = DLR * FBETA3 (AS + XK2)
         AS = AS + SXTH * (XK0 + 2.* XK1 + 2.* XK2 + XK3)
  4    CONTINUE
       END IF
*
* ---------------------------------------------------------------------
*
       RETURN
       END

*
* =================================================================av==
*
* ..The subroutine BETAFCT for the coefficients  BETA0...BETA3  of the
*    beta function of QCD up to order alpha_s^5 (N^3LO), normalized by
*
*        d a_s / d ln mu_r^2  =  - BETA0 a_s^2 - BETA1 a_s^3 - ...
*
*    with  a_s = alpha_s/(4*pi).
*
* ..The MSbar coefficients are written to the common-block BETACOM for
*   NF = 3...6  (parameters NFMIN, NFMAX) quark flavours.
*
* ..The factors CF, CA and TF  are taken from the common-block  COLOUR.
*    Beyond NLO the QCD colour factors are hard-wired in this routine,
*    and the numerical coefficients are truncated to six digits.
*
* =====================================================================
*
*
       SUBROUTINE BETAFCT
*
       IMPLICIT DOUBLE PRECISION (A - Z)
       INTEGER NFMIN, NFMAX, NF
       PARAMETER (NFMIN = 3, NFMAX = 6)
*
* ---------------------------------------------------------------------
*
* ..Input common-block
*
       COMMON / COLOUR / CF, CA, TR
*
* ..Output common-block
*
       COMMON / BETACOM   / BETA0 (NFMIN:NFMAX), BETA1 (NFMIN:NFMAX),
     1                   BETA2 (NFMIN:NFMAX), BETA3 (NFMIN:NFMAX)

*
* ---------------------------------------------------------------------
*
* ..The full LO and NLO coefficients
*
       B00 =  11./3.D0 * CA
       B01 =  -4./3.D0 * TR
       B10 =  34./3.D0 * CA**2
       B11 = -20./3.D0 * CA*TR - 4.* CF*TR
*
* ..Flavour-number loop and output to the array
*
       DO 1 NF = NFMIN, NFMAX
*
       BETA0(NF) = B00 + B01 * NF
       BETA1(NF) = B10 + B11 * NF
*
       BETA2(NF) = 1428.50 - 279.611 * NF + 6.01852 * NF**2
       BETA3(NF) = 29243.0 - 6946.30 * NF + 405.089 * NF**2
     1             + 1.49931 * NF**3
*
* ---------------------------------------------------------------------
*
  1    CONTINUE
*
       RETURN
       END
*
* =================================================================av==

C--   G.W. DZEROX taken from CERNLIB to find the zero of a function.
      DOUBLE PRECISION FUNCTION DZEROX(A0,B0,EPS,MAXF,F,MODE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C     Based on
C
C        J.C.P. Bus and T.J. Dekker, Two Efficient Algorithms with
C        Guaranteed Convergence for Finding a Zero of a Function,
C        ACM Trans. Math. Software 1 (1975) 330-345.
C
C        (MODE = 1: Algorithm M;    MODE = 2: Algorithm R)
      CHARACTER*80 ERRTXT
      LOGICAL LMT
      DIMENSION IM1(2),IM2(2),LMT(2)
      PARAMETER (Z1 = 1, HALF = Z1/2)
      DATA IM1 /2,3/, IM2 /-1,3/
      DZEROX = 0.D0             ! G.W. to prevent compiler warning
      IF(MODE .NE. 1 .AND. MODE .NE. 2) THEN
       C=0
       WRITE(ERRTXT,101) MODE
       WRITE(6,*) ERRTXT
       GO TO 99
      ENDIF
      FA=F(B0)
      FB=F(A0)
      IF(FA*FB .GT. 0) THEN
       C=0
       WRITE(ERRTXT,102) A0,B0
       WRITE(6,*) ERRTXT
       GO TO 99
      ENDIF
      ATL=ABS(EPS)
      B=A0
      A=B0
      LMT(2)=.TRUE.
      MF=2
    1 C=A
      FC=FA
    2 IE=0
    3 IF(ABS(FC) .LT. ABS(FB)) THEN
       IF(C .NE. A) THEN
        D=A
        FD=FA
       END IF
       A=B
       B=C
       C=A
       FA=FB
       FB=FC
       FC=FA
      END IF
      TOL=ATL*(1+ABS(C))
      H=HALF*(C+B)
      HB=H-B
      IF(ABS(HB) .GT. TOL) THEN
       IF(IE .GT. IM1(MODE)) THEN
        W=HB
       ELSE
        TOL=TOL*SIGN(Z1,HB)
        P=(B-A)*FB
        LMT(1)=IE .LE. 1
        IF(LMT(MODE)) THEN
         Q=FA-FB
         LMT(2)=.FALSE.
        ELSE
         FDB=(FD-FB)/(D-B)
         FDA=(FD-FA)/(D-A)
         P=FDA*P
         Q=FDB*FA-FDA*FB
        END IF
        IF(P .LT. 0) THEN
         P=-P
         Q=-Q
        END IF
        IF(IE .EQ. IM2(MODE)) P=P+P
        IF(P .EQ. 0 .OR. P .LE. Q*TOL) THEN
         W=TOL
        ELSEIF(P .LT. HB*Q) THEN
         W=P/Q
        ELSE
         W=HB
        END IF
       END IF
       D=A
       A=B
       FD=FA
       FA=FB
       B=B+W
       MF=MF+1
       IF(MF .GT. MAXF) THEN
        WRITE(6,*) "Error in DZEROX: TOO MANY FUNCTION CALLS"
        GO TO 99
       ENDIF
       FB=F(B)
       IF(FB .EQ. 0 .OR. SIGN(Z1,FC) .EQ. SIGN(Z1,FB)) GO TO 1
       IF(W .EQ. HB) GO TO 2
       IE=IE+1
       GO TO 3
      END IF
      DZEROX=C
   99 CONTINUE
      RETURN
  101 FORMAT('Error in DZEROX: MODE = ',I3,' ILLEGAL')
  102 FORMAT('Error in DZEROX: F(A) AND F(B) HAVE THE SAME SIGN, A = ',
     1     1P,D15.8,', B = ',D15.8)
      END

C ---------------------------------------------------------------------


        subroutine corthom(a,n,work,cond)
        implicit double precision (a-h,o-z)
        save
        double complex a(1),work(1)
c
c        this subroutine inverts the user-supplied matrix
c        a by means of the gram-schmidt process. in fact, this
c        is a memory management routine for the routine cortho1,
c        which performs the actual inversion
c
c               input parameters:
c
c  a - the n*n - matrix to be inverted (destroyed by the
c         subroutine)
c  n - the dimensionality of the matrix a
c
c               output parameters:
c
c  a - the inverse of a on input
c  cond - the estimate of the condition number of the matrix a
c         that has been inverted
c
c               work array
c
c  work - must be at least 2 * n * (n+1)+2 double precision locations long
c
c
c        . . . allocate memory for the matrix inverter
c
        ib=1
        lb=n*n
c
        iw=ib+lb+1
c
c       invert the matrix
c
        call cortho1(a,work(ib),n,work(iw),cond)
        return
        end
c
c
c
c
c
        subroutine cortho1(a,b,n,work,cond)
        implicit double precision (a-h,o-z)
        save
        double complex a(n,n),b(n,n),cd,zero,
     1      work(1)
c
c       set the matrix b to unity
c
        done=1
        zero=0
        do 1400 i=1,n
        do 1200 j=1,n
        b(j,i)=zero
 1200 continue
        b(i,i)=1
 1400 continue
c
c        conduct the gram-schmidt process
c
        dnormax=-1
        dnormin=1.0d23
c
        do 4000 i=1,n
c
c       orthogonalize the i-th column to all preceeding ones
c
        if(i .eq. 1) goto 2190
        do 2180 j=1,i-1
c
        call corthom_scap(a,n,i,j,cd)
c
        do 2170 k=1,n
        a(i,k)=a(i,k)-a(j,k)*cd
        b(i,k)=b(i,k)-b(j,k)*cd
 2170 continue
 2180 continue
 2190 continue
c
c       normalize the i-th row
c
        call corthom_scap(a,n,i,i,cd)
c
        d=cd
        d=done/sqrt(d)
        if(dnormax .lt. d) dnormax=d
        if(dnormin .gt. d) dnormin=d
        do 2400 j=1,n
        a(i,j)=a(i,j)*d
        b(i,j)=b(i,j)*d
 2400 continue
c
c       orthogonalize all subsequent rows to the i-th one
c
        if(i .eq. n) goto 4000
c
        do 3000 j=i+1,n
c
        cd=0
        do 2600 k=1,n
        cd=cd+a(i,k)*dconjg(a(j,k))
 2600 continue
        cd=dconjg(cd)
c
        do 2800 k=1,n
        a(j,k)=a(j,k)-cd*a(i,k)
        b(j,k)=b(j,k)-cd*b(i,k)
 2800 continue
 3000 continue
c
 4000 continue
        cond=dnormax/dnormin
c
c       now, multiply the abjoint of the resulting
c       orthogonal matrix by the triangular one,
c       obtaining the inverse of the original a
c
        do 5000 i=1,n
        do 4800 j=1,n
        cd=0
        do 4200 k=1,n
        cd=cd+dconjg(a(k,i))*b(k,j)
 4200 continue
        work(j)=cd
 4800 continue
        do 4900 j=1,n
        a(j,i)=work(j)
 4900 continue
 5000 continue
c
c        now, transpose a
c
        do 5400 i=2,n
        do 5200 j=1,i
        cd=a(i,j)
        a(i,j)=a(j,i)
        a(j,i)=cd
 5200 continue
 5400 continue
c
        return
        end
c
c
c
c
c
        subroutine corthom_matvec(a,n,x,y)
        implicit double precision (a-h,o-z)
        save
        double complex a(n,n),x(1),y(1),cd
c
c        apply the matrix a to the vector x obtaining y
c
        do 1400 i=1,n
        cd=0
        do 1200 j=1,n
        cd=cd+a(i,j)*x(j)
 1200 continue
        y(i)=cd
 1400 continue
        return
        end
c
c
c
c
c
        subroutine corthom_scap(a,n,i,j,prod)
        implicit double complex (a-h,o-z)
        save
        dimension a(n,n)
c
        prod=0
        do 1200 k=1,n
        prod=prod+a(i,k)*conjg(a(j,k))
 1200 continue
        return
        end