!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

      MODULE m_wann_lapw_sph_plot

c*****************************************************************
c            plot wannierfunction in muffin tins
c            Frank Freimuth, November 2006
c*****************************************************************
      CONTAINS
      SUBROUTINE wann_lapw_sph_plot(ff,gg,flo,acof,bcof,ccof,x,
     >         nlo,jmtd,lmaxd,nlod,llod,lmd,rmsh,lmaxn,llo,jri,
     <         xdnout)

      USE m_ylm
      use m_constants

      implicit none
      integer,intent(in)::jmtd,lmaxd,nlod,llod,lmd,lmaxn,nlo
      integer,intent(in)::llo(nlod),jri
      real,intent(in)::rmsh(jmtd)
      real,intent(in)::x(3)
      real,intent(in)::ff(jmtd,0:lmaxd)
      real,intent(in)::gg(jmtd,0:lmaxd)
      real,intent(in)::flo(jmtd,nlod)
      complex,intent(in)::acof(0:lmd)
      complex,intent(in)::bcof(0:lmd)
      complex,intent(in)::ccof(-llod:llod,nlod)
      complex,intent(out)::xdnout

      real sx
      integer i,j,jr,l,m,lm
      complex ylm((lmaxd+1)**2),xd1,xd2,s

      sx = 0.0
      DO 50 i = 1,3
         sx = sx + x(i)*x(i)
   50 CONTINUE
      sx = sqrt(sx)
      DO 80 j = jri-1,2,-1
         IF (sx.GE.rmsh(j)) GO TO 90
   80 CONTINUE
   90 jr = j
      CALL ylm4(
     >          lmaxn,x,
     <          ylm)
      xd1 = cmplx(0.,0.)
      xd2 = cmplx(0.,0.)
      DO l = 0,lmaxn
       DO 110 m = -l,l
        lm = l*(l+1)+m
        s = ylm(lm+1)*(ImagUnit)**l
        xd1 = xd1 + (acof(lm)*cmplx(ff(jr,l),0.)+
     +               bcof(lm)*cmplx(gg(jr,l),0.))*s/
     /               (rmsh(jr))
c        print*,"xd1=",xd1
        IF (jr.EQ.1) GO TO 110
        xd2 = xd2 + (acof(lm)*cmplx(ff(jr+1,l),0.)+
     +               bcof(lm)*cmplx(gg(jr+1,l),0.))*s/
     /               (rmsh(jr+1))

  110  CONTINUE
      ENDDO
c..contributions from the local orbitals
      IF (nlo.GE.1) THEN
       DO l = 1,nlo
        DO 111 m = -llo(l),llo(l)
         lm = llo(l)*(llo(l)+1)+m

         s = ylm(lm+1)*(ImagUnit)**l
         xd1 = xd1 + ccof(m,l)*flo(jr,l)*s/
     /               (rmsh(jr))

         IF (jr.EQ.1) GO TO 111
         xd2 = xd2 + ccof(m,l)*flo(jr+1,l)*s/
     /               (rmsh(jr+1))

  111   CONTINUE
       ENDDO
      ENDIF
      IF (jr.EQ.1) THEN
         xdnout = xd1
      ELSE
         xdnout = xd1 + (xd2-xd1) *
     +                  (sx-rmsh(jr)) / (rmsh(jr+1)-rmsh(jr))

      END IF

      END SUBROUTINE wann_lapw_sph_plot
      END MODULE m_wann_lapw_sph_plot


!!this module provide functions to calculate the potential/kinetic/gradient energy of the fields/gravity.
module mutils
  use model
  use latticefft
  implicit none
#include "configure.h"

  logical::need_recalculate=.true.
  real(dl)::last_potential_energy, last_fields_kinetic_energy, last_fields_gradient_energy, last_gravity_kinetic_energy, last_gravity_gradient_energy, last_total_detg, last_effective_Hubble

contains

  !!the total potential energy of the scalar fields
  function potential_energy()
    real(dl) potential_energy,cach(n)
    DEFINE_IND
    if(.not. need_recalculate)then
       potential_energy=last_potential_energy
       return
    endif
    cach = 0._dl
    !$omp parallel do default(shared) private(i,j,k)
    LOOP
    cach(k) = cach(k) + potential(fields_f(:,i,j,k))*DETG(i,j,k)
    ENDLOOP
    !$omp end parallel do
    potential_energy = sum(cach)/ncube
    return
  end function potential_energy

  !!the total kinetic energy of the scalar fields
  function fields_kinetic_energy()
    real(dl) fields_kinetic_energy,cachj(n),cach(n)
    DEFINE_IND
    if(.not. need_recalculate)then
       fields_kinetic_energy = last_fields_kinetic_energy
       return
    endif
#if METRIC_PERTURB
    cach = 0._dl
    !$omp parallel do default(shared) private(i,j,k)
    LOOP
    cach(k) = cach(k) + sum(fields_p(:,i,j,k)**2)/DETG(i,j,k)
    ENDLOOP
    !$omp end parallel do
    fields_kinetic_energy = sum(cach) / 2._dl /ncube
#else
    fields_kinetic_energy = sum(fields_p**2)/2._dl/ncube
#if METRIC_OPTION == FRW_BACKGROUND
    fields_kinetic_energy = fields_kinetic_energy/scale_factor()**6
#endif
#endif
    return
  end function fields_kinetic_energy

  !!the total gradient energy of the scalar fields
  function fields_gradient_energy()
    real(dl) fields_gradient_energy,cach(n)
    DEFINE_IND
    if(.not. need_recalculate)then
       fields_gradient_energy = last_fields_gradient_energy
       return
    endif
    cach = 0._dl
    !$omp parallel do default(shared) private(i,j,k)
    LOOP
    cach(k) = cach(k) +   &
#if DIS_SCHEME == LATTICEEASY
         sum((GRID_FLD(fields_f,:,i+1,j,k)-GRID_FLD(fields_f,:,i,j,k))**2 &
         +(GRID_FLD(fields_f,:,i,j+1,k)-GRID_FLD(fields_f,:,i,j,k))**2 &
         +(GRID_FLD(fields_f,:,i,j,k+1)-GRID_FLD(fields_f,:,i,j,k))**2)
#elif DIS_SCHEME ==  HLATTICE1
#if METRIC_PERTURB
         DETG(i,j,k) * ( &
         GUP11(i,j,k) * sum(TWO_DFLD_X(i,j,k)**2) &
         + GUP22(i,j,k) * sum(TWO_DFLD_Y(i,j,k)**2) &
         + GUP33(i,j,k) * sum(TWO_DFLD_Z(i,j,k)**2) &
         + 2._dl*( &
         GUP23(i,j,k) * sum(TWO_DFLD_Y(i,j,k)*TWO_DFLD_Z(i,j,k)) &
         + GUP13(i,j,k) * sum(TWO_DFLD_X(i,j,k)*TWO_DFLD_Z(i,j,k)) &
         + GUP12(i,j,k) * sum(TWO_DFLD_X(i,j,k)*TWO_DFLD_Y(i,j,k)) &
         ))
#else
         sum(TWO_DFLD_X(i,j,k)**2) &
         + sum(TWO_DFLD_Y(i,j,k)**2) &
         + sum(TWO_DFLD_Z(i,j,k)**2)
#endif
#elif DIS_SCHEME == HLATTICE2
#if METRIC_PERTURB
         DETG(i,j,k) * ( &
         GUP11(i,j,k) * sum(TWELVE_DFLD_X(i,j,k)**2) &
         + GUP22(i,j,k) * sum(TWELVE_DFLD_Y(i,j,k)**2) &
         + GUP33(i,j,k) * sum(TWELVE_DFLD_Z(i,j,k)**2) &
         + 2._dl*( &
         GUP23(i,j,k) * sum(TWELVE_DFLD_Y(i,j,k)*TWELVE_DFLD_Z(i,j,k)) &
         + GUP13(i,j,k) * sum(TWELVE_DFLD_X(i,j,k)*TWELVE_DFLD_Z(i,j,k)) &
         + GUP12(i,j,k) * sum(TWELVE_DFLD_X(i,j,k)*TWELVE_DFLD_Y(i,j,k)) &
         ))
#else
         sum(TWELVE_DFLD_X(i,j,k)**2) &
         + sum(TWELVE_DFLD_Y(i,j,k)**2) &
         + sum(TWELVE_DFLD_Z(i,j,k)**2)
#endif
#endif
    ENDLOOP
    !$omp end parallel do
#if DIS_SCHEME == LATTICEEASY
    fields_gradient_energy = sum(cach) /ncube/ (metric%physdx)**2 / 2._dl
#elif DIS_SCHEME == HLATTICE1
    fields_gradient_energy = sum(cach) /ncube/ (metric%physdx)**2 / 8._dl
#elif DIS_SCHEME == HLATTICE2
    fields_gradient_energy = sum(cach) /ncube/ (metric%physdx)**2 / 288._dl
#endif
  end function fields_gradient_energy

!!For metric
  function gravity_kinetic_energy()
    real(dl) gravity_kinetic_energy,cach(n)
    DEFINE_IND
    if(.not. need_recalculate)then
       gravity_kinetic_energy = last_gravity_kinetic_energy
       return
    endif
#if METRIC_PERTURB
    cach=0._dl
    !$omp parallel do default(shared) private(i,j,k)
    LOOP
    cach(k) = cach(k) + ( sum(MEPIV(i,j,k)**2) + 2._dl*sum(MEPIU(i,j,k)**2) - sum(MEPIU(i,j,k))**2 )/DETG(i,j,k)
    ENDLOOP
    !$omp end parallel do
    gravity_kinetic_energy = sum(cach)/Mplsq/ncube
#else
    gravity_kinetic_energy = -3.*effective_Hubble()**2*Mplsq
#endif
    return
  end function gravity_kinetic_energy

  function gravity_gradient_energy(dg)
    !!only keep O(h^2) terms, but I keep the g^{ij}'s to keep the formula covariant. Keeping all terms covariant is important when we do a coordinate transformation (no leaking of energy).
    real(dl) gravity_gradient_energy,cach(n)
    real(dl),optional::dg
    DEFINE_IND
#if ! METRIC_PERTURB
    gravity_gradient_energy = 0.
    return
#else
    if(.not.need_recalculate)then
       gravity_gradient_energy=last_gravity_gradient_energy
       return
    endif
    cach = 0._dl
    !$omp parallel do default(shared) private(i,j,k)
    LOOP
    cach(k) = cach(k) + ( &
#if DIS_SCHEME == HLATTICE1
         TWO_DV_X(1,i,j,k)**2 + TWO_DV_Y(2,i,j,k)**2 + TWO_DV_Z(3,i,j,k)**2  &
         - TWO_DU_Z(1,i,j,k)*TWO_DU_Z(2,i,j,k)- TWO_DU_X(2,i,j,k)*TWO_DU_X(3,i,j,k) - TWO_DU_Y(1,i,j,k)*TWO_DU_Y(3,i,j,k)  &
         )/2. &
         - (TWO_DV_X(1,i,j,k)+TWO_DV_Z(3,i,j,k))*TWO_DV_Y(2,i,j,k) - TWO_DV_X(1,i,j,k)*TWO_DV_Z(3,i,j,k) &
         + TWO_DV_Y(1,i,j,k)*TWO_DU_Z(1,i,j,k) + TWO_DV_Z(2,i,j,k)*TWO_DU_X(2,i,j,k) + TWO_DV_X(3,i,j,k)*TWO_DU_Y(3,i,j,k)
#elif DIS_SCHEME == HLATTICE2
         TWELVE_DV_X(1,i,j,k)**2 + TWELVE_DV_Y(2,i,j,k)**2 + TWELVE_DV_Z(3,i,j,k)**2  &
         - TWELVE_DU_Z(1,i,j,k)*TWELVE_DU_Z(2,i,j,k)- TWELVE_DU_X(2,i,j,k)*TWELVE_DU_X(3,i,j,k) - TWELVE_DU_Y(1,i,j,k)*TWELVE_DU_Y(3,i,j,k)  &
         )/2. &
         - (TWELVE_DV_X(1,i,j,k)+TWELVE_DV_Z(3,i,j,k))*TWELVE_DV_Y(2,i,j,k) - TWELVE_DV_X(1,i,j,k)*TWELVE_DV_Z(3,i,j,k) &
         + TWELVE_DV_Y(1,i,j,k)*TWELVE_DU_Z(1,i,j,k) + TWELVE_DV_Z(2,i,j,k)*TWELVE_DU_X(2,i,j,k) + TWELVE_DV_X(3,i,j,k)*TWELVE_DU_Y(3,i,j,k)
#endif
    ENDLOOP
    !$omp end parallel do

    if(present(dg))then
       gravity_gradient_energy = sum(cach)/ncube * dg**(1./3._dl)*Mplsq/metric%physdx**2
    else
       gravity_gradient_energy = sum(cach)/ncube * total_detg()**(1./3._dl)*Mplsq/metric%physdx**2
    endif
#if DIS_SCHEME == HLATTICE1
    gravity_gradient_energy = gravity_gradient_energy/8._dl
#elif DIS_SCHEME == HLATTICE2
    gravity_gradient_energy = gravity_gradient_energy/288._dl
#endif
    return
#endif
  end function gravity_gradient_energy

  function total_energy()
    real(dl) total_energy
    total_energy=potential_energy()+ fields_gradient_energy() + fields_kinetic_energy() + gravity_kinetic_energy() + gravity_gradient_energy()
  end function total_energy

  function total_detg()
    real(dl) total_detg,cach(n)
    DEFINE_IND
    if(.not. need_recalculate)then
       total_detg=last_total_detg
       return
    endif
#if METRIC_PERTURB
    cach = 0._dl
    !$omp parallel do default(shared) private(i,j,k)
    LOOP
    cach(k) = cach(k) + DETG(i,j,k)
    ENDLOOP
    !$omp end parallel do
    total_detg = sum(cach)/ncube
#else
    total_detg = 1._dl
#endif
    return
  end function total_detg

   function scale_factor()
     real(dl) scale_factor
#if METRIC_PERTURB
     scale_factor = (total_detg())**(1._dl/3._dl)
#else
#if USE_CONFORMAL_TIME
     scale_factor = metric%y
#else
     scale_factor = metric%y**(2./3._dl)
