module NCA_DIAG
  USE NCA_VARS_GLOBAL
  USE NCA_SETUP
  !
  USE SF_CONSTANTS,only: one,xi,zero,pi
  USE SF_TIMER,    only: start_timer,stop_timer
  USE SF_IOTOOLS,  only: str
  USE SF_LINALG,   only: eigh
  USE SF_MISC,     only: assert_shape
  !
  implicit none
  private

  public :: nca_diagonalize_hlocal

contains

  !+-------------------------------------------------------------------+
  !                    FULL DIAGONALIZATION
  !+-------------------------------------------------------------------+
  !PURPOSE  : Setup the Hilbert space, create the Hamiltonian, get the
  ! GS, build the Green's functions calling all the necessary routines
  !+-------------------------------------------------------------------+
  subroutine nca_diagonalize_hlocal
    integer                            :: i,j,isector,dim,unit,stride
    real(8),dimension(Nsectors)        :: e0
    real(8)                            :: egs,zeta_function_diag
    real(8),dimension(:,:),allocatable :: Hmat
    real(8),dimension(:),allocatable   :: Eval
    !
    e0=0d0
    !
    write(LOGfile,"(A)")"Diagonalizing Hamiltonian:"
    call start_timer
    stride=0
    EigBasis=0d0
    EigValues=0d0
    do isector=1,Nsectors
       dim=getdim(isector)
       !
       allocate(Hmat(dim,dim));Hmat=0d0
       allocate(Eval(dim));Eval=0d0
       !
       call build_hlocal(isector,Hmat)
       call eigh(Hmat,Eval)
       !
       e0(isector)=minval(Eval)
       !
       write(LOGfile,"(A,F15.8)")"Solving sector: "//&
            ", nup:"//str(getnup(isector))//", ndw:"//str(getndw(isector))//&
            ", dim="//str(getdim(isector))//", Egs=",e0(isector)
       !
       EigBasis(stride+1:stride+dim,stride+1:stride+dim) = Hmat(:,:)
       EigValues(stride+1:stride+dim)                    = Eval
       !
       stride=stride+dim
       !
       deallocate(Hmat,Eval)
    enddo
    call stop_timer
    !
    !Get the partition function Z and rescale energies
    Egs=minval(e0)
    EigValues = EigValues - Egs
    zeta_function_diag=sum(exp(-beta*EigValues(:)))
    !
    write(LOGfile,"(A)")"DIAG summary:"
    write(LOGfile,"(A,f20.12)")'Egs  =',Egs
    write(LOGfile,"(A,f20.12)")'Z    =',zeta_function_diag
  end subroutine nca_diagonalize_hlocal

  !+------------------------------------------------------------------+
  !PURPOSE  : Build Hamiltonian sparse matrix DOUBLE PRECISION
  !+------------------------------------------------------------------+
  subroutine build_hlocal(isector,Hmat)
    real(8),dimension(:,:)           :: Hmat
    integer                          :: isector
    integer,dimension(Nlevels)       :: ib
    integer                          :: dim
    integer                          :: i,j,m,iorb,jorb,ispin
    integer                          :: k1,k2,k3,k4
    real(8)                          :: sg1,sg2,sg3,sg4
    real(8),dimension(Norb)          :: nup,ndw
    real(8)                          :: htmp
    logical                          :: Jcondition
    type(sector_map)                 :: H
    !
    dim=getdim(isector)
    !
    call build_sector(isector,H)
    !
    call assert_shape(Hmat,[Dim,Dim],"Build_Hlocal","Hmat")
    !
    Hmat = 0d0
    !
    !-----------------------------------------------!
    states: do i=1,Dim
       m = H%map(i)
       ib = bdecomp(m,2*Ns)
       !
       do iorb=1,Norb
          nup(iorb)=dble(ib(iorb))
          ndw(iorb)=dble(ib(iorb+Ns))
       enddo
       !
       htmp=0.d0
       !
       !LOCAL HAMILTONIAN PART:
       !local energies
       htmp = htmp - xmu*(sum(nup)+sum(ndw))
       !
       do iorb=1,Norb
          htmp = htmp + dreal(impHloc(1,1,iorb,iorb))*nup(iorb)
          htmp = htmp + dreal(impHloc(Nspin,Nspin,iorb,iorb))*ndw(iorb)
       enddo
       !
       Hmat(i,i)=Hmat(i,i)+htmp
       !
       !
       !Density-density interaction: same orbital, opposite spins
       !Euloc=\sum=i U_i*(n_u*n_d)_i
       htmp = zero
       do iorb=1,Norb
          htmp = htmp + Uloc(iorb)*nup(iorb)*ndw(iorb)
       enddo
       !
       if(Norb>1)then
          !density-density interaction: different orbitals, opposite spins:
          ! =   U'   *     sum_{i/=j} [ n_{i,up}*n_{j,dw} + n_{j,up}*n_{i,dw} ]
          ! =  (Uloc-2*Jh)*sum_{i/=j} [ n_{i,up}*n_{j,dw} + n_{j,up}*n_{i,dw} ]
          do iorb=1,Norb
             do jorb=iorb+1,Norb
                htmp = htmp + Ust*(nup(iorb)*ndw(jorb) + nup(jorb)*ndw(iorb))
             enddo
          enddo
          !density-density interaction: different orbitals, parallel spins
          ! = \sum_{i<j}    U''     *[ n_{i,up}*n_{j,up} + n_{i,dw}*n_{j,dw} ]
          ! = \sum_{i<j} (Uloc-3*Jh)*[ n_{i,up}*n_{j,up} + n_{i,dw}*n_{j,dw} ]
          do iorb=1,Norb
             do jorb=iorb+1,Norb
                htmp = htmp + (Ust-Jh)*(nup(iorb)*nup(jorb) + ndw(iorb)*ndw(jorb))
             enddo
          enddo
       endif
       !if using the Hartree-shifted chemical potential: mu=0 for half-filling
       !sum up the contributions of hartree terms:
       if(hfmode)then
          do iorb=1,Norb
             htmp = htmp - 0.5d0*Uloc(iorb)*(nup(iorb)+ndw(iorb)) + 0.25d0*uloc(iorb)
          enddo
          if(Norb>1)then
             do iorb=1,Norb
                do jorb=iorb+1,Norb
                   htmp=htmp-0.5d0*Ust*(nup(iorb)+ndw(iorb)+nup(jorb)+ndw(jorb))+0.25d0*Ust
                   htmp=htmp-0.5d0*(Ust-Jh)*(nup(iorb)+ndw(iorb)+nup(jorb)+ndw(jorb))+0.25d0*(Ust-Jh)
                enddo
             enddo
          endif
       endif
       !
       Hmat(i,i)=Hmat(i,i)+htmp
       !
       !
       !
       !SPIN-EXCHANGE (S-E) and PAIR-HOPPING TERMS
       !S-E: J c^+_iorb_up c^+_jorb_dw c_iorb_dw c_jorb_up  (i.ne.j)
       !S-E: J c^+_{iorb} c^+_{jorb+Ns} c_{iorb+Ns} c_{jorb}
       if(Norb>1.AND.Jhflag)then
          do iorb=1,Norb
             do jorb=1,Norb
                Jcondition=(&
                     (iorb/=jorb).AND.&
                     (ib(jorb)==1).AND.&
                     (ib(iorb+Ns)==1).AND.&
                     (ib(jorb+Ns)==0).AND.&
                     (ib(iorb)==0))
                if(Jcondition)then
                   call c(jorb,m,k1,sg1)
                   call c(iorb+Ns,k1,k2,sg2)
                   call cdg(jorb+Ns,k2,k3,sg3)
                   call cdg(iorb,k3,k4,sg4)
                   j=binary_search(H%map,k4)
                   htmp = Jx*sg1*sg2*sg3*sg4
                   !
                   if(j/=0)Hmat(i,j)=Hmat(i,j)+htmp
                   !
                endif
             enddo
          enddo
       endif
       !
       !PAIR-HOPPING (P-H) TERMS
       !P-H: J c^+_iorb_up c^+_iorb_dw   c_jorb_dw   c_jorb_up  (i.ne.j)
       !P-H: J c^+_{iorb}  c^+_{iorb+Ns} c_{jorb+Ns} c_{jorb}
       if(Norb>1.AND.Jhflag)then
          do iorb=1,Norb
             do jorb=1,Norb
                Jcondition=(&
                     (iorb/=jorb).AND.&
                     (ib(jorb)==1).AND.&
                     (ib(jorb+Ns)==1).AND.&
                     (ib(iorb+Ns)==0).AND.&
                     (ib(iorb)==0))
                if(Jcondition)then
                   call c(jorb,m,k1,sg1)
                   call c(jorb+Ns,k1,k2,sg2)
                   call cdg(iorb+Ns,k2,k3,sg3)
                   call cdg(iorb,k3,k4,sg4)
                   j=binary_search(H%map,k4)
                   htmp = Jp*sg1*sg2*sg3*sg4
                   !
                   if(j/=0)Hmat(i,j)=Hmat(i,j)+htmp
                   !
                endif
             enddo
          enddo
       endif
       !
       !
       !
       !IMPURITY LOCAL HYBRIDIZATION
       !Off-diagonal elements, i.e. non-local part
       !same spin:
       do iorb=1,Norb
          do jorb=1,Norb
             !this loop considers only the orbital off-diagonal terms
             !because iorb=jorb can not have simultaneously
             !occupation 0 and 1, as required by this if Jcondition:
             !UP
             Jcondition = &
                  (impHloc(1,1,iorb,jorb)/=zero) .AND. &
                  (ib(jorb)==1)                  .AND. &
                  (ib(iorb)==0)
             if (Jcondition) then
                call c(jorb,m,k1,sg1)
                call cdg(iorb,k1,k2,sg2)
                j = binary_search(H%map,k2)
                htmp = impHloc(1,1,iorb,jorb)*sg1*sg2
                !
                Hmat(i,j) = Hmat(i,j) + htmp
                !
             endif
             !DW
             Jcondition = &
                  (impHloc(Nspin,Nspin,iorb,jorb)/=zero) .AND. &
                  (ib(jorb+Ns)==1)                       .AND. &
                  (ib(iorb+Ns)==0)
             if (Jcondition) then
                call c(jorb+Ns,m,k1,sg1)
                call cdg(iorb+Ns,k1,k2,sg2)
                j = binary_search(H%map,k2)
                htmp = impHloc(Nspin,Nspin,iorb,jorb)*sg1*sg2
                !
                Hmat(i,j) = Hmat(i,j) + htmp
                !
             endif
          enddo
       enddo
       !
    enddo states
    !-----------------------------------------------!
    !
    call delete_sector(isector,H)
    !
  end subroutine build_hlocal

end MODULE NCA_DIAG


      subroutine runF_iii(i1,i2,i3,m0sq,Gr,Czero3,N0)
C---  Expression for rearrangement of extension of Eq. 5.69
C---  Calculates Diii, requires D00iii
C---  Small terms of order Gr(i,j)*Dijklm
C---  Denominator m0sq
      implicit none
      include 'TRconstants.f'
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      include 'pvweenumber.f'
      integer ep,N0,i1,i2,i3,m,n,np
      parameter(np=3)
      double precision m0sq,Gr(np,np)
      double complex Czero3(z3max,-2:0),bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gr(n,m)*Dv(diiiii(z5(n,m,i1,i2,i3))+N0,ep)
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=4d0*Dv(dzziii(z3(i1,i2,i3))+N0,ep-1)

      Dv(diii(z3(i1,i2,i3))+N0,ep)=
     . (20d0*Dv(dzziii(z3(i1,i2,i3))+N0,ep)
     . -pole
     . -2d0*Czero3(z3(i1,i2,i3),ep)
     . +bit)/(2d0*m0sq)

      enddo

      return
      end


      subroutine gen(iseed,
     &               parameterOfSFR,
     &               radius,
     &               numberOfStarsInSample,
     &               thin_disk_age,
     &               burst_age,
     &               massReductionFactor,
     &               thick_disk_stars_fraction,
     &               halo_stars_fraction,
     &               thick_disk_age,
     &               thick_disk_sfr_param,
     &               halo_age,
     &               halo_stars_formation_time)
C     Divides the SFR in intervals of time. In each interval, the total
C     mass of stars is distributed. The mass of each star follows the
C     distribution law given by Initial Mass Function (IMF). The birth
C     time is also calculated, from which the scale height and finally
C     cylindrical z-coordinate are determined.
      implicit none

      external ran
      real ran

      integer, parameter :: MAX_STARS_COUNT = 6000000,
     &                      BINS_COUNT = 5000
      real, parameter :: THIN_DISK_SCALE_HEIGHT_KPC = 0.250,
     &                   THICK_DISK_SCALE_HEIGHT_KPC = 0.900,
     &                   BURST_FORMATION_FACTOR = 5.0,
     &                   HALO_STARS_BIRTH_END_TIME = 1.0,
     &                   HALO_DISTANCE_PARAM = 5.0,
     &                   PI = 4.0 * atan(1.0)
      integer ::  iseed,
     &            numberOfStarsInSample,
     &            bin_index,
     &            stars_count,
     &            in,
     &            numberOfWDs,
     &            flagOfWD(MAX_STARS_COUNT)
      real :: z_coordinate,                radius,
     &        time_try_sfr,                sfr_try,
     &        burst_age,                   burst_init_time,
     &        current_bin_init_time,       random_value,
     &        time_try,                    thick_disk_stars_fraction,
     &        parameterOfSFR,              areaOfSector,
     &        thin_disk_age,               normalization_const,
     &        time_increment,              massReductionFactor,
     &        psi,                         star_mass,
     &        total_generated_mass_in_bin, mrep,
     &        halo_stars_fraction,         burst_mrep,
     &        normal_mrep,                 thick_disk_max_sfr,
     &        thin_disk_birth_init_time,   thick_disk_age,
     &        thick_disk_max_sfr_relative_time,    thick_disk_sfr_param,
     &        halo_age,                    halo_stars_formation_time,
     &        thick_disk_birth_init_time,  max_age,
     &        halo_birth_init_time
      real :: mass_from_Salpeter_IMF,
     &        get_normalization_const
      double precision :: coordinate_Theta(MAX_STARS_COUNT),
     &                    coordinate_R(MAX_STARS_COUNT),
     &                    coordinate_Zcylindr(MAX_STARS_COUNT)
C     TODO: rename this to main_sequence_mass?
      real :: m(MAX_STARS_COUNT),
     &        starBirthTime(MAX_STARS_COUNT),
     &        scale_height
      integer :: disk_belonging(MAX_STARS_COUNT)

      common /tm/ starBirthTime,
     &            m
      common /coorcil/ coordinate_R,
     &                 coordinate_Theta,
     &                 coordinate_Zcylindr
      common /index/ flagOfWD,
     &               numberOfWDs,
     &               disk_belonging

