MODULE my_functions
CONTAINS
   FUNCTION every_fifth (ptr_array) RESULT (ptr_fifth )
   !
   !  Purpose:
   !    To produce a pointer to every fifth element in an
   !    input rank one array.
   !
   !  Record of revisions:
   !      Date       Programmer          Description of change
   !      ====       ==========          =====================
   !    12/24/06    S. J. Chapman        Original code
   !
   IMPLICIT NONE

   ! Data dictionary: declare calling parameter types & definitions
   INTEGER, DIMENSION(:), POINTER :: ptr_array
   INTEGER, DIMENSION(:), POINTER :: ptr_fifth

   ! Data dictionary: declare local variable types & definitions
   INTEGER :: low           ! Array lower bound
   INTEGER :: high          ! Array upper bound

   low = LBOUND(ptr_array,1)
   high = UBOUND(ptr_array,1)
   ptr_fifth => ptr_array(low:high:5)

   END FUNCTION every_fifth
END MODULE


!-------------------------------------------------------------------------------
!> module COUPLER / Atmosphere-Land Driver
!!
!! @par Description
!!          Coupler driver: atmosphere-land
!!
!! @author Team SCALE
!!
!! @par History
!! @li      2014-02-25 (T.Yamaura)  [new]
!<
!-------------------------------------------------------------------------------
module mod_cpl_atmos_land_driver
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use scale_precision
  use scale_stdio
  use scale_grid_index
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: CPL_AtmLnd_driver_setup
  public :: CPL_AtmLnd_driver

  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
  !-----------------------------------------------------------------------------