#endif
#endif
   end function scale_factor

  function effective_Hubble(totdg)
    real(dl) effective_Hubble
    real(dl),optional::totdg
    real(dl) cach(n)
    DEFINE_IND
    if(.not. need_recalculate)then
       effective_Hubble = last_effective_Hubble
       return
    endif
#if METRIC_PERTURB
    cach = 0._dl
    !$omp parallel do default(shared) private(i,j,k)
    LOOP
    cach(k) = cach(k) + sum(MEPIU(i,j,k))*DETG(i,j,k)
    ENDLOOP
    !$omp end parallel do
    if(present(totdg))then
       effective_Hubble = -sum(cach)/ncube/totdg/3._dl/Mplsq
    else
       effective_Hubble =  -sum(cach)/ncube/total_detg()/3._dl/Mplsq
    endif
#else
#if USE_CONFORMAL_TIME
    effective_Hubble = -(metric%piy/metric%y**2/6._dl/Mplsq)
#else
    effective_Hubble = -(metric%piy/metric%y/4._dl/Mplsq)
#endif
#endif
  end function effective_Hubble

  subroutine coor_trans()
    real(dl) ainc
    !!================================================
    !!coordinate transformation: redefine dx-> a dx
#if METRIC_PERTURB
    ainc = (total_detg())**(1._dl/3._dl)
    metric%a = metric%a*ainc
    metric%physdx = metric%physdx * ainc
    metric_h(1:3,:,:,:) = metric_h(1:3,:,:,:) - 2._dl*log(ainc)
    ainc = ainc**3
    metric_p = metric_p/ainc
    fields_p = fields_p/ainc
#else
    metric%a = scale_factor()
    metric%physdx = metric%dx*metric%a
#endif
    need_recalculate = .true.
    !!================================================
  end subroutine coor_trans

  subroutine get_dgup(i, j , k, dg, dgup, ddgup_dh)
    integer(IB) i,j,k
    real(dl) dg, dgup(6),ddgup_dh(6,6)
    real(dl) eh6,eh3,seii(3),eii(3), eii3(3), eii6(3), eii23(3), ss(3)
#if METRIC_PERTURB
    eii6(1) = fast_exp(-H11(i,j,k)/6._dl)
    eii6(2) = fast_exp(-H22(i,j,k)/6._dl)
    eii6(3) = fast_exp(-H33(i,j,k)/6._dl)

    eh6 = 1./(eii6(1)*eii6(2)*eii6(3))
    eh3 = eh6**2
    dg = eh6*eh3  !!sqrt(|det g|) = e^{h/2}

    eii3 = eii6**2
    eii23 = eii3 **2
    seii = eii6*eii3
    eii = seii**2

    ss = eii23*(/ H12(i,j,k)**2*eii3(2) + H13(i,j,k)**2*eii3(3), &
         H21(i,j,k)**2*eii3(1) + H23(i,j,k)**2*eii3(3), &
         H31(i,j,k)**2*eii3(1) + H32(i,j,k)**2*eii3(2) /)
    dgup(1:3) = ( eii + ss/2.)*dg
    dgup(4:6) = -MEV(i,j,k)/seii + 0.5_dl*eh6* (/ H12(i,j,k)*H13(i,j,k), &
         H21(i,j,k)*H23(i,j,k) , H31(i,j,k)*H32(i,j,k) /)

    ddgup_dh(1:3,4) = (/ 0._dl, eii3(3), eii3(2) /) * eii23 * (dg*H23(i,j,k))
    ddgup_dh(1:3,5) = (/ eii3(3), 0._dl, eii3(1) /) * eii23 * (dg*H13(i,j,k))
    ddgup_dh(1:3,6) = (/ eii3(2), eii3(1), 0._dl /) * eii23 * (dg*H12(i,j,k))
    ddgup_dh(4:6,4) = (/ -1._dl/seii(1), 0._dl, 0._dl /) &
         + 0.5_dl*eh6* (/ 0._dl, H12(i,j,k), H13(i,j,k) /)
    ddgup_dh(4:6,5) = (/ 0._dl, -1._dl/seii(2), 0._dl /) &
         + 0.5_dl*eh6* (/ H12(i,j,k), 0._dl, H23(i,j,k) /)
    ddgup_dh(4:6,6) = (/ 0._dl, 0._dl, -1._dl/seii(3) /) &
         + 0.5_dl*eh6* (/ H13(i,j,k), H23(i,j,k), 0._dl /)

    ddgup_dh(1:3,1) =  dgup(1:3)/2._dl - dg *(/ &
          eii(1)+ss(1)/3._dl, H21(i,j,k)**2*eii3(1)*eii23(2)/6._dl, H31(i,j,k)**2*eii3(1)*eii23(3)/6._dl /)
    ddgup_dh(1:3,2) =  dgup(1:3)/2._dl - dg * (/ &
         H21(i,j,k)**2 * eii3(2)*eii23(1)/6._dl, eii(2)+ss(2)/3._dl, H32(i,j,k)**2*eii3(2)*eii23(3) /)
    ddgup_dh(1:3,3) =  dgup(1:3)/2._dl - dg *(/ &
         H31(i,j,k)**2*eii3(3)*eii23(1), H32(i,j,k)**2*eii3(3)*eii23(2), eii(3)+ss(3)/3._dl /)
    ddgup_dh(4:6,1) =  eh6/12._dl*  (/ H12(i,j,k)*H13(i,j,k), H21(i,j,k)*H23(i,j,k) , H31(i,j,k)*H32(i,j,k) /)
    ddgup_dh(4:6,2) = ddgup_dh(4:6,1)
    ddgup_dh(4:6,3) = ddgup_dh(4:6,1)
    ddgup_dh(4,1) = ddgup_dh(4,1) - H23(i,j,k)/seii(1)/2._dl
    ddgup_dh(5,2) = ddgup_dh(5,2) - H13(i,j,k)/seii(2)/2._dl
    ddgup_dh(6,3) = ddgup_dh(6,3) - H12(i,j,k)/seii(3)/2._dl
#endif
    return
  end subroutine get_dgup

!!IMPORTANT: This is a single-thread subroutine
!!DO NOT CALL IT IN A PARALLEL LOOP
  subroutine get_cach(k)
    integer(IB) i,j,k,ii
#if METRIC_PERTURB
#if DIS_SCHEME == HLATTICE1
    if(k.eq.1)then !!initialize slice #1 and slice #0
       do ii=0,1
          !$omp parallel do default(shared) private(i,j)
          do j=1,n; do i=1,n
             call get_dgup(i,j,ii,sipar%cach_dg(i,j,ii),sipar%cach_dgup(:,i,j,ii),sipar%cach_ddgup(:,:,i,j,ii))
          enddo; enddo
          !$omp end parallel do
       enddo
       sipar%cach_ind(-1) = 2 !!previous slice
       sipar%cach_ind(0) = 0  !!the current slice
       sipar%cach_ind(1) = 1 !!next slice
    endif

    sipar%cach_ind = mod(sipar%cach_ind+1, 3)  !!rotate the indices
    !!calculate the slice #k+1
    !$omp parallel do default(shared) private(i,j)
    do j=1,n; do i=1,n
       call get_dgup(i,j,k+1,sipar%cach_dg(i,j,sipar%cach_ind(1)), sipar%cach_dgup(:,i,j,sipar%cach_ind(1)),sipar%cach_ddgup(:,:,i,j,sipar%cach_ind(1)))
    enddo; enddo
    !$omp end parallel do
#elif DIS_SCHEME == HLATTICE2
    if(k.eq.1)then !!initialize slice #0, #1, #2, #3
       do ii=0,3
          !$omp parallel do default(shared) private(i,j)
          do j=1,n; do i=1,n
             call get_dgup(i,j,ii-1,sipar%cach_dg(i,j,ii),sipar%cach_dgup(:,i,j,ii),sipar%cach_ddgup(:,:,i,j,ii))
          enddo; enddo
          !$omp end parallel do
       enddo
       sipar%cach_ind(-2) = 4
       sipar%cach_ind(-1) = 0
       sipar%cach_ind(0) = 1  !!the current slice
       sipar%cach_ind(1) = 2
       sipar%cach_ind(2) = 3
    endif

    sipar%cach_ind = mod(sipar%cach_ind+1, 5)  !!rotate the indices
    !!calculate the slice #k+1
    !$omp parallel do default(shared) private(i,j)
    do j=1,n; do i=1,n
       call get_dgup(i,j,k+2,sipar%cach_dg(i,j,sipar%cach_ind(2)), sipar%cach_dgup(:,i,j,sipar%cach_ind(2)),sipar%cach_ddgup(:,:,i,j,sipar%cach_ind(2)))
    enddo; enddo
    !$omp end parallel do
#endif
#endif
    return
  end subroutine get_cach

  subroutine get_energy()
    need_recalculate = .true.
    last_total_detg = total_detg()
    last_potential_energy = potential_energy()
    last_fields_kinetic_energy = fields_kinetic_energy()
    last_fields_gradient_energy = fields_gradient_energy()
    last_gravity_kinetic_energy = gravity_kinetic_energy()
    last_gravity_gradient_energy = gravity_gradient_energy(last_total_detg)
    last_effective_Hubble = effective_Hubble(last_total_detg)
    need_recalculate = .false.
  end subroutine get_energy

  function total_fields_energy()
    real(dl) total_fields_energy
    total_fields_energy = potential_energy() + fields_kinetic_energy() + fields_gradient_energy()
  end function total_fields_energy

  subroutine get_GW_spectrum(S_k)
    real(dl) S_k(fft_numk)
    real(dl),parameter::amp=const_pi/2.*Mplsq/ncube**2
    DEFINE_IND
    real(dl) hpk(fft_numk),ppk(fft_numk),tmp
    S_k=0._dl
#if HIJ_DEFINED
#if METRIC_PERTURB
    !!get the h_{ij}'
    metric_p = metric_p*(2./Mplsq*metric%physdx)
    !$omp parallel do
    LOOP
    MEPIU(i,j,k) = (2.*MEPIU(i,j,k)-sum(MEPIU(i,j,k)))
    ENDLOOP
    !$omp end parallel do
#else
    metric_p = metric_p*metric%physdx
#endif

#if METRIC_OPTION == FRW_PERTURB_ADAPTIVE
    print*,"coordinate transformation..."
#endif
    call CubicMassiveFFT(6,metric_h,metric_p,FFT_FORWARD)

#ifdef DEBUG_MODE
    call fft_Get_TT_Power(metric_h,metric_p,hpk,ppk,OUTPUT_TT)
    call CubicMassiveFFT(6,metric_h,metric_p,FFT_BACKWARD)
    print*,sqrt(sum(metric_h**2)/ncube)
    tmp=0.
    !$omp parallel do reduction(+:tmp)
    LOOP
    tmp = tmp + sum(metric_h(1:3,i,j,k))**2
    ENDLOOP
    !$omp end parallel do
    print*,sqrt(tmp)
    tmp=0.
    !$omp parallel do reduction(+:tmp)
    LOOP
    tmp = tmp + (TWELVE_DU_X(1,i,j,k)+TWELVE_DV_Y(3,i,j,k)+TWELVE_DV_Z(2,i,j,k))**2 &
         +(TWELVE_DU_Y(2,i,j,k)+TWELVE_DV_X(3,i,j,k)+TWELVE_DV_Z(1,i,j,k))**2 &
         +(TWELVE_DU_Z(3,i,j,k)+TWELVE_DV_Y(1,i,j,k)+TWELVE_DV_X(2,i,j,k))**2
    ENDLOOP
    !$omp end parallel do
    print*,sqrt(tmp)/12.
    stop
#endif
#if METRIC_OPTION == FRW_PERTURB_ADAPTIVE
    call fft_Get_TT_Power(metric_h,metric_p,hpk,ppk,OUTPUT_ADAPTIVE)
#else
    call fft_Get_TT_Power(metric_h,metric_p,hpk,ppk,UNCHANGED)
#endif
    do i=1,fft_numk
       S_k(i)=((i*const_2pi/n)**2*hpk(i) + ppk(i))/metric%physdx**2*amp*fft_vol(i)*real(i,dl)/(4._dl*const_pi)
    enddo
    call CubicMassiveFFT(6,metric_h,metric_p,FFT_BACKWARD)
#if METRIC_OPTION ==  FRW_PERTURB_ADAPTIVE
!    print*,"After coordinate transformation <h_{ij}^2>^{1/2}~", sqrt(sum(metric_h**2)/ncube)
    LOOP
#if DIS_SCHEME == HLATTICE1
    fields_f(:,i,j,k) =  fields_f(:,i,j,k) - (TWO_DFLD_X(i,j,k)*metric_p(1,i,j,k) + TWO_DFLD_Y(i,j,k)*metric_p(2,i,j,k) + TWO_DFLD_Z(i,j,k)*metric_p(3,i,j,k))/2.
    fields_p(:,i,j,k) =  fields_p(:,i,j,k) - (TWO_DF_X_FLD(fields_p,:,i,j,k)*metric_p(1,i,j,k) + TWO_DF_Y_FLD(fields_p,:,i,j,k)*metric_p(2,i,j,k) + TWO_DF_Z_FLD(fields_p,:,i,j,k)*metric_p(3,i,j,k))/2.
#elif DIS_SCHEME == HLATTICE2
    fields_f(:,i,j,k) =  fields_f(:,i,j,k) - (TWELVE_DFLD_X(i,j,k)*metric_p(1,i,j,k) + TWELVE_DFLD_Y(i,j,k)*metric_p(2,i,j,k) + TWELVE_DFLD_Z(i,j,k)*metric_p(3,i,j,k))/12.
    fields_p(:,i,j,k) =  fields_p(:,i,j,k) - (TWELVE_DF_X_FLD(fields_p,:,i,j,k)*metric_p(1,i,j,k) + TWELVE_DF_Y_FLD(fields_p,:,i,j,k)*metric_p(2,i,j,k) + TWELVE_DF_Z_FLD(fields_p,:,i,j,k)*metric_p(3,i,j,k))/12.
#else
    stop "For METRIC_OPTION=FRW_PERTURB_ADPATIVE you must use DIS_SCHEME = HLATTICE1 or HLATTICE2"