C     TODO: find out the meaning of psi, mrep and 1.0e6
      normalization_const = get_normalization_const(parameterOfSFR,
     &                                              thin_disk_age)
      time_increment = thin_disk_age / BINS_COUNT
      psi = normalization_const * time_increment
      areaOfSector = PI * radius ** 2
      mrep = psi * areaOfSector * 1.0e6
      mrep = mrep * massReductionFactor
      normal_mrep = mrep
      burst_mrep = mrep * BURST_FORMATION_FACTOR

      max_age = max(thin_disk_age, thick_disk_age, halo_age)
      burst_init_time = max_age - burst_age
      thin_disk_birth_init_time = max_age - thin_disk_age
      thick_disk_birth_init_time = max_age - thick_disk_age
      halo_birth_init_time = max_age - halo_age
C     This can be easily proved by taking derivative from
C     y = t * exp(-t / tau)
      thick_disk_max_sfr_relative_time = thick_disk_sfr_param
      thick_disk_max_sfr = (thick_disk_max_sfr_relative_time
     &                      * exp(-thick_disk_max_sfr_relative_time
     &                              / thick_disk_sfr_param))

      write(6,*) '      Mass reduction factor = ', massReductionFactor

      stars_count = 0

      do bin_index = 1, BINS_COUNT
          total_generated_mass_in_bin = 0.0

          current_bin_init_time = (thin_disk_birth_init_time
     &                             + float(bin_index - 1)
     &                               * time_increment)

          if (current_bin_init_time >= burst_init_time) then
              mrep = burst_mrep
          else
              mrep = normal_mrep
          end if

          do
              star_mass = mass_from_Salpeter_IMF(iseed)
              stars_count = stars_count + 1

              if (stars_count == MAX_STARS_COUNT) then
                  write(6,*) '     ***  Dimension exceeded   ***'
                  write(6,*) '***  Increase the reduction factor   ***'
                  stop
              end if

              m(stars_count) = star_mass

C             disk_belonging = 1 (thin disk), = 2 (thick disk)
              random_value = ran(iseed)
              if (random_value <= thick_disk_stars_fraction) then
                  disk_belonging(stars_count) = 2
                  do
                      time_try = thick_disk_age * ran(iseed)
                      time_try_sfr = time_try
     &                               * exp(-time_try
     &                                      / thick_disk_sfr_param)
                      sfr_try = thick_disk_max_sfr * ran(iseed)
                      if (sfr_try <= time_try_sfr) then
                          starBirthTime(stars_count) = (
     &                        time_try + thick_disk_birth_init_time)
                          exit
                      end if
                  end do
              else if (random_value > thick_disk_stars_fraction
     &                 .and. random_value <= thick_disk_stars_fraction
     &                                       + halo_stars_fraction) then
                  disk_belonging(stars_count) = 3
                  starBirthTime(stars_count) = halo_birth_init_time
     &                + halo_stars_formation_time * ran(iseed)
              else
                  disk_belonging(stars_count) = 1
                  starBirthTime(stars_count) = thin_disk_birth_init_time
     &                + float(bin_index - 1) * time_increment
     &                + time_increment * ran(iseed)
                  total_generated_mass_in_bin =
     &                total_generated_mass_in_bin + star_mass
              end if

              if (disk_belonging(stars_count) == 1) then
                  scale_height = THIN_DISK_SCALE_HEIGHT_KPC
              else if (disk_belonging(stars_count) == 2) then
                  scale_height = THICK_DISK_SCALE_HEIGHT_KPC
              end if

C             Coordinates of halo stars will be generated in polar.f
              if (disk_belonging(stars_count) /= 3) then
C                 Inverse transform sampling for y = exp(-z / H)
                  z_coordinate = -scale_height * log(
     &                1.0 - ran(iseed) * (1.0 - exp(-radius
     &                                              / scale_height)))
C                 Assigning random sign
                  in = int(2.0 * ran(iseed))
                  coordinate_Zcylindr(stars_count) = z_coordinate
     &                                              * dfloat(1 - 2 * in)
              end if
              if (total_generated_mass_in_bin >= mrep) then
                  exit
              end if
          end do
      end do

      numberOfStarsInSample = stars_count
      write(6,*) '     Number of stars in sample=',numberOfStarsInSample

      end subroutine

      function get_normalization_const(parameterOfSFR,
     &                                 thin_disk_age)
C         Calculating the normalization constant of the SFR
          implicit none

C         TODO: find out what this sigma is
          real, parameter :: sigma = 51.0
          real :: parameterOfSFR,
     &            thin_disk_age,
     &            get_normalization_const

          get_normalization_const = sigma
     &                              / (parameterOfSFR
     &                                 * (1.0 - exp(-thin_disk_age
     &                                               / parameterOfSFR)))
      end function

C     TODO: change this to inverse transform sampling
      function mass_from_Salpeter_IMF(iseed)
C         Calculating the mass following the IMF by Salpeter 55.
          implicit none

          external ran
          real ran

          real, parameter :: mmin = 0.4,
     &                       mmax = 50.0

          integer :: iseed,
     &               ISEED1,
     &               ISEED2
          real :: mass_from_Salpeter_IMF,
     &            fractionOfDB,
     &            thin_disk_age,
     &            parameterIMF,
     &            parameterIFMR,
     &            burst_age,
     &            ymax,
     &            zy,
     &            zx,
     &            zyimf

          common /param/ fractionOfDB,
     &                   thin_disk_age,
     &                   parameterIMF,
     &                   parameterIFMR,
     &                   burst_age
          common /RSEED/ ISEED1,
     &                   ISEED2

C         Releasing a number (y-coordinate) according to a comparison
C         function cte.
          ymax = mmin ** parameterIMF

          do
              zy = ymax * ran(iseed)
C             Releasing another number (x-coordinate)
              zx = ((mmax - mmin) * ran(iseed)) + mmin
C             Calculating the value of the IMF for m = zx
              zyimf = zx ** parameterIMF
C             Comparing IMF with the function cte
              if (zy <= zyimf) then
                  mass_from_Salpeter_IMF = zx
                  exit
              end if
          end do
      end function


!==============================================================================!
  subroutine Source_F22_K_Eps_V2_F(grid)
!------------------------------------------------------------------------------!
!   Calculate source terms in eliptic relaxation  equation                     !
!   for vi2 and imposing  boundary condition for f22                           !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use all_mod
  use pro_mod
  use rans_mod
  use Grid_Mod
  use Parameters_Mod
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
!-----------------------------------[Locals]-----------------------------------!
  integer s, c, c1, c2, j
  real    Sor11,  f22hg
  real    A0
!==============================================================================!
!                                                                              !
!  The form of source terms are :                                              !
!                                                                              !
!     /                                                                        !
!    |                                                                         !
!    | f22hg*dV ; f22hg - f22hg homogenious is placed in a source              !
!    |                     coefficients b(c)                                   !
!   /                                                                          !
!      f22hg = (1.0 - Cv_1)*(vi2(c)/Kin(c) - 2.0/3.0)/Tsc(c)     &             !
!              + 2.0*Cv_2*Pk(c)/(3.0*Kin(c))                                   !
!                                                                              !
!     /                                                                        !
!    |                                                                         !
!    | f22*dV ;this term is placed in a diagonal of coefficient matrix         !
!    |                                                                         !
!   /                                                                          !
!                                                                              !
!                                                                              !
!  Dimensions of certain variables                                             !
!                                                                              !
!     Tsc            [s]                                                       !
!     Kin            [m^2/s^2]                                                 !
!     Eps            [m^3/s^2]                                                 !
!     vi2            [m^2/s^2]                                                 !
!     f22            [-]                                                       !
!     Lsc            [m]                                                       !
!                                                                              !
!------------------------------------------------------------------------------!

  call Time_And_Length_Scale(grid)

 ! Source term f22hg
 if(SIMULA == ZETA.or.SIMULA==HYB_ZETA) then
   do c = 1, grid % n_cells
     f22hg = (1.0 - Cf_1 - 0.65*Pk(c)   &
           / (Eps % n(c) + TINY))       &
           * (v_2 % n(c) - 2.0 / 3.0)   &
           / (Tsc(c) + TINY)            &
           + 0.0085 * Pk(c) / (Kin % n(c) + TINY)
     b(c) = b(c) + f22hg * grid % vol(c) / (Lsc(c)**2 + TINY)

     ! Buoyancy contribution:
     if(BUOY == YES) f22hg = (- 0.65*Pbuoy(c)/(Eps % n(c) + tiny))*&
           (v_2 % n(c) - 2.0/3.0)/(Tsc(c) + tiny)   &
            + 0.0085 * Pbuoy(c)/(Kin % n(c) + tiny)
   end do

   ! Source term f22hg
   do c = 1, grid % n_cells
     Sor11 = grid % vol(c)/(Lsc(c)**2 + TINY)
     A % val(A % dia(c)) = A % val(A % dia(c)) + Sor11
   end do

   ! Imposing boundary condition for f22 on the wall
   do s = 1, grid % n_faces
     c1=grid % faces_c(1,s)
     c2=grid % faces_c(2,s)
     if(c2 < 0 .and. TypeBC(c2) /= BUFFER ) then
       if(TypeBC(c2)==WALL .or. TypeBC(c2)==WALLFL) then

         f22 % n(c2) = -2.0 * VISc * v_2 % n(c1)     &
                     / WallDs(c1)**2

        ! Fill in a source coefficients

        ! Linearization of the near wall terms helps to get more
         ! stable solution, especially for small wall distance.
         A0 = Scoef(s)
         b(c1) = b(c1) + A0 * f22 % n(c2)
       end if   ! end if of BC=wall
     end if    ! end if of c2<0
   end do
 else if(SIMULA == K_EPS_VV) then
   do c = 1, grid % n_cells
     f22hg = (1.0 - Cf_1)*(v_2 % n(c)/(Kin % n(c)+TINY) - TWO_THIRDS)/(Tsc(c)+TINY)   &
                + Cf_2*Pk(c)/(Kin % n(c)+TINY)
     b(c) = b(c) + f22hg*grid % vol(c)/(Lsc(c)+TINY)**2
     Sor11 = grid % vol(c)/Lsc(c)**2
     A % val(A % dia(c)) = A % val(A % dia(c)) + Sor11
   end do

   ! Imposing boundary condition for f22 on the wall
   do s = 1, grid % n_faces
     c1=grid % faces_c(1,s)
     c2=grid % faces_c(2,s)
     if(c2 < 0 .and. TypeBC(c2) /= BUFFER ) then
       if(TypeBC(c2)==WALL .or. TypeBC(c2)==WALLFL) then
         f22 % n(c2) = -20.0*VISc**2*v_2 % n(c1)/                     &
                       (WallDs(c1)**4*Eps % n(c2))

        ! Fill in a source coefficients

        ! Linearization of the near wall terms helps to get more
         ! stable solution, especially for small wall distance.
         A0 = Scoef(s)
         b(c1) = b(c1) + A0 * f22 % n(c2)
       end if   ! end if of BC=wall
     end if    ! end if of c2<0
   end do
 end if

 end subroutine