contains

  subroutine CPL_AtmLnd_driver_setup
    use mod_atmos_phy_sf_driver, only: &
       ATMOS_PHY_SF_driver_final
    use mod_land_phy_bucket, only: &
       LAND_PHY_driver_final
    use scale_cpl_atmos_land, only: &
       CPL_AtmLnd_setup
    use mod_cpl_vars, only: &
       CPL_TYPE_AtmLnd
    implicit none
    !---------------------------------------------------------------------------

    call ATMOS_PHY_SF_driver_final
    call LAND_PHY_driver_final

    call CPL_AtmLnd_setup( CPL_TYPE_AtmLnd )
    call CPL_AtmLnd_driver( .false. )

    return
  end subroutine CPL_AtmLnd_driver_setup

  subroutine CPL_AtmLnd_driver( update_flag )
    use scale_const, only: &
       LH0  => CONST_LH0,  &
       I_SW => CONST_I_SW, &
       I_LW => CONST_I_LW
    use scale_grid_real, only: &
       CZ => REAL_CZ, &
       FZ => REAL_FZ
    use scale_cpl_atmos_land, only: &
       CPL_AtmLnd
    use mod_cpl_vars, only: &
       LST,              &
       ALBG,             &
       DENS => CPL_DENS, &
       MOMX => CPL_MOMX, &
       MOMY => CPL_MOMY, &
       MOMZ => CPL_MOMZ, &
       RHOS => CPL_RHOS, &
       PRES => CPL_PRES, &
       ATMP => CPL_ATMP, &
       QV   => CPL_QV  , &
       PREC => CPL_PREC, &
       SWD  => CPL_SWD , &
       LWD  => CPL_LWD , &
       TG   => CPL_TG,   &
       QVEF => CPL_QVEF, &
       TCS  => CPL_TCS,  &
       DZG  => CPL_DZG,  &
       Z0M  => CPL_Z0M,  &
       Z0H  => CPL_Z0H,  &
       Z0E  => CPL_Z0E,  &
       AtmLnd_XMFLX,     &
       AtmLnd_YMFLX,     &
       AtmLnd_ZMFLX,     &
       AtmLnd_SWUFLX,    &
       AtmLnd_LWUFLX,    &
       AtmLnd_SHFLX,     &
       AtmLnd_LHFLX,     &
       AtmLnd_QVFLX,     &
       Lnd_GHFLX,        &
       Lnd_PRECFLX,      &
       Lnd_QVFLX,        &
       CNT_Atm_Lnd,      &
       CNT_Lnd
    implicit none

    ! argument
    logical, intent(in) :: update_flag

    ! work
    integer :: i, j

    real(RP) :: XMFLX (IA,JA) ! x-momentum flux at the surface [kg/m2/s]
    real(RP) :: YMFLX (IA,JA) ! y-momentum flux at the surface [kg/m2/s]
    real(RP) :: ZMFLX (IA,JA) ! z-momentum flux at the surface [kg/m2/s]
    real(RP) :: SWUFLX(IA,JA) ! upward shortwave flux at the surface [W/m2]
    real(RP) :: LWUFLX(IA,JA) ! upward longwave flux at the surface [W/m2]
    real(RP) :: SHFLX (IA,JA) ! sensible heat flux at the surface [W/m2]
    real(RP) :: LHFLX (IA,JA) ! latent heat flux at the surface [W/m2]
    real(RP) :: GHFLX (IA,JA) ! ground heat flux at the surface [W/m2]

    real(RP) :: tmpX(IA,JA) ! temporary XMFLX [kg/m2/s]
    real(RP) :: tmpY(IA,JA) ! temporary YMFLX [kg/m2/s]

    real(RP) :: DZ    (IA,JA) ! height from the surface to the lowest atmospheric layer [m]
    !---------------------------------------------------------------------------

    if( IO_L ) write(IO_FID_LOG,*) '*** Coupler: Atmos-Land'

    DZ(:,:) = CZ(KS,:,:) - FZ(KS-1,:,:)

    call CPL_AtmLnd( &
      LST,                                      & ! (inout)
      XMFLX, YMFLX, ZMFLX,                      & ! (out)
      SWUFLX, LWUFLX, SHFLX, LHFLX, GHFLX,      & ! (out)
      update_flag,                              & ! (in)
      DZ, DENS, MOMX, MOMY, MOMZ,               & ! (in)
      RHOS, PRES, ATMP, QV, SWD, LWD,           & ! (in)
      TG, QVEF, ALBG(:,:,I_SW), ALBG(:,:,I_LW), & ! (in)
      TCS, DZG, Z0M, Z0H, Z0E                   ) ! (in)

    ! interpolate momentum fluxes
    do j = JS, JE
    do i = IS, IE
      tmpX(i,j) = ( XMFLX(i,j) + XMFLX(i+1,j  ) ) * 0.5_RP ! at u/y-layer
      tmpY(i,j) = ( YMFLX(i,j) + YMFLX(i,  j+1) ) * 0.5_RP ! at x/v-layer
    enddo
    enddo

    do j = JS, JE
    do i = IS, IE
      XMFLX(i,j) = tmpX(i,j)
      YMFLX(i,j) = tmpY(i,j)
      ZMFLX(i,j) = ZMFLX(i,j) * 0.5_RP ! at w-layer
    enddo
    enddo

    ! temporal average flux
    AtmLnd_XMFLX (:,:) = ( AtmLnd_XMFLX (:,:) * CNT_Atm_Lnd + XMFLX (:,:)     ) / ( CNT_Atm_Lnd + 1.0_RP )
    AtmLnd_YMFLX (:,:) = ( AtmLnd_YMFLX (:,:) * CNT_Atm_Lnd + YMFLX (:,:)     ) / ( CNT_Atm_Lnd + 1.0_RP )
    AtmLnd_ZMFLX (:,:) = ( AtmLnd_ZMFLX (:,:) * CNT_Atm_Lnd + ZMFLX (:,:)     ) / ( CNT_Atm_Lnd + 1.0_RP )
    AtmLnd_SWUFLX(:,:) = ( AtmLnd_SWUFLX(:,:) * CNT_Atm_Lnd + SWUFLX(:,:)     ) / ( CNT_Atm_Lnd + 1.0_RP )
    AtmLnd_LWUFLX(:,:) = ( AtmLnd_LWUFLX(:,:) * CNT_Atm_Lnd + LWUFLX(:,:)     ) / ( CNT_Atm_Lnd + 1.0_RP )
    AtmLnd_SHFLX (:,:) = ( AtmLnd_SHFLX (:,:) * CNT_Atm_Lnd + SHFLX (:,:)     ) / ( CNT_Atm_Lnd + 1.0_RP )
    AtmLnd_LHFLX (:,:) = ( AtmLnd_LHFLX (:,:) * CNT_Atm_Lnd + LHFLX (:,:)     ) / ( CNT_Atm_Lnd + 1.0_RP )
    AtmLnd_QVFLX (:,:) = ( AtmLnd_QVFLX (:,:) * CNT_Atm_Lnd + LHFLX (:,:)/LH0 ) / ( CNT_Atm_Lnd + 1.0_RP )

    Lnd_GHFLX  (:,:) = ( Lnd_GHFLX  (:,:) * CNT_Lnd + GHFLX(:,:)     ) / ( CNT_Lnd + 1.0_RP )
    Lnd_PRECFLX(:,:) = ( Lnd_PRECFLX(:,:) * CNT_Lnd + PREC (:,:)     ) / ( CNT_Lnd + 1.0_RP )
    Lnd_QVFLX  (:,:) = ( Lnd_QVFLX  (:,:) * CNT_Lnd - LHFLX(:,:)/LH0 ) / ( CNT_Lnd + 1.0_RP )

    CNT_Atm_Lnd = CNT_Atm_Lnd + 1.0_RP
    CNT_Lnd     = CNT_Lnd     + 1.0_RP

    return
  end subroutine CPL_AtmLnd_driver