#endif
    ENDLOOP
    !!reload the metric
    call metric_load_term("data/"//trim(run_name)//"_metric_pij.log",2)
#else
#if METRIC_PERTURB
    metric_p = metric_p*(Mplsq/2./ metric%physdx)
    !$omp parallel do
    LOOP
    MEPIU(i,j,k) = (MEPIU(i,j,k)-sum(MEPIU(i,j,k)))/2.
    ENDLOOP
    !$omp end parallel do
#else
    metric_p = metric_p/ metric%physdx
#endif
#endif
#endif
  end subroutine get_GW_spectrum

end module mutils


subroutine ht_dia_sai(bcdpop,bcmstandstem,bc0ssa,bc0ssb,bcdstm,bcxstm,bczmxc,   &
                    & bczht,dht,bcxstmrep,bcrsai)
!
implicit none
!
! Dummy arguments
!
real :: bc0ssa,bc0ssb,bcdpop,bcdstm,bcmstandstem,bcrsai,bcxstm,bcxstmrep,bczht, &
      & bczmxc,dht
intent (in) bc0ssa,bc0ssb,bcdpop,bcdstm,bcmstandstem,bcxstm,bczht,bczmxc
intent (out) bcrsai,bcxstmrep
intent (inout) dht
!
!     + + + purpose + + +
! this routine checks for consistency between plant height and biomass
! accumulation, using half and double the stem diameter (previously unused)
! as check points. the representative stem diameter is set to show where
! within the range the actual stem diameter is.

!     + + + argument declarations + + +

!     + + + argument definitions + + +
!     bcdpop - crop seeding density (#/m^2)
!     bcmstandstem - crop standing stem mass (kg/m^2)
!     bc0ssa - stem area to mass coefficient a, result is m^2 per plant
!     bc0ssb - stem area to mass coefficient b, argument is kg per plant
!     bcdstm - number of crop stems per unit area (#/m^2)
!     bcxstm - crop stem diameter (m)
!     bczmxc - maximum potential plant height (m)
!     bczht  - crop height (m)
!     dht - daily height increment (m)
!     bcxstmrep - a representative diameter so that acdstm*acxstmrep*aczht=acrsai
!     bcrsai - crop stem area index (m^2/m^2)

!     + + + local variables + + +
!
!     min_dia, max_dia, min_height, max_height, new_height set here but
!     commented out in the code  jcaii 8/08/08
!

!     + + + local variable definitions + + +
!     min_dia - minimum stem diameter
!     max_dia - maximum stem diameter
!     min_height - minimum plant height
!     max_height - maximum plant height
!     new_height - plant height plus increment

!     + + + local parameters + + +
!
!     multmin, multmax set here but commented out in the code  jcaii 8/08/08
!

!     + + + local parameter definitions + + +
!     multmin - multiplier to find minimum stem diameter from set stem diameter
!     multmax - multiplier to find maximum stem diameter from set stem diameter

!     + + + end of specifications + + +

      ! calculate crop stem area index
      ! when exponent is not 1, must use mass for single plant stem to get stem area
      ! bcmstandstem, convert (kg/m^2) / (plants/m^2) = kg/plant
      ! result of ((m^2 of stem)/plant) * (# plants/m^2 ground area) = (m^2 of stem)/(m^2 ground area)
if (bcdpop>0.0) then
  bcrsai = bcdpop*bc0ssa*(bcmstandstem/bcdpop)**bc0ssb
else
  bcrsai = 0.0
end if

!      if( dht .lt. 0.0 ) then
!          write(*,*) 'error - this should never appear'
!          stop
!      if( dht .gt. 0.0 ) then
!          ! only adjust height during period of height increase
!          ! back calculate height limits
!          ! min diameter, max height
!          min_dia = multmin * bcxstm
!          max_height = bcrsai / (bcdstm * min_dia)
!
!          ! max diameter, min height
!          max_dia = multmax * bcxstm
!          min_height = bcrsai / (bcdstm * max_dia)
!
!          ! check proposed height increase
!          if( dht .gt. 0.0 ) then
!              new_height = bczht + dht
!              if( new_height .gt. max_height ) then
!                  ! stem is too thin, slow height increase, no less than zero
!                  dht = max(0.0, max_height - bczht)
!              else if( new_height .lt. min_height ) then
!                  ! stem is too thick, speed height increase
!                  dht = min(bczmxc - bczht, min_height - bczht)
!              end if
!          end if
!      end if

      ! (m^2 stem / m^2 ground) / ((stems/m^2 ground) * m) = m/stem
      ! this value not reset unless it is meaningful
if ((bcdstm*(bczht+dht))>0.0) then
  bcxstmrep = bcrsai/(bcdstm*(bczht+dht))
else
  bcxstmrep = 0.0
end if
!
end subroutine ht_dia_sai


PROGRAM convert_date

use calendar

implicit none

integer :: day, month, year, hour, minute, second
CHARACTER(4) :: YYYY
CHARACTER(2) :: MM, DD, HH, NN, SS
integer :: values(3)
integer :: julian = 0
integer :: v(9)
integer :: iy, ja, jm, jy, ierr
integer :: iday,imonth,iyear
INTEGER, PARAMETER :: slen = 256
INTEGER :: i,j,k

! Process the command line
CALL process_command_line

values = (/ year, month, day /)

julian = date_to_julian(day, month, year, values, ierr)
! julian = date_to_julian(day, month, year, ierr)

print *, "Date = ", year, month, day
print *, "julian = ", julian

! The Julian date for CE  1985 January  1 00:00:00.0 UT is
! JD 2446066.500000
print *, "Convert julian to <days since 1/1/1985> = ", julian - 2446066.500000 + 1

open(UNIT=20,FILE='aid.dat',STATUS='new')
write(20,*) FLOOR(julian - 2446066.500000 + 1)
write(20,*) year, month, day
close(20)

CONTAINS

SUBROUTINE process_command_line

IMPLICIT NONE

CHARACTER(slen) :: arg1,arg2
INTEGER :: ierr
INTEGER, DIMENSION(3) :: values
! STEVE: add input error handling!^M
! inputs are in the format "-x xxx"^M
DO i=1,COMMAND_ARGUMENT_COUNT(),2
  CALL GET_COMMAND_ARGUMENT(i,arg1)
  PRINT *, "Argument ", i, " = ",TRIM(arg1)

  select case (arg1)
    case ('-y')
      CALL GET_COMMAND_ARGUMENT(i+1,arg2)
      PRINT *, "Argument ", i+1, " = ",TRIM(arg2)
      READ(arg2,*) year
      WRITE(YYYY,'(i4.4)') year
      print *, "year = ", arg2
      print *, "YYYY = ", YYYY
    case('-m')
      CALL GET_COMMAND_ARGUMENT(i+1,arg2)
      PRINT *, "Argument ", i+1, " = ",TRIM(arg2)
      READ(arg2,*) month
      WRITE(MM,'(i2.2)') month
      print *, "month = ", arg2
      print *, "MM = ", MM
    case('-d')
      CALL GET_COMMAND_ARGUMENT(i+1,arg2)
      PRINT *, "Argument ", i+1, " = ",TRIM(arg2)
      READ(arg2,*) day
      WRITE(DD,'(i2.2)') day
      print *, "day = ", arg2
      print *, "DD = ", DD
    case('-h')
      CALL GET_COMMAND_ARGUMENT(i+1,arg2)
      PRINT *, "Argument ", i+1, " = ",TRIM(arg2)
      READ(arg2,*) hour
      WRITE(HH,'(i2.2)') hour
      print *, "hour = ", arg2
      print *, "HH = ", HH
  end select
END DO

END SUBROUTINE process_command_line

END PROGRAM convert_date


!*******************************************************************
!                                                                  *
      INTEGER FUNCTION ITREXG(I1,I2,I3,I4,K)
!
!   Written by G. Gaigalas,                                        *
!   Vanderbilt University,  Nashville               October  1996  *
!   Transform to fortran 90/95 by G. Gaigalas       December 2012  *
!   The last modification made by G. Gaigalas       October  2017  *
!                                                                  *
!*******************************************************************
!
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(IN)  :: I1, I2, I3, I4
      INTEGER, INTENT(OUT) :: K
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: J
!-----------------------------------------------
      J=MAX0(IABS(I1-I2),IABS(I3-I4))
      K=MIN0(IABS(I1+I2),IABS(I3+I4))-J+1
      ITREXG=J
      RETURN
      END FUNCTION ITREXG


program bugs
   implicit none
   real last
   real c(10)
   integer p

   ! Initialise c with successive integer values.
   do p=1,10
       c(p)=p
    enddo

    ! Calculate and print ratios of successive integers.
    last = 0.0
    do p=1,10
        call divide(c(p), last)
        last = c(p)
    enddo
end program bugs

subroutine divide(d,e)
    implicit none
    real d,e
    print *,e/d
end subroutine divide


! { dg-do compile }
! { dg-options "-O1 -ftree-loop-linear" }
! PR tree-optimization/36286

program test_count
    integer, dimension(2,3) :: a, b
    a = reshape( (/ 1, 3, 5, 2, 4, 6 /), (/ 2, 3 /))
    b = reshape( (/ 0, 3, 5, 7, 4, 8 /), (/ 2, 3 /))
    print '(3l6)', a.ne.b
    print *, a(1,:).ne.b(1,:)
    print *, a(2,:).ne.b(2,:)
    print *, count(a.ne.b)
end program test_count


module worker_module
use iso_fortran_env, only: real64
contains

  subroutine my_vector_add(n, a, b)
    implicit none

    integer :: i,n
    real(real64),dimension(n) :: a, b

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

  end subroutine my_vector_add

  subroutine my_vector_add_assumed(a, b)
    implicit none

    integer :: i
    real(real64) :: a(:), b(:)

    do i = 1,size(a)
       a(i) = a(i) + b(i)
    end do

  end subroutine my_vector_add_assumed

  subroutine my_vector_add_assumed_contiguous(a, b)
    implicit none

    integer :: i
    real(real64), contiguous :: a(:), b(:)

    do i = 1,size(a)
       a(i) = a(i) + b(i)
    end do

  end subroutine my_vector_add_assumed_contiguous

  subroutine my_vector_add_allocatable(a, b)
    implicit none

    integer :: i
    real(real64),allocatable :: a(:), b(:)

    do i = 1,size(a)
       a(i) = a(i) + b(i)
    end do

  end subroutine my_vector_add_allocatable

  subroutine my_vector_add_pointer(a, b)
    implicit none

    integer :: i
    real(real64), pointer :: a(:), b(:)

    do i = 1,size(a)
       a(i) = a(i) + b(i)
    end do

  end subroutine my_vector_add_pointer

  subroutine my_vector_add_pointer_contiguous(a, b)
    implicit none

    integer :: i
    real(real64), pointer,contiguous :: a(:), b(:)

    do i = 1,size(a)
       a(i) = a(i) + b(i)
    end do

  end subroutine my_vector_add_pointer_contiguous

end module worker_module


      SUBROUTINE slDTFD (IHOUR, IMIN, SEC, DAYS, J)
*+
*     - - - - - -
*      D T F D
*     - - - - - -
*
*  Convert hours, minutes, seconds to days (double precision)
*
*  Given:
*     IHOUR       int       hours
*     IMIN        int       minutes
*     SEC         dp        seconds
*
*  Returned:
*     DAYS        dp        interval in days
*     J           int       status:  0 = OK
*                                    1 = IHOUR outside range 0-23
*                                    2 = IMIN outside range 0-59
*                                    3 = SEC outside range 0-59.999...
*
*  Notes:
*
*     1)  The result is computed even if any of the range checks fail.
*
*     2)  The sign must be dealt with outside this routine.
*
*  P.T.Wallace   Starlink   July 1984
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      INTEGER IHOUR,IMIN
      DOUBLE PRECISION SEC,DAYS
      INTEGER J

*  Seconds per day
      DOUBLE PRECISION D2S
      PARAMETER (D2S=86400D0)

*  Preset status
      J=0

*  Validate sec, min, hour
      IF (SEC.LT.0D0.OR.SEC.GE.60D0) J=3
      IF (IMIN.LT.0.OR.IMIN.GT.59) J=2
      IF (IHOUR.LT.0.OR.IHOUR.GT.23) J=1

*  Compute interval
      DAYS=(60D0*(60D0*DBLE(IHOUR)+DBLE(IMIN))+SEC)/D2S

      END


real :: pi = 4.*atan(1.)
real :: tau

include "inc2.f90"


      SUBROUTINE SLARTV( N, X, INCX, Y, INCY, C, S, INCC )
*
*  -- LAPACK auxiliary routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      INTEGER            INCC, INCX, INCY, N
*     ..
*     .. Array Arguments ..
      REAL               C( * ), S( * ), X( * ), Y( * )
*     ..
*
*  Purpose
*  =======
*
*  SLARTV applies a vector of real plane rotations to elements of the
*  real vectors x and y. For i = 1,2,...,n
*
*     ( x(i) ) := (  c(i)  s(i) ) ( x(i) )
*     ( y(i) )    ( -s(i)  c(i) ) ( y(i) )
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The number of plane rotations to be applied.
*
*  X       (input/output) REAL array,
*                         dimension (1+(N-1)*INCX)
*          The vector x.
*
*  INCX    (input) INTEGER
*          The increment between elements of X. INCX > 0.
*
*  Y       (input/output) REAL array,
*                         dimension (1+(N-1)*INCY)
*          The vector y.
*
*  INCY    (input) INTEGER
*          The increment between elements of Y. INCY > 0.
*
*  C       (input) REAL array, dimension (1+(N-1)*INCC)
*          The cosines of the plane rotations.
*
*  S       (input) REAL array, dimension (1+(N-1)*INCC)
*          The sines of the plane rotations.
*
*  INCC    (input) INTEGER
*          The increment between elements of C and S. INCC > 0.
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, IC, IX, IY
      REAL               XI, YI
*     ..
*     .. Executable Statements ..
*
      IX = 1
      IY = 1
      IC = 1
      DO 10 I = 1, N
         XI = X( IX )
         YI = Y( IY )
         X( IX ) = C( IC )*XI + S( IC )*YI
         Y( IY ) = C( IC )*YI - S( IC )*XI
         IX = IX + INCX
         IY = IY + INCY
         IC = IC + INCC
   10 CONTINUE
      RETURN
*
*     End of SLARTV
*
      END


program variables_01
implicit none
integer :: x, y
x = 2
y = 3
if (x /= 2) error stop
if (y /= 3) error stop

x = y
if (x /= 3) error stop
if (y /= 3) error stop

y = 1
if (y == 1) x = 1
if (y /= 1) x = 2
if (x /= 1) error stop

y = 2
if (y == 1) x = 1
if (y /= 1) x = 2
if (x /= 2) error stop

x = 2
y = 1
if (y == 1) x = x + 1
if (y /= 1) x = x - 1
if (x /= 3) error stop

x = 2
y = 2
if (y == 1) x = x + 1
if (y /= 1) x = x - 1
if (x /= 1) error stop
end program


!-------------------------------------------------------------------------!
!                                                                         !
!        N  A  S     P A R A L L E L     B E N C H M A R K S  3.3         !
!                                                                         !
!                       O p e n M P     V E R S I O N                     !
!                                                                         !
!                                   B T                                   !
!                                                                         !
!-------------------------------------------------------------------------!
!                                                                         !
!    This benchmark is an OpenMP version of the NPB BT code.              !
!    It is described in NAS Technical Report 99-011.                      !
!                                                                         !
!    Permission to use, copy, distribute and modify this software         !
!    for any purpose with or without fee is hereby granted.  We           !
!    request, however, that all derived work reference the NAS            !
!    Parallel Benchmarks 3.3. This software is provided "as is"           !
!    without express or implied warranty.                                 !
!                                                                         !
!    Information on NPB 3.3, including the technical report, the          !
!    original specifications, source code, results and information        !
!    on how to submit new results, is available at:                       !
!                                                                         !
!           http://www.nas.nasa.gov/Software/NPB/                         !
!                                                                         !
!    Send comments or suggestions to  npb@nas.nasa.gov                    !
!                                                                         !
!          NAS Parallel Benchmarks Group                                  !
!          NASA Ames Research Center                                      !
!          Mail Stop: T27A-1                                              !
!          Moffett Field, CA   94035-1000                                 !
!                                                                         !
!          E-mail:  npb@nas.nasa.gov                                      !
!          Fax:     (650) 604-3957                                        !
!                                                                         !
!-------------------------------------------------------------------------!

c---------------------------------------------------------------------
c
c Authors: R. Van der Wijngaart
c          T. Harris
c          M. Yarrow
c          H. Jin
c
c---------------------------------------------------------------------

c---------------------------------------------------------------------
       program BT
c---------------------------------------------------------------------

       include  'header.h'

       integer i, niter, step, fstatus
       double precision navg, mflops, n3

       external timer_read
       double precision tmax, timer_read, t, trecs(t_last)
       logical verified
       character class
       character t_names(t_last)*8
!$     integer  omp_get_max_threads
!$     external omp_get_max_threads

c---------------------------------------------------------------------
c      Root node reads input file (if it exists) else takes
c      defaults from parameters
c---------------------------------------------------------------------

       open (unit=2,file='timer.flag',status='old', iostat=fstatus)
       if (fstatus .eq. 0) then
         timeron = .true.
         t_names(t_total) = 'total'
         t_names(t_rhsx) = 'rhsx'
         t_names(t_rhsy) = 'rhsy'
         t_names(t_rhsz) = 'rhsz'
         t_names(t_rhs) = 'rhs'
         t_names(t_xsolve) = 'xsolve'
         t_names(t_ysolve) = 'ysolve'
         t_names(t_zsolve) = 'zsolve'
         t_names(t_rdis1) = 'redist1'
         t_names(t_rdis2) = 'redist2'
         t_names(t_add) = 'add'
         close(2)
       else
         timeron = .false.
       endif

       write(*, 1000)
       open (unit=2,file='inputbt.data',status='old', iostat=fstatus)

       if (fstatus .eq. 0) then
         write(*,233)
 233     format(' Reading from input file inputbt.data')
         read (2,*) niter
         read (2,*) dt
         read (2,*) grid_points(1), grid_points(2), grid_points(3)
         close(2)
       else
         write(*,234)
         niter = niter_default
         dt    = dt_default
         grid_points(1) = problem_size
         grid_points(2) = problem_size
         grid_points(3) = problem_size
       endif
 234   format(' No input file inputbt.data. Using compiled defaults')

       write(*, 1001) grid_points(1), grid_points(2), grid_points(3)
       write(*, 1002) niter, dt
!$     write(*, 1003) omp_get_max_threads()
       write(*, *)

 1000  format(//, ' NAS Parallel Benchmarks (NPB3.3-OMP)',
     >            ' - BT Benchmark', /)
 1001  format(' Size: ', i4, 'x', i4, 'x', i4)
 1002  format(' Iterations: ', i4, '       dt: ', F11.7)
 1003  format(' Number of available threads: ', i5)

       if ( (grid_points(1) .gt. IMAX) .or.
     >      (grid_points(2) .gt. JMAX) .or.
     >      (grid_points(3) .gt. KMAX) ) then
             print *, (grid_points(i),i=1,3)
             print *,' Problem size too big for compiled array sizes'
             goto 999
       endif

       call set_constants

       do i = 1, t_last
          call timer_clear(i)
       end do

       call initialize

       call exact_rhs

c---------------------------------------------------------------------
c      do one time step to touch all code, and reinitialize
c---------------------------------------------------------------------
       call adi
       call initialize

       do i = 1, t_last
          call timer_clear(i)
       end do
       call timer_start(1)
       CALL PARMACS_ROI_BEGIN ()

       do  step = 1, niter

          if (mod(step, 20) .eq. 0 .or.
     >        step .eq. 1) then
             write(*, 200) step
 200         format(' Time step ', i4)
          endif

          call parmacs_iter_begin(step)
          call adi
          call parmacs_iter_end(step)

       end do

       CALL PARMACS_ROI_END ()
       call timer_stop(1)
       tmax = timer_read(1)

       call verify(niter, class, verified)

       n3 = 1.0d0*grid_points(1)*grid_points(2)*grid_points(3)
       navg = (grid_points(1)+grid_points(2)+grid_points(3))/3.0
       if( tmax .ne. 0. ) then
          mflops = 1.0e-6*float(niter)*
     >  (3478.8*n3-17655.7*navg**2+28023.7*navg)
     >  / tmax
       else
          mflops = 0.0
       endif
       call print_results('BT', class, grid_points(1),
     >  grid_points(2), grid_points(3), niter,
     >  tmax, mflops, '          floating point',
     >  verified, npbversion,compiletime, cs1, cs2, cs3, cs4, cs5,
     >  cs6, '(none)')

c---------------------------------------------------------------------
c      More timers
c---------------------------------------------------------------------
       if (.not.timeron) goto 999

       do i=1, t_last
          trecs(i) = timer_read(i)
       end do
       if (tmax .eq. 0.0) tmax = 1.0

       write(*,800)
 800   format('  SECTION   Time (secs)')
       do i=1, t_last
          write(*,810) t_names(i), trecs(i), trecs(i)*100./tmax
          if (i.eq.t_rhs) then
             t = trecs(t_rhsx) + trecs(t_rhsy) + trecs(t_rhsz)
             write(*,820) 'sub-rhs', t, t*100./tmax
             t = trecs(t_rhs) - t
             write(*,820) 'rest-rhs', t, t*100./tmax
          elseif (i.eq.t_zsolve) then
             t = trecs(t_zsolve) - trecs(t_rdis1) - trecs(t_rdis2)
             write(*,820) 'sub-zsol', t, t*100./tmax
          elseif (i.eq.t_rdis2) then
             t = trecs(t_rdis1) + trecs(t_rdis2)
             write(*,820) 'redist', t, t*100./tmax
          endif
 810      format(2x,a8,':',f9.3,'  (',f6.2,'%)')
 820      format('    --> ',a8,':',f9.3,'  (',f6.2,'%)')
       end do

 999   continue

       end


      SUBROUTINE BESIZ (ZIN,M,IOM,IRP,GJIM,GJIN,GYKM,GYKN,LERR)
C
C  MODIFIED FROM BESSEL TO SAVE SPACE IN 1985, JUNE
C
C     ORDINARY AND MODIFIED BESSEL FUNCTIONS OF INTEGRAL ORDER
C     FOR COMPLEX ARGUMENT
C
C     COMPLEX VARIABLE NOTATION     (I = SQUARE ROOT OF -1)
C
C (IN ) RECTANGULAR COORDINATES  -  Z = X+I*Y, PHI = X, CHI = Y
C (IN ) POLAR COORDINATES  -  Z = RHO*COS(ANGLE)+I*RHO*SIN(ANGLE)
C (IN )                    -  PHI = RHO,  THE RADIUS VECTOR
C (IN )                    -  CHI = ANGLE IN DEGREES
C (IN )                    -  180 < CHI <= 180  (PROGRAM CORRECTS)
C (IN ) M  = ORDER TO BE COMPUTED - PROGRAM COMPUTES ORDERS M AND M+1.
C (IN )        EX.  IF N = M+1 THEN WILL GIVE JM(Z) AND JN(Z)
C (IN ) IOM = 1  COMPUTE ORDINARY BESSEL FUNCTIONS
C (IN ) IOM = 2  COMPUTE MODIFIED BESSEL FUNCTIONS
C (IN ) IRP = 1  ARGUMENT IS IN RECTANGULAR COORDINATES
C (IN ) IRP = 2  ARGUMENT IS IN POLAR COORDINATES - ANGLE IN DEGREES
C
C (OUT) GJIM,GJIN - BESSEL FUNCTIONS OF THE FIRST KIND
C (OUT)     GJIM = JM(Z) OR IM(Z)
C (OUT)     GJIN = JN(Z) OR IN(Z)
C (OUT) GYKM,GYKN - BESSEL FUNCTIONS OF THE SECOND KIND
C (OUT)     GYKM = YM(Z) OR KM(Z)
C (OUT)     GYKN = YN(Z) OR KN(Z)
C
C (OUT) LERR IS AN INTEGER INDICATING IF THERE WAS A RUN ERROR IN THE
C (OUT)      SUBROUTINE.  LERR = 0, NO ERROR.  LERR > 1, THERE WAS AN
C (OUT)      ERROR.  USER CAN TEST THIS NUMBER AND THEN DECIDE WHETHER
C (OUT)      TO CONTINUE OR NOT.
C
      REAL EPSI(9)
      COMPLEX JIM,YKM,JIN,YKN,Z,ZL,OH,X,Y,CM1,CN1,CM2,CN2,
     1 CM3,CN3,CM4,CN4,T,TMK,TMK1,TNK,TNK1,TVK,TVK1,TWK,
     2 TWK1,ST,SU,SV,SW,GJIM,GJIN,GYKM,GYKN,
     3 JHN1,JHM1,JHM,SJM1,SJN1,W,FL1,GL1,NF,DF,FL,NG,DG,GL,
     4 QN,KN,KM,I,ZIN,PN,HM,HN,ZT3,ZT4,
     5 S1,S2,S3,S4,FM1,FM2,FN1,FN2,HM1,HM2,
     6 HN1,HN2,A1,A2,A3,A4
C
C
      DATA PI/3.1415926535897932/,PSI/-.1159315156584124488107/
      DATA EPSI/ 1.E-9, 1.E-18, 1.E-30, 1.E-30, 1.E+30, 1.E-10, 1.E-14,
     1     1.E+10, 85.0/
      DATA I/(0.0,1.0)/
C
C**MAKE UP LOCAL VARIABLES
      Z=ZIN
      ZR=REAL(Z)
      ZI=AIMAG(Z)
	MORD=M
	IBM=MORD
	RM=FLOAT(MORD)
	NORD=MORD+1
	IBN=NORD
	RN=FLOAT(NORD)
      LIOM=IOM
      JERR=0
C**JERR=1, Z=0
      IF(ZR .EQ. 0.0 .AND. ZI .EQ. 0.0)  GOTO 5000
C**JERR=8., TYPE B.F. WRONG
      IF(LIOM.NE.1.AND.LIOM.NE.2) GOTO 5070
      N=IRP
C**JERR=2., COORDINATE SYSTEM WRONG
      IF(N .NE. 1 .AND. N .NE. 2) GOTO 5010
      IF(N .EQ. 2) GOTO 130
C*******************************************************************
C**RECTANGULAR COORDINATES
      RHO=CABS(Z)
      THETA=ATAN2(ZI,ZR)
      GOTO 140
C******************************************************************
C**POLAR COORDINATES
  130 PHI=ZR
      CHI=ZI
      CHI=AMOD(CHI,360.0)
C**PUT CHI INTO (-180.0,180.0)
      IF(ABS(CHI).GT.180.0) CHI=CHI-SIGN(360.0,CHI)
      RHO=PHI
      THETA=PI*(CHI/180.)
      ZR=RHO*COS(THETA)
      ZI=RHO*SIN(THETA)
      Z=CMPLX(ZR,ZI)
C*******************************************************************
C**JERR=3., PREVENTS GETTING LOG 0
C**EPSI(3)=1.E-48
  140 IF(RHO .LT. EPSI(3))  GOTO 5020
      ZL=CMPLX(ALOG(RHO)+PSI,THETA)
      IF(LIOM .EQ. 2) GOTO 160
C******************************************************************
C**SIGNS FOR ORDINARY B.F.
      SGN=-1.0
      SGPI=2./PI
      GOTO 170
C******************************************************************
C**SIGNS FOR MODIFIED B.F.
  160 SGN=1.0
      SGPI=1.0
C******************************************************************
  170 OH=.5*Z
      X=OH**2
      Y=1.0/Z
C*****************************************************************
C**WEBER-SCHLAFLI
      IF(RHO .LT. 21.0)  GOTO  180
C**HANKEL ASYMPTOTIC SERIES
      IF(FLOAT(IBN**2)/RHO .LE. 1.95)  GOTO  1000
C**GAUSS CONTINUED FRACTION AND RECURRENCE
  180 IF(RHO .GT. 2.5)  GOTO  600
C
C     SET UP INTIIAL CONDITIONS FOR  M=0  N=1
C
C**RETURN FOR SMALL CABS(Z)<2.5
      ASSIGN 2000 TO JS1
  200 IF(IBM-1) 201,210,220
C*********************************************************************
C**COMMON FACTOR OF J(0) AND I(0)
  201 CM1=1.
C**COMMON FACTOR OF J(1) AND I(1)
      CN1=OH
C**COMMON FACTOR OF INFINITE SERIES FOR Y(0) AND K(0)
      CM2=SGN*.5
C**COMMON FACTOR OF INFINITE SERIES FOR Y(1) AND K(1)
      CN2=SGN*.5*OH
C*******************************************************************
      SRV=0.0
      SRW=1.0
C*******************************************************************
C**COMMON FACTOR OF FINITE SERIES FOR Y(0) AND K(0)
      CM3=0.0
C**COMMON FACTOR OF FINITE SERIES FOR Y(1) AND K(1)
      CN3=SGN*Y
C**SUM OF TERMS OF FINITE SERIES FOR Y(0) AND K(0)
      CM4=0.0
C**SUM OF TERMS OF FINITE SERIES FOR Y(1) AND K(1)
      CN4=1.0
C*****************************************************************
      GOTO 500
C
C     SET UP INITIAL CONDITIONS FOR  M=1  N=2
C
  210 CM1=OH
      CN1=X*.5
      CM2=SGN*.5*OH
      CN2=SGN*.5*CN1
      SRV=1.0
      SRW=1.5
      CM3=SGN*Y
      CN3=SGN*2.*Y**2
      CM4=1.0
      CN4=1.-SGN*X
      GOTO 500
C
C     SET UP INITIAL CONDITIONS FOR  M=2  N=3
C
  220 IF(IBM .GT. 2)  GOTO 300
      CM1=.5*X
      CN1=X*OH/6.
      CM2=SGN*.5*CM1
      CN2=SGN*.5*CN1
      SRV=1.5
      SRW=11./6.
      CM3=SGN*2.*Y**2
      CN3=1.0/(SGN*6.*CN1)
      CM4=1.-SGN*X
      CN4=1.-SGN*.5*X+(.5*X)**2
      GOTO 500
C
C     CODING FOR THE I TH ORDER FOR RHO < 2.5
C
  300 CM1=X*.5
      T3=2.
      SRV=1.5
  310 T3=T3+1.
      T4=1./T3
      CM1=OH*CM1*T4
      T5=CABS(CM1)
C**JERR=4., CONSTANT TERM OF FINITE SERIES TOO LARGE
C**EPSI(5)=1.E+75, EPSI(4)=1.E-75
      IF(T5 .GT. EPSI(5) .OR. T5 .LT. EPSI(4))  GOTO 5030
      SRV=SRV+T4
      IF(INT(T3) .NE. IBM)  GOTO 310
      T4=1./(T3+1.)
      SRW=SRV+T4
      CN1=OH*CM1*T4
      CM3=1.0/(FLOAT(2*IBM)*SGN*CM1)
      CN3=1.0/(FLOAT(2*IBN)*SGN*CN1)
      CM2=SGN*.5*CM1
      CN2=SGN*.5*CN1
C
C     COMPUTE THE FINITE SERIES
C
      TMK=1.0
      TNK=1.0
      CM4=0.
      CN4=TMK
      IFR=1
      K=0
  400 K=K+1
	IF ((IFR .EQ. 0) .OR. (IBM .EQ. IFR) .OR. (IBN .EQ. IFR))
     +       TYPE 10 ,IFR,IBM,IBN
 10   FORMAT (' WARNING (BESSEL) -- IFR, IBM, IBN',3I10)
      TMK1=-SGN*TMK*X/FLOAT(IFR*(IBM-IFR))
      TNK1=-SGN*TNK*X/FLOAT(IFR*(IBN-IFR))
      CN4=CN4+TNK1
      CM4=CM4+TMK
      TNK = TNK1
      TMK = TMK1
      IFR=IFR+1
      T2=CABS(TNK1)
C**EPSI(2)=1.E-18
      IF(T2 .GE. EPSI(2) .AND. K .LT. 100 .AND. IFR .NE. IBM)  GOTO 400
      IF(T2 .GE. EPSI(2) .AND. K .EQ. 100 .AND. IFR .NE. IBM)  STOP 777
      CN4=CN4+TNK1
C**SUM THE SERIES TERMS IN REVERSE ORDER
C  440 K=K-1
C      CN4=CN4+TN(K)
C      CM4=CM4+TM(K)
C      IF(K .GT. 1)  GOTO 440
C
C     COMPUTE THE INFINITE SERIES
C
  500 TMK=1.0
      ST = TMK
      TNK=1.0
      SU = TNK
      SV=SRV
      SW = SRW
      K=0
      IFR=0
      T1=FLOAT(IBN)
      T3=SRW
      T4=0.0
C******************************************************************
C**BEGIN.. CALCULATE TERMS IN SERIES UNTIL IT CONVERGES
  510 K=K+1
      IFR=IFR+1
      T1=T1+1.0
      T2=T3
      T3=T2+1.0/T1
      T4=T4+1.0/FLOAT(IFR)
      P=T4+T2
      Q=T4+T3
C**J(M) OR I(M)
      TMK1=SGN*TMK*X/FLOAT(IFR*(IBM+IFR))
C**Y(M) OR K(M)
      TVK1=P*TMK1
C**J(N) OR I(N)
      TNK1=SGN*TNK*X/FLOAT(IFR*(IBN+IFR))
C**Y(N) OR K(N)
      TWK1=Q*TNK1
      T5=CABS(TWK1)
      ST=ST+TMK1
      SU=SU+TNK1
      SV=SV+TVK1
      SW=SW+TWK1
      TMK=TMK1
      TNK=TNK1
C**OUT OF LOOP
C**EPSI(2)=1.E-18
CPRINT *,T5,SGN,TWK1,TNK1,X,K
      IF(T5 .GE. EPSI(2) .AND. K .LT. 100)  GOTO 510
      IF(T5 .GE. EPSI(2) .AND. K .EQ. 100) STOP 776
C***********************************************************
C**J(M) OR I(M)
C      ST=TM(K+1)
C**J(N) OR I(N)
C      SU=TN(K+1)
C**Y(M) OR K(M)
C      SV=TV(K+1)
C**Y(N) OR K(N)
C      SW=TW(K+1)
C**SUM THE SERIES TERMS IN REVERSE ORDER
C  540 ST=ST+TM(K)
C      SU=SU+TN(K)
C      SV=SV+TV(K)
C      SW=SW+TW(K)
C      K=K-1
C      IF(K .GT. 0) GOTO 540
C**RESULTS STORED IN OUTPUT ARRAYS
      JIM=CM1*ST
      JIN=CN1*SU
      SGN1=1.0
      SGN2=1.0
C**ORDINARY B.F.
      IF(LIOM .EQ. 1)  GOTO 560
C**MODIFIED B.F. DIFFER IN SIGNS OF EVEN TERMS
C**M EVEN, N ODD, SGN1=1.0
C**M ODD, N EVEN
      IF(MOD(MORD,2).EQ.0) SGN1=-1.0
      SGN2=-SGN1
C**SUM THE LOGARITHMIC TERM, THE FINITE TERM, AND THE
C**THE INFINITE SERIES TERM.  THEN MULTIPLY BY THEIR
C**COMMON FACTOR.
C**FIRST, DO Y(M) OR K(M)
  560 YKM=SGPI*(SGN1*JIM*ZL+CM3*CM4+SGN2*CM2*SV)
C**THEN DO Y(N) OR K(N)
      YKN=SGPI*(SGN2*JIN*ZL+CN3*CN4+SGN1*CN2*SW)
      GOTO  JS1,(2000,630)
C
C     COMPUTATION FOR Z > 2.5 BY USE OF RECURSION FORMULAS
C
C**RETURN TO RECURSION AFTER USING SERIES TO CALCULATE
C**STARTING VALUE FOR RECURRENCE PROCEDURES.
  600 ASSIGN 630 TO JS1
      TX=RHO*RHO/4.0
      T1=1.0
      IFR=0
      IFN=NORD
C**INCREASE ORDER UNTIL T1 < 1.E-10
  610 IFR=IFR+1
      IFN=IFN+1
      T1=T1*TX/FLOAT(IFR*IFN)
C**EPSI(6)=1.E-10
      IF(T1 .GE. EPSI(6))  GOTO 610
      IBM=IFN
      IBN=IFN+1
C**GO COMPUTE B.F. OF ORDER IFN AND IFN+1 USING SERIES.
      GOTO 200
C**RETURN FROM SERIES.  USE B.F. OF HIGH ORDER TO
C**START DOWNWARD RECURSION.
  630 JHN1=JIN
      JHM1=JIM
C**J(M-1)=(2M/Z)*J(M)-J(N)
      JHM=FLOAT(2*IBM)*Y*JHM1+SGN*JHN1
      IBM=IBM-1
      IF(IBM.LE.MORD) GOTO 650
C**J(N)=J(M)=J(N-1)
  640 JHN1=JHM1
C**J(M)=J(M-1)
      JHM1=JHM
      JHM=FLOAT(2*IBM)*Y*JHM1+SGN*JHN1
C**DECREASE ORDER TO COMPUTE J(M-2) = ((2*(M-1))/Z)*J(M-1)-J(N-1)
C**UNTIL IBM = MORD.
      IBM=IBM-1
C**FINISHED RECURSION
      IF(IBM .NE. MORD)  GOTO 640
C**J OR I COMPUTED BY RECURSION ARE STORED IN OUTPUT ARRAYS
  650 JIM=JHM
      JIN=JHM1
C**SAVE VALUES OF J(M) AND J(N) COMPUTED BY DOWNWARD RECURSION.
      SJM1=JIM
      SJN1=JIN
C
C     COMPUTE Y AND K BY USING CONTINUED FRACTIONS OF GAUSS
C
      SGN1=1.0
      IF(LIOM .EQ. 2)  GOTO 700
C**ORDINARY B.F.
      SGN3=1.0
      IF(ZI .GE. 0.0)  GOTO 730
      SGN1=-1.0
      SGN3=-1.0
C**1/2Z., ROTATED BY SGN1 TO RIGHT HALF-PLANE IF NECESSARY.
  730 W=.5*SGN1*Y*I
      GO TO 740
C**MODIFIED B.F.
C**Z IN RIGHT HALF-PLANE
  700 IF(ZR .GE. 0.0)  GOTO 710
C**MODIFIED B.F.., LEFT HALF-PLANE
      SGN1=-1.0
C**QUAD II
      SGN3=-1.0
C**QUAD III
      IF(ZI .LT. 0.0) SGN3=1.0
C**1/2Z., ROTATED BY SGN1 TO RIGHT HALF-PLANE IF NECESSARY.
  710 W=SGN1*.5*Y
  740 AA=.5+RN
      BB=.5-RN
      CLL=50.0
C**M ODD, N EVEN
      SGN1=1.0
C**M EVEN, N ODD
      IF(MOD(NORD,2).NE.0) SGN1=-1.0
      SGN2=-SGN1
      FL=0.0
      GL=0.0
C**BEGIN USING CONTINUED FRACTION FOR Y OR K
  760 FL1=FL
      GL1=GL
      BL=BB+CLL
      BL1=BL+1.0
      ALL=AA+CLL-1.0
C****************************************************************
C**H(L)(A,B.,V)
      NF=1.0+BL*W*FL1
      DF=NF+ALL*W
      FL=NF/DF
C***************************************************************
C**G(L)(A,B.,V)
      NG=1.0+BL1*W*GL1
      DG=NG+ALL*W
      GL=NG/DG
C*************************************************************
      CLL=CLL-1.0
      IF(CLL .GE. .5)  GOTO 760
      QN=FL*(1.0+(BB+1.0)*W*GL)
C************************************************************
C**ORDINARY B.F.
      IF(LIOM .EQ. 2)  GOTO 780
C**ORDINARY B.F.
C**ANALYTIC CONTINUATION TO FIND CORRECT VALUE FOR Y
      PN=I*SGN3*QN
      HN=4.0*W/(PI*(PN*JIN-JIM))
      HM=HN*PN
C*********************************************************
C**Y STORED IN OUTPUT ARRAYS
      YKM=SGN3*I*(JIM-HM)
      YKN=SGN3*I*(JIN-HN)
C********************************************************
C**RETURN FROM SUBROUTINE
      GOTO  2000
C**MODIFIED B.F.
C**Z IN RIGHT-HALF PLANE
  780 IF(ZR .GE. 0.0)  GOTO 790
C**-I(N) WHEN N IS ODD
      SJN1=SGN1*SJN1
C**I(M) WHEN M IS EVEN
      SJM1=SGN2*SJM1
C**Q(N)*I(N)+I(M)=Q(M+1)*I(M+1)+I(M)
  790 KN=2.0*W/(QN*SJN1+SJM1)
C**K(M)=K(N)*Q(N)=K(N-1)
      KM=QN*KN
C*************************************************************
      IF(ZR .GE. 0.0) GO TO 810
C**ANALYTIC CONTINUATION USED TO FIND CORRECT VALUE FOR K
      T1=SGN3*PI
      KN=SGN1*KN+I*T1*SJN1
      KM=SGN2*KM+I*T1*SJM1
C************************************************************
C**RESULTS STORED IN OUTPUT ARRAYS.
  810 YKM=KM
      YKN=KN
C**RETURN FROM SUBROUTINE
      GOTO 2000
C
C     COMPUTE BESSEL FUNCTIONS USING HANKEL ASYMPTOTIC SERIES
C
 1000 SGN1=1.0
      T=-I
      ZETA=.5*THETA
C**RIGHT HALF-PLANE
      IF(ZR .GE. 0.0)  GOTO 1010
C**ROTATE Z TO RIGHT HALF-PLANE.
      SGN1=-1.0
      T=I
C**ROTATE -180 DEGREES FROM QUAD II TO QUAD IV
      ZETA=.5*(THETA-PI)
C**ROTATE 180 DEGREES FROM QUAD III TO QUAD I
      IF(ZI .LT. 0.0) ZETA=.5*(THETA+PI)
C**PUTS Z IN RIGHT HALF-PLANE
 1010 RED=SGN1*ZR
      CMD=SGN1*ZI
C**ORDINARY B.F.
C**+-I/(8*Z)
      IF(LIOM .EQ. 1) W=T*Y*0.125
C**MODIFIED B.B.
C**+-1/(8*Z)
      IF(LIOM .EQ.2) W=SGN1*Y*0.125
      K=2
      TC1=1.0
      TC2=1.0
C**4*M**2
      RFM2=4.0*RM*RM
C**4*N**2
      RFN2=4.0*RN*RN
      SGN=-1.0
      S1=1.0
      S2=1.0
      S3=1.0
      S4=1.0
C**(4*M**2-1)*(-I/(8*Z))
      ZT3=(RFM2-1.0)*W
C**(4*N**2-1)*(I/(8*Z))
      ZT4=(RFN2-1.0)*W
      TMK=-ZT3
      TNK=ZT3
      TVK=-ZT4
      TWK=ZT4
      T5=CABS(ZT4)
 1050 K=K+1
      TC1=TC1+1.0
      TC2=TC2+2.0
      SGN=-SGN
C**M-TH TERM OF SERIES P(M) +- I*Q(M) OR P(M) +- Q(M)
      ZT3=((RFM2-TC2**2)/TC1)*ZT3*W
C**N-TH TERM OF SERIES P(N) +- I*Q(N) OR P(N) +- Q(N)
      S1=S1+TMK
      S2=S2+TNK
      S3=S3+TVK
      S4=S4+TWK
      ZT4=((RFN2-TC2**2)/TC1)*ZT4*W
      TMK=SGN*ZT3
      TNK=ZT3
      TVK=SGN*ZT4
      TWK=ZT4
C**EPSI(2)=1.E-18
      IF(CABS(ZT3) .GE. EPSI(2) .AND. K .LT. 100
     1   .AND. T5 .GE. CABS(ZT4)) GOTO 1050
      IF(CABS(ZT3) .GE. EPSI(2) .AND. K .EQ. 100
     1   .AND. T5 .GE. CABS(ZT4)) STOP 775
      IF(CABS(ZT3) .GE. EPSI(2) .AND. T5 .LT. CABS(ZT4)) GO TO 1080
      S1=S1+TMK
      S2=S2+TNK
      S3=S3+TVK
      S4=S4+TWK
C**SUM THE SERIES TERMS IN REVERSE ORDER
 1080 K=K-1
C**P(M)+I*Q(M) FOR J(M) OR P(M)+Q(M) FOR I(M)
C      S1=S1+TM(K)
C**P(M)-I*Q(M) FOR Y(M) OR P(M)-Q(M) FOR K(M)
C      S2=S2+TN(K)
C**P(N)+I*Q(N) FOR J(N) OR P(N)+Q(N) FOR I(N)
C      S3=S3+TV(K)
C**P(N)-I*Q(N) FOR Y(N) OR P(N)-Q(N) FOR K(N)
C     S4=S4+TW(K)
C      IF(K .NE. 1)  GOTO  1080
      IF(LIOM.EQ.2) GO TO 1200
C********************************************************
C**ORDINARY B.F.
      C1=1.0/SQRT(.5*PI*RHO)
      C2=.25*PI
      C3=.5*PI*RM
      C4=.5*PI*RN
C**EPSI(9)=350.0 IN ORIGINAL PROGRAM, CHANGED TO 85. FOR MINC
      IF(ABS(CMD) .GT. EPSI(9))  GOTO 5040
      C5=C1*EXP(-CMD)
      C6=C1*EXP(CMD)
C**EPSI(8)=1.0E+10
      IF(ABS(RED) .GT. EPSI(8))  GOTO 5050
C**+- ZR - THETA/2 - PI/4 - N*M/2
      ALPH1=RED-ZETA-C2-C3
      ALPH2=RED+ZETA-C2-C3
      ALPH3=RED-ZETA-C2-C4
      ALPH4=RED+ZETA-C2-C4
C**H(N)(1)(Z)
      FM1=C5*CMPLX(COS(ALPH1),SIN(ALPH1))*S1
C**H(N)(2)(Z)
      FM2=C6*CMPLX(COS(ALPH2),-SIN(ALPH2))*S2
C**H(N+1)(1)(Z)
      FN1=C5*CMPLX(COS(ALPH3),SIN(ALPH3))*S3
C**H(N+1)(2)(Z)
      FN2=C6*CMPLX(COS(ALPH4),-SIN(ALPH4))*S4
      IF(ZR .LT. 0.0)  GOTO  1115
C**Z LIES IN RIGHT HALF-PLANE
C**J(M)
      HM1=FM1
C**Y(M)
      HM2=FM2
C**J(N)
      HN1=FN1
C**Y(N)
      HN2=FN2
      GOTO  1140
C**CORRECT HANKEL FUNCTIONS IF Z WAS GIVEN IN THE
C**LEFT HALF-PLANE
C**M EVEN, N ODD
 1115 SGN1=1.0
C**M ODD, N EVEN
      IF(MOD(MORD,2) .NE. 0) SGN1=-1.0
      SGN2=-SGN1
      IF(ZI .LT. 0.0)  GOTO  1130
C**IV --> II
      HM1=SGN2*FM2
      HM2=SGN1*(FM1+2.0*FM2)
      HN1=SGN1*FN2
      HN2=SGN2*(FN1+2.0*FN2)
      GOTO  1140
C**I --> III
 1130 HM1=SGN1*(2.0*FM1+FM2)
      HM2=SGN2*FM1
      HN1=SGN2*(2.0*FN1+FN2)
      HN2=SGN1*FN1
C**OUTPUT ARRAYS FOR ORDINARY B.F.
 1140 JIM=.5*(HM1+HM2)
      JIN=.5*(HN1+HN2)
      YKM=.5*I*(HM2-HM1)
      YKN=.5*I*(HN2-HN1)
C**RETURN
      GOTO  2000
C********************************************************
C**MODIFIED B.F.
 1200 C1=1.0/SQRT(2.0*PI)
      C2=1.0/SQRT(RHO)
      C3=SQRT(.5*PI)
C**EPSI(9)=350.0
      IF(ABS(RED) .GT. EPSI(9))  GOTO 5040
      C4=EXP(-RED)
      C5=C1*C2*EXP(RED)
      C6=C1*C2*C4
      C7=C3*C2*C4
C**EPSI(8)=1.0E+10
      IF(ABS(CMD) .GT. EPSI(8)) GOTO 5050
      ALPH1=CMD-ZETA
      A1=CMPLX(COS(ALPH1),SIN(ALPH1))
      SGN1=1.0
      IF(ZR .LE. 0.0) SGN1=-1.0
      IF(ZI .LE. 0.0) SGN1=-SGN1
      ALPH2=-CMD-ZETA+SGN1*(RM+.5)*PI
      A2=CMPLX(COS(ALPH2),SIN(ALPH2))
      ALPH3=-CMD-ZETA+SGN1*(RN+.5)*PI
      A3=CMPLX(COS(ALPH3),SIN(ALPH3))
      ALPH4=-ZETA-CMD
      A4=CMPLX(COS(ALPH4),SIN(ALPH4))
C**I(M)
      FM1=C5*A1*S1+C6*A2*S2
C**I(N)
      FN1=C5*A1*S3+C6*A3*S4
C**K(M)
      FM2=C7*A4*S2
C**K(N)
      FN2=C7*A4*S4
      IF(ZR .LT. 0.0)  GOTO  1220
C**OUTPUT ARRAYS FOR Z IN RIGHT HALF-PLANE
      JIM=FM1
      JIN=FN1
      YKM=FM2
      YKN=FN2
C**RETURN
      GOTO  2000
C**OUTPUT ARRAYS FOR Z IN LEFT HALF-PLANE
C**M EVEN, N ODD
 1220 SGN1=1.0
C**M ODD, N EVEN
      IF(MOD(MORD,2) .NE. 0) SGN1=-1.0
      SGN2=-SGN1
C**QUAD II
      T=I
C**QUAD III
      IF(ZI .LT. 0.0) T=-I
      JIM=SGN1*FM1
      JIN=SGN2*FN1
      YKM=SGN1*(FM2-T*PI*JIM)
      YKN=SGN2*(FN2-T*PI*JIN)
C**RETURN
      GOTO  2000
C********************************************************
C
C     ERROR PRINT OUTS
C
 5000 JERR=1
      GOTO 5090
 5001 WRITE(7,5002)
 5002 FORMAT(// 49H CAN NOT COMPUTE THE BESSEL FUNCTION IF Z IS ZERO)
      WRITE(7,5003)
 5003 FORMAT(// 47H J 0 EQUAL 1  -  ALL OTHER ORDERS OF J ARE ZERO)
      WRITE(7,5004)
 5004 FORMAT(38H0ALL ORDERS OF Y ARE EQUAL TO INFINITY)
      GO TO 5100
C************************************************************
 5010  JERR=2
      GOTO 5090
 5011 WRITE(7,5012) OPT2
 5012 FORMAT(/ 30H OPT2 IS NOT 1 OR 2     OPT2 =,E12.4)
      GOTO 5100
C**************************************************************
 5020 JERR=3
      GOTO 5090
 5021 WRITE(7,5022) RHO
 5022 FORMAT(// 29H RHO IS OUTSIDE RANGE   RHO =,E12.4)
      GO TO 5100
C*************************************************************
 5030 JERR=4
      GOTO 5090
 5031 WRITE(7,5032)
 5032 FORMAT(// 43H CONSTANT TERM OF FINITE SERIES WILL EXCEED,
     123H NUMBER SIZE OF MACHINE)
      WRITE(7,5033) OM,RN,CMR1,CMI1
 5033 FORMAT(4HOM =,F12.4, 5H  N =,E12.4, 8H  CMR1 =,E12.4,
     1 8H  CMI1 =, E12.4)
      WRITE(7,5034) PHI,CHI
 5034 FORMAT(6H0PHI =,E15.8, 7H  CHI =,E15.8)
      GOTO 5100
C***************************************************************
 5040 JERR=5
      GOTO 5090
 5041 WRITE(7,5042)
 5042 FORMAT(/ 52H ERROR IN ASYMPTOTIC SECTION - ARGUMENT FOR EXP TOO ,
     1 5HLARGE)
      WRITE(7,5043) RED,CMD
 5043 FORMAT(1H0,5HRED =,E15.8,4X,5HCMD =,E15.8)
      GOTO 5100
C*****************************************************************(
 5050 JERR=6
      GOTO 5090
 5051 WRITE(7,5052)
 5052 FORMAT(/ 52H ARGUMENT FOR SIN AND COS IN ASYMPTOTIC SECTION TOO ,
     1 5HLARGE)
      WRITE(7,5053) ZETA
 5053 FORMAT(1H0,6HZETA =,E15.8)
      GOTO 5100
C****************************************************************
 5060 JERR=7
      GOTO 5090
 5061 WRITE(7,5062)
 5062 FORMAT(55H SUBROUTINE CALCULATES INTEGRAL ORDER ONLY- CHECK INPUT)
      GOTO 5100
C**********************************************************************
 5070 JERR=8
      GOTO 5090
 5071 WRITE(7,5072)
 5072 FORMAT(33H OPT1 IS NOT 1 OR 2 - CHECK INPUT)
      GOTO 5100
C********************************************************************
 5090 WRITE(7,5091)
 5091 FORMAT(// 40H RUN ERROR IN BESSEL FUNCTION SUBROUTINE)
      WRITE(7,5777) ' PHI',PHI,' CHI',CHI,' ORD',ORD,'OPT1',OPT1,
     1  'OPT2',OPT2
C 5092 FORMAT(1H0,5HPHI =,F15.8,4X,5HCHI =,F15.8,4X,5HORD =,F6.1,4X,
C     1 6HOPT1 =,F6.1,4X,6HOPT2 =,F6.1)
 5777 FORMAT(1H0,5(A4,' =',E14.7,4X))
      GOTO (5001,5011,5021,5031,5041,5051,5061,5071), JERR
 5100 WRITE(7,5101)
 5101 FORMAT(1H )
C
 2000 LERR=JERR
      GJIM=JIM
      GJIN=JIN
      GYKM=YKM
      GYKN=YKN
      RETURN
      END


! <tridiag_sor_solver.for - A component of the City-scale
!                 Chemistry Transport Model EPISODE-CityChem>
!*****************************************************************************!
!*
!* EPISODE - An urban-scale air quality model
!* ==========================================
!* Copyright (C) 2018  NILU - Norwegian Institute for Air Research
!*                     Instituttveien 18
!*                     PO Box 100
!*                     NO-2027 Kjeller
!*                     Norway
!*
!*                     Contact persons: Gabriela Sousa Santos - gss@nilu.no
!*                                      Paul Hamer - pdh@nilu.no
!*
!* Unless explicitly acquired and licensed from Licensor under another license,
!* the contents of this file are subject to the Reciprocal Public License ("RPL")
!* Version 1.5, https://opensource.org/licenses/RPL-1.5 or subsequent versions as
!* allowed by the RPL, and You may not copy or use this file in either source code
!* or executable form, except in compliance with the terms and conditions of the RPL.
!*
!* All software distributed under the RPL is provided strictly on an "AS IS" basis,
!* WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, AND LICENSOR HEREBY
!* DISCLAIMS ALL SUCH WARRANTIES, INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF
!* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT, OR NON-INFRINGEMENT.
!* See the RPL for specific language governing rights and limitations under the RPL.
!*
!* ==========================================
!* The dispersion model EPISODE (Grønskei et. al., 1993; Larssen et al., 1994;
!* Walker et al., 1992, 1999; Slørdal et al., 2003, 2008) is an Eulerian grid model
!* with embedded subgrid models for calculations of pollutant concentrations resulting
!* from different types of sources (area-, line- and point sources). EPISODE solves the
!* time dependent advection/-diffusion equation on a 3 dimensional grid.
!* Finite difference numerical methods are applied to integrate the solution forward in time.
!* It also includes extensions as the implementation of a simplified EMEP photochemistry
!* scheme for urban areas (Walker et al. 2004) and a scheme for Secondary Organic Aerosol
!* implemented by Håvard Slørdal
!*
!* Grønskei, K.E., Walker, S.E., Gram, F. (1993) Evaluation of a model for hourly spatial
!*    concentrations distributions. Atmos. Environ., 27B, 105-120.
!* Larssen, S., Grønskei, K.E., Gram, F., Hagen, L.O., Walker, S.E. (1994) Verification of
!*    urban scale time-dependent dispersion model with sub-grid elements in Oslo, Norway.
!*    In: Air poll. modelling and its appl. X. New York, Plenum Press.
!* Slørdal, L.H., McInnes, H., Krognes, T. (2008): The Air Quality Information System AirQUIS.
!*    Info. Techn. Environ. Eng., 1, 40-47, 2008.
!* Slørdal, L.H., Walker, S.-E., Solberg, S. (2003) The Urban Air Dispersion Model EPISODE
!*    applied in AirQUIS. Technical Description. NILU TR 12/2003. ISBN 82-425-1522-0.
!* Walker, S.E., Grønskei, K.E. (1992) Spredningsberegninger for on-line overvåking i Grenland.
!*    Programbeskrivelse og brukerveiledning. Lillestrøm,
!*    Norwegian Institute for Air Research (NILU OR 55/92).
!* Walker, S.E., Slørdal, L.H., Guerreiro, C., Gram, F., Grønskei, K.E. (1999) Air pollution
!*    exposure monitoring and estimation. Part II. Model evaluation and population exposure.
!*    J. Environ. Monit, 1, 321-326.
!* Walker, S.-E., Solberg, S., Denby, B. (2003) Development and implementation of a simplified
!*    EMEP photochemistry scheme for urban areas in EPISODE. NILU TR 13/2013.
!*    ISBN 82-425-1524-7
!*
!* ==========================================
!*
!**********************************************************************

      subroutine tridiag_sor_solver

! This routine solves the Poisson-equation, using an iterative SOR-
! solver, where each iteration is applied on a vertical grid coloumn
! which is first solved using the Gaussian tridiagonal algorithm.

! Modifications:
!    29 Jan 2019  M. Karl: replaced real*8 by double precision
!    29 Jan 2019  M. Karl: replaced TAB by spaces
!
!**********************************************************************

! Insert the necessary MODULE calls:

      use module_mc_wind_files
      use module_mc_wind_domain
      use module_mc_wind_adjust

      use module_mc_wind_winds

! We require the use of IMPLICIT NONE:

      implicit none

! Local declarations:

      integer :: i,j,k
      integer :: iter
!	real*8    :: term1,term2
      double precision    :: t1,t2,t3
      double precision    :: relax_par
      double precision    :: tol,rel_tol
      double precision    :: prev,max_iteration_change,max_rel_iteration_change

      logical :: not_reached_tol

      double precision, allocatable :: alf(:)
      double precision, allocatable :: bet(:)
      double precision, allocatable :: gam(:)
      double precision, allocatable :: brh(:)

      double precision, allocatable :: del(:)
      double precision, allocatable :: cek(:)
      double precision, allocatable :: mek(:)
      double precision, allocatable :: lam(:)

      double precision, allocatable :: iteration_change(:,:,:)
      double precision, allocatable :: rel_iteration_change(:,:,:)

! Allocate the required internal memory:

      if (.not. allocated (alf))   allocate (alf(km))
      if (.not. allocated (bet))   allocate (bet(km))
      if (.not. allocated (gam))   allocate (gam(km))
      if (.not. allocated (brh))   allocate (brh(km))

      if (.not. allocated (del))   allocate (del(km))
      if (.not. allocated (cek))   allocate (cek(km))
      if (.not. allocated (mek))   allocate (mek(km))
      if (.not. allocated (lam))   allocate (lam(km))

      if (.not. allocated (iteration_change)) &
    allocate (iteration_change(im,jm,km))
      if (.not. allocated (rel_iteration_change)) &
    allocate (rel_iteration_change(im,jm,km))

! Content of the routine:

! Applied "constants" in the iteration procedure:

        t1 = 1.0/(dx*dx)
        t2 = 1.0/(dy*dy)
        t3 = 2.0*(t1 + t2)

! Heading for the iteration information written to the log-file:

      if (fe_log) then
        write(funit_log,*)
        write(funit_log,*)
        write(funit_log,*) ' Iteration information for the adjustment:'
        write(funit_log,*)
        write(funit_log,'(1X,A16,3A4,A16,3A4)') &
         ' MAX ABS CHANGE ','  I ','  J ','  K ', &
         ' MAX REL CHANGE ','  I ','  J ','  K '
      end if

! During the first "lim_iter" iterations the values of:
!     the relaxation-parameter,     "relax_par",
!     the absolute error tolerance, "tol"
! and the relative error tolerance, "rel_tol"
! are applied as specified in the user-input list:

      relax_par = rel_par
      tol       = tolerance
      rel_tol   = rel_tolerance
      not_reached_tol = .TRUE.

! ======================================================================
! Start iteration procedure:

      do iter = 1,max_iter

! Go through all of the internal horizontal grid points (1:im,1:jm).

        do j = 1,jm
          do i = 1,im

! Calculate all the needed coefficients for this (i,j) grid point.
          k = 1

!         --------------------------------------------------------------
!         Version 1:
!
!          alf(k) = (ck(k) + bk(k))*f4(i,j,k)
!     &           + (pk(k) - qk(k))*f1(i,j,k)
!     &           -  t3
!
!          gam(k) =  ak(k)*f4(i,j,k)
!     &           +  rk(k)*f1(i,j,k)
!
!          brh(k) =  g_rhs(i,j,k)
!     &           - (t2 - (bk(k) + ck(k))*f3(i,j,k))*lambda(i,j-1,k)
!     &           - (t1 - (bk(k) + ck(k))*f2(i,j,k))*lambda(i-1,j,k)
!     &           - (t1 + (bk(k) + ck(k))*f2(i,j,k))*lambda(i+1,j,k)
!     &           - (t2 + (bk(k) + ck(k))*f3(i,j,k))*lambda(i,j+1,k)
!     &           +  ak(k)*f3(i,j,k)*lambda(i,j-1,k+1)
!     &           +  ak(k)*f2(i,j,k)*lambda(i-1,j,k+1)
!     &           -  ak(k)*f2(i,j,k)*lambda(i+1,j,k+1)
!     &           -  ak(k)*f3(i,j,k)*lambda(i,j+1,k+1)
!
!
!         --------------------------------------------------------------
!         Version 2:

            alf(k) =  h3(i,j,k) + h8(i,j,k)

            gam(k) =  h13(i,j,k)

            brh(k) =  g_rhs(i,j,k) &
              - (h1(i,j,k) + h6(i,j,k))  * lambda(i,j-1,k) &
              - (h2(i,j,k) + h7(i,j,k))  * lambda(i-1,j,k) &
              - (h4(i,j,k) + h9(i,j,k))  * lambda(i+1,j,k) &
              - (h5(i,j,k) + h10(i,j,k)) * lambda(i,j+1,k) &
              -  h11(i,j,k) * lambda(i,j-1,k+1) &
              -  h12(i,j,k) * lambda(i-1,j,k+1) &
              -  h14(i,j,k) * lambda(i+1,j,k+1) &
              -  h15(i,j,k) * lambda(i,j+1,k+1)

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

! Start Test of specific values:

          if ( ABS(alf(k)) <= ABS(gam(k)) ) then
            write(funit_log,*)  &
        'Not strictly diagonal-dominant in row ',k
            STOP
          end if
!           if ( iter == 1 .AND. i == 20 .AND. j == 16 .AND. k==1) then
!             write(funit_log,*) 'alf(20,16,1) = ',alf(k)
!             write(funit_log,*) 'gam(20,16,1) = ',gam(k)
!             write(funit_log,*) 'brh(20,16,1) = ',brh(k)
!           end if
! End Test of specific values.

          do k = 2,km-1

!         --------------------------------------------------------------
!         Version 1:
!            bet(k) =  ck(k)*f4(i,j,k)
!     &             +  pk(k)*f1(i,j,k)
!
!            alf(k) =  bk(k)*f4(i,j,k)
!     &             -  qk(k)*f1(i,j,k)
!     &             -  t3
!
!            gam(k) =  ak(k)*f4(i,j,k)
!     &             +  rk(k)*f1(i,j,k)
!
!            brh(k) =  g_rhs(i,j,k)
!     &             +  ck(k)*f3(i,j,k)*lambda(i,j-1,k-1)
!     &             +  ck(k)*f2(i,j,k)*lambda(i-1,j,k-1)
!     &             -  ck(k)*f2(i,j,k)*lambda(i+1,j,k-1)
!     &             -  ck(k)*f3(i,j,k)*lambda(i,j+1,k-1)
!     &             - (t2 - bk(k)*f3(i,j,k))*lambda(i,j-1,k)
!     &             - (t1 - bk(k)*f2(i,j,k))*lambda(i-1,j,k)
!     &             - (t1 + bk(k)*f2(i,j,k))*lambda(i+1,j,k)
!     &             - (t2 + bk(k)*f3(i,j,k))*lambda(i,j+1,k)
!     &             +  ak(k)*f3(i,j,k)*lambda(i,j-1,k+1)
!     &             +  ak(k)*f2(i,j,k)*lambda(i-1,j,k+1)
!     &             -  ak(k)*f2(i,j,k)*lambda(i+1,j,k+1)
!     &             -  ak(k)*f3(i,j,k)*lambda(i,j+1,k+1)
!
!
!         --------------------------------------------------------------
!         Version 2:

            bet(k) =  h3(i,j,k)

            alf(k) =  h8(i,j,k)

            gam(k) =  h13(i,j,k)

            brh(k) =  g_rhs(i,j,k) &
               - h1(i,j,k)  * lambda(i,j-1,k-1) &
               - h2(i,j,k)  * lambda(i-1,j,k-1) &
               - h4(i,j,k)  * lambda(i+1,j,k-1) &
               - h5(i,j,k)  * lambda(i,j+1,k-1) &
               - h6(i,j,k)  * lambda(i,j-1,k) &
               - h7(i,j,k)  * lambda(i-1,j,k) &
               - h9(i,j,k)  * lambda(i+1,j,k) &
               - h10(i,j,k) * lambda(i,j+1,k) &
               - h11(i,j,k) * lambda(i,j-1,k+1) &
               - h12(i,j,k) * lambda(i-1,j,k+1) &
               - h14(i,j,k) * lambda(i+1,j,k+1) &
               - h15(i,j,k) * lambda(i,j+1,k+1)

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

            if( ABS(alf(k)) <= (ABS(bet(k)) + ABS(gam(k))) )then
              write(funit_log,*)  &
          'Not strictly diagonal-dominant in row ',k
              STOP
            end if

! Start Test of specific values:
!           if ( iter == 1 .AND. i == 20 .AND. j == 16 .AND. k==2) then
!             write(funit_log,*) 'bet(20,16,2) = ',bet(k)
!             write(funit_log,*) 'alf(20,16,2) = ',alf(k)
!             write(funit_log,*) 'gam(20,16,2) = ',gam(k)
!             write(funit_log,*) 'brh(20,16,2) = ',brh(k)
!           end if
! End Test of specific values.

          end do

          k = km

!         --------------------------------------------------------------
!         Version 1:
!
!          bet(k) =  ck(k)*f4(i,j,k)
!     &           +  pk(k)*f1(i,j,k)
!
!          alf(k) = (ak(k) + bk(k))*f4(i,j,k)
!     &           + (rk(k) - qk(k))*f1(i,j,k)
!     &           -  t3
!
!          brh(k) =  g_rhs(i,j,k)
!     &           +  ck(k)*f3(i,j,k)*lambda(i,j-1,k-1)
!     &           +  ck(k)*f2(i,j,k)*lambda(i-1,j,k-1)
!     &           -  ck(k)*f2(i,j,k)*lambda(i+1,j,k-1)
!     &           -  ck(k)*f3(i,j,k)*lambda(i,j+1,k-1)
!     &           - (t2 - (bk(k) + ak(k))*f3(i,j,k))*lambda(i,j-1,k)
!     &           - (t1 - (bk(k) + ak(k))*f2(i,j,k))*lambda(i-1,j,k)
!     &           - (t1 + (bk(k) + ak(k))*f2(i,j,k))*lambda(i+1,j,k)
!     &           - (t2 + (bk(k) + ak(k))*f3(i,j,k))*lambda(i,j+1,k)
!
!         --------------------------------------------------------------
!         Version 2:

            bet(k) =  h3(i,j,k)

            alf(k) =  h8(i,j,k) + h13(i,j,k)

            brh(k) =  g_rhs(i,j,k) &
              -  h1(i,j,k)  * lambda(i,j-1,k-1) &
              -  h2(i,j,k)  * lambda(i-1,j,k-1) &
              -  h4(i,j,k)  * lambda(i+1,j,k-1) &
              -  h5(i,j,k)  * lambda(i,j+1,k-1) &
              - (h6(i,j,k)  + h11(i,j,k))  * lambda(i,j-1,k) &
              - (h7(i,j,k)  + h12(i,j,k))  * lambda(i-1,j,k) &
              - (h9(i,j,k)  + h14(i,j,k))  * lambda(i+1,j,k) &
              - (h10(i,j,k) + h15(i,j,k))  * lambda(i,j+1,k)

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

            if( ABS(alf(k)) <= ABS(bet(k)) )then
              write(funit_log,*)  &
          'Not strictly diagonal-dominant in row ',k
              STOP
            end if

! Start Test of specific values:
!           if ( iter == 1 .AND. i == 20 .AND. j == 16 .AND. k==km) then
!             write(funit_log,*) 'bet(20,16,km) = ',bet(k)
!             write(funit_log,*) 'alf(20,16,km) = ',alf(k)
!             write(funit_log,*) 'brh(20,16,km) = ',brh(k)
!           end if
! End Test of specific values.

! Now all the coefficients of the TRIDIAGONAL system for the vertical
! coloumn at the grid point (i,j) have been calculated.
! Below a simple tridiagonal solver is implemented. This solver
! assumes that the system is stricktly diagonal dominant.

! Start TRIDIAGONAL SOLVER:

            del(1) = alf(1)
            cek(1) = brh(1)

            do k = 2,km
              mek(k) = bet(k)/del(k-1)
              del(k) = alf(k) - mek(k)*gam(k-1)
              cek(k) = brh(k) - mek(k)*cek(k-1)
            end do

            lam(km) = cek(km)/del(km)
            do k = km-1,1,-1
              lam(k) = (cek(k) - gam(k)*lam(k+1))/del(k)
            end do

! End TRIDIAGONAL SOLVER.

! We have now calculated the new values of lambda(i,j,k) for the
! vertical coloumn (i,j), and these are stored in lam(1:km)

! Start SOR algorithm:

            do k = 1,km
              prev = lambda(i,j,k)
              lambda(i,j,k) = prev + relax_par*(lam(k) - prev)
              iteration_change(i,j,k) = ABS(lambda(i,j,k) - prev)

              if (iteration_change(i,j,k) == 0.0) then
                rel_iteration_change(i,j,k) = 0.0
              else
                if (lambda(i,j,k) == 0.0 ) then
                  rel_iteration_change(i,j,k) =  &
                     iteration_change(i,j,k) / ABS(prev)
                else
                  rel_iteration_change(i,j,k) =  &
                     iteration_change(i,j,k) / ABS(lambda(i,j,k))
                end if
              end if

            end do
! End SOR algorithm.

          end do   ! do i = 1,im
        end do   ! do j = 1,jm

        max_iteration_change     = MAXVAL(iteration_change)
        max_rel_iteration_change = MAXVAL(rel_iteration_change)

! **********************************************************************
!       For test of divergence Calculate the adjusted wind field:
!
!        call calculate_adjusted_wfield
!
!     LHS_TEST_START:
!	bcg = 0.0
!
!      do j = 1,jm
!        do i = 1,im
!          term1 = u(i,j,1) + u(i-1,j,1) - u0(i,j,1) - u0(i-1,j,1)
!		term1 = term1*(depth(i+1,j)-depth(i-1,j))/dx
!          term2 = v(i,j,1) + v(i,j-1,1) - v0(i,j,1) - v0(i,j-1,1)
!		term2 = term2*(depth(i,j+1)-depth(i,j-1))/dy
!          bcg(i,j) = (delta_sigmal(1)*depth(i,j))/(4.0*h0*alfa*alfa)
!          bcg(i,j) = bcg(i,j)*(term1 + term2)
! TEST:         bcg(i,j) = 0.0
!
!          lambda(i,j,km+1) = lambda(i,j,km)
!          lambda(i,j,0)    = lambda(i,j,1) + bcg(i,j)
!
!        end do
!      end do
!
!      do j = 1,jm
!        do i = 1,im
!          g_rhs(i,j,1) = g_rhs(i,j,1)
!     &       + (ck(1)*f3(i,j,1)*bcg(i,j-1))
!     &       + (ck(1)*f2(i,j,1)*bcg(i-1,j))
!     &       - ((pk(1)*f1(i,j,1)+ck(1)*f4(i,j,1))*bcg(i,j))
!     &       - (ck(1)*f2(i,j,1)*bcg(i+1,j))
!     &       - (ck(1)*f3(i,j,1)*bcg(i,j+1))
!        end do
!      end do
!
!        fe_log =.TRUE.
!        if (fe_log) then
!
!       Write time-series for the surface stations:
!
!        if(iter == 1)then
!           Write heading for the time-series file:
!           write(funit_log,'(7X,A12,4(A16,3A4))')
!     &        'Alfa value',
!     &        'Max In. 3Ddiv','I','J','K',
!     &        'Max Fi. 3Ddiv','I','J','K',
!     &        'Min In. 3Ddiv','I','J','K',
!     &        'Min Fi. 3Ddiv','I','J','K'
!        end if
!        write(funit_log,'(1X,I6,F12.5,4(F16.9,3I4))')
!     &      iter,alfa,MAXVAL(div0_3D),MAXLOC(div0_3D),
!     &                MAXVAL(div_3D), MAXLOC(div_3D),
!     &                MINVAL(div0_3D),MINLOC(div0_3D),
!     &                MINVAL(div_3D), MINLOC(div_3D)
!       end if ! (fe_log)
!        fe_log =.FALSE.
!     LHS_TEST_END.
! **********************************************************************
        if (fe_log) then
          write(funit_log,'(F16.7,3I4,F16.7,3I4)') &
         max_iteration_change,MAXLOC(iteration_change), &
         max_rel_iteration_change,MAXLOC(rel_iteration_change)
        end if

        if (max_iteration_change < tol) then

          if(max_rel_iteration_change < rel_tol) then

            not_reached_tol = .FALSE.
! LHS_TEST_START:
!            fe_log =.TRUE.
! LHS_TEST_END.
            if (fe_log) then
              write(funit_log,*)
              write(funit_log,'(1X,A,F8.5,A,I4)')  &
         'The relative tolerance limit ',rel_tol, &
         ' obtained after iteration:',iter
              write(funit_log,'(1X,A,F8.5,A)')  &
         'The absolute tolerance limit',tol,' is obtained as well.'
              write(funit_log,'(1X,A,F8.5)')  &
         'The maximum relative iteration change = ', &
          max_rel_iteration_change
              write(funit_log,'(1X,A,F8.5)')  &
         'The maximum absolute iteration change = ', &
          max_iteration_change
            end if

! The wanted absolute and relative minimum change in the lambda values
! have been reached, and the iteration loop ("do iter = 1,max_iter")
! can be ended by the following EXIT statement:

            EXIT    ! "do iter = 1,max_iter"

          end if  ! "if(max_rel_iteration_change < rel_tol) then"

        end if  ! "if (max_iteration_change < tolerance)"

! After "lim_iter" iterations we can change the values of:
!      the relaxation-parameter,     "relax_par",
!      the absolute error tolerance, "tol"
!  and the relative error tolerance, "rel_tol":

        if (iter == (lim_iter+1) ) then
          relax_par = lim_rel_par
          tol       = lim_tolerance
          rel_tol   = lim_rel_tolerance
        end if

      end do  ! do iter = 1,max_iter

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

! If the wanted absolute and relative tolerance are not reached,
! appropriate messages are written to the log-file:

      if(not_reached_tol)then

        if (fe_log) then
          n_tol_not_reached = n_tol_not_reached + 1
          write(funit_log,*)
          write(funit_log,'(A,F8.6,A,F10.5)') &
        ' Tolerance not achieved. Tolerance = ',tolerance, &
        ' ALFA = ',alfa
          write(funit_log,'(A,F8.6)') &
        ' Max_rel_iteration_change = ',max_rel_iteration_change
          write(funit_log,'(A,F8.6)') &
        ' Max_iteration_change = ',max_iteration_change
          write(funit_log,*)
        end if

       end if  ! (not_reached_tol)

! =====================================================================
! Since each of the horizontal wind components depend on six neigh-
! boring lamda-values, we need lamda values both for k=0 and k=km+1.
! With the applied zero-gradient boundary condition these values are:
!
!
! Since this depend on the actual boundary condition it should
! preferably be done in a separate routine: "call vert_bc_lambda"??

      do j = 0,jm+1
        do i = 0,im+1
          lambda(i,j,0) = lambda(i,j,1)
          lambda(i,j,km+1) = lambda(i,j,km)
        end do
      end do
! =====================================================================

! Deallocate internal memory:

      if (allocated (alf)) deallocate (alf)
      if (allocated (bet)) deallocate (bet)
      if (allocated (gam)) deallocate (gam)
      if (allocated (brh)) deallocate (brh)

      if (allocated (del)) deallocate (del)
      if (allocated (cek)) deallocate (cek)
      if (allocated (mek)) deallocate (mek)
      if (allocated (lam)) deallocate (lam)

      if (allocated (iteration_change)) deallocate (iteration_change)
      if (allocated (rel_iteration_change))  &
                               deallocate (rel_iteration_change)

      return
      end subroutine tridiag_sor_solver


!
!  Copyright 2016 ARTED developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
!This file is "CG.f90"
!This file contain a subroutine.
!Subroutine CG
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120--------130
Subroutine CG_omp(iter_cg_max)
  use Global_Variables
  use timelog
  implicit none
  real(8),parameter :: delta_cg=1.d-15
  integer iter,ik,ib,ibt
  integer :: iter_cg_max
  real(8) :: xkHxk,gkgk,pkHpk,xkTxk
  real(8) :: uk,s,ev
!  complex(8) :: xk(NL),hxk(NL),gk(NL),pk(NL),pko(NL),txk(NL)
  complex(8) :: cx,cp,xkHpk
  real(8) :: esp_var_l(1:NB,1:NK)
  complex(8) :: zs
! sato
  integer :: ia,j,i,ix,iy,iz
  real(8) :: kr
! omp
  integer :: thr_id,omp_get_thread_num
  thr_id=0

  call timelog_begin(LOG_CG)
  esp_var_l(:,:)=0.d0
!$omp parallel private(thr_id)
!$  thr_id=omp_get_thread_num()
!$omp do private(ia,j,i,ix,iy,iz,kr,ib,ibt,s,xkHxk,xkTxk,iter,uk,gkgk,xkHpk,pkHpk,ev,cx,cp,zs)
  do ik=NK_s,NK_e
! sato -----------------------------------------------------------------------------------------
!    k2=sum(kAc(ik,:)**2)
!Constructing nonlocal part
  do ia=1,NI
  do j=1,Mps(ia)
    i=Jxyz(j,ia); ix=Jxx(j,ia); iy=Jyy(j,ia); iz=Jzz(j,ia)
    kr=kAc(ik,1)*(Lx(i)*Hx-ix*aLx)+kAc(ik,2)*(Ly(i)*Hy-iy*aLy)+kAc(ik,3)*(Lz(i)*Hz-iz*aLz)
    ekr_omp(j,ia,ik)=exp(zI*kr)
  enddo
  enddo
! sato -----------------------------------------------------------------------------------------
  do ib=1,NB
    do ibt=1,ib-1
      s=sum(conjg(zu_GS(:,ibt,ik))*zu_GS(:,ib,ik))*Hxyz
      zu_GS(1:NL,ib,ik)=zu_GS(1:NL,ib,ik)-zu_GS(1:NL,ibt,ik)*s
    end do
    s=1.0d0/sqrt(sum(abs(zu_GS(:,ib,ik))**2)*Hxyz)
    xk_omp(1:NL,thr_id)=zu_GS(1:NL,ib,ik)*s
    call hpsi_omp_KB(ik,xk_omp(:,thr_id),txk_omp(:,thr_id),hxk_omp(:,thr_id))
    xkHxk=sum(conjg(xk_omp(:,thr_id))*hxk_omp(:,thr_id))*Hxyz
    xkTxk=sum(conjg(xk_omp(:,thr_id))*txk_omp(:,thr_id))*Hxyz

    do iter=1,iter_cg_max
      gk_omp(1:NL,thr_id)=(hxk_omp(1:NL,thr_id)-xkHxk*xk_omp(1:NL,thr_id))
      do ibt=1,ib-1
        zs=sum(conjg(zu_GS(:,ibt,ik))*gk_omp(:,thr_id))*Hxyz
        gk_omp(1:NL,thr_id)=gk_omp(1:NL,thr_id)-zu_GS(1:NL,ibt,ik)*zs
      end do
      s=sum(abs(gk_omp(:,thr_id))**2)*Hxyz

      select case (iter)
      case(1)
        pk_omp(1:NL,thr_id)=gk_omp(1:NL,thr_id)
      case default
        uk=s/gkgk
        pk_omp(1:NL,thr_id)=gk_omp(1:NL,thr_id)+uk*pk_omp(1:NL,thr_id)
      end select
      gkgk=s

      zs=sum(conjg(xk_omp(:,thr_id))*pk_omp(:,thr_id))*Hxyz
      pko_omp(1:NL,thr_id)=pk_omp(1:NL,thr_id)-xk_omp(1:NL,thr_id)*zs
      s=1.0d0/sqrt(sum(abs(pko_omp(:,thr_id))**2)*Hxyz)
      pko_omp(1:NL,thr_id)=pko_omp(1:NL,thr_id)*s
      call hpsi_omp_KB(ik,pko_omp(:,thr_id),ttpsi_omp(:,thr_id),htpsi_omp(:,thr_id))
      xkHpk=sum(conjg( xk_omp(:,thr_id))*htpsi_omp(:,thr_id))*Hxyz
      pkHpk=sum(conjg(pko_omp(:,thr_id))*htpsi_omp(:,thr_id))*Hxyz
      ev=0.5d0*((xkHxk+pkHpk)-sqrt((xkHxk-pkHpk)**2+4*abs(xkHpk)**2))
      cx=xkHpk/(ev-xkHxk)
      cp=1.d0/sqrt(1.d0+abs(cx)**2)
      cx=cx*cp
      if(abs(ev-xkHxk)<delta_cg) exit
       xk_omp(1:NL,thr_id)=cx* xk_omp(1:NL,thr_id)+cp*  pko_omp(1:NL,thr_id)
      hxk_omp(1:NL,thr_id)=cx*hxk_omp(1:NL,thr_id)+cp*htpsi_omp(1:NL,thr_id)
      txk_omp(1:NL,thr_id)=cx*txk_omp(1:NL,thr_id)+cp*ttpsi_omp(1:NL,thr_id)
      xkHxk=sum(conjg(xk_omp(:,thr_id))*hxk_omp(:,thr_id))*Hxyz
      xkTxk=sum(conjg(xk_omp(:,thr_id))*txk_omp(:,thr_id))*Hxyz
    enddo

    s=1.0d0/sqrt(sum(abs(xk_omp(:,thr_id))**2)*Hxyz)
    zu_GS(1:NL,ib,ik)=xk_omp(1:NL,thr_id)*s
    call hpsi_omp_KB(ik,zu_GS(:,ib,ik),ttpsi_omp(:,thr_id),htpsi_omp(:,thr_id))
    xkHxk=sum(conjg(zu_GS(1:NL,ib,ik))*htpsi_omp(:,thr_id))*Hxyz
    esp_var_l(ib,ik)=sqrt(sum(abs(htpsi_omp(:,thr_id)-xkHxk*zu_GS(1:NL,ib,ik))**2)*Hxyz)*occ(ib,ik)
  enddo
  enddo

!$omp end parallel

  call timelog_begin(LOG_ALLREDUCE)
  call MPI_ALLREDUCE(esp_var_l,esp_var,NB*NK,MPI_REAL8,MPI_SUM,NEW_COMM_WORLD,ierr)
  call timelog_end(LOG_ALLREDUCE)

  call timelog_end(LOG_CG)

  return
End Subroutine CG_OMP
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120--------130