module patterngenerator

 ! generate random patterns with specified temporal and spatial auto-correlation
 ! in spherical harmonic space.
 use mersenne_twister, only: random_setseed,random_gauss,random_stat
 use mod_param
 use mod_param, only: r_kind => kind_io4, kind_evod
 use mod_param, only:  pi => con_pi, rerth => con_rerth

 implicit none
 private

 public :: computevarspec, computevargrid, setvarspect,&
           patterngenerator_init, patterngenerator_destroy, getnoise, &
           patterngenerator_advance, getvarspectrum, random_pattern, ndimspec, &
           read_pattern,write_pattern,patterngenerator_advance_skeb

 type random_pattern
    real(kind_evod), public :: lengthscale
    real(kind_evod), public :: tau
    real(kind_evod), public :: dt
    real(kind_evod), public :: phi
    real(kind_evod), public :: stdev
    real(4), allocatable, dimension(:), public :: varspectrum, varspectrum1d, lap
    integer, allocatable, dimension(:), public      ::    degree,order,idx_e,idx_o
    integer, allocatable, dimension(:,:), public    :: idx
    integer, public :: seed
    type(random_stat), public :: rstate
 end type random_pattern

 integer :: nlons,nlats,ntrunc,ndimspec

 contains

 subroutine patterngenerator_init(lscale, delt, tscale, stdev, iseed, rpattern,&
                                  nlon, nlat, jcap, ls_node, npatterns,&
                                  varspect_opt)
   real(kind_evod), intent(in),dimension(npatterns) :: lscale,tscale,stdev
   real(kind_evod), intent(in) :: delt
   integer, intent(in) :: nlon,nlat,jcap,npatterns,varspect_opt
   integer, intent(in) :: ls_node(ls_dim,3)
   type(random_pattern), intent(out), dimension(npatterns) :: rpattern
   integer(8), intent(in) :: iseed(npatterns)
   integer m,j,l,n,nm,nn,np,indev1,indev2,indod1,indod2
   integer(8) count, count_rate, count_max, count_trunc
   integer(8) :: iscale = 10000000000
   integer count4, member_id, ierr
   integer indlsod,indlsev,jbasev,jbasod
   include 'function_indlsod.h'
   include 'function_indlsev.h'

   nlons = nlon
   nlats = nlat
   ntrunc = jcap

   ndimspec = (ntrunc+1)*(ntrunc+2)/2
   do np=1,npatterns
      allocate(rpattern(np)%idx(0:ntrunc,0:ntrunc))
      allocate(rpattern(np)%idx_e(len_trie_ls))
      allocate(rpattern(np)%idx_o(len_trio_ls))
      rpattern(np)%idx_e = 0; rpattern(np)%idx_o = 0; rpattern(np)%idx = 0
      nm = 0
      do m=0,ntrunc
         do n=m,ntrunc
            nm = nm + 1
            rpattern(np)%idx(m,n) = nm
         enddo
      enddo
      do j = 1, ls_max_node
         l=ls_node(j,1) ! zonal wavenumber
         jbasev=ls_node(j,2)
         jbasod=ls_node(j,3)
         indev1 = indlsev(l,l)
         indod1 = indlsod(l+1,l)
         if (mod(l,2) .eq. mod(ntrunc+1,2)) then
            indev2 = indlsev(ntrunc+1,l)
            indod2 = indlsod(ntrunc  ,l)
         else
            indev2 = indlsev(ntrunc  ,l)
            indod2 = indlsod(ntrunc+1,l)
         endif
         n = l ! degree
         do nn=indev1,indev2
            if (n <= ntrunc .and. l <= ntrunc) then
              nm = rpattern(np)%idx(l,n)
              rpattern(np)%idx_e(nn) = nm
            endif
            n = n + 2
         enddo
         n = l+1
         do nn=indod1,indod2
            if (n <= ntrunc .and. l <= ntrunc) then
              nm = rpattern(np)%idx(l,n)
              rpattern(np)%idx_o(nn) = nm
            endif
            n = n + 2
         enddo
      enddo
      allocate(rpattern(np)%degree(ndimspec),rpattern(np)%order(ndimspec),rpattern(np)%lap(ndimspec))
      rpattern(np)%degree = (/((n,n=m,ntrunc),m=0,ntrunc)/)
      rpattern(np)%order = (/((m,n=m,ntrunc),m=0,ntrunc)/)
      rpattern(np)%lap = -rpattern(np)%degree*(rpattern(np)%degree+1.0)
      rpattern(np)%tau = tscale(np)
      rpattern(np)%lengthscale = lscale(np)
      rpattern(np)%dt = delt
      rpattern(np)%phi = exp(-delt/tscale(np))
      rpattern(np)%stdev = stdev(np)
      allocate(rpattern(np)%varspectrum(ndimspec))
      allocate(rpattern(np)%varspectrum1d(0:ntrunc))
      ! seed computed on root, then bcast to all tasks and set.
      if (me == me_l_0) then
         member_id=ens_mem
         print*,' member_id is ',member_id
         if (iseed(np) == 0) then
           ! generate a random seed from system clock and ens member number
           call system_clock(count, count_rate, count_max)
           ! iseed is elapsed time since unix epoch began (secs)
           ! truncate to 4 byte integer
           count_trunc = iscale*(count/iscale)
           count4 = count - count_trunc + member_id
           print *,'using seed',count4
         else
           !count4 = iseed(np) + member_id
           ! don't rely on compiler to truncate integer(8) to integer(4) on
           ! overflow, do wrap around explicitly.
           count4 = mod(iseed(np) + member_id + 2147483648, 4294967296) - 2147483648
           print *,'using seed iseed member_id ',count4,iseed(np),member_id
         endif
      endif
      ! broadcast seed to all tasks.
      ! call mpi_bcast(count4,1,mpi_integer,me_l_0,mc_comp,ierr)
      rpattern(np)%seed = count4
      ! set seed (to be the same) on all tasks. save random state.
      call random_setseed(rpattern(np)%seed,rpattern(np)%rstate)

      if (varspect_opt .ne. 0 .and. varspect_opt .ne. 1) then
         if (me == me_l_0) then
            print *,'warning: illegal value for varspect_opt (should be 0 or 1), using 0 (gaussian spectrum)...'
         endif
         call setvarspect(rpattern(np),0)
      else if ( (varspect_opt == 1) .and. (opt_jff .eqv. .false.) ) then
         call setvarspect_skeb(rpattern(np),varspect_opt)
      else
         call setvarspect(rpattern(np),varspect_opt)
      endif
   enddo ! n=1,npatterns
 end subroutine patterngenerator_init

 subroutine patterngenerator_destroy(rpattern,npatterns)
   type(random_pattern), intent(inout) :: rpattern(npatterns)
   integer, intent(in) :: npatterns
   integer n
   do n=1,npatterns
   deallocate(rpattern(n)%varspectrum,rpattern(n)%varspectrum1d)
   deallocate(rpattern(n)%degree,rpattern(n)%order,rpattern(n)%lap)
   deallocate(rpattern(n)%idx,rpattern(n)%idx_e,rpattern(n)%idx_o)
   enddo
 end subroutine patterngenerator_destroy

 subroutine computevarspec(rpattern,dataspec,var)
    ! compute globally integrated variance from spectral coefficients
    complex(r_kind), intent(in) :: dataspec(ndimspec)
    real(r_kind), intent(out) ::  var
    type(random_pattern), intent(in) :: rpattern
    integer n
    var = 0.
    do n=1,ndimspec
       if (rpattern%order(n) .ne. 0) then
           var = var + dataspec(n)*conjg(dataspec(n))
       else
           var = var + 0.5*dataspec(n)*conjg(dataspec(n))
       endif
    enddo
 end subroutine computevarspec

 subroutine computevargrid(datagrid,var,areawts)
    ! compute globally integrated variance from data on gaussian grid
    real(r_kind), intent(in) :: datagrid(nlons,nlats),areawts(nlons,nlats)
    real(r_kind), intent(out) ::  var
    var = sum(areawts*datagrid**2)
 end subroutine computevargrid

 subroutine getvarspectrum(rpattern,dataspec,varspect)
    type(random_pattern), intent(in) :: rpattern
    complex(r_kind), intent(in) :: dataspec(ndimspec)
    real(r_kind), intent(out) :: varspect(0:ntrunc)
    integer n
    varspect = 0.
    do n=1,ndimspec
       if (rpattern%order(n) .ne. 0) then
          varspect(rpattern%degree(n)) = varspect(rpattern%degree(n)) + &
          dataspec(n)*conjg(dataspec(n))
       else
          varspect(rpattern%degree(n)) = varspect(rpattern%degree(n)) + &
          0.5*dataspec(n)*conjg(dataspec(n))
       endif
    enddo
 end subroutine getvarspectrum

 subroutine getnoise(rpattern,noise_e,noise_o)
   real(kind_evod), intent(inout) :: noise_e(len_trie_ls,2)
   real(kind_evod), intent(inout) :: noise_o(len_trio_ls,2)
   ! generate white noise with unit variance in spectral space
   type(random_pattern), intent(inout) :: rpattern
   real :: noise(2*ndimspec)
   integer nm,nn
   call random_gauss(noise,rpattern%rstate)
   noise(1) = 0.; noise(ndimspec+1) = 0.
   noise = noise*sqrt(1./ntrunc)
   noise_e = 0.; noise_o = 0.
   ! subset
   do nn=1,len_trie_ls
      nm = rpattern%idx_e(nn)
      if (nm == 0) cycle
      noise_e(nn,1) = noise(nm)/sqrt(2.*rpattern%degree(nm)+1)
      noise_e(nn,2) = noise(ndimspec+nm)/sqrt(2.*rpattern%degree(nm)+1)
      if (rpattern%order(nm) .eq. 0) then
        noise_e(nn,1) = sqrt(2.)*noise_e(nn,1)
        noise_e(nn,2) = 0.
      endif
   enddo
   do nn=1,len_trio_ls
      nm = rpattern%idx_o(nn)
      if (nm == 0) cycle
      noise_o(nn,1) = noise(nm)/sqrt(2.*rpattern%degree(nm)+1)
      noise_o(nn,2) = noise(ndimspec+nm)/sqrt(2.*rpattern%degree(nm)+1)
      if (rpattern%order(nm) .eq. 0) then
        noise_o(nn,1) = sqrt(2.)*noise_o(nn,1)
        noise_o(nn,2) = 0.
      endif
   enddo
 end subroutine getnoise

subroutine read_pattern(rpattern,pattern2d_e,pattern2d_o,lunptn)
   real(kind_evod), intent(inout) :: pattern2d_e(len_trie_ls,2)
   real(kind_evod), intent(inout) :: pattern2d_o(len_trio_ls,2)
   type(random_pattern), intent(inout) :: rpattern
   integer, intent(in) :: lunptn
   real(kind_evod),allocatable  :: pattern2d(:)
   integer nm,nn,ierr

   allocate(pattern2d(2*ndimspec))

   ! read only on root process, and send to all tasks
   if (me .eq. me_l_0) then
      read(lunptn) pattern2d
      print*,'reading in random pattern (min/max/size)',minval(pattern2d),maxval(pattern2d),size(pattern2d)
   endif
   call mpi_bcast(pattern2d,2*ndimspec,mpi_r_io_r,me_l_0,mc_comp,ierr)
   ! subset
   do nn=1,len_trie_ls
      nm = rpattern%idx_e(nn)
      if (nm == 0) cycle
      pattern2d_e(nn,1) = pattern2d(nm)
      pattern2d_e(nn,2) = pattern2d(ndimspec+nm)
   enddo
   do nn=1,len_trio_ls
      nm = rpattern%idx_o(nn)
      if (nm == 0) cycle
      pattern2d_o(nn,1) = pattern2d(nm)
      pattern2d_o(nn,2) = pattern2d(ndimspec+nm)
   enddo
   !print*,'after scatter...',me,maxval(pattern2d_e),maxval(pattern2d_o) &
   ! ,minval(pattern2d_e),minval(pattern2d_o)
   deallocate(pattern2d)
 end subroutine read_pattern

 subroutine write_pattern(rpattern,pattern2d_e,pattern2d_o,lunptn)
   real(kind_evod), intent(in) :: pattern2d_e(len_trie_ls,2)
   real(kind_evod), intent(in) :: pattern2d_o(len_trio_ls,2)
   type(random_pattern), intent(inout) :: rpattern
   integer, intent(in) :: lunptn
   real(kind_evod), allocatable  :: pattern2d(:),pattern2d_out(:)
   integer nm,nn,ierr

   allocate(pattern2d(2*ndimspec),pattern2d_out(2*ndimspec))
   pattern2d=0.0
   pattern2d_out=0.0
   ! fill in apprpriate pieces of array
   !print*,'before collection...',me,maxval(pattern2d_e),maxval(pattern2d_o) &
   ! ,minval(pattern2d_e),minval(pattern2d_o)
   do nn=1,len_trie_ls
      nm = rpattern%idx_e(nn)
      if (nm == 0) cycle
      pattern2d(nm)          = pattern2d_e(nn,1)
      pattern2d(ndimspec+nm) = pattern2d_e(nn,2)
   enddo
   do nn=1,len_trio_ls
      nm = rpattern%idx_o(nn)
      if (nm == 0) cycle
      pattern2d(nm)          = pattern2d_o(nn,1)
      pattern2d(ndimspec+nm) = pattern2d_o(nn,2)
   enddo
   call mpi_reduce(pattern2d,pattern2d_out,2*ndimspec,&
                   mpi_r_io_r,mpi_sum,me_l_0,mc_comp,ierr)
  !  write only on root process
   if (me .eq. me_l_0) then
      print*,'writing out random pattern (min/max/size)',&
      minval(pattern2d_out),maxval(pattern2d_out),size(pattern2d_out)
      write(lunptn) pattern2d_out
   endif
   deallocate(pattern2d,pattern2d_out)
 end subroutine write_pattern

 subroutine patterngenerator_advance(dataspec_e,dataspec_o,rpattern)
    ! advance 1st-order autoregressive process with
    ! specified autocorrelation (phi) and variance spectrum (spectrum)
    real(kind_evod), intent(inout) :: dataspec_e(len_trie_ls,2)
    real(kind_evod), intent(inout) :: dataspec_o(len_trio_ls,2)
    real(kind_evod) :: noise_e(len_trie_ls,2)
    real(kind_evod) :: noise_o(len_trio_ls,2)
    type(random_pattern), intent(inout) :: rpattern
    integer j,l,n,nn,nm
    call getnoise(rpattern,noise_e,noise_o)
    do nn=1,len_trie_ls
       nm = rpattern%idx_e(nn)
       if (nm == 0) cycle
       dataspec_e(nn,1) =  rpattern%phi*dataspec_e(nn,1) + &
                           rpattern%stdev*sqrt(1.-rpattern%phi**2)*rpattern%varspectrum(nm)*noise_e(nn,1)
       dataspec_e(nn,2) =  rpattern%phi*dataspec_e(nn,2) + &
                           rpattern%stdev*sqrt(1.-rpattern%phi**2)*rpattern%varspectrum(nm)*noise_e(nn,2)
    enddo
    do nn=1,len_trio_ls
       nm = rpattern%idx_o(nn)
       if (nm == 0) cycle
       dataspec_o(nn,1) =  rpattern%phi*dataspec_o(nn,1) + &
                           rpattern%stdev*sqrt(1.-rpattern%phi**2)*rpattern%varspectrum(nm)*noise_o(nn,1)
       dataspec_o(nn,2) =  rpattern%phi*dataspec_o(nn,2) + &
                           rpattern%stdev*sqrt(1.-rpattern%phi**2)*rpattern%varspectrum(nm)*noise_o(nn,2)
    enddo
 end subroutine patterngenerator_advance

   subroutine setvarspect(rpattern,varspect_opt)

      use mod_param, only: rerth => con_rerth
     ! define variance spectrum (isotropic covariance)
     ! normalized to unit global variance
     type(random_pattern), intent(inout) :: rpattern
     integer, intent(in) :: varspect_opt
     complex(r_kind) noise(ndimspec)
     real(r_kind) var
     integer n

     ! 1d variance spectrum (as a function of total wavenumber)
     if (varspect_opt == 0) then ! gaussian
       ! rpattern%lengthscale is interpreted as an efolding length
       ! scale, in meters.
       do n=0,ntrunc
          rpattern%varspectrum1d(n) = exp(-rpattern%lengthscale**2*(float(n)*(float(n)+1.))/(4.*rerth**2))
       enddo
       ! scaling factors for spectral coeffs of white noise pattern with unit variance
       rpattern%varspectrum = sqrt(ntrunc*exp(rpattern%lengthscale**2*rpattern%lap/(4.*rerth**2)))
     else if (varspect_opt == 1) then ! power law
       ! rpattern%lengthscale is interpreted as a power, not a length.
       do n=0,ntrunc
         !   rpattern%varspectrum1d(n) = float(n)**(rpattern%lengthscale)
         rpattern%varspectrum1d(n) = float(n+1)**(rpattern%lengthscale)
       enddo
       ! scaling factors for spectral coeffs of white noise pattern with unit variance
       !rpattern%varspectrum = sqrt(ntrunc*(rpattern%degree)**(rpattern%lengthscale))
       rpattern%varspectrum = sqrt(ntrunc*((rpattern%degree+1)**(rpattern%lengthscale)))
     endif

     noise = 0.
     do n=1,ndimspec
       if (rpattern%order(n) .ne. 0.) then
         noise(n) = cmplx(1.,1.)/sqrt(2.*rpattern%degree(n)+1)
       else
         noise(n) = sqrt(2.)/sqrt(2.*rpattern%degree(n)+1.)
       endif
     enddo
     noise(1) = 0 ! no global mean.
     ! make sure global mean variance is 1.
     noise = noise*sqrt(1./ntrunc)
     noise = rpattern%varspectrum*noise
     call computevarspec(rpattern,noise,var)
     rpattern%varspectrum = rpattern%varspectrum/sqrt(var)
     rpattern%varspectrum1d = rpattern%varspectrum1d/var

   end subroutine setvarspect

   !===================================================================================================
   subroutine patterngenerator_advance_skeb(dataspec_e,dataspec_o,rpattern)

     ! advance 1st-order autoregressive process with
     ! specified autocorrelation (phi) and variance spectrum (spectrum)
     real(kind_evod), intent(inout) :: dataspec_e(len_trie_ls,2)
     real(kind_evod), intent(inout) :: dataspec_o(len_trio_ls,2)
     real(kind_evod) :: noise_e(len_trie_ls,2)
     real(kind_evod) :: noise_o(len_trio_ls,2)
     real(r_kind) :: alpha
     type(random_pattern), intent(inout) :: rpattern
     integer j,l,n,nn,nm

     alpha = rpattern%dt/rpattern%tau
     call getnoise(rpattern,noise_e,noise_o)
     do nn=1,len_trie_ls
        nm = rpattern%idx_e(nn)
        if (nm == 0) cycle
        dataspec_e(nn,1) =  (1-alpha)*dataspec_e(nn,1) + sqrt(alpha)*rpattern%varspectrum(nm)*rpattern%stdev*noise_e(nn,1)
        dataspec_e(nn,2) =  (1-alpha)*dataspec_e(nn,2) + sqrt(alpha)*rpattern%varspectrum(nm)*rpattern%stdev*noise_e(nn,2)
     enddo
     do nn=1,len_trio_ls
        nm = rpattern%idx_o(nn)
        if (nm == 0) cycle
        dataspec_o(nn,1) =  (1-alpha)*dataspec_o(nn,1) + sqrt(alpha)*rpattern%varspectrum(nm)*rpattern%stdev*noise_o(nn,1)
        dataspec_o(nn,2) =  (1-alpha)*dataspec_o(nn,2) + sqrt(alpha)*rpattern%varspectrum(nm)*rpattern%stdev*noise_o(nn,2)
     enddo

   end subroutine    ! patterngenerator_advance_skeb

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

   subroutine setvarspect_skeb(rpattern,varspect_opt)

   ! define variance spectrum (isotropic covariance)
   ! normalized to unit global variance

     type(random_pattern), intent(inout) :: rpattern
     integer, intent(in) :: varspect_opt
     complex(r_kind) noise(ndimspec)
     real(r_kind) var,rgamma, F0, delE,delEp, TOT_Backscat, pi,alpha
     integer n

     pi = atan(1.0)*4.0
     alpha = rpattern%dt/rpattern%tau
     delE = 1.E-5    ! m2 s-3 (Berner et al 2009)
                     ! This may depend on the model resolution!
     delEp = delE*rpattern%dt

     rpattern%varspectrum = (rpattern%degree+1)**(rpattern%lengthscale)
     rgamma = 0.
     do n=1,ndimspec
        rgamma = rgamma +  rpattern%degree(n)*(2.*rpattern%degree(n)+1)*      &
                           (rpattern%degree(n)+1)**(2*rpattern%lengthscale+1)
     enddo

     F0 = sqrt(4*pi*rerth**2*alpha*delEp/rgamma)/rpattern%stdev

     rpattern%varspectrum   = F0*rpattern%varspectrum

   end subroutine setvarspect_skeb