end module mod_cpl_atmos_land_driver


subroutine rdkss(fnamekss1,fnamekss2,ipaw,npsp,nkpt,ntypat)
use kssvars
implicit none
character(80) :: fnamekss1,fnamekss2
integer :: ipaw,nkpt,ntypat
character*80 :: title1,title2
double precision :: hart,ryd
parameter (ryd=13.6056981,hart=2.d0*ryd)
integer :: ik,ib,ips,il,ipwt,ish,is,jtypat,ieof,ikn,ikwfm,jps,kat,in,ioffmx, &
& isym,ioff,jloop,npsp,iloop,i,j,k,ig,iban,ikpt,iat,ipsp,ibwfm, &
& ict,ibndt
integer :: ii,npw2,nspinor2,nbnd2,ibnd,isppol,ios,lv,lend
integer, allocatable :: occ2(:)

 open(unit=10,file=fnamekss1,status='old',form='unformatted')
 read(10) !codvsn,headform,fform

 read(10) !bantot,date,intxc,ixc,natom,ngfft(1:3),&
!& nkpt,nspden,nspinor,nsppol,nsym,npsp,ntypat,occopt,pertcase,usepaw,&
!& ecut,ecutdg,ecutsm,ecut_eff,qptn(1:3),rprimd(1:3,1:3),stmbias,tphysel,tsmear

! allocate (istwfk(nkpt),nband(nkpt*nsppol),npwarr(nkpt),so_typat(ntypat),&
!& symafm(nsym),symrel(3,3,nsym),typat(natom))
! allocate (kpt(3,nkpt),occ(bantot),tnons(3,nsym),znucltypat(ntypat), &
!& xred(3,natom))
 read(10) !istwfk(1:nkpt),nband(1:nkpt*nsppol),&
!& npwarr(1:nkpt),so_typat(1:ntypat),symafm(1:nsym),symrel(1:3,1:3,1:nsym), &
!& typat(1:natom),kpt(1:3,1:nkpt),occ(1:bantot),tnons(1:3,1:nsym), &
!& znucltypat(1:ntypat)

 do ipsp=1,npsp
! (npsp lines, 1 for each pseudopotential ; npsp=ntypat, except if alchemical pseudo-atoms)
  read(10) !title,znuclpsp,zionpsp,pspso,pspdat,pspcod,pspxc
 enddo

!(final record: residm, coordinates, total energy, Fermi energy)
 read(10) !residm,xred(1:3,1:natom),etotal,fermie

 if (ipaw.ne.0) read(10) !idummy
 if (ipaw.ne.0) read(10) !idummy

 read(10) title1(1:80)
 read(10) title2(1:80)
 read(10) nsym2,nbandkss,npwkss,ishm,mpsang
! allocate (symrel2(3,3,nsym2),tnons2(3,nsym2),gbig(3,npwkss),shlim(ishm))
 allocate (gbig(3,npwkss))
 read(10) !(((symrel2(i,j,k),i=1,3),j=1,3),k=1,nsym2)
 read(10) !((tnons2(i,k),i=1,3),k=1,nsym2)
 read(10) ((gbig(i,ig),i=1,3),ig=1,npwkss)
 read(10) !(shlim(in),in=1,ishm)

! allocate (vkbsign(ntypat,mpsang),vkb(npwkss,ntypat,mpsang,nkpt), &
!& vkbd(npwkss,ntypat,mpsang,nkpt))
 allocate (en(nkpt,nbandkss),wfg(npwkss,nbandkss,nkpt))
 read(10) !((vkbsign(is,il),il=1,mpsang),is=1,ntypat)
 do ik=1,nkpt
   do is=1,ntypat
     do il=1,mpsang
       read(10) !(vkb(ig,is,il,ik),ig=1,npwkss)
       read(10) !(vkbd(ig,is,il,ik),ig=1,npwkss)
     end do
   end do
   read(10) (en(ik,ib),ib=1,nbandkss)
   do ib=1,nbandkss
     read(10) (wfg(ig,ib,ik),ig=1,npwkss)
   end do
 end do

! deallocate (symrel2,tnons2,shlim,vkbsign,vkb,vkbd)

 close(10)

 return
end subroutine rdkss


! -*- mode: F90; mode: font-lock -*-
! ------------------------------------------------------------------------------
! $Id$
! ------------------------------------------------------------------------------
! Conquest: O(N) DFT
! ------------------------------------------------------------------------------
! Code area 9: general
! ------------------------------------------------------------------------------

!!****h* Conquest/Conquest *
!!
!!  NAME
!!   Conquest
!!  PURPOSE
!!   Main routine for the Conquest code
!!  USES
!!   common, dimens, logicals, numbers, matrix_data,
!!   pseudopotential_data, global_module, mpi, io_module
!!  AUTHOR
!!   D.R.Bowler
!!  CREATION DATE
!!   Way, way back in the deep history of Conquest - 1995 or so
!!  MODIFICATION HISTORY
!!   07/05/01 by DRB
!!    Added ROBODoc header, changed indentation
!!   28/05/2001 dave
!!    Changed ROBODoc header to a module so that it shows up at the top :)
!!    Stripped control call
!!   29/05/2001 dave
!!    Stripped initialise call
!!    Stripped and inserted main.inc
!!   31/05/2001 dave
!!    Added RCS Id tag to header
!!   07/06/2001 dave
!!    Added use fft_module, datatypes and removed includes and mpi
!!    Also changed comms to cq_init and cq_exit
!!   13/06/2001 dave
!!    Changed call to cq_init to use numprocs
!!   15/03/2002 dave
!!    Added RCS id tag for object file identification and tidied
!!    comment structure a little (added header)
!!   15:20, 25/09/2002 mjg & drb
!!    Changed so that the variable density is used from density_module
!!   12:43, 04/02/2003 drb
!!    Changed to use init_comms and end_comms from GenComms
!!   13:50, 10/02/2003 drb
!!    Changed to use control_run
!!   15:01, 12/03/2003 drb
!!    Removed reference to workspace
!!   10:18, 2004/01/09 dave
!!    Added use pseudopotential_common
!!   2008/02/06 08:21 dave
!!    Changed for output to file not stdout
!!   2011/12/11 L.Tong
!!    Removed redundant variable number_of_bands, use ne_in_cell
!!    instead
!!   2012/03/27 L.Tong
!!   - Changed spin implementation
!!   - updated some calls that no longer passes mu
!!   2016/01/28 16:45 dave
!!    Updated module name to ion_electrostatic
!!   2019/12/24 tsuyoshi
!!    Removed flag_atomic_density_from_pao
!!  SOURCE
!!
program Conquest

  use datatypes
  use blip
  use dimens
  use logicals
  use numbers
  use matrix_data
  use group_module
  use primary_module
  use cover_module
  use mult_module
  use pseudopotential_data
  use pseudopotential_common
  use pseudo_tm_info, only: pseudo
  use pao_format,     only: pao
  use initialisation
  use potential_module
  use global_module
  use force_module,   only: tot_force
  use grid_index
  use atoms
  use species_module
  use fft_module
  use GenComms
  use density_module, only: density
  use control,        only: control_run
  use support_spec_format
  use ol_int_datatypes
  use functions_on_grid
  use ion_electrostatic
  use DiagModule
  use ScalapackFormat
  use atomic_density, only: atomic_density_table, rcut_dens
  use block_module,   only: nx_in_block,ny_in_block,nz_in_block, &
                            n_pts_in_block
  use memory_module
  use minimise
  use timer_stdclocks_module
  !use output_module
  !use complete_module

  implicit none

  ! RCS tag for object file identification
  character(len=80), save :: &
       CQid = "$Id$"

  ! Global variables (for now !)
  logical      :: fixed_potential

  ! Energies and electrons
  real(double) :: total_energy

  ! Chemical potential
  real(double) :: mu
  logical      :: vary_mu

  fixed_potential = .false.
  ! identify what node we are on
  call init_comms(myid, numprocs)

  ! Initialise reads in data and finds an initial, self-consistent
  ! Hamiltonian
  call initialise(vary_mu, fixed_potential, mu, total_energy)
  if (inode == ionode .and. iprint_gen > 0) &
       write (io_lun, '(4x,"Finished initialise")')

  ! control does (at the moment) blip minimisation and simple MD
  call control_run(fixed_potential, vary_mu, total_energy)
  if (inode == ionode .and. iprint_gen > 0) &
       write (io_lun, '(4x,"Finished control")')

  call write_mem_use

  call print_time_report

  !**<lat>** as initialise routine we may need a complete routine
  !          cheking if everything is fine before ending ; write_mem_use
  !          and print_time_report can be within this routine
  !call complete()
  !call close_user_output()

  ! Wrap up
  call my_barrier ()
  !call save_state( inode, ionode, mu, expected_reduction, n_run, output_file)
  !call save_blip(inode, ionode)
  call end_comms ()