end module patterngenerator


      PROGRAM PROG82
C   ******************************************************************
C   THIS PROGRAM RATES A SHELL AND TUBE HEAT EXCHANGER WITH
C   EITHER A SINGLE SHELL PASS AND ANY MULTIPLE OF TWO TUBE
C   PASSES PR TWO OR MORE SHELL PASSES.
C   THE PROGRAM ASSUMES THAT THERE IS NO CHANGE OF PHASE.
C
C   THE PROGRAM USES DEVELOPED CORRELATIONS FOR FRICTION FACTORS
C   IN BOTH THE SHELL AND TUBE SIDES. HEDRICK'S CORRELATION
C   (Chem. Eng. June, 1990) FOR ESTIMATING THE HEAT TRANSFER
C   COEFFICIENT FOR TUBES IN THE TRANSITION REGION IS EMPLOYED
C   IN THE PROGRAM
C     Adapted by Rohit Goswami from Kayode's Fortran Programs
C   ******************************************************************
C
C   NOMENCLATURE:               TUBE SIDE
C
C   1.    FLUID TYPE                                =     FTS
C   2.    NUMBER OF TUBES                           =     NT
C   3.    TUBE INSIDE DIA., inch                    =     TID
C   4.    TUBE OUTSIDE DIA., inch                   =     TOD
C   5.    TUBE PITCH, inch                          =     TP
C   6.    PITCH TYPE (TRIANGLE/SQUARE)              =     T/S
C   7.    TUBE LENGTH, ft.                          =     TL
C   8.    NUMBER OF PASSES                          =     TNP
C   9.    FOULING FACTOR                            =     TFF
C   10.   INLET TEMPERATURE, oF                     =     TT1
C   11.   OUTLET TEMPERATURE, oF                    =     TT2
C   12.   SPECIFIC HEAT CAPACITY (Btu/lboF)         =     TSHC
C   13.   VISCOSITY, cP                             =     TVIS
C   14.   DENSITY, lb/ft^3                          =     TDEN
C   15.   FLUID THERMAL CONDUCTIVITY (Btu/ft.h.oF)  =     TFK
C   16.   MASS FLOWRATE, lb/hr                      =     TW
C
C   NOMENCLATURE:             SHELL SIDE
C
C   1.    FLUID TYPE                                =     FSS
C   2.    NUMBER OF SHELL PASSES                    =     NS
C   3.    SHELL INSIDE DIA., inch                   =     SID
C   4.    NUMBER OF BAFFLES                         =     NB
C   5.    BAFFLE SPACING, inch                      =     BSP
C   6.    FOULING FACTOR                            =     SFF
C   7.    INLET TEMPERATURE, oF                     =     TS1
C   8.    OUTLET TEMPERATURE, oF                    =     TS2
C   9.    SPECIFIC HEAT CAPACITY (Btu/lboF)         =     SSHC
C   10.   VISCOSITY, cP                             =     SVIS
C   11.   DENSITY, lb/ft^3                          =     SDEN
C   12.   FLUID THERMAL CONDUCTIVITY (Btu/ft.h.oF)  =     SFK
C   13.   MASS FLOWRATE, lb/hr                      =     SW
C   ******************************************************************

      PARAMETER (PI = 3.1415927, G=32.174)

      CHARACTER*30 FTS, FSS
      CHARACTER TYPE
C
      COMMON/TUBE1/ FTS, TYPE
      COMMON/TUBE2/ NT, TID, TOD, TP, TL, TNP
      COMMON/TUBE3/ TFF, TT1, TT2, TSHC, TVIS, TDEN
      COMMON/TUBE4/ TFK, TW
      COMMON/TUBE5/ RET, PRT, TFRF, HT, TV
      COMMON/TUBE6/ TDELP, TRDELP, TOTDP
      COMMON/SHELL1/ FSS
      COMMON/SHELL2/ NS, SID, NB, BSP, SFF
      COMMON/SHELL3/ TS1, TS2, SSHC, SVIS, SDEN
      COMMON/SHELL4/ SFK, SW
      COMMON/SHELL5/ RES, PRS, SFRF, HS, SV
      COMMON/SHELL6/ SDELP

      COMMON/OUT/ Q, AREA, F, LMTD, U, Q1, CMTD

      REAL NT, NS, NB, LMTD

      OPEN (UNIT = 3, FILE = 'DATA82.DAT', STATUS ='OLD', ERR = 18)
      OPEN (UNIT = 1, FILE = 'PRN')

C   READ THE TUBE SIDE HEAT EXCHANGER PARAMETERS

C   READ THE FLUID TYPE: FTS

      READ (3, 11, ERR = 19) FTS
11    FORMAT (A)

C   READ THE NUMBER OF TUBES: NT
C   READ THE TUBE INSIDE DIAMETER, inch : TID
C   READ THE TUBE OUTSIDE DIAMETER, inch : TOD
C   READ THE TUBE PITCH, inch : TP
C   READ THE TYPE OF PITCH (TRIANGULAR: T) or (SQUARE: S): TYPE

      READ (3, *, ERR= 19) NT, TID, TOD, TP
      READ (3, 12, ERR= 19) TYPE
12    FORMAT   (A)

C   READ THE TUBE LENGTH, ft. : TL
C   READ THE NUMBER OF PASSES : TNP
C   READ THE TUBE SIDE FOULING FACTOR : TFF
C   READ THE INLET TEMPERATURE, oF : TT1
C   READ THE OUTLET TEMPERATURE, oF : TT2
C   READ THE SPECIFIC HEAT CAPACITY OF FLUID, (Btu/hr.ft.oF) : TSHC
C   READ THE FLUID THERMAL CONDUCTIVITY (Btu/ft.h.oF) : TFK
C   READ THE FLUID VISCOSITY, cP : TVIS
C   READ THE FLUID DENSITY, lb/ft^3 : TDEN
C   READ THE FLUID FLOWRATE, lb/hr.: TW

      READ (3, *, ERR=19) TL, TNP, TFF, TT1
      READ (3, *, ERR=19) TT2, TSHC, TVIS, TDEN
      READ (3, *, ERR=19) TFK, TW

C   READ THE SHELL SIDE HEAT EXCHANGER PARAMETERS

C   READ THE FLUID TYPE: FSS

      READ (3, 13, ERR=19) FSS

13    FORMAT   (A)

C   READ THE NUMBER OF SHELL: NS
C   READ THE SHELL SIDE INSIDE DIAMETER, inch: SID
C   READ THE NUMBER OF BAFFLES: NB
C   READ THE BAFFLE SPACING, inch: BSP
C   READ THE SHELL SIDE FOULING FACTOR, SFF
C   READ THE INLET TEMPERATURE, oF: TSI
C   READ THE OULET TEMPERATURE, oF: TS2
C   SHELL SIDE SPECIFIC HEAT CAPACITY, Btu/ib.oF.: SSHC
C   READ THE FLUID VISCOSITY, cP: SVIS
C   READ THE FLUID DENSITY, ib/ft^3.: SDEN
C   READ THE FLUID THERMAL CONDUCTIVITY, Btu/hr.ft.oF.: SFK
C   READ THE FLUID FLOWRATE, ib/hr.: SW.

      READ (3, *, ERR=19) NS, SID, NB, BSP
      READ (3, *, ERR=19) SFF, TS1, TS2, SSHC
      READ (3, *, ERR=19) SVIS, SDEN, SFK, SW

      GO TO 15

18    WRITE    (*, 20)
20    FORMAT   (3X, 'ERROR MESSAGE IN THE DATA VALUE')
      GO TO 999
19    WRITE    (*, 21)
21    FORMAT   (3X, 'DATA VALUE DOES NOT EXIST')
      GO TO 999

C   TUBE SIDE CALCULATION

15    CALL   TUBE

C   SHELL SIDE CALCULATION
      CALL SHELL
C   CALCULATE THE HEAT LOAD
      Q = TW*TSHC*ABS(TT2-TT1)
C   CALCULATE THE LOG MEAN TEMPERATURE DIFFERENCE (LMTD)

      VAL1 = (TS1-TT2)-(TS2-TT1)
      VAL2 = ALOG((TS1-TT2)/(TS2-TT1))
      LMTD = ABS(VAL1/VAL2)
C   CALCULATE THE APPROACH FACTOR
      R = (TS1-TS2)/(TT2-TT1)
      P = (TT2-TT1) / (TS1-TT1)

      IF (NS .EQ. 1.0 .AND. R .EQ. 1.0) THEN
        PX = P/(NS-NS*P+P)
        SUM1 = (PX*(R*R+1.0)**0.5)/(1.0-PX)
        SUM2 = 2.0/PX-1.0-R+(R*R+1.0)**0.5
        SUM3 = 2.0/PX-1.0-R-(R*R+1.0)**0.5
        SUM4 = ALOG(SUM2/SUM3)
        F = SUM1/SUM4
        GO TO 100
      ELSEIF (NS .EQ. 1.0 .AND. R .GT. 1.0) THEN
55      SUM5 = ((R*P-1.0)/(P-1.0))**(1.0/NS)
        PX = (1.0-SUM5)/(R-SUM5)
        SUM6 = (R*R+1.0)**0.5/(R-1.0)
        SUM7 = ALOG((1.0-PX)/(1.0-R*PX))
        SUM41 = ((2.0/PX)-1.0-R+(R*R+1.0)**0.5)
        SUM42 = ((2.0/PX)-1.0-R-(R*R+1.0)**0.5)
C   Broken IF maybe. (dangling)

      IF (SUM41 .LT. 0.0 .OR. SUM42 .LT. 0.0) THEN
        NS = NS+1.
        TNP = TNP+2.
        GO TO 55
        ELSE
        SUM43 = ALOG(SUM41/SUM42)
      ENDIF

      F = (SUM6*SUM7)/SUM43

      IF (F .LT. 0.8) THEN
        NS = NS+1.0
        TNP = TNP+2.
        GO TO 55
        ELSE
        END IF

      GO TO 100

      ELSEIF (NS .GE. 2.0 .AND. NT .GE. 4.0) THEN
        SUM8 = (R*R+1.0)**0.5/(2.0*(R-1.0))
        SUM9 = ALOG((1.0-P)/(1.0-P*R))
        SUM10 = 2/P-1.0-R+((2/P)*((1.0-P)*(1-P*R))**0.5)+(R*R+1.)**0.5
        SUM11 = 2/P-1.0-R+((2/P)*((1.0-P)*(1.-P*R))**0.5)-(R*R+1.)**0.5

        F = (SUM8*SUM9)/ALOG(SUM10/SUM11)
      ENDIF

C   CORRECTED MEAN TEPERATURE

100   CMTD=F*LMTD

C CALCULATE THE OVERALL HEAT TRANSFER COEFFICIENT
C Btu/hr.ft^2.oF

      U = 1.0/(1./HT+1./HS+TFF+SFF)

C   CALCULATE THE OUTSIDE AREA OF THE HEAT EXCHANGER UNIT ft^2

      AREA=(TOD/12.0*TP*NT*NS*TL)

      Q1 = AREA*U*CMTD
      CALL RESULT

C   FORM FEED THE PRINTING PAPER TO TOP OF THE NEXT PAGE.

      WRITE (1, *) CHAR(12)

      CLOSE (UNIT=3, STATUS='KEEP')
      CLOSE (UNIT=1)
999   STOP
      END

C   *THIS PROGRAM CALCULATES TUBE TUBE SIDE HEAT TRANSFER COEFFICIENT,
C   * REYNOLDS NUMBER, PRANDTL NUMBER, FRICTION FACTOR AND PRESSURE DROP.*

      SUBROUTINE TUBE
      PARAMETER (PI = 3.1415927, G = 32.174)
      CHARACTER*30 FTS, FSS
      CHARACTER TYPE

      COMMON/TUBE1/ FTS, TYPE
      COMMON/TUBE2/ NT, TID, TOD, TP, TL, TNP
      COMMON/TUBE3/ TFF, TT1, TT2, TSHC, TVIS, TDEN
      COMMON/TUBE4/ TFK, TW
      COMMON/TUBE5/ RET, PRT, TFRF, HT, TV
      COMMON/TUBE6/ TDELP, TRDELP, TOTDP
      COMMON/SHELL1/ FSS
      COMMON/SHELL2/ NS, SID, NB, BSP, SFF
      COMMON/SHELL3/ TS1, TS2, SSHC, SVIS, SDEN
      COMMON/SHELL4/ SFK, SW
      COMMON/SHELL5/ RES, PRS, SFRF, HS, SV
      COMMON/SHELL6/ SDELP

      COMMON/OUT/ Q, AREA, F, LMTD, U, Q1, CMTD

      REAL NT, NS, NB, LMTD