end program Conquest
!!*****


      SUBROUTINE HSPLI (KF, KP1,KP2)
C...This subroutine splits one hadron of code KF
C.  into 2 partons of code KP1 and KP2
C.  KP1 refers to a color triplet [q or (qq)bar]
C.  KP2 to a a color anti-triplet [qbar or (qq)]
C.  allowed inputs:
C.  KF = 6:14 pi0,pi+-,k+-,k0L,k0s, p,n
C.     = -13,-14  pbar,nbar
C.     = 34 Sigma+
C.     = 35/39 Sigma0/Lambda0
C.     = 36    Sigma-
C.     = 37    Xi0
C.     = 38    Xi-
C-------------------------------------------------
      SAVE

      Select case(IABS(KF))

      Case (6)                  ! pi0
        R = S_RNDM(0)
        IF (R.LE.0.)  THEN
           KP1 = 1
           KP2 = -1
        ELSE
          KP1 = 2
          KP2 = -2
        ENDIF
      Case (7)                  ! pi+
        KP1 = 1
        KP2 = -2
      Case (8)                  ! pi-
        KP1 = 2
        KP2 = -1
      Case (9)                  ! K+
        KP1 = 1
        KP2 = -3
      Case (10)                  ! K-
        KP1 = 3
        KP2 = -1
      Case (11,12)                  ! K0S/K0L
        KP1 = 2
        KP2 = -3
        IF (S_RNDM(0).GT. 0.5)  THEN
          KP1 = 3
          KP2 = -2
        ENDIF
      Case (13)                  ! p/pbar
        R = 6.*S_RNDM(0)
        IF (R .LT.3.)       THEN
          KP1 = 1
          KP2 = 12
        ELSEIF (R .LT. 4.)  THEN
          KP1 = 1
          KP2 = 21
        ELSE
          KP1 = 2
          KP2 = 11
        ENDIF
      Case (14)                 ! n/nbar
        R = 6.*S_RNDM(0)
        IF (R .LT.3.)       THEN
           KP1 = 2
           KP2 = 12
        ELSEIF (R .LT. 4.)  THEN
          KP1 = 2
          KP2 = 21
        ELSE
          KP1 = 1
          KP2 = 22
        ENDIF
      Case (34)                 !Sigma+
        R = 6.*S_RNDM(0)
        IF (R .LT.3.)       THEN
           KP1 = 3
           KP2 = 11
        ELSEIF (R .LT. 4.)  THEN
          KP1 = 1
          KP2 = 31
        ELSE
          KP1 = 1
          KP2 = 13
        ENDIF
      Case (35,39)              !Sigma0/Lambda0
        R = 6.*S_RNDM(0)
        IF (R .LT.3.)       THEN
           KP1 = 3
           KP2 = 21
        ELSEIF (R .LT. 4.)  THEN
          KP1 = 1
          KP2 = 32
        ELSE
          KP1 = 2
          KP2 = 13
        ENDIF
      Case (36)                 !Sigma-
        R = 6.*S_RNDM(0)
        IF (R .LT.3.)       THEN
           KP1 = 3
           KP2 = 22
        ELSEIF (R .LT. 4.)  THEN
          KP1 = 2
          KP2 = 32
        ELSE
          KP1 = 2
          KP2 = 23
        ENDIF
      Case (37)                 !Xi0
        R = 6.*S_RNDM(0)
        IF (R .LT.3.)       THEN
           KP1 = 1
           KP2 = 33
        ELSEIF (R .LT. 4.)  THEN
          KP1 = 3
          KP2 = 13
        ELSE
          KP1 = 1
          KP2 = 33
        ENDIF
      Case (38)                 !Xi-
        R = 6.*S_RNDM(0)
        IF (R .LT.3.)       THEN
           KP1 = 2
           KP2 = 33
        ELSEIF (R .LT. 4.)  THEN
          KP1 = 3
          KP2 = 23
        ELSE
          KP1 = 2
          KP2 = 33
        ENDIF
      Case Default
C...Test for good input
        WRITE(6,*)
     &      'HSPLI : Routine entered with illegal particle code ',KF
        STOP ! This has to be replaced by the usual SIBYLL exception if exists.
      End Select

C if anti-baryon, invert valences
      IF (KF .LT. 0) THEN
        KPP = KP1
        KP1 = -KP2
        KP2 = -KPP
      ENDIF
      RETURN
      END


!-------------------------------------------------------------------------------
!> module LAND / Physics Bucket
!!
!! @par Description
!!          bucket-type land physics module
!!
!! @author Team SCALE
!! @li      2013-08-31 (T.Yamaura)  [new]
!<
!-------------------------------------------------------------------------------
module mod_land_phy_bucket
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use scale_precision
  use scale_stdio
  use scale_prof
  use scale_grid_index
  use scale_land_grid_index
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: LAND_PHY_driver_setup
  public :: LAND_PHY_driver_first
  public :: LAND_PHY_driver_final

  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !

  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
  !-----------------------------------------------------------------------------
  logical, private, save :: LAND_LKE_STRG_UPDATE = .false. ! is STRG updated in the lowest level?
  logical, private, save :: LAND_LKE_TG_UPDATE   = .false. ! is TG updated in the lowest level?

  real(RP), private, save, allocatable :: GHFLX  (:,:)
  real(RP), private, save, allocatable :: PRECFLX(:,:)
  real(RP), private, save, allocatable :: QVFLX  (:,:)

  ! limiter
  real(RP), private, parameter :: BETA_MAX = 1.0_RP