C   CALCULTAE THE FLOW AREA: TFA, ft^2

      TFA = (PI*TID**2*NT)/(4.0*144.0*TNP)

C   CALCULATE THE MASS VELOCITY, ib/hr.ft^2

      GT = TW/TFA

C CALCULATE THE REYNOLDS NUMBER: RET

      RET = (GT*TID)/(12.0*2.42*TVIS)

C   CALCULATE THE PRANDTL NUT[BER: PRT

      PRT = (TSHC*TVIS*2.42)/TFK

C   CHECK THAT THE REYNOLDS NUMBER IS IN THE TRANSITION REGION
C   (i.e. 2000<RET<10,000)

      IF (RET .GT. 2000.0 .AND. RET .LT. 10000.0) THEN
        X1 = RET/1000.0
        X2 = 10.0*TID/TL
        X3 = (1.0-(X1/10.0)**0.256)
        X4 = X2**X3
        B1 = (-3.08+3.075*X1+(0.32567*X1**2)-(0.02185*X1**3))*X4
        HT = (16.1/TOD)*(B1*TFK*PRT**0.33)
        GO TO 110

      ELSE IF (RET .GT. 10000.0) THEN
        HT = 0.027*TFK*(12.0/TID)*(RET**0.8)*(PRT**0.33)
      ENDIF

110   HT    = HT*TID/TOD

C   CALCULATE THE TUBE FRICTION FACTOR

      IF (RET .GT. 1000.0) THEN
        TFRF = 0.0029/(RET**0.25603)
      ELSE
      ENDIF

C   CALCULATE THE FLUID VELOCITY, ft./s.

      TV = GT/(3600.0*TDEN)

C   CALCULATE THE TUBE SIDE PRESSURE DROP, psi.

      TDELP = (TFRF*(GT/3600.0)**2*TL*TNP)/(2.0*G*TDEN*TID/12.0)

C   CALCULATE THE PRESSURE DROP OF RETURN LOSSES, psi.
C   USING FRANK'S CORRELATION.

      TRDELP = (2.5*TNP*TDEN*TV**2)/(2*G*144.0)

C   CALCULATE THE TOTAL PRESSURE DROP EXCLUDING THE NOZZLE IN THE
C   TUBE SIDE, psi.

      TOTDP = TDELP+TRDELP

      RETURN
      END

C   ****************************************************************
C   *THIS PROGRAM CALCULATES THE SHELL SIDE HEAT TRANSFER
C   *
C   *COEFFICIENT,
C   REYNOLDS NUMBER, PRANDTL NUMBER, FRICTION FACTOR *
C   *AND PRESSURE DROP.
C   *
C   ****************************************************************

      SUBROUTINE SHELL

      PARAMETER (PI = 3.1415927, G=32.174)
      CHARACTER*30 FTS, FSS
      CHARACTER TYPE

      COMMON/TUBE1/ FTS, TYPE
      COMMON/TUBE2/ NT, TID, TOD, TP, TL, TNP
      COMMON/TUBE3/ TFF, TT1, TT2, TSHC, TVIS, TDEN
      COMMON/TUBE4/ TFK, TW
      COMMON/TUBE5/ RET, PRT, TFRF, HT, TV
      COMMON/TUBE6/ TDELP, TRDELP, TOTDP
      COMMON/SHELL1/ FSS
      COMMON/SHELL2/ NS, SID, NB, BSP, SFF
      COMMON/SHELL3/ TS1, TS2, SSHC, SVIS, SDEN
      COMMON/SHELL4/ SFK, SW
      COMMON/SHELL5/ RES, PRS, SFRF, HS, SV
      COMMON/SHELL6/ SDELP

      COMMON/OUT/ Q, AREA, F, LMTD, U, Q1, CMTD

      REAL NT, NS, NB, LMTD

C   CHECK WHETHER PITCH TYPE IS TRIANGULAR OR SQUARE

      IF (TYPE .EQ. 'T' .OR. TYPE .EQ. 't') THEN
        DE = ((1.72*TP**2)-(0.5*PI*TOD**2))/(0.5*PI*12.0*TOD)
        GO TO 120
      ELSE IF (TYPE .EQ. 'S' .OR. TYPE .EQ. 's') THEN
        DE = 4.*((TP**2)-(PI*TOD**2/4.0))/(PI*12.0*TOD)
      ENDIF

C   CALCULATE THE TUBE CLEARANCE, inch
120      TC = TP-TOD

C   CALCULATE THE SHELL FLOW AREA, ft^2.

      IF (NS .GE. 2.0 .AND. NT .GE. 4.0) THEN
        SFA = (0.5*(SID*TC*BSP))/(144.0*TP)
        GO TO 130
        ELSE
        SFA = (SID*TC*BSP)/(144.0*TP)
      ENDIF

C   CALCULATE THE SHELL SUPERFICIAL FLOW RATE, Ib/ft^2.hr.
130   GS = SW/SFA

C   CALCULATE THE SHELL VELOCITY, ft./sec.
      SV = SW/(3600.0*SDEN*SFA)

C   CALCULATE THE REYNOLDS NUMBER
      RES = (DE*GS)/(2.42*SVIS)

C   CALCULATE THE PRANDTL NUMBER
      PRS = (2.42*SSHC*SVIS)/SFK

C   CALCULATE THE SHELL SIDE HEAT TRANSFER COEFFICIENT
      HS = 0.36/DE*SFK*(RES**0.55)*(PRS**0.333)

C   CHECK WHETHER THE SHELL'S REYNOLDS NUMBER IS LESS OR GREATER
C   THAN 500
      IF (RES .LT. 500.0) THEN
        SFRF = 0.11183/(RES**0.59246)
        GO TO 140
      ELSEIF (RES .GT. 500.0) THEN
        SFRF = 0.01159/(RES**0.18597)
      ENDIF

C   CALCULATE THE SHELL SIDE PRESSURE DROP, psi.
140   VAL1 = SFRF*(GS/3600.0)**2*SID/12.0*(NB+1.)
      VAL2 = 64.4*SDEN*DE
      SDELP = (VAL1/VAL2)*NS

C

      RETURN
      END

C   ***************************************************************
C   THIS PROGRAM PRINTS THE RESULTS OF THE SHELL AND TUBE HEAT
C   EXCHANGER ONTO A PRINTER
C   ***************************************************************

      SUBROUTINE RESULT
      CHARACTER*30 FTS,FSS
      CHARACTER TYPE

      COMMON/TUBE1/ FTS, TYPE
      COMMON/TUBE2/ NT, TID, TOD, TP, TL, TNP
      COMMON/TUBE3/ TFF, TT1, TT2, TSHC, TVIS, TDEN
      COMMON/TUBE4/ TFK, TW
      COMMON/TUBE5/ RET, PRT, TFRF, HT, TV
      COMMON/TUBE6/ TDELP, TRDELP, TOTDP
      COMMON/SHELL1/ FSS
      COMMON/SHELL2/ NS, SID, NB, BSP, SFF
      COMMON/SHELL3/ TS1, TS2, SSHC, SVIS, SDEN
      COMMON/SHELL4/ SFK, SW
      COMMON/SHELL5/ RES, PRS, SFRF, HS, SV
      COMMON/SHELL6/ SDELP

      COMMON/OUT/ Q, AREA, F, LMTD, U, Q1, CMTD

      REAL NT, NS, NB, LMTD

      WRITE (1, 150)
150   FORMAT (///,18X,'*SHELL AND TUBE HEAT EXCHANGER RATING*')

      WRITE (1, 160)
160   FORMAT (78(1H*))

      WRITE (1, 170)
170   FORMAT (40X,'TUBE SIDE',10X,'SHELL SIDE')

      WRITE (1, 180)
180   FORMAT (78(1H-))

      WRITE (1, 190) FTS, FSS
190   FORMAT (2X,'FLUID TYPE:',T40, A15, T60, A15)

      WRITE (1, 200) TW, SW
200   FORMAT (2X,'FLUID FLOW RATE , lb/hr.:',T40, F10.0,T60,F10.0)

      WRITE (1, 210) TSHC, SSHC
210   FORMAT (2X,'SPECIFIC HEAT CAPACITY, Btu/ib.oF:',T40, F8.3,T60,
     +     F8.3)

      WRITE (1, 220)TDEN, SDEN
220   FORMAT (2X,'FLUID DENSITY, lb/ft^3:',T40,F8.3,T60,F8.3)

      WRITE (1, 230) TVIS, SVIS
230   FORMAT (2X,'FLUID VISCOSITY, cP:',T40,F8.3,T60,F8.3)

      WRITE (1, 240) TFK, SFK
240   FORMAT (2X,'FLUID THERMAL COND. Btu/ft.h.oF:',T40,F8.3,T60,F8.3)

      WRITE (1, 250) TT1, TS1
250   FORMAT (2X,'FLUID INLET TEMPERATURE, oF:',T40,F8.0,T60,F8.0)

      WRITE (1, 260) TT2, TS2
260   FORMAT (2X,'FLUID OUTLET TEMPERATURE, oF:',T40,F8.0,T60,F8.0)

      WRITE (1, 270) TID, SID
270   FORMAT (2X,'INSIDE DIAMETER, inch:',T40,F8.3,T60,F8.3)

      WRITE (1, 280) TOD
280   FORMAT (2X,'OUTSIDE DIAMETER, inch:',T40,F8.3)

      IF (TYPE .EQ. 'T' .OR. TYPE .EQ. 't') THEN
        WRITE (1, 290) TP
290   FORMAT (2X,'TUBE PITCH, inch:',T40,F8.3,T60,'TRIANGULAR PITCH')
      ELSEIF (TYPE .EQ. 'S' .OR. TYPE .EQ. 's') THEN
        WRITE (1, 300) TP
300   FORMAT (2X,'TUBE PITCH, inch:',T40,F8.3,T60,'SQUARE PITCH')
      ENDIF

      WRITE (1, 310) TL
310   FORMAT (2X,'TUBE LENGTH, ft.:',T40,F8.3)

      WRITE (1, 315) NT
315   FORMAT (2X,'NUMBER OF TUBES:', T40, F6.0)

      WRITE (1, 320) TNP, NS
320   FORMAT (2X,'NUMBER OF PASSES:',T40,F4.0,T60,F4.0)

      WRITE (1, 340) NB
340   FORMAT (2X,'NUMBER OF BAFFLES:',T60,F4.0)

      WRITE (1, 350) BSP
350   FORMAT (2X,'BAFFLE SPACING, inch:',T60,F4.1)

      WRITE (1, 360) TV, SV
360   FORMAT (2X,'FLUID VELOCITY, ft/sec.:',T40,F8.3,T60,F8.3)

      WRITE (1, 370) RET, RES
370   FORMAT (2X,'REYNOLDS NUMBER:',T40,F9.0,T60,F9.0)

      WRITE (1, 380) PRT, PRS
380   FORMAT (2X,'PRANDTL NUMBER:',T40,F8.4,T60,F8.4)

      WRITE (1, 390) TFRF, SFRF
390   FORMAT (2X,'FRICTION FACTOR (ft^2/in^2):',T40,F8.5,T60,F8.5)

      WRITE (1, 400) HT, HS
400   FORMAT (2X,'HEAT COEFF., Btu/hr.ft^2.oF:',T40,F9.1,T60,F9.1)

      WRITE (1, 410) TOTDP, SDELP
410   FORMAT (2X,'PRESSURE DROP, psi:',T40,F8.4,T60,F8.4)

      WRITE (1, 420) TFF, SFF
420   FORMAT (2X,'FOULING FACTOR:',T40,F8.4,T60,F8.4)

      WRITE (1, 430) F
430   FORMAT (2X,'APPROACH FACTOR, F:', T40, F8.4)

      WRITE (1, 440) LMTD
440      FORMAT (2X,'LOG MEAN TEMP. DIFF. oF:',T40,F8.2)

      WRITE (1, 450) CMTD
450      FORMAT (2X,'CORRECTED MEAN TEMP. DIFF. oF:',T40,F8.2)

      WRITE (1, 460) U
460      FORMAT (2X,'OVERALL HEAT COEFF., Btu/hr.ft^2.oF:',T40,F9.1)

      WRITE (1, 470) AREA
470      FORMAT (2X,'OUTSIDE AREA OF UNIT, ft^2:',T40,F9.1)

      WRITE (1, 480) Q
480      FORMAT (2X,'HEAT LOAD ON UNIT, Btu/hr:',T40,F12.0)

      WRITE (1, 490) Q1
490      FORMAT (2X,'HEAT TRANSFERRED, Btu/hr:',T40,F12.0)

      WRITE (1, 500)
500      FORMAT (1H,78(1H-) )

C   FORM FEED THE PRINTING PAPER TO THE TOP OF THE NEXT PAGE.

      WRITE (1, *) CHAR(12)

      RETURN
      END


MODULE sections_tools
   !!=====================================================================
   !!                       ***  MODULE  sections_tools  ***
   !!
   !! History: 2011: Clement Bricaud, Mercator-Ocean
   !!
   !!=====================================================================
   !! * Modules used
   USE declarations

   IMPLICIT NONE
   PRIVATE

   !! * Routine accessibility
   PUBLIC pointToCoordF         ! define a point with geographical coordinates
   PUBLIC distance2             ! compute distance between 2 points
   PUBLIC distance3             ! compute distance between a point and a line
   PUBLIC intersec              ! intersection between 2 lines
   PUBLIC slope_coeff           ! slope coefficient of a line
   PUBLIC qcksrt                ! organize a list of point
   PUBLIC write_debug           ! write debug messages
   PUBLIC file_open             ! open a file ( ascii, bin)

CONTAINS

  TYPE(COORD_SECTION) FUNCTION pointToCoordF(p)
     !!---------------------------------------------------------------------
     !!         ***  FUNCTION pointToCoordF  ***
     !!
     !! ** Purpose: define a point with geographical coordinates
     !!
     !!---------------------------------------------------------------------
     !! * arguments
     TYPE(POINT_SECTION), INTENT(IN) ::  p

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

     pointToCoordF = COORD_SECTION(glamf(p%I,p%J),gphif(p%I,p%J))

     RETURN

  END FUNCTION pointToCoordF

  REAL(wp) FUNCTION distance2(coordA,coordB,ld_date_line)
     !!---------------------------------------------------------------------
     !!         ***  FUNCTION distance  ***
     !!
     !! ** Purpose:compute distance between coordA and coordB
     !!            We add 360 to coordB%long if the line (coordA,coordB)
     !!            crosses the date-line.
     !!
     !!---------------------------------------------------------------------
     !! * arguments
     TYPE(COORD_SECTION), INTENT(IN) :: coordA,coordB
     LOGICAL,INTENT(IN),OPTIONAL     :: ld_date_line

     !! * Local declarations
     REAL(wp) :: zrad, zrayon
     REAL(wp) :: zpi = 3.141592653589793
     REAL(wp) :: zlam1, zlam2, zphi1, zphi2

     !-----------------------------------------------
     zrayon = 6367000.0
     zrad   = zpi/180.
     zlam1  = coordA%lon*zrad
     zlam2  = coordB%lon*zrad
     zphi1  = coordA%lat*zrad
     zphi2  = coordB%lat*zrad
     !
     !function output
     distance2=0.001*2.*zrayon *ASIN(SQRT(SIN((zphi2-zphi1)/2.0)**2.0+COS(zphi1)*COS(zphi2)*SIN((zlam2-zlam1)/2.0)**2.0) )
     !
     RETURN
  END FUNCTION distance2

  REAL(wp) FUNCTION distance3(coordA,coordB,coordC,ll_debug)
     !!---------------------------------------------------------------------
     !!         ***  FUNCTION cosinus  ***
     !!
     !! ** Purpose: compute distance between a point B and a line (AC)
     !!
     !! ** Methode: use Al-Kashi theorem
     !!
     !!              B                   A first point of the section
     !!             / \                  B intermediate point on the section
     !!            / | \                 C last point of the section
     !!           /  |  \
     !!          /   |   \               angle=ACB
     !!         /    |    \
     !!        /     |     \             distance3=Bd
     !!       /      |      \
     !!    C  -------d------- A
     !!
     !!---------------------------------------------------------------------
     !! * arguments
     TYPE(COORD_SECTION), INTENT(IN) :: coordA,coordB,coordC
     LOGICAL                         :: ll_debug

     !! * Local declarations
     REAL(wp)                        :: ztmp
     REAL(wp)                        :: za, zb, zc, zangle

     !-----------------------------------------------
     za = SQRT( (coordB%lon-coordC%lon)**2 + (coordB%lat-coordC%lat)**2 )
     zb = SQRT( (coordA%lon-coordC%lon)**2 + (coordA%lat-coordC%lat)**2 )
     zc = SQRT( (coordA%lon-coordB%lon)**2 + (coordA%lat-coordB%lat)**2 )
     !
     IF( za /= 0. .AND. zb /= 0. )THEN
        ztmp = ( za**2 + zb**2  - zc**2 ) / ( 2.0*za*zb )
        ztmp = MIN(ztmp,1.00_wp)
        IF( ztmp==1.00_wp )THEN ; zangle = 0.0
        ELSE                    ; zangle = ABS(acos(ztmp))
        ENDIF
     ELSE
        PRINT*,'You should not have this situation: za zb =',za,zb ; STOP
     ENDIF
     !
     distance3 = za*ABS(sin(zangle))
     !
     !function output
     RETURN
  END FUNCTION distance3

  REAL(wp) FUNCTION slope_coeff(coordA,coordB,ld_dateline)
     !!---------------------------------------------------------------------
     !!         ***  Function slope_coeff  ***
     !!
     !! ** Purpose: Compute slope coefficient of the line (coordA,coordB)
     !!
     !! ** Method:
     !!           Usual method :
     !!                   slope_coeff = (latB-latA)/(lonB-lonA)
     !!           Special case: the segment [A,B] crosses the date-line (lddate=T)
     !!                   slope_coeff = (latB-latA)/(360+lonB-lonA)
     !!---------------------------------------------------------------------
     !! * arguments
     TYPE(COORD_SECTION), INTENT(IN) :: coordA, coordB
     LOGICAL,INTENT(IN),OPTIONAL     :: ld_dateline

     !! * Local declarations
     REAL(wp)                        :: zcoeff
     INTEGER                         :: idateline

     !!---------------------------------------------------------
     !initialization
     zcoeff = 1.e20
     idateline=0
     IF( PRESENT( ld_dateline))THEN
       IF( ld_dateline )idateline=1
     ENDIF

     !compute slope coefficient
     IF ( coordB%lon-coordA%lon .NE. 0.) &
         zcoeff=(coordB%lat-coordA%lat)/(360*idateline+coordB%lon-coordA%lon)

     !output
     slope_coeff = zcoeff
     RETURN

  END FUNCTION slope_coeff

  TYPE(COORD_SECTION) FUNCTION intersec(sec,coord_a,coord_b)
     !!---------------------------------------------------------------------
     !!         ***  Function intersec  ***
     !!
     !! ** Purpose:Return the coordinates of the intersection point,
     !!            between segment [a,b] and the section.
     !!            If no intersection the point = -9999.
     !!
     !! ** Method:(coord_a,coord_b) => y=za2*x+zb2  (2)
     !!            sec              => y=za1*x+zb1  (1)
     !!    Intersection = (X,Y) solves (1) and (2)
     !!    Vefify that (X,Y) is in [coord_a,coord_b] AND in the section
     !!
     !! ** Action: 1. compute za1, za1
     !!            2. compute zb1, zb2
     !!            3. compute X and Y
     !!            4.Verify that (zX,zY) is in [coord_a,coord_b]
     !!              and in [sec%coordSec(1),sec%coordSec(2)]
     !!
     !! History: Author: 10/05 Matthieu Laborie
     !!          Additions:
     !!           05-2007: (C Bricaud) add special cases
     !!                                (crossing date line)
     !-----------------------------------------------------------------------------
     !! * arguments
     TYPE(SECTION), INTENT(IN)        :: sec
     TYPE(COORD_SECTION)  , INTENT(IN):: coord_a, coord_b

     !! * Local declarations
     TYPE(COORD_SECTION) :: coordInter
     REAL(wp)            :: za1,za2, &! slope coefficient
                            zb1,zb2, &!
                            zX,zY     ! coordinates of intersection
     LOGICAL             :: ll_date_line=.FALSE. !segment [a,b] crosses the date-line ?

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

     !=================!
     !0. INITALIZATION !
     !=================!
     coordInter=COORD_SECTION(-9999.,-9999.)
     ll_date_line=.FALSE.
     !we need to know if [coord_a,coord_b] crosses the date-line
     if(coord_a%lon-coord_b%lon .GT. 180)ll_date_line=.TRUE.

     !=======================!
     !1. compute za1 and za2 !
     !=======================!
     za1=sec%slopeSection
     za2=slope_coeff(coord_a,coord_b,ll_date_line)

     !=======================!
     !2. compute zb1 and zb2 !
     !=======================!

     ! Compute coefficient b for a straight line y=a*x+b
     !        Usual method:  knowing value of a, we compute b with coordinates of 1 point:
     !                       b=latA-a.lonA or b=latB-a.lonB
     !        Particular case: the straight line crosses the date line; so it is in 2 parts:
     !                         one on the left of the date-line and one the right
     !                         then,b can could have 2 values:
     ! As the date-line can be crossed by the section and the segment of the mesh [a,b],
     ! we have to check if the segment [a,b] crosses the date-line (we know it already for the
     ! section(sec%ll_date_line): ll_date_line
     ! Then, there are 4 cases for computing b1 and b2 ( sec%ll_date_line=T/F AND ll_date_line=T/F )
     !=========================================================================================!
     ! CASE A :                               !CASE C:
     ! sec%ll_date_line=T AND ll_date_line =T !sec%ll_date_line=F AND ll_date_line =T
     !                                        !     |  -180 !+180   |
     ! this case doesn't exist                !     |       !       |
     !========================================! a___|_______!_______|__b
     !CASE B:                                 !     |       !       |
     !sec%ll_date_line=T AND ll_date_line=F   !     |       !       |
     !     \     |                            ! section  date-line  section
     !   a__\__b |                            ! b1: usual method
     !       \   |                            ! b2: depend of longitude of
     !        \  |                            !     sec%coordSec(1) et de  sec%coordSec(2)
     !         \ |                            !=================================================!
     !          \|                            !CASE D:
     !     +180  \  -180                      !sec%ll_date_line=F AND ll_date_line =F
     !           |\                           !      |       !       |
     !           | \                          !      | +180  ! -180  |
     !           |  \                         !  a___|___b   !   a___|___b
     !           |a__\__b                     !      |       !       |
     !           |    \                       !      |       !       |
     !    date-line   section                 !   section date-line section
     !b2: usual method                        !b1: usual method
     !b1: depend of longitude of a and b.     !b2: usual method
     !==========================================================================================!

     IF( sec%ll_date_line )THEN
          IF( ll_date_line )THEN
              !CASE A: this case doesn't exist
              !-------
              zb1=1.e20
              zb2=1.e20
          ELSE
              !CASE B:
              !-------
              !compute zb2:
              !zb2 = coord_b%lat - za2 * coord_b%lon = coord_a%lat - za2 * coord_a%lon
              zb2=coord_b%lat - za2 * coord_b%lon

              !compute zb1:
              IF( coord_a%lon .GT. 0 .AND. coord_b%lon .GT. 0  )THEN
                  zb1 = sec%coordSec(1)%lat - za1 * sec%coordSec(1)%lon
              ELSE
                  zb1 = sec%coordSec(2)%lat - za1 * sec%coordSec(2)%lon
              ENDIF
          ENDIF
     ELSE
          IF( ll_date_line )THEN
              !CASE C:
              !-------
              !Compute zb1:
              !zb1 = sec%coordSec(1)%lat - za1 * sec%coordSec(1)%lon
              !    = sec%coordSec(2)%lat - za1 * sec%coordSec(2)%lon
              zb1 = sec%coordSec(1)%lat - za1 * sec%coordSec(1)%lon

              !Compute zb2:
              IF( sec%coordSec(1)%lon .GT. 0 .AND. sec%coordSec(2)%lon .GT. 0 )THEN
                  zb2 = coord_a%lat - za2 * coord_a%lon
              ELSE
                  zb2 = coord_b%lat - za2 * coord_b%lon
              ENDIF
          ELSE
              !CASE D:
              !-------
              !compute zb1:
              !zb1 = sec%coordSec(1)%lat - za1 * sec%coordSec(1)%lon
              !    = sec%coordSec(2)%lat - za1 * sec%coordSec(2)%lon
              zb1 = sec%coordSec(1)%lat - za1 * sec%coordSec(1)%lon

              !compute zb2:
              !zb2 = coord_b%lat - za2 * coord_b%lon = coord_a%lat - za2 * coord_a%lon
              zb2 = coord_b%lat - za2 * coord_b%lon
          ENDIF
     ENDIF

     IF( (za1 - za2) .NE. 0) THEN
          !================================!
          !3. Compute intersection (zX,zY) !
          !================================!
          IF( za1 == 1.e20 ) THEN ! Case X=constant
              zX = sec%coordSec(1)%lon
              zY = za2 * zX + zb2
          ELSE IF ( za2 == 1.e20) THEN ! Case X=constant
              zX = coord_b%lon
              zY = za1 * zX + zb1
          ELSE ! Case zY=A*zX+B
              zX = (zb2 - zb1) / (za1 - za2)
              zY = (za1 * zX ) + zb1
          ENDIF

          !==============================================!
          !4.Verify that (zX,zY) is in [coord_a,coord_b] !
          !  and in [sec%coordSec(1),sec%coordSec(2)]    !
          !==============================================!
          !Be careful! The test is not the same for all configurations
          IF( sec%ll_date_line )THEN

              IF( ll_date_line )THEN
                  !CASE A: this case doesn't exist
                  !-------
                  coordInter=COORD_SECTION(-9999.,-9999.)
              ELSE
                  !CASE B:
                  !-------
                  IF( zX .GE. MIN(coord_a%lon,coord_b%lon ) .AND. &
                      zX .LE. MAX(coord_a%lon,coord_b%lon ) .AND. &
                      zY .GE. MIN(coord_a%lat,coord_b%lat ) .AND. &
                      zY .LE. MAX(coord_a%lat,coord_b%lat ) .AND. &
                    ((zX .LE. MIN(sec%coordSec(1)%lon,sec%coordSec(2)%lon ) .AND. &
                      zX .GE. -180) .OR.  &
                     (zX .GE. MAX(sec%coordSec(1)%lon,sec%coordSec(2)%lon ) .AND. &
                      zX .LE. 180)) .AND. &
                      zY .GE. MIN(sec%coordSec(1)%lat,sec%coordSec(2)%lat ) .AND. &
                      zY .LE. MAX(sec%coordSec(1)%lat,sec%coordSec(2)%lat ) ) THEN
                     coordInter = COORD_SECTION(zX, zY)
                  ENDIF
              ENDIF
          ELSE

              IF( ll_date_line )THEN
                  !CASE C:
                  !-------
                  IF( ((zX .LE. MIN(coord_a%lon,coord_b%lon ) .AND. &
                        zX .GE. -180 )  .OR. &
                       (zX .GE. MAX(coord_a%lon,coord_b%lon ) .AND. &
                        zX .LE. 180 )) .AND. &
                        zY .GE. MIN(coord_a%lat,coord_b%lat ) .AND. &
                        zY .LE. MAX(coord_a%lat,coord_b%lat ) .AND. &
                        zX .GE. MIN(sec%coordSec(1)%lon,sec%coordSec(2)%lon ) .AND. &
                        zX .LE. MAX(sec%coordSec(1)%lon,sec%coordSec(2)%lon ) .AND. &
                        zY .GE. MIN(sec%coordSec(1)%lat,sec%coordSec(2)%lat ) .AND. &
                        zY .LE. MAX(sec%coordSec(1)%lat,sec%coordSec(2)%lat ) ) THEN
                        coordInter = COORD_SECTION(zX, zY)
                  ENDIF
              ELSE
                  !CASE D:
                  !-------
                  IF( zX .GE. MIN(coord_a%lon,coord_b%lon ) .AND. &
                      zX .LE. MAX(coord_a%lon,coord_b%lon ) .AND. &
                      zY .GE. MIN(coord_a%lat,coord_b%lat ) .AND. &
                      zY .LE. MAX(coord_a%lat,coord_b%lat ) .AND. &
                      zX .GE. MIN(sec%coordSec(1)%lon,sec%coordSec(2)%lon ) .AND. &
                      zX .LE. MAX(sec%coordSec(1)%lon,sec%coordSec(2)%lon ) .AND. &
                      zY .GE. MIN(sec%coordSec(1)%lat,sec%coordSec(2)%lat ) .AND. &
                      zY .LE. MAX(sec%coordSec(1)%lat,sec%coordSec(2)%lat ) ) THEN
                      coordInter = COORD_SECTION(zX, zY)
                  ENDIF
              ENDIF
          ENDIF

     ENDIF

     !output
     intersec = coordInter
     RETURN

  END FUNCTION intersec

  SUBROUTINE qcksrt(arr1,arr2,n)
     !!---------------------------------------------------------------------
     !!         ***  SUBROUTINE qcksrt  ***
     !!
     !! ** Purpose : organize a list point by latitude , and after by longitude
     !!              using "numerical recipies " routine.
     !!---------------------------------------------------------------------
     !! * arguments
     INTEGER,INTENT(IN)                 :: n           ! number of points
     REAL(wp),DIMENSION(n),INTENT(INOUT):: arr1,arr2   ! longitude and latitude

     !! * Local declarations
     INTEGER , PARAMETER                :: m = 7, nstack = 500
     REAL(wp), PARAMETER                :: fm=7875.,fa=211.,fc=1663.,fmi=1./fm
     INTEGER                            :: il, ir, i, iq, ist    !local integers
     INTEGER                            :: jj                    !loop indices
     REAL(wp)                           :: zfx, za, zb           !local real
     INTEGER,DIMENSION(nstack)          :: istack(nstack)        !temp array
     !---------------------------------------------------
     ist=0
     il=1
     ir=n
     zfx=0.
     !
 10  IF( ir-il .LT. m )THEN

        DO jj = il+1,ir
           za = arr1(jj)
           zb = arr2(jj)
           DO i = jj-1,1,-1
              IF( arr1(i) .LE. za )GOTO 12
              arr1(i+1) = arr1(i)
              arr2(i+1) = arr2(i)
           ENDDO
           i=0
 12        arr1(i+1) = za
           arr2(i+1) = zb
        ENDDO
        IF( ist .EQ. 0 )RETURN
        ir  = istack(ist)
        il  = istack(ist-1)
        ist = ist-2
     ELSE
        i  = il
        jj = ir
        zfx = MOD(zfx*fa+fc,fm)
        iq = il+(ir-il+1)*(zfx*fmi)
        za  = arr1(iq)
        arr1(iq) = arr1(il)
        zb = arr2(iq)
        arr2(iq) = arr2(il)
 20     CONTINUE
 21     IF( jj .GT. 0 )THEN
           IF( za .LT. arr1(jj) )THEN
              jj = jj-1
              GOTO 21
           ENDIF
        ENDIF
        IF( jj .LE. i )THEN
           arr1(i) = za
           arr2(i) = zb
           GOTO 30
        ENDIF
        arr1(i) = arr1(jj)
        arr2(i) = arr2(jj)
        i=i+1
 22     IF( i .LE. n )THEN
           IF( za .GT. arr1(i) )THEN
              i = i+1
              GOTO 22
           ENDIF
        ENDIF
        IF( jj .LE.i )THEN
           arr1(jj) = za
           arr2(jj) = zb
           i        = jj
           GOTO 30
        ENDIF
        arr1(jj) = arr1(i)
        arr2(jj) = arr2(i)
        jj = jj - 1
        GOTO 20
 30     ist = ist + 2
        IF( ist .GT. nstack )PAUSE 'nstack too small'
        IF( ir-i .GE. i-1 )THEN
           istack(ist  ) = ir
           istack(ist-1) = i + 1
           ir = i-1
        ELSE
           istack(ist  ) = i-1
           istack(ist-1) = il
           il = i+1
        ENDIF
     ENDIF
     GOTO 10
  END SUBROUTINE qcksrt

  SUBROUTINE write_debug(ksec,cd_write)
     !!---------------------------------------------------------------------
     !!         ***  SUBROUTINE write_debug  ***
     !!
     !! ** Purpose: write debug messages
     !!
     !!---------------------------------------------------------------------
     !! * arguments
     INTEGER           :: ksec       !number of section
     CHARACTER(len=*)  :: cd_write   !message to write

     !! * Local declarations
     INTEGER           :: iunit
     LOGICAL           :: llok
     CHARACTER(len=80) :: clfilename

     !!---------------------------------------------------------------------
     IF( ksec == nsecdebug .OR. nsecdebug == -1 )THEN

        !open / verify is debug output file is open

        clfilename=TRIM(secs(ksec)%name)//"_debug"
        iunit = num_sec_debug(ksec)

        IF( iunit .EQ. 0 )THEN
           PRINT*,"Open debug file: "//TRIM(clfilename)
           iunit = 100 + ksec
           num_sec_debug(ksec) = iunit

           CALL file_open(iunit,clfilename,llok,cdform="FORMATTED",cdstatus="REPLACE",cdaction="WRITE")

           IF( .NOT. llok )THEN
               PRINT*,"Can not open TRIM(clfilename)." ; STOP
           ENDIF
        ENDIF

       WRITE(iunit,*)TRIM(cd_write)

     ENDIF

  END SUBROUTINE write_debug

  SUBROUTINE file_open(knum,cdfile,ldok,cdform,cdstatus,cdaction)
     !!---------------------------------------------------------------------
     !!         ***  ROUTINE file_open ***
     !!
     !! ** Purpose: open a file
     !!
     !!---------------------------------------------------------------------
     !! * arguments
     INTEGER          ,INTENT(IN)  :: knum       ! file unit number
     CHARACTER(len=*),INTENT(IN)   :: cdfile     ! file name to open
     LOGICAL          ,INTENT(OUT) :: ldok       ! =.TRUE. if file exists and is corectly opened
     CHARACTER(len=*),INTENT(IN)   :: cdform,   &! FORM arguments for OPEN function
                                      cdstatus, &! STATUS arguments for OPEN function
                                      cdaction   ! ACTION arguments for OPEN function

     !! * Local declarations
     INTEGER :: iost
     LOGICAL :: llbon=.FALSE. !check existence of file
     !!---------------------------------------------------------------------
     ldok = .FALSE.                        ! initialization; file not found and not opened

     !check presence of file
     IF( cdstatus .EQ. "OLD" ) THEN
        INQUIRE( FILE=cdfile, EXIST=llbon ) ! check presence of namelist
        IF( llbon )THEN ;  PRINT*,TRIM(cdfile)//' EXISTS'
        ELSE            ;  PRINT*,TRIM(cdfile)//' NOT EXISTS' ; STOP
        ENDIF
     ENDIF

     !open file
     OPEN(UNIT=knum,FILE=TRIM(cdfile),FORM=cdform,status=cdstatus,action=cdaction,iostat=iost)
     IF ( iost == 0 )THEN
          ldok=.TRUE.
     ELSE
          PRINT*,TRIM(cdfile)//' bad opening. STOP.'; STOP
     ENDIF

  END SUBROUTINE file_open

END MODULE sections_tools


!=============================================================================!
        subroutine lhs1f3D( mat, Ah, Dh, Dhi, Vh11, ABhi, dtl, vl )
!
!  Form the LHS for the \xi direction for the three-dimensional
!  Navier-Stokes Equations using 4th order differencing.
!
!=============================================================================!
        use global
        use buffer
        use stencil
        implicit none

        complex :: mat(5,ndof,ndof,nx,ny), vl(ndof,nx,ny)
        real    :: Ah(ndof,ndof,nx,ny), Dh(ndof,ndof,nx,ny)
        real    :: Dhi(ndof,ndof,nx,ny), Vh11(6,nx,ny), ABhi(6,nx,ny)
        real    :: dtl(nx,ny)

!.... first derivative operator

        real    :: a1, a2, a3, a4, a5
        real    :: b1, b2, b3, b4, b5
        complex :: c1, c2, c3, c4, c5

        integer :: i, j, idof, jdof
        logical :: calcd
!=============================================================================!
!       if ( mod(real(istep-1+iter),two) .eq. zero ) then
          calcd = .true.
!       else
!         calcd = .false.
!       end if
!       write(88,*) 'lhs1f3D: ',istep, iter, calcd

!.... fourth-order stencil

        a1 = alfa * ga1  / dxi
        a2 = alfa * ga2  / dxi
        a3 = alfa * zero / dxi
        a4 = alfa * ga3  / dxi
        a5 = alfa * ga4  / dxi

        b1 = alfa * da1 / dxi**2
        b2 = alfa * da2 / dxi**2
        b3 = alfa * da3 / dxi**2
        b4 = alfa * da4 / dxi**2
        b5 = alfa * da5 / dxi**2

        c1 = im * alfa * ga1  / dxi
        c2 = im * alfa * ga2  / dxi
        c3 = im * alfa * zero / dxi
        c4 = im * alfa * ga3  / dxi
        c5 = im * alfa * ga4  / dxi

        !$omp parallel do private (i,idof,jdof)
        loop_j: do j = 1, ny
        loop_i: do i = 1, nx

!.... \hat{A} term

        do idof = 1, ndof
          do jdof = 1, ndof
            mat(1,idof,jdof,i,j) = a1 * dtl(i,j) * Ah(idof,jdof,i,j)
            mat(2,idof,jdof,i,j) = a2 * dtl(i,j) * Ah(idof,jdof,i,j)
            mat(3,idof,jdof,i,j) = a3 * dtl(i,j) * Ah(idof,jdof,i,j)
            mat(4,idof,jdof,i,j) = a4 * dtl(i,j) * Ah(idof,jdof,i,j)
            mat(5,idof,jdof,i,j) = a5 * dtl(i,j) * Ah(idof,jdof,i,j)
          end do
        end do

!.... \hat{A}_i term

        mat(1,2,4,i,j) = mat(1,2,4,i,j) - c1 * dtl(i,j) * ABhi(1,i,j)
        mat(1,3,4,i,j) = mat(1,3,4,i,j) - c1 * dtl(i,j) * ABhi(2,i,j)
        mat(1,4,2,i,j) = mat(1,4,2,i,j) - c1 * dtl(i,j) * ABhi(1,i,j)
        mat(1,4,3,i,j) = mat(1,4,3,i,j) - c1 * dtl(i,j) * ABhi(2,i,j)

        mat(2,2,4,i,j) = mat(2,2,4,i,j) - c2 * dtl(i,j) * ABhi(1,i,j)
        mat(2,3,4,i,j) = mat(2,3,4,i,j) - c2 * dtl(i,j) * ABhi(2,i,j)
        mat(2,4,2,i,j) = mat(2,4,2,i,j) - c2 * dtl(i,j) * ABhi(1,i,j)
        mat(2,4,3,i,j) = mat(2,4,3,i,j) - c2 * dtl(i,j) * ABhi(2,i,j)

        mat(3,2,4,i,j) = mat(3,2,4,i,j) - c3 * dtl(i,j) * ABhi(1,i,j)
        mat(3,3,4,i,j) = mat(3,3,4,i,j) - c3 * dtl(i,j) * ABhi(2,i,j)
        mat(3,4,2,i,j) = mat(3,4,2,i,j) - c3 * dtl(i,j) * ABhi(1,i,j)
        mat(3,4,3,i,j) = mat(3,4,3,i,j) - c3 * dtl(i,j) * ABhi(2,i,j)

        mat(4,2,4,i,j) = mat(4,2,4,i,j) - c4 * dtl(i,j) * ABhi(1,i,j)
        mat(4,3,4,i,j) = mat(4,3,4,i,j) - c4 * dtl(i,j) * ABhi(2,i,j)
        mat(4,4,2,i,j) = mat(4,4,2,i,j) - c4 * dtl(i,j) * ABhi(1,i,j)
        mat(4,4,3,i,j) = mat(4,4,3,i,j) - c4 * dtl(i,j) * ABhi(2,i,j)

        mat(5,2,4,i,j) = mat(5,2,4,i,j) - c5 * dtl(i,j) * ABhi(1,i,j)
        mat(5,3,4,i,j) = mat(5,3,4,i,j) - c5 * dtl(i,j) * ABhi(2,i,j)
        mat(5,4,2,i,j) = mat(5,4,2,i,j) - c5 * dtl(i,j) * ABhi(1,i,j)
        mat(5,4,3,i,j) = mat(5,4,3,i,j) - c5 * dtl(i,j) * ABhi(2,i,j)

        if (calcd) then

!.... \hat{D} term

          do idof = 1, ndof
            do jdof = 1, ndof
              mat(3,idof,jdof,i,j) = mat(3,idof,jdof,i,j) + &
                                     alfa * dtl(i,j) * Dh(idof,jdof,i,j)
            end do
          end do

!.... \hat{D}_i term

          do idof = 1, ndof
            do jdof = 1, ndof
              mat(3,idof,jdof,i,j) = mat(3,idof,jdof,i,j) + &
                                     im * alfa * dtl(i,j) * Dhi(idof,jdof,i,j)
            end do
          end do

        end if

!.... \hat{V}_{\xi\xi} term

        mat(1,2,2,i,j) = mat(1,2,2,i,j) - b1 * dtl(i,j) * Vh11(1,i,j)
        mat(1,2,3,i,j) = mat(1,2,3,i,j) - b1 * dtl(i,j) * Vh11(5,i,j)
        mat(1,3,2,i,j) = mat(1,3,2,i,j) - b1 * dtl(i,j) * Vh11(6,i,j)
        mat(1,3,3,i,j) = mat(1,3,3,i,j) - b1 * dtl(i,j) * Vh11(2,i,j)
        mat(1,4,4,i,j) = mat(1,4,4,i,j) - b1 * dtl(i,j) * Vh11(3,i,j)
        mat(1,5,5,i,j) = mat(1,5,5,i,j) - b1 * dtl(i,j) * Vh11(4,i,j)

        mat(2,2,2,i,j) = mat(2,2,2,i,j) - b2 * dtl(i,j) * Vh11(1,i,j)
        mat(2,2,3,i,j) = mat(2,2,3,i,j) - b2 * dtl(i,j) * Vh11(5,i,j)
        mat(2,3,2,i,j) = mat(2,3,2,i,j) - b2 * dtl(i,j) * Vh11(6,i,j)
        mat(2,3,3,i,j) = mat(2,3,3,i,j) - b2 * dtl(i,j) * Vh11(2,i,j)
        mat(2,4,4,i,j) = mat(2,4,4,i,j) - b2 * dtl(i,j) * Vh11(3,i,j)
        mat(2,5,5,i,j) = mat(2,5,5,i,j) - b2 * dtl(i,j) * Vh11(4,i,j)

        mat(3,2,2,i,j) = mat(3,2,2,i,j) - b3 * dtl(i,j) * Vh11(1,i,j)
        mat(3,2,3,i,j) = mat(3,2,3,i,j) - b3 * dtl(i,j) * Vh11(5,i,j)
        mat(3,3,2,i,j) = mat(3,3,2,i,j) - b3 * dtl(i,j) * Vh11(6,i,j)
        mat(3,3,3,i,j) = mat(3,3,3,i,j) - b3 * dtl(i,j) * Vh11(2,i,j)
        mat(3,4,4,i,j) = mat(3,4,4,i,j) - b3 * dtl(i,j) * Vh11(3,i,j)
        mat(3,5,5,i,j) = mat(3,5,5,i,j) - b3 * dtl(i,j) * Vh11(4,i,j)

        mat(4,2,2,i,j) = mat(4,2,2,i,j) - b4 * dtl(i,j) * Vh11(1,i,j)
        mat(4,2,3,i,j) = mat(4,2,3,i,j) - b4 * dtl(i,j) * Vh11(5,i,j)
        mat(4,3,2,i,j) = mat(4,3,2,i,j) - b4 * dtl(i,j) * Vh11(6,i,j)
        mat(4,3,3,i,j) = mat(4,3,3,i,j) - b4 * dtl(i,j) * Vh11(2,i,j)
        mat(4,4,4,i,j) = mat(4,4,4,i,j) - b4 * dtl(i,j) * Vh11(3,i,j)
        mat(4,5,5,i,j) = mat(4,5,5,i,j) - b4 * dtl(i,j) * Vh11(4,i,j)

        mat(5,2,2,i,j) = mat(5,2,2,i,j) - b5 * dtl(i,j) * Vh11(1,i,j)
        mat(5,2,3,i,j) = mat(5,2,3,i,j) - b5 * dtl(i,j) * Vh11(5,i,j)
        mat(5,3,2,i,j) = mat(5,3,2,i,j) - b5 * dtl(i,j) * Vh11(6,i,j)
        mat(5,3,3,i,j) = mat(5,3,3,i,j) - b5 * dtl(i,j) * Vh11(2,i,j)
        mat(5,4,4,i,j) = mat(5,4,4,i,j) - b5 * dtl(i,j) * Vh11(3,i,j)
        mat(5,5,5,i,j) = mat(5,5,5,i,j) - b5 * dtl(i,j) * Vh11(4,i,j)

!.... I term

        mat(3,1,1,i,j) = mat(3,1,1,i,j) + one
        mat(3,2,2,i,j) = mat(3,2,2,i,j) + one
        mat(3,3,3,i,j) = mat(3,3,3,i,j) + one
        mat(3,4,4,i,j) = mat(3,4,4,i,j) + one
        mat(3,5,5,i,j) = mat(3,5,5,i,j) + one

!.... implicit damping term updated to fourth order

        if (eps_e .ne. zero) then

        mat(1,1,1,i,j) = mat(1,1,1,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb1
        mat(1,2,2,i,j) = mat(1,2,2,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb1
        mat(1,3,3,i,j) = mat(1,3,3,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb1
        mat(1,4,4,i,j) = mat(1,4,4,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb1
        mat(1,5,5,i,j) = mat(1,5,5,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb1

        mat(2,1,1,i,j) = mat(2,1,1,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb2
        mat(2,2,2,i,j) = mat(2,2,2,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb2
        mat(2,3,3,i,j) = mat(2,3,3,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb2
        mat(2,4,4,i,j) = mat(2,4,4,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb2
        mat(2,5,5,i,j) = mat(2,5,5,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb2

        mat(3,1,1,i,j) = mat(3,1,1,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb3
        mat(3,2,2,i,j) = mat(3,2,2,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb3
        mat(3,3,3,i,j) = mat(3,3,3,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb3
        mat(3,4,4,i,j) = mat(3,4,4,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb3
        mat(3,5,5,i,j) = mat(3,5,5,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb3

        mat(4,1,1,i,j) = mat(4,1,1,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb4
        mat(4,2,2,i,j) = mat(4,2,2,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb4
        mat(4,3,3,i,j) = mat(4,3,3,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb4
        mat(4,4,4,i,j) = mat(4,4,4,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb4
        mat(4,5,5,i,j) = mat(4,5,5,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb4

        mat(5,1,1,i,j) = mat(5,1,1,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb5
        mat(5,2,2,i,j) = mat(5,2,2,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb5
        mat(5,3,3,i,j) = mat(5,3,3,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb5
        mat(5,4,4,i,j) = mat(5,4,4,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb5
        mat(5,5,5,i,j) = mat(5,5,5,i,j) + alfa * dtl(i,j)*eps_e*buff(i,j)*fb5

        end if

!.... sponge

        if (.not. calcd) then

        if (ispg .eq. 1) then

          mat(3,1,1,i,j) = mat(3,1,1,i,j) + alfa * dtl(i,j) * spg(i,j)
          mat(3,2,2,i,j) = mat(3,2,2,i,j) + alfa * dtl(i,j) * spg(i,j)
          mat(3,3,3,i,j) = mat(3,3,3,i,j) + alfa * dtl(i,j) * spg(i,j)
          mat(3,4,4,i,j) = mat(3,4,4,i,j) + alfa * dtl(i,j) * spg(i,j)
          mat(3,5,5,i,j) = mat(3,5,5,i,j) + alfa * dtl(i,j) * spg(i,j)

        else if (ispg .ge. 2) then

          mat(3,1,1,i,j) = mat(3,1,1,i,j) + alfa*dtl(i,j)*(spg(i,j)+spg2(i,j))
          mat(3,2,2,i,j) = mat(3,2,2,i,j) + alfa*dtl(i,j)*(spg(i,j)+spg2(i,j))
          mat(3,3,3,i,j) = mat(3,3,3,i,j) + alfa*dtl(i,j)*(spg(i,j)+spg2(i,j))
          mat(3,4,4,i,j) = mat(3,4,4,i,j) + alfa*dtl(i,j)*(spg(i,j)+spg2(i,j))
          mat(3,5,5,i,j) = mat(3,5,5,i,j) + alfa*dtl(i,j)*(spg(i,j)+spg2(i,j))

        end if

        end if

        end do loop_i
        end do loop_j

!.... apply boundary treatment to the LHS

        call lhsbt1f3D( mat, Ah, Dh, Dhi, Vh11, ABhi, spg, spg2, dtl, calcd )

!.... apply boundary conditions to the LHS

        call lhsbc1f3D( mat, vl, vm )

        return
        end


***
      real*8 FUNCTION eddington(mt,lum,kw)
*
*     Author : N. Giacobbo
*     Date :   19th March 2017
*
      integer kw
      real*8 mt,Xh,lum
*
*       Computes the Eddigton factor.
*       Ref: Graefener et al. 2011
*
* WR stars
      if(kw.ge.7 .and. kw.lt.10)then
         Xh = 0.d0
      else
         if(kw.eq.0 .or. kw.eq.1)then
            Xh = 0.7d0
         elseif(kw.eq.2)then
            Xh = 0.6d0
         elseif(kw.eq.3)then
            Xh = 0.5d0
         elseif(kw.eq.4)then
            Xh = 0.4d0
         elseif(kw.eq.5 .or. kw.eq.6)then
            Xh = 0.2d0
        endif
      endif

* equation (8) in Graefener+ 2011 but used in both Graenefer+ and Vink+
      eddington = 10.d0**(-4.813d0 + Log10(1.d0 + Xh) + Log10(lum) -
     &               Log10(mt))
*
      return
*
      end
***


    SUBROUTINE model_penman(evapoTranspirationPriestlyTaylor, ...)
        REAL, INTENT(IN) :: evapoTranspirationPriestlyTaylor
        ...
        evapoTranspirationPenman = evapoTranspirationPriestlyTaylor / Alpha +  &
                (1000.0 * (rhoDensityAir * specificHeatCapacityAir * VPDair *  &
                conductance / (lambdaV * (hslope + psychrometricConstant))))
    END SUBROUTINE model_penman


      SUBROUTINE DUV(NNH,DIVSC,ZETASC,LDIAG,TRIGS,ALP,DALP,ANNP1,
     $              CORSC1,CORSC2,RLAT,U,V)
C
C THIS SUBROUTINE OBTAINS CAPITAL U AND V MOMENTUM COMPONENTS FROM THE
C VORTICITY AND DIVERGENCE SPECTRAL COEFFICIENTS
C IT IS A REDUCED VERSION OF ROUTINE UV FOR A SINGLE POINT
C
C CALLED BY: EVAL
C CALLS: DFT991
C
C REVISIONS:
C 7-10-92 CHANGE TO CCM CODING CONVENTIONS (R. JAKOB)
C
C---- Model Parameters -------------------------------------------------
C
      INCLUDE 'params.i'
C
C------------ Arguments ------------------------------------------------
C
C     Input
C
C SPECTRAL TRUNCATION COEFFICIENT
      INTEGER NNH
C DIVERGENCE SPECTRAL COEFFICIENTS
      COMPLEX DIVSC(NALPH)
C VORTICITY SPECTRAL COEFFICIENTS
      COMPLEX ZETASC(NALPH)
C SPECTRAL ARRAY INDEX
      INTEGER LDIAG(0:MAXH,2)
C FOURIER COEFFICIENTS
      REAL TRIGS(MAXH+1,2)
C ASSOC. LEGENDRE POLYNOMIALS
      REAL ALP(NALPH)
C DERIV. ASSOC. LEGENDRE POLYNOMIALS
      REAL DALP(NALPH)
C LAPLACIAN SCALING FACTORS FOR U,V
      REAL ANNP1(MAXH)
C CORIOLIS COEFFICIENTS
      REAL CORSC1,CORSC2
C LATITUDE OF POINT
      REAL RLAT
C
C     Output
C
C COMPUTED EASTWARD WIND
      REAL U
C COMPUTED NORTHWARD WIND
      REAL V
C
C------ Local Variables ------------------------------------------------
C
C
      COMPLEX CMAT1(NALPH), CMAT2(NALPH),
     $        CMAT3(NALPH), CMAT4(NALPH)
      COMPLEX UTMP1(MAXH+1), UTMP2(MAXH+1),
     $        VTMP1(MAXH+1), VTMP2(MAXH+1)
      COMPLEX UCOSFC(MAXH+1),VCOSFC(MAXH+1)
C
C     TEMPORARIES
C
      INTEGER M,N,JM,JN,IS,INDEX
      REAL UCOS,VCOS,DIV
C
C----- Executable Statements -------------------------------------------
C
C     COMPUTE U AND V MOMENTUM COMPONENTS FROM VORTICITY AND DIVERGENCE
C
C     COMPUTE INTERMEDIATE QUANTITIES FOR COMPUTATIONAL EFFICIENCY
C
      DO 230 JN=0,NNH
         IS = LDIAG(JN,2)
C
         DO 220 JM=1,LDIAG(JN,1)
            M = JM-1
            N = M + JN
C
C           TERMS N=0 UNDEFINED
C
            IF (N .GT. 0) THEN
               CMAT1(IS+JM)  = ANNP1(N)*REAL(M)*CMPLX(
     $                 -AIMAG(DIVSC(IS+JM)),REAL(DIVSC(IS+JM)))
               CMAT2(IS+JM)  = ANNP1(N)*ZETASC(IS+JM)
               CMAT3(IS+JM)  = ANNP1(N)*REAL(M)*CMPLX(
     $               -AIMAG(ZETASC(IS+JM)),REAL(ZETASC(IS+JM)))
               CMAT4(IS+JM)  = ANNP1(N)*DIVSC(IS+JM)
            ENDIF
  220    CONTINUE
  230 CONTINUE
C
C     ADD CORIOLIS TERM FOR ROTATED COORDINATES
C
C     WAVE M=0, N=1
      INDEX = LDIAG(1,2)+1
      CMAT2(INDEX) = CMAT2(INDEX)-CMPLX(ANNP1(1)*CORSC1,0.0)
C     WAVE M=1, N=1
      INDEX = LDIAG(0,2)+2
      CMAT2(INDEX) = CMAT2(INDEX)-CMPLX(ANNP1(1)*CORSC2,0.0)
      CMAT3(INDEX) = CMAT3(INDEX)-CMPLX(0.0,ANNP1(1)*CORSC2)
C
C     EVEN DIAGONALS FIRST
C
      DO 280 JN=0,NNH,2
         IS = LDIAG(JN,2)
C
C     THIS DETOUR ELIMINATES NEED TO EXPLICITLY ZERO UTMP1, UTMP2, ETC.
C
         IF (JN .EQ. 0) THEN
C
C           SPECIAL HANDLING FOR N=M=0
C
            UTMP1(1) = CMPLX(0.0,0.0)
            UTMP2(1) = CMPLX(0.0,0.0)
            VTMP1(1) = CMPLX(0.0,0.0)
            VTMP2(1) = CMPLX(0.0,0.0)
            DO 250 JM=2,LDIAG(0,1)
               UTMP1(JM) = - CMAT1(JM)*ALP(JM)
               UTMP2(JM) =   CMAT2(JM)*DALP(JM)
               VTMP1(JM) = - CMAT3(JM)*ALP(JM)
               VTMP2(JM) = - CMAT4(JM)*DALP(JM)
  250       CONTINUE
         ELSE
C
C           ALL OTHER EVEN DIAGONALS
C
            DO 270 JM=1,LDIAG(JN,1)
               UTMP1(JM) = UTMP1(JM) - CMAT1(IS+JM)*ALP(IS+JM)
               UTMP2(JM) = UTMP2(JM) + CMAT2(IS+JM)*DALP(IS+JM)
               VTMP1(JM) = VTMP1(JM) - CMAT3(IS+JM)*ALP(IS+JM)
               VTMP2(JM) = VTMP2(JM) - CMAT4(IS+JM)*DALP(IS+JM)
  270       CONTINUE
         ENDIF
  280 CONTINUE
C
C     ODD DIAGONALS NEXT
C
      DO 310 JN=1,NNH,2
         IS = LDIAG(JN,2)
         DO 300 JM=1,LDIAG(JN,1)
            UTMP2(JM) = UTMP2(JM) - CMAT1(IS+JM)*ALP(IS+JM)
            UTMP1(JM) = UTMP1(JM) + CMAT2(IS+JM)*DALP(IS+JM)
            VTMP2(JM) = VTMP2(JM) - CMAT3(IS+JM)*ALP(IS+JM)
            VTMP1(JM) = VTMP1(JM) - CMAT4(IS+JM)*DALP(IS+JM)
  300    CONTINUE
  310 CONTINUE
C
C     COMBINE CONTRIBUTIONS OF EVEN AND ODD WAVENUMBERS TO OBTAIN
C     FOURIER COEFFICIENTS
C
      DO 330 JM=1,LDIAG(0,1)
         IF (RLAT .GE. 0.0) THEN
            UCOSFC(JM) = UTMP1(JM) + UTMP2(JM)
            VCOSFC(JM) = VTMP1(JM) + VTMP2(JM)
         ELSE
            UCOSFC(JM) = UTMP1(JM) - UTMP2(JM)
            VCOSFC(JM) = VTMP1(JM) - VTMP2(JM)
         ENDIF
  330 CONTINUE
C
C     CALL DFT ROUTINE FOR INVERSE TRANSFORM OF UCOS AND VCOS
C
      CALL DFT991(UCOSFC,TRIGS,MAXH,LDIAG(0,1),UCOS)
      CALL DFT991(VCOSFC,TRIGS,MAXH,LDIAG(0,1),VCOS)
C
C     RENORMALIZE WIND FIELD
C
      DIV = COS(RLAT)
      IF (DIV .NE. 0.0) THEN
         U = UCOS/DIV
         V = VCOS/DIV
      ELSE
         WRITE (0,350)
  350    FORMAT(/,' STSWM: FATAL ERROR IN ROUTINE DUV',
     $          /,' VELOCITY COMPONENTS MULTIVALUED AT POLES')
         STOP
      ENDIF
C
      RETURN
C
      END