contains
  !-----------------------------------------------------------------------------
  !> Setup
  subroutine LAND_PHY_driver_setup
    use scale_process, only: &
       PRC_MPIstop
    use mod_land_vars, only: &
       LAND_TYPE_PHY
    implicit none

    logical  :: dummy

    NAMELIST / PARAM_LAND_BUCKET / &
       LAND_LKE_STRG_UPDATE, &
       LAND_LKE_TG_UPDATE

    integer :: ierr
    !---------------------------------------------------------------------------

    if( IO_L ) write(IO_FID_LOG,*)
    if( IO_L ) write(IO_FID_LOG,*) '+++ Module[BUCKET]/Categ[LAND]'

    allocate( GHFLX  (IA,JA) )
    allocate( PRECFLX(IA,JA) )
    allocate( QVFLX  (IA,JA) )

    if ( LAND_TYPE_PHY /= 'BUCKET' ) then
       if( IO_L ) write(IO_FID_LOG,*) 'xxx LAND_TYPE_PHY is not BUCKET. Check!'
       call PRC_MPIstop
    endif

    !--- read namelist
    rewind(IO_FID_CONF)
    read(IO_FID_CONF,nml=PARAM_LAND_BUCKET,iostat=ierr)

    if( ierr < 0 ) then !--- missing
       if( IO_L ) write(IO_FID_LOG,*) '*** Not found namelist. Default used.'
    elseif( ierr > 0 ) then !--- fatal error
       write(*,*) 'xxx Not appropriate names in namelist PARAM_LAND_BUCKET. Check!'
       call PRC_MPIstop
    endif
    if( IO_L ) write(IO_FID_LOG,nml=PARAM_LAND_BUCKET)

    return
  end subroutine LAND_PHY_driver_setup

  !-----------------------------------------------------------------------------
  !> Physical processes for land submodel
  subroutine LAND_PHY_driver_first
    use scale_const, only: &
       DWATR => CONST_DWATR, &
       CL    => CONST_CL
    use scale_time, only: &
       dt => TIME_DTSEC_LAND
    use scale_land_grid, only: &
       dz => GRID_LCDZ
    use mod_land_vars, only: &
       TG,                 &
       STRG,               &
       ROFF,               &
       QVEF,               &
       I_STRGMAX,          &
       I_STRGCRT,          &
       I_TCS,              &
       I_HCS,              &
       I_DFW,              &
       P => LAND_PROPERTY, &
       LAND_vars_fillhalo
    use mod_cpl_vars, only: &
       CPL_getCPL2Lnd
    implicit none

    ! work
    integer :: k, i, j

    real(RP) :: ov(LKS:LKE-1)
    real(RP) :: iv(LKS:LKE-1)
    real(RP) :: ld(LKS:LKE-1)
    real(RP) :: md(LKS:LKE-1)
    real(RP) :: ud(LKS:LKE-1)
    !---------------------------------------------------------------------------

    if( IO_L ) write(IO_FID_LOG,*) '*** Land step: Bucket'

    call CPL_getCPL2Lnd( GHFLX  (:,:), & ! [OUT]
                         PRECFLX(:,:), & ! [OUT]
                         QVFLX  (:,:)  ) ! [OUT]

    do j = JS, JE
    do i = IS, IE
      ! prepare to solve tridiagonal matrix for STRG
      ld(:) = 0.0_RP
      md(:) = 0.0_RP
      ud(:) = 0.0_RP

      do k = LKS+1, LKE-1
        ld(k) = -2.0_RP * dt * P(i,j,I_DFW) / ( dz(k) * ( dz(k) + dz(k-1) ) )
      end do
      do k = LKS, LKE-1
        ud(k) = -2.0_RP * dt * P(i,j,I_DFW) / ( dz(k) * ( dz(k) + dz(k+1) ) )
        md(k) = 1.0_RP - ld(k) - ud(k)
      end do

      iv(:)     = STRG(LKS:LKE-1,i,j)
      iv(LKS)   = STRG(LKS,i,j) + ( PRECFLX(i,j) + QVFLX(i,j) ) * dt
      iv(LKE-1) = STRG(LKE-1,i,j) - ud(LKE-1) * STRG(LKE,i,j)

      call solve_tridiagonal_matrix( &
        ov(:),                     & ! (out)
        iv(:), ld(:), md(:), ud(:) ) ! (in)

      ! update water storage
      STRG(LKS:LKE-1,i,j) = ov(:)

      ! update lowest STRG
      if( LAND_LKE_STRG_UPDATE ) then
        STRG(LKE,i,j) = STRG(LKE-1,i,j)
      end if

      ! modify STRG to the upper limit
      do k = LKS, LKE
        if( STRG(k,i,j) > P(i,j,I_STRGMAX) ) then
          ! update vertically integral run-off water
          ROFF(i,j)   = ROFF(i,j) + STRG(k,i,j) - P(i,j,I_STRGMAX)
          STRG(k,i,j) = P(i,j,I_STRGMAX)
        end if
      end do

      ! update moisture efficiency
      QVEF(i,j) = min( STRG(LKS,i,j)/P(i,j,I_STRGCRT), BETA_MAX )

      ! prepare to solve tridiagonal matrix for TG
      ld(:) = 0.0_RP
      md(:) = 0.0_RP
      ud(:) = 0.0_RP

      do k = LKS+1, LKE-1
        ld(k) = -2.0_RP * dt * P(i,j,I_TCS) / ( dz(k) * ( dz(k) + dz(k-1) ) ) &
              / ( ( 1.0_RP - P(i,j,I_STRGMAX) / dz(k) * 1.0E-3_RP ) * P(i,j,I_HCS) & ! heat capacity for soil
                + STRG(k,i,j) / dz(k) * 1.0E-3_RP * DWATR * CL ) ! heat capacity for water
      end do
      do k = LKS, LKE-1
        ud(k) = -2.0_RP * dt * P(i,j,I_TCS) / ( dz(k) * ( dz(k) + dz(k+1) ) ) &
              / ( ( 1.0_RP - P(i,j,I_STRGMAX) / dz(k) * 1.0E-3_RP ) * P(i,j,I_HCS) & ! heat capacity for soil
                + STRG(k,i,j) / dz(k) * 1.0E-3_RP * DWATR * CL ) ! heat capacity for water
        md(k) = 1.0_RP - ld(k) - ud(k)
      end do

      iv(:)     = TG(LKS:LKE-1,i,j)
      iv(LKS)   = TG(LKS,i,j) - dt * 2.0_RP * GHFLX(i,j) / dz(k) &
                / ( ( 1.0_RP - P(i,j,I_STRGMAX) / dz(LKS) * 1.0E-3_RP ) * P(i,j,I_HCS) & ! heat capacity for soil
                  + STRG(LKS,i,j) / dz(LKS) * 1.0E-3_RP * DWATR * CL ) ! heat capacity for water
      iv(LKE-1) = TG(LKE-1,i,j) - ud(LKE-1) * TG(LKE,i,j)

      call solve_tridiagonal_matrix( &
        ov(:),                     & ! (out)
        iv(:), ld(:), md(:), ud(:) ) ! (in)

      ! update ground temperature
      TG(LKS:LKE-1,i,j) = ov(:)

      ! update lowest TG
      if( LAND_LKE_TG_UPDATE ) then
        TG(LKE,i,j) = TG(LKE-1,i,j)
      end if

    end do
    end do

    call LAND_vars_fillhalo

    return
  end subroutine LAND_PHY_driver_first

  subroutine LAND_PHY_driver_final
    use scale_land_grid, only: &
       dz => GRID_LCDZ
    use mod_land_vars, only: &
       TG,                 &
       QVEF,               &
       I_TCS,              &
       I_Z0M,              &
       I_Z0H,              &
       I_Z0E,              &
       P => LAND_PROPERTY
    use mod_cpl_vars, only: &
       CPL_putLnd
    implicit none

    real(RP) :: dz_h(IA,JA)
    !---------------------------------------------------------------------------

    dz_h(:,:) = dz(LKS)

    call CPL_putLnd( TG  (LKS,:,:),    & ! [IN]
                     QVEF(:,:),        & ! [IN]
                     P   (:,:,I_TCS),  & ! [IN]
                     dz_h(:,:),        & ! [IN]
                     P   (:,:,I_Z0M),  & ! [IN]
                     P   (:,:,I_Z0H),  & ! [IN]
                     P   (:,:,I_Z0E)   ) ! [IN]

    return
  end subroutine LAND_PHY_driver_final

  ! solve tridiagonal matrix with Thomas's algorithm
  subroutine solve_tridiagonal_matrix( &
      ov,            & ! (out)
      iv, ld, md, ud ) ! (in)
    implicit none

    ! argument
    real(RP), intent(out) :: ov(:) ! output vector

    real(RP), intent(in) :: iv(:) ! input vector
    real(RP), intent(in) :: ld(:) ! lower diagonal
    real(RP), intent(in) :: md(:) ! middle diagonal
    real(RP), intent(in) :: ud(:) ! upper diagonal

    ! work
    integer :: n, k

    real(RP) :: a(size(ld))
    real(RP) :: b(size(md))
    real(RP) :: c(size(ud))
    real(RP) :: d(size(iv))
    real(RP) :: tmp
    !---------------------------------------------------------------------------

    ! maximum array size
    n = size( ov(:) )

    ! initialize
    a(:) = ld(:)
    b(:) = md(:)
    c(:) = ud(:)
    d(:) = iv(:)

    c(1) = c(1) / b(1)
    d(1) = d(1) / b(1)

    ! foward reduction
    do k = 2, n
      tmp  = b(k) - a(k) * c(k-1)
      c(k) = c(k) / tmp
      d(k) = ( d(k) - a(k) * d(k-1) ) / tmp
    end do

    ! backward substitution
    ov(n) = d(n)
    do k = n-1, 1, -1
      ov(k) = d(k) - c(k) * ov(k+1)
    end do

    return
  end subroutine solve_tridiagonal_matrix

end module mod_land_phy_bucket


PROGRAM test_cycle_2
INTEGER :: i, j, product
outer: DO i = 1, 3
   inner: DO j = 1, 3
      IF ( j == 2) CYCLE outer
      product = i * j
      WRITE (*,*) i, ' * ', j, ' = ', product
   END DO inner
END DO outer
END PROGRAM