ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c Check the window W for data gaps, and replaces these gaps with -998 DN.

c The problem is that data gaps are zero filled and zero is also a
c valid DN value.  Therefore, the meaning of 0 DN is ambiguous.

c Any string of 7 or more consecutive zeroes, either vertical or horizontal, is
c considered a data gap because such an event rarely occurs naturally, and
c is more likely to be due to (1) data dropouts (in the transmission from
c Jupiter to Earth), (2) image data-compression line truncation, or (3)
c image editing.  Therefore, any such string is replaced by -998 DN.

c Additionally, windows along the left and right margins are checked for
c data-compression line truncation, no matter how short the gap may be.

      subroutine check_window(W,iw,jw,lk,sk,k,rtype,poe,gap)
      implicit none
c Inputs...
      integer iw,jw
      integer lk,sk		!W(0,0) = D(sk,lk)
      integer k
      integer rtype
      integer poe		!planet-of-encounter (J=5,S=6,U=7,N=8)
c Updated...
      integer*2 W(-iw:iw,-jw:jw)	!gaps set to -998
c Output...
      logical gap			!true if data gap exist
c Local variables...
      integer i,j,ii,jj,loop,dn
      integer n			!running count of strings of 0s
      integer switch		!0=even line, 1=odd line
      integer line,samp
      integer type		!1=left margin, 2=right margin, 0=neither

      gap = .false.		!initialize the result

c Any horizontal or vertical string of 0s that is at least 7 pixels long is
c considered a data gap.

c Since images taken at Uranus and Neptune suffer from data-compression
c line truncation, we allow for shorter horizontal strings based on
c the following rules:

c If the mark is on the left margin and the line is even, and if the string of
c 0s starts at sample 1, we assume that this is a result of data compression
c line truncation.

c If the mark is on the right margin and the string ends at sample 800, we
c assume truncation.  (In mode IMK, both odd and even lines may be truncated on
c the right)

c This algorithm is not foolproof, but assumes the most probable circumstances.

c To expedite the algorithm, we classify the marks into three types:
c   type=1 if mark is on the left margin
c   type=2 if mark is on the right margin
c   type=0 if neither is true

c type is derived from the more general rtype, where
c rtype=1,2,3,4 for the upper-left, upper-right, lower-left, and lower-
c right corners, =5,6,7,8 for the top, left, bottom, and right margins,
c and 0 everywhere else (the interior).

      type = 0
      if (rtype.eq.1 .or. rtype.eq.3 .or. rtype.eq.6) type=1
      if (rtype.eq.2 .or. rtype.eq.4 .or. rtype.eq.8) type=2

c For pre data compression encounters, we turn the type off
      if (poe.lt.7) type=0

c Search for horizontal strings of 0s...

c Before scanning line-by-line, we set the odd/even switch...
      line = lk - jw		!first line in W
      if (2*(line/2).eq.line) then
         switch = 0		!first line is even
      else
         switch = 1		!first line is odd
      endif

c Scan each line segment of W for strings of 0s... `

      do 30 j=-jw,jw
      n = 0			!reset the string count

      do 20 i=-iw,iw
      if (W(i,j).eq.0) then
         n = n + 1		!add 1 to the string
         goto 20
      endif
      if (n.eq.0) goto 20	!if no string, continue
      if (n.ge.7) goto 16	!if string is long enough, fill in the gap
      if (type.eq.1 .and. switch.eq.0) then
         samp = sk + i - n
         if (samp.eq.1) goto 16		!fill in the gap
      endif
      if (type.eq.2) then
         samp = sk + i - 1
         if (samp.eq.800) goto 16	!fill in the gap
      endif
      n = 0			!if no gap detected, reset the string
      goto 20			!and continue
   16 gap = .true.		!here if gap has been detected
      do ii=i-n,i-1
         W(ii,j) = -998		!change the 0s to -998s
      enddo
      n = 0
   20 continue

      if (n.ge.7) then		!flush out the last gap
         gap = .true.
         ii = iw		!the gap ends at the end of W
         do loop=1,n
            W(ii,j) = -998	!change the 0s to -998s
            ii = ii - 1
         enddo
      endif

   30 switch = 1 - switch	!flip the odd/even switch

c Scan every column segment of W for strings of 0s or -998s...

      do 60 i=-iw,iw
      j = -jw
      n = 0

      do 50 j=-jw,jw
      if (W(i,j).eq.0 .or. W(i,j).eq.-998) then
         n = n + 1
         goto 50
      endif
      if (n.eq.0) goto 50
      if (n.ge.7) then
         gap = .true.
         do jj=j-n,j-1
            W(i,jj) = -998
         enddo
      endif
      n = 0
   50 continue
   60 continue

      return
      end


!***********************************/
!	Name:
!	Alias:UVenkatakrishnanVar_Mod4OMP
!	Description:
!	Type:
!	Input:
!	Output:
!	Note:
!	Author:Akitaka Toyota
!	Date:2018.02.09
!	Update:
!	Other:
!***********************************/
module UVenkatakrishnanVar_Mod4OMP
use StructVar_Mod
implicit none

    type UFindVariationWithOMP
        integer :: iAdjacentCell
        double precision, allocatable :: Variation(:,:) !5vairable,2(max or min)
    end type

    type UGetNormalGradientWithOMP
        integer :: iFrontCell
        integer :: iBackCell
    end type

    type UVenkatakrishnanWithOMP
        double precision :: VE2 !Venkatakrishnan's epsilon squared
        integer, pointer :: iMaxMin
    end type

    type PrivateVarOfUVenkatakrishnan
        type(UFindVariationWithOMP) :: UFV
        type(UGetNormalGradientWithOMP) :: UGNG
        type(UVenkatakrishnanWithOMP) :: UV
    end type

end module UVenkatakrishnanVar_Mod4OMP


C    Copyright (c) 2014, Sandia Corporation.
C    Under the terms of Contract DE-AC04-94AL85000 with Sandia Corporation,
C    the U.S. Government retains certain rights in this software.
C
C    Redistribution and use in source and binary forms, with or without
C    modification, are permitted provided that the following conditions are
C    met:
C
C        * Redistributions of source code must retain the above copyright
C          notice, this list of conditions and the following disclaimer.
C
C        * Redistributions in binary form must reproduce the above
C          copyright notice, this list of conditions and the following
C          disclaimer in the documentation and/or other materials provided
C          with the distribution.
C
C        * Neither the name of Sandia Corporation nor the names of its
C          contributors may be used to endorse or promote products derived
C          from this software without specific prior written permission.
C
C    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C    A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C    OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C    SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C    LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C    DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C    THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C    (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C    OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
C

C $Id: labove.f,v 1.2 1991/03/21 15:44:51 gdsjaar Exp $
C $Log: labove.f,v $
C Revision 1.2  1991/03/21 15:44:51  gdsjaar
C Changed all 3.14159... to atan2(0.0, -1.0)
C
c Revision 1.1.1.1  1990/11/30  11:10:57  gdsjaar
c FASTQ Version 2.0X
c
c Revision 1.1  90/11/30  11:10:56  gdsjaar
c Initial revision
c
C
CC* FILE: [.MAIN]LABOVE.FOR
CC* MODIFIED BY: TED BLACKER
CC* MODIFICATION DATE: 7/6/90
CC* MODIFICATION: COMPLETED HEADER INFORMATION
C
      SUBROUTINE LABOVE (MP,ML,N,IPOINT,COOR,ILINE,LTYPE,LCON,
     +   LINKP,LINKL,X,Y,Y1,Y2,IFIND,INDEX,IFIRST,INEXT)
C***********************************************************************
C
C  SUBROUTINE LABOVE = GETS THE CLOSEST LINE ABOVE A GIVEN X,Y
C
C***********************************************************************
C
C  VARIABLES USED:
C     IFIND  = THE CLOSEST LINE FOUND ABOVE THE X,Y LOCATION
C     IFIRST = THE CCW END OF THE LINE (LEFT END)
C     INEXT  = THE CW END OF THE LINE (RIGHT END)
C
C***********************************************************************
C
      DIMENSION IPOINT(MP),COOR(2,MP),ILINE(ML),LTYPE(ML),LCON(3,ML)
      DIMENSION LINKP(2,MP),LINKL(2,ML)
      DIMENSION N(29)
C
      LOGICAL BAD,ADDLNK,ERR,UP
C
      PI = ATAN2(0.0, -1.0)
C
      TWOPI=PI+PI
      ADDLNK=.FALSE.
      DIST=Y2-Y1
C
      DO 100 I=1,N(19)
         CALL LTSORT(ML,LINKL,I,II,ADDLNK)
         IF(II.GT.0)THEN
            I1=LCON(1,II)
            I2=LCON(2,II)
            I3=LCON(3,II)
            CALL LTSORT(MP,LINKP,I1,J1,ADDLNK)
            CALL LTSORT(MP,LINKP,I2,J2,ADDLNK)
            IF(I3.NE.0)THEN
               CALL LTSORT(MP,LINKP,IABS(I3),J3,ADDLNK)
            ELSE
               J3=0
            ENDIF
C
C  SEE IF LINE EXISTS
C
            IF((J1.GT.0).AND.(J2.GT.0))THEN
C
C  CHECK A STRAIGHT LINE TO SEE IF IT SPANS THE POINT
C
               IF((LTYPE(II).EQ.1).AND.
     +            (((COOR(1,J1).LE.X).AND.(COOR(1,J2).GE.X)).OR.
     +            ((COOR(1,J2).LE.X).AND.(COOR(1,J1).GE.X))))THEN
C
C  SEE IF LINE IS ABOVE
C
                  CALL DLPARA(COOR(1,J1),COOR(2,J1),COOR(1,J2),
     +               COOR(2,J2),XM1,B1,BAD)
                  IF(.NOT.BAD)THEN
                     YTRY=(XM1*X)+B1
                     IF(YTRY.GT.Y)THEN
C
C  CHECK DISTANCE TO THE LINE - RECORD LINE NO. IF CLOSEST
C
                        DTRY=YTRY-Y
                        IF((DTRY.LE.DIST).OR.(ABS(DIST-DTRY).LT.
     +                     .001*DIST))THEN
                           DIST=DTRY
                           IFIND=I
                           INDEX=II
                           IF(COOR(1,J1).GT.X)THEN
                              IFIRST=I2
                              INEXT=I1
                           ELSE
                              IFIRST=I1
                              INEXT=I2
                           ENDIF
                        ENDIF
                     ENDIF
                  ENDIF
C
C  CHECK AN ARC LINE
C
               ELSEIF(((LTYPE(II).EQ.3).OR.(LTYPE(II).EQ.4).OR.
     +            (LTYPE(II).EQ.6)).AND.(J3.GT.0))THEN
                  CALL ARCPAR(MP,LTYPE(II),ILINE(II),COOR,LINKP,J1,J2,
     +               J3,I3,XCEN,YCEN,THETA1,THETA2,TANG,R1,R2,ERR,
     +               ICCW,ICW,XK,XA)
                  IF(.NOT.ERR)THEN
C
C  SET THE ARC AS EITHER AN UPWARD ARCH OR DOWNWARD ARCH
C  (A CLOSED CIRCLE IS ALWAYS AN UPWARD ARCH)
C
                     IF(J1.EQ.J2)THEN
                        UP=.TRUE.
                     ELSEIF(COOR(1,ICCW).GE.COOR(1,ICW))THEN
                        UP=.TRUE.
                     ELSE
                        UP=.FALSE.
                     ENDIF
C
C  THE INPUT POINT IS RIGHT AT THE CENTER OF THE CIRCLE
C
                     IF((Y.EQ.YCEN).AND.(X.EQ.XCEN))THEN
                        RP=0.
                        THETAP=(THETA1+THETA2)*.5
                     ELSE
                        THETAP=ATAN2(Y-YCEN,X-XCEN)
                        RP=SQRT( ((X-XCEN)**2) + ((Y-YCEN)**2) )
                     ENDIF
C
C  SEE IF THE POINT ANGLE IS WITHIN THE BEGINNING AND ENDING ANGLES
C
                     IF( ( (THETAP.LE.THETA2) .AND. (THETAP.GE.THETA1) )
     &                  .OR.
     &                  ( (THETAP+TWOPI.LE.THETA2) .AND.
     &                  (THETAP+TWOPI.GE.THETA1) )
     &                  .OR.
     &                  ( (THETAP.LE.THETA1) .AND. (THETAP.GE.THETA2) )
     &                  .OR.
     &                  ( (THETAP+TWOPI.LE.THETA1) .AND.
     &                  (THETAP+TWOPI.GE.THETA2) ) ) THEN
C
C  SEE IF THE POINT TO CENTER DISTANCE IS LESS THAN THE
C  ARC RADIUS AT THAT ANGLE FOR AN UPWARD ARC OR GREATER FOR
C  A DOWNWARD ARC (BELOW THE ARC)
C
                        RTEST = XA * EXP ( XK * THETAP )
                        IF( ( (UP) .AND. (RTEST.GE.RP) ) .OR.
     +                     ( (.NOT.UP) .AND. (RTEST.LE.RP) ) )THEN
C
C  CHECK Y DISTANCE TO THE LINE - RECORD LINE NO. IF CLOSEST
C
                           CALL ARCY(XCEN,YCEN,THETA1,THETA2,XK,XA,
     +                        X,YTRY,ERR)
                           DTRY=YTRY-Y
                           IF( (.NOT.ERR) .AND.
     +                        (YTRY .GT. Y) .AND.
     +                        ( (DTRY.LE.DIST) .OR.
     +                        (ABS(DIST-DTRY).LT..001*DIST)))THEN
                              DIST=DTRY
                              IFIND=I
                              INDEX=II
                              IF(UP)THEN
                                 IFIRST=IPOINT(ICW)
                                 INEXT=IPOINT(ICCW)
                              ELSE
                                 IFIRST=IPOINT(ICCW)
                                 INEXT=IPOINT(ICW)
                              ENDIF
                           ENDIF
                        ENDIF
C
C  THE ONLY OTHER ARC POSSIBILITY IS IF THE X FALLS IN THE SPAN
C  BETWEEN THE TWO ENDPOINTS OR BETWEEN END POINTS AND CENTER POINT
C
                     ELSEIF ( ((X - COOR(1,J1) ) *
     +                  (X - COOR(1,J2) ) .LT.0)
     +                  .OR.
     +                  ((X - COOR(1,J1) ) *
     +                  (X - COOR(1,J3) ) .LT.0)
     +                  .OR.
     +                  ((X - COOR(1,J2) ) *
     +                  (X - COOR(1,J3) ) .LT.0) ) THEN
C
C  CHECK Y DISTANCE TO THE LINE - RECORD LINE NO. IF CLOSEST
C
                        CALL ARCY(XCEN,YCEN,THETA1,THETA2,XK,XA,
     +                     X,YTRY,ERR)
                        DTRY=YTRY-Y
                        IF( (.NOT.ERR) .AND.
     +                     (YTRY .GT. Y) .AND.
     +                     ( (DTRY.LE.DIST) .OR.
     +                     (ABS(DIST-DTRY).LT..001*DIST)))THEN
                           DIST=DTRY
                           IFIND=I
                           INDEX=II
C
C  TREAT THE BETWEEN END POINTS DIFFERENTLY THAN BETWEEN
C  ENDPOINT AND CENTER POINT
C
                           IF( ((X - COOR(1,J1) ) *
     +                        (X - COOR(1,J2) )) .LT.0) THEN
                              IF(UP)THEN
                                 IFIRST=IPOINT(ICW)
                                 INEXT=IPOINT(ICCW)
                              ELSE
                                 IFIRST=IPOINT(ICCW)
                                 INEXT=IPOINT(ICW)
                              ENDIF
                           ELSE
                              IF( COOR(2,ICCW) .GT.
     +                           COOR(2,ICW) ) THEN
                                 IFIRST=IPOINT(ICCW)
                                 INEXT=IPOINT(ICW)
                              ELSE
                                 IFIRST=IPOINT(ICW)
                                 INEXT=IPOINT(ICCW)
                              ENDIF
                           ENDIF
                        ENDIF
                     ENDIF
                  ENDIF
               ENDIF
            ENDIF
         ENDIF
  100 CONTINUE
C
      RETURN
C
      END


module process

  implicit none

contains

  subroutine assign_blocks

    use datatypes
    use local, ONLY: block_store, nprocs, block_size_x, block_size_y, block_size_z, &
         stm_z_min, stm_z_max, stm_x_min, stm_x_max, stm_y_min, stm_y_max

    implicit none

    integer :: proc, iblock, ig1, ind_group, block_x, block_y, block_z, nblock
    real(double) :: rbx, rby, rbz

    write(*,*) 'Range for x: ',stm_x_min, stm_x_max
    write(*,*) 'Range for y: ',stm_y_min, stm_y_max
    write(*,*) 'Range for z: ',stm_z_min, stm_z_max
    nblock = 0
    do proc=1,nprocs
       block_store(proc)%active = 0
       do iblock=1, block_store(proc)%num_blocks
          ! Create starting point for block using ind_block
          nblock = nblock + 1
          ! Check min area - if the RHS of block is in LHS of area, keep it
          rbx = block_size_x*real(block_store(proc)%nx(iblock),double)
          rby = block_size_y*real(block_store(proc)%ny(iblock),double)
          rbz = block_size_z*real(block_store(proc)%nz(iblock),double)
          if(rbx>=stm_x_min.AND.rby>=stm_y_min.AND.rbz>=stm_z_min) &
               block_store(proc)%active(iblock) = block_store(proc)%active(iblock) + 1
          !write(*,*) 'RHS: ',rbx,rby,rbz
          ! Now LHS of block and RHS of area
          rbx = block_size_x*real(block_store(proc)%nx(iblock)-1,double)
          rby = block_size_y*real(block_store(proc)%ny(iblock)-1,double)
          rbz = block_size_z*real(block_store(proc)%nz(iblock)-1,double)
          if(rbx<=stm_x_max.AND.rby<=stm_y_max.AND.rbz<=stm_z_max) &
               block_store(proc)%active(iblock) = block_store(proc)%active(iblock) + 1
          !write(*,*) 'RHS: ',rbx,rby,rbz
          !write(*,*) 'Active: ',iblock!block_store(proc)%active(iblock)
          if(block_store(proc)%active(iblock)==2) then
             !write(*,*) 'Active: ',iblock!block_store(proc)%active(iblock)
             block_store(proc)%active(iblock)=1
          else
             block_store(proc)%active(iblock)=0
          end if
       end do
    end do
    write(*,*) "Blocks assigned"
    return
  end subroutine assign_blocks

  subroutine process_charge

    use datatypes
    use numbers
    use local, ONLY: nprocs, n_bands_active, nkp, block_store, efermi, wtk, stm_broad, &
         nxmin, nymin, nzmin, current, nptsx, nptsy, nptsz, &
         eigenvalues, band_no, stm_bias, charge_stub, n_bands_active, band_no, nkp, flag_by_kpoint, &
         flag_output, dx, cube, gpv
    use block_module, only: n_pts_in_block, in_block_x,in_block_y,in_block_z
    use io_module, ONLY: get_file_name
    use output, ONLY: write_dx_density, write_cube, write_dx_coords
    use global_module, only : nspin

    implicit none

    integer :: proc, ispin
    real(double) :: n_elect
    character(len=50) :: filename, ci

    write(*,*) 'Processing charge'
    allocate(current(nptsx,nptsy,nptsz))
    do ispin=1,nspin
       current = zero
       if(nspin==1) then
          ci = TRIM(charge_stub)
       else
          if(ispin==1) ci = TRIM(charge_stub)//"_up"
          if(ispin==2) ci = TRIM(charge_stub)//"_dn"
       end if
       do proc = 1, nprocs
          call get_file_name(ci,nprocs,proc,filename)
          ! Open file
          open(unit=17,file=filename)
          call read_domain(17,proc,current)
          close(unit=17)
       end do ! proc
       call write_cube(current,ci)
       n_elect = sum(current)*gpv
       write(*,*) 'Number of electrons in active area: ',n_elect
    end do ! ispin
    return
  end subroutine process_charge

  subroutine process_bands

    use datatypes
    use numbers
    use local, ONLY: nkp, efermi, current, nptsx, nptsy, nptsz, eigenvalues, flag_by_kpoint, &
         n_bands_total, band_active_kp, flag_proc_range, band_full_to_active, &
         E_procwf_min, E_procwf_max, flag_procwf_range_Ef, band_proc_no, n_bands_process
    use output, ONLY: write_cube
    use global_module, only : nspin
    use read, ONLY: read_eigenvalues, read_psi_coeffs

    implicit none

    integer :: proc, band, nk, idum1, idum2, kp, ispin
    real(double) :: weight, rbx, rby, rbz, sq, test
    real(double), dimension(2) :: Emin, Emax
    character(len=50) :: filename, ci
    complex(double_cplx), dimension(:,:,:), allocatable :: psi

    write(*,*) 'Processing bands'
    ! Read eigenvalues
    call read_eigenvalues
    ! Read eigenvector coefficients
    call read_psi_coeffs
    allocate(current(nptsx,nptsy,nptsz))
    allocate(psi(nptsx,nptsy,nptsz))
    if(flag_proc_range) then
       Emin = E_procwf_min
       Emax = E_procwf_max
       if(flag_procwf_range_Ef) then
          Emin = efermi + Emin
          Emax = efermi + Emax
       end if
       do ispin=1,nspin
          if(flag_by_kpoint) then ! Separate bands by k-point
             do band=1,n_bands_total
                current = zero
                do kp = 1,nkp
                   if(eigenvalues(band,kp,ispin) >= Emin(ispin) .and. &
                        eigenvalues(band,kp,ispin) <= Emax(ispin) .and. &
                        band_active_kp(band,kp,ispin)==1) then
                      call pao_to_grid(band_full_to_active(band), kp, ispin, psi)
                      current = psi*conjg(psi)
                      write(ci,'("Band",I0.6,"den_kp",I0.3,"S",I0.1)') band, kp, ispin
                      call write_cube(current,ci)
                   end if
                end do ! kp
             end do ! bands = 1, n_bands_total
          else ! Sum over k-points
             do band=1,n_bands_total
                current = zero
                idum1=0
                do kp = 1,nkp
                   if(eigenvalues(band,kp,ispin) >= Emin(ispin) .and. &
                        eigenvalues(band,kp,ispin) <= Emax(ispin) .and. &
                        band_active_kp(band,kp,ispin)==1) then
                      call pao_to_grid(band_full_to_active(band), kp, ispin, psi)
                      current = current + psi*conjg(psi)
                      idum1 = 1
                   end if
                end do ! kp
                if(idum1==1) then
                   write(ci,'("Band",I0.6,"den_totS",I0.1)') band, ispin
                   call write_cube(current,ci)
                end if
             end do ! bands
          end if
       end do
    else ! User has provided list of bands
       do ispin=1,nspin
          if(flag_by_kpoint) then ! Separate bands by k-point
             do band=1,n_bands_process
                current = zero
                do kp = 1,nkp
                   ! This clause is needed in case the user chose an energy range that only selects some k-points
                   if(band_active_kp(band_proc_no(band),kp,ispin)==1) then
                      call pao_to_grid(band_full_to_active(band_proc_no(band)), kp, ispin, psi)
                      current = psi*conjg(psi)
                      write(ci,'("Band",I0.6,"den_kp",I0.3,"S",I0.1)') band_proc_no(band), kp, ispin
                      call write_cube(current,ci)
                   end if
                end do ! kp
             end do ! bands = 1, n_bands_total
          else ! Sum over k-points
             do band=1,n_bands_process
                current = zero
                do kp = 1,nkp
                   ! This clause is needed in case the user chose an energy range that only selects some k-points
                   if(band_active_kp(band_proc_no(band),kp,ispin)==1) then
                      call pao_to_grid(band_full_to_active(band_proc_no(band)), kp, ispin, psi)
                      current = current + psi*conjg(psi)
                   end if
                end do ! kp
                write(ci,'("Band",I0.6,"den_totS",I0.1)') band_proc_no(band), ispin
                call write_cube(current,ci)
             end do ! bands
          end if
       end do
    end if
    return
  end subroutine process_bands

  subroutine process_dos

    use datatypes
    use numbers, ONLY: zero, RD_ERR, twopi, half, one, two, four, six
    use local, ONLY: eigenvalues, n_bands_total, nkp, wtk, efermi, flag_total_iDOS
    use read, ONLY: read_eigenvalues, read_psi_coeffs
    use global_module, ONLY: nspin, n_DOS, E_DOS_min, E_DOS_max, sigma_DOS
    use units, ONLY: HaToeV

    implicit none

    ! Local variables
    integer :: i_band, i_kp, i_spin, n_DOS_wid, n_band, n_min, n_max, i
    real(double) :: Ebin, dE_DOS, a, pf_DOS, spin_fac
    real(double), dimension(nspin) :: total_electrons, iDOS_low
    real(double), dimension(:,:), allocatable :: total_DOS, iDOS
    real(double), dimension(:,:), allocatable :: occ

    if(nspin==1) then
       spin_fac = two
    else if(nspin==2) then
       spin_fac = one
    end if
    ! Read eigenvalues
    call read_eigenvalues
    allocate(total_DOS(n_DOS,nspin),iDOS(n_DOS,nspin),occ(n_bands_total,nkp))
    total_DOS = zero
    iDOS = zero
    ! Set limits on DOS output
    if(abs(E_DOS_min)<RD_ERR) then
       E_DOS_min = minval(eigenvalues(1,:,:))
       write(*,fmt='(2x,"DOS lower limit set automatically: ",f12.5," Ha")') E_DOS_min
    else
       write(*,fmt='(2x,"DOS lower limit set by user: ",f12.5," Ha")') E_DOS_min
    end if
    if(abs(E_DOS_max)<RD_ERR) then
       E_DOS_max = maxval(eigenvalues(n_bands_total,:,:))
       write(*,fmt='(2x,"DOS upper limit set automatically: ",f12.5," Ha")') E_DOS_max
    else
       write(*,fmt='(2x,"DOS upper limit set by user: ",f12.5," Ha")') E_DOS_max
    end if
    ! Spacing, width, prefactor
    dE_DOS = (E_DOS_max - E_DOS_min)/real(n_DOS-1,double)
    ! Set sigma automatically
    if(abs(sigma_DOS)<RD_ERR) then
       sigma_DOS = four*dE_DOS
       write(*,fmt='(2x,"Sigma set automatically: ",f12.6," Ha")') sigma_DOS
    else
       write(*,fmt='(2x,"Sigma set by user: ",f12.6," Ha")') sigma_DOS
       if(six*sigma_DOS < dE_DOS) write(*,fmt='(4x,"Sigma is much less than bin size: this may cause errors")')
    end if
    ! Adjust limits to allow full peak to be seen
    E_DOS_min = E_DOS_min - two*sigma_DOS
    E_DOS_max = E_DOS_max + two*sigma_DOS
    ! Recalculate dE_DOS now that we've broadened it
    dE_DOS = (E_DOS_max - E_DOS_min)/real(n_DOS-1,double)
    write(*,fmt='(2x,"Dividing DOS into ",i5," bins of width ",f12.6," Ha")') n_DOS, dE_DOS
    n_DOS_wid = floor(six*sigma_DOS/dE_DOS) ! How many bins either side of state we consider
    pf_DOS = one/(sigma_DOS*sqrt(twopi))
    total_electrons = zero
    iDOS_low = zero ! Integral of DOS to lowest energy bound
    ! Accumulate DOS over bands and k-points for each spin
    do i_spin = 1, nspin
       occ = zero
       call occupy(occ,eigenvalues,efermi,i_spin)
       do i_kp = 1, nkp
          do i_band=1,n_bands_total ! All bands
             if(eigenvalues(i_band, i_kp, i_spin)>E_DOS_min .and. &
                  eigenvalues(i_band, i_kp, i_spin)<E_DOS_max) then
                n_band = floor((eigenvalues(i_band, i_kp, i_spin) - E_DOS_min)/dE_DOS) + 1
                n_min = n_band - n_DOS_wid
                if(n_min<1) n_min = 1
                n_max = n_band + n_DOS_wid
                if(n_max>n_DOS) n_max = n_DOS
                do i = n_min, n_max
                   Ebin = real(i-1,double)*dE_DOS + E_DOS_min
                   a = (Ebin-eigenvalues(i_band, i_kp, i_spin))/sigma_DOS
                   total_DOS(i,i_spin) = total_DOS(i,i_spin) + wtk(i_kp)*pf_DOS*exp(-half*a*a)
                   total_electrons(i_spin) = total_electrons(i_spin) + occ(i_band,i_spin)*wtk(i_kp)*pf_DOS*exp(-half*a*a)
                   iDOS(i,i_spin) = iDOS(i,i_spin) + wtk(i_kp)*pf_DOS*exp(-half*a*a)
                end do
             else if(eigenvalues(i_band, i_kp, i_spin)<E_DOS_min) then
                iDOS_low(i_spin) = iDOS_low(i_spin) + wtk(i_kp)
             end if
          end do
       end do
       ! Now integrate DOS
       write(*,*) 'iDOS_low is ',iDOS_low
       do i = 2, n_DOS
          iDOS(i,i_spin) = iDOS(i,i_spin) + iDOS(i-1,i_spin)
       end do
    end do
    ! Include spin factor
    iDOS = iDOS*dE_DOS*spin_fac
    if(flag_total_iDOS) then
       do i_spin = 1, nspin
          iDOS(:,i_spin) = iDOS(:,i_spin) + spin_fac*iDOS_low(i_spin)
       end do
    end if
    total_electrons = total_electrons*dE_DOS*spin_fac
    total_DOS = total_DOS*spin_fac
    if(nspin==1) then
       write(*,fmt='(2x,"DOS between ",f11.3," and ",f11.3," Ha integrates to ",f12.3," electrons")') &
            E_DOS_min, E_DOS_max, total_electrons(1)
    else
       write(*,fmt='(2x,"Spin Up DOS integrates to ",f12.3," electrons")') total_electrons(1)
       write(*,fmt='(2x,"Spin Dn DOS integrates to ",f12.3," electrons")') total_electrons(2)
    end if
    ! Since we write out DOS against eV we need this conversion to get the integral right
    total_DOS = total_DOS/HaToeV
    ! Write out DOS, shifted to Ef = 0
    open(unit=17, file="DOS.dat")
    do i_spin = 1, nspin
       write(17,fmt='("# Spin ",I1)') i_spin
       write(17,fmt='("# Original Fermi-level: ",f12.5," eV")') HaToeV*efermi(i_spin)
       write(17,fmt='("# DOS shifted relative to Fermi-level")')
       if(flag_total_iDOS) then
          write(17,fmt='("#  Energy (eV)     DOS (/eV)    Total iDOS")')
       else
          write(17,fmt='("#  Energy (eV)     DOS (/eV)    Local iDOS")')
       end if
       do i=1, n_DOS
          write(17,fmt='(3f14.5)') HaToeV*(E_DOS_min + dE_DOS*real(i-1,double)-efermi(i_spin)), &
               total_DOS(i,i_spin), iDOS(i,i_spin)
       end do
       write(17,fmt='("&")')
    end do
    close(unit=17)
    return
  end subroutine process_dos

  ! Important note
  !
  ! Formally we have: PAO(\mathbf{r}) = f(r) r^l Y_{lm}(\hat{\mathbf{r}})
  !
  ! However it is much easier when dealing with the explicit Cartesian form
  ! of spherical harmonics to scale the Y_{lm} by r^l (because the Cartesian
  ! form has 1/r^l as part of it) so this is what we do.  The routine
  ! spherical_harmonic_rl returns this (and its differential)
  !
  ! So we have dPAO/dalpha = df/dr.dr/dalpha.(r^lY) + f.d(r^lY)/dalpha where alpha
  ! is x/y/z and dr/dalpha = alpha/r.
  subroutine pao_dpao_to_grid(i_band, i_kp, i_spin, psi, dpsi)

    use datatypes
    use numbers
    use units
    use global_module, ONLY: ni_in_cell, atom_coord, species_glob
    use pao_format, ONLY: pao
    use local, ONLY: nptsx, nptsy, nptsz, grid_x, grid_y, grid_z, stm_x_min, stm_x_max, &
         stm_y_min, stm_y_max, stm_z_min, stm_z_max, evec_coeff, kx, ky, kz, i_job
    use dimens, ONLY: RadiusAtomf, r_super_x, r_super_y, r_super_z

    implicit none

    ! Passed variables
    integer :: i_band, i_kp, i_spin
    complex(double_cplx), dimension(nptsx, nptsy, nptsz) :: psi
    complex(double_cplx), dimension(nptsx, nptsy, nptsz, 3) :: dpsi

    ! Local variables
    integer :: i_atom, i_grid_x, i_grid_y, i_grid_z, i_l, i_zeta, i_m, ix, iy, iz
    integer :: i_spec, j, npao
    integer :: minx, maxx, miny, maxy, minz, maxz
    real(double) :: dr, dx, dy, dz, sph_rl, f_r, df_r, dx_dr, dy_dr, dz_dr, del_r
    real(double) :: a, b, c, d, r1, r2, r3, r4, rr, kr, krx, kry, krz
    real(double), dimension(3) :: dsph_rl, dg
    complex(double_cplx) :: phase, phase_shift

    psi = zero
    dpsi = zero
    ! Grid spacing
    dg(1) = grid_x!/BohrToAng
    dg(2) = grid_y!/BohrToAng
    dg(3) = grid_z!/BohrToAng
    ! Loop over atoms
    do i_atom = 1, ni_in_cell
       i_spec = species_glob(i_atom)
       !write(*,*) 'Atom, spec, pos: ',i_atom, i_spec, atom_coord(3, i_atom) + RadiusAtomf(i_spec), stm_z_min
       if(atom_coord(3, i_atom) + RadiusAtomf(i_spec) >= stm_z_min) then ! Is the atom in STM region?
          kr = kx(i_kp)*atom_coord(1, i_atom) + ky(i_kp)*atom_coord(2, i_atom) + kz(i_kp)*atom_coord(3, i_atom)
          !phase = cmplx(cos(kr),sin(kr))
          ! Find grid limits
          minx = floor( (atom_coord(1, i_atom) - RadiusAtomf(i_spec))/dg(1) )
          maxx = floor( (atom_coord(1, i_atom) + RadiusAtomf(i_spec))/dg(1) ) + 1
          miny = floor( (atom_coord(2, i_atom) - RadiusAtomf(i_spec))/dg(2) )
          maxy = floor( (atom_coord(2, i_atom) + RadiusAtomf(i_spec))/dg(2) ) + 1
          minz = floor( (atom_coord(3, i_atom) - RadiusAtomf(i_spec))/dg(3) )
          maxz = floor( (atom_coord(3, i_atom) + RadiusAtomf(i_spec))/dg(3) ) + 1
          ! Account for STM limits
          !if(stm_x_min>zero) minx = max(minx, floor(stm_x_min/dg(1)) )
          !if(stm_x_max<r_super_x) maxx = min(maxx, floor(stm_x_max/dg(1)+1) )
          !if(stm_y_min>zero) miny = max(miny, floor(stm_y_min/dg(2)) )
          !if(stm_y_max<r_super_y) maxy = min(maxy, floor(stm_y_max/dg(2)+1) )
          if(i_job==4.or.i_job==5) then ! STM not band density, so no z periodicity
             if(stm_z_min>zero) then
                minz = minz - floor(stm_z_min/dg(3))
             end if
             if(minz<1) minz = 1
             maxz = min(maxz, nptsz)
          end if
          !end if
          ! Loop over grid points
          do i_grid_z = minz, maxz
             ! Find z grid position and dz
             dz = dg(3)*real(i_grid_z-1,double)+stm_z_min - atom_coord(3,i_atom)
             iz = i_grid_z
             ! Wrap if we're making band densities, but not for STM simulation
             krz = zero
             if(i_job==3) then
                if(i_grid_z<1) then
                   iz = i_grid_z + nptsz
                   krz = kz(i_kp)*r_super_z
                end if
                if(i_grid_z>nptsz) then
                   iz = i_grid_z - nptsz
                   krz = -kz(i_kp)*r_super_z
                end if
             end if
             do i_grid_y = miny, maxy
                ! Find y grid position and dy and wrap grid point
                dy = dg(2)*real(i_grid_y-1,double)+stm_y_min - atom_coord(2,i_atom)
                iy = i_grid_y
                kry = zero
                if(i_grid_y<1) then
                   iy = i_grid_y + nptsy
                   kry = ky(i_kp)*r_super_y
                end if
                if(i_grid_y>nptsy) then
                   iy = i_grid_y - nptsy
                   kry = -ky(i_kp)*r_super_y
                end if
                do i_grid_x = minx, maxx
                   ! Find x grid position and dx and wrap grid point
                   dx = dg(1)*real(i_grid_x-1,double)+stm_x_min - atom_coord(1,i_atom)
                   ix = i_grid_x
                   krx = zero
                   if(i_grid_x<1) then
                      ix = i_grid_x + nptsx
                      krx = kx(i_kp)*r_super_x
                   end if
                   if(i_grid_x>nptsx) then
                      ix = i_grid_x - nptsx
                      krx = -kx(i_kp)*r_super_x
                   end if
                   ! Calculate dr
                   dr = sqrt(dx*dx + dy*dy + dz*dz)
                   if(dr<=RadiusAtomf(i_spec)) then
                      phase = cmplx(cos(kr+krx+kry+krz),sin(kr+krx+kry+krz))
                      ! dr/dx = x/r etc.  Are the variable names confusing?
                      dx_dr = dx/dr
                      dy_dr = dy/dr
                      dz_dr = dz/dr
                      npao = 1
                      ! Loop over l
                      do i_l = 0, pao(i_spec)%greatest_angmom
                         ! Loop over zeta
                         do i_zeta = 1, pao(i_spec)%angmom(i_l)%n_zeta_in_angmom
                            ! Find f(r), df/dr
                            del_r = pao(i_spec)%angmom(i_l)%zeta(i_zeta)%delta
                            j = floor(dr/del_r) + 1
                            if(j+1<=pao(i_spec)%angmom(i_l)%zeta(i_zeta)%length) then
                               rr = real(j,double)*del_r
                               a = (rr - dr)/del_r
                               b = one - a
                               c = a * ( a * a - one ) * del_r * del_r / six
                               d = b * ( b * b - one ) * del_r * del_r / six
                               r1 = pao(i_spec)%angmom(i_l)%zeta(i_zeta)%table(j)
                               r2 = pao(i_spec)%angmom(i_l)%zeta(i_zeta)%table(j+1)
                               r3 = pao(i_spec)%angmom(i_l)%zeta(i_zeta)%table2(j)
                               r4 = pao(i_spec)%angmom(i_l)%zeta(i_zeta)%table2(j+1)
                               f_r = a*r1 + b*r2 + c*r3 + d*r4
                               ! Re-use a and b before redefining
                               c = -del_r*(three*a*a-one)/six
                               d =  del_r*(three*b*b-one)/six
                               a = -one/del_r
                               b = -a
                               df_r = a*r1 + b*r2 + c*r3 + d*r4
                            else
                               f_r = zero
                               df_r = zero
                            end if
                            ! Loop over m
                            do i_m = -i_l, i_l
                               ! Get spherical harmonic and gradient
                               ! NB returns r^l times spherical harmonic
                               call spherical_harmonic_rl(dx, dy, dz, i_l, i_m, sph_rl, dsph_rl)
                               ! Accumulate into psi, grad psi
                               psi(ix, iy, iz) = psi(ix, iy, iz) + &
                                    phase*evec_coeff(npao,i_atom,i_band, i_kp, i_spin) * sph_rl * f_r
                               dpsi(ix, iy, iz, 1) = dpsi(ix, iy, iz, 1) + &
                                    phase*evec_coeff(npao,i_atom,i_band, i_kp, i_spin) * &
                                    (sph_rl * df_r * dx_dr + dsph_rl(1) * f_r)
                               dpsi(ix, iy, iz, 2) = dpsi(ix, iy, iz, 2) + &
                                    phase*evec_coeff(npao,i_atom,i_band, i_kp, i_spin) * &
                                    (sph_rl * df_r * dy_dr + dsph_rl(2) * f_r)
                               dpsi(ix, iy, iz, 3) = dpsi(ix, iy, iz, 3) + &
                                    phase*evec_coeff(npao,i_atom,i_band, i_kp, i_spin) * &
                                    (sph_rl * df_r * dz_dr + dsph_rl(3) * f_r)
                               npao = npao + 1
                            end do ! i_m
                         end do ! i_zeta
                      end do ! i_l
                   end if ! dr <= RadiusAtomf
                end do ! i_grid_x
             end do ! i_grid_y
          end do ! i_grid_z
       end if ! Atom is in STM region
    end do ! i_atom
    return
  end subroutine pao_dpao_to_grid

  subroutine pao_to_grid(i_band, i_kp, i_spin, psi)

    use datatypes
    use numbers
    use units
    use global_module, ONLY: ni_in_cell, atom_coord, species_glob
    use pao_format, ONLY: pao
    use local, ONLY: nptsx, nptsy, nptsz, grid_x, grid_y, grid_z, stm_x_min, stm_x_max, &
         stm_y_min, stm_y_max, stm_z_min, stm_z_max, evec_coeff, kx, ky, kz, i_job
    use dimens, ONLY: RadiusAtomf, r_super_x, r_super_y, r_super_z

    implicit none

    ! Passed variables
    integer :: i_band, i_kp, i_spin
    complex(double_cplx), dimension(nptsx, nptsy, nptsz) :: psi

    ! Local variables
    integer :: i_atom, i_grid_x, i_grid_y, i_grid_z, i_l, i_zeta, i_m, ix, iy, iz
    integer :: i_spec, j, npao
    integer :: minx, maxx, miny, maxy, minz, maxz
    real(double) :: dr, dx, dy, dz, sph_rl, f_r, df_r, dx_dr, dy_dr, dz_dr, del_r
    real(double) :: a, b, c, d, r1, r2, r3, r4, rr, kr, krx, kry, krz
    real(double), dimension(3) :: dsph_rl, dg
    complex(double_cplx) :: phase, phase_shift

    psi = zero
    ! Grid spacing
    dg(1) = grid_x!/BohrToAng
    dg(2) = grid_y!/BohrToAng
    dg(3) = grid_z!/BohrToAng
    ! Loop over atoms
    do i_atom = 1, ni_in_cell
       i_spec = species_glob(i_atom)
       !write(*,*) 'Atom, spec, pos: ',i_atom, i_spec, atom_coord(3, i_atom) + RadiusAtomf(i_spec), stm_z_min
       if(atom_coord(3, i_atom) + RadiusAtomf(i_spec) >= stm_z_min) then ! Is the atom in STM region?
          kr = kx(i_kp)*atom_coord(1, i_atom) + ky(i_kp)*atom_coord(2, i_atom) + kz(i_kp)*atom_coord(3, i_atom)
          !phase = cmplx(cos(kr),sin(kr))
          ! Find grid limits
          minx = floor( (atom_coord(1, i_atom) - RadiusAtomf(i_spec))/dg(1) )
          maxx = floor( (atom_coord(1, i_atom) + RadiusAtomf(i_spec))/dg(1) ) + 1
          miny = floor( (atom_coord(2, i_atom) - RadiusAtomf(i_spec))/dg(2) )
          maxy = floor( (atom_coord(2, i_atom) + RadiusAtomf(i_spec))/dg(2) ) + 1
          minz = floor( (atom_coord(3, i_atom) - RadiusAtomf(i_spec))/dg(3) )
          maxz = floor( (atom_coord(3, i_atom) + RadiusAtomf(i_spec))/dg(3) ) + 1
          ! Account for STM limits
          !if(stm_x_min>zero.and.minx<0) then
          !   if(minx+nptsx>floor(stm_x_min
          !if(stm_x_min>zero) minx = max(minx, floor(stm_x_min/dg(1)) )
          !if(stm_x_max<r_super_x) maxx = min(maxx, floor(stm_x_max/dg(1)+1) )
          !if(stm_y_min>zero) miny = max(miny, floor(stm_y_min/dg(2)) )
          !if(stm_y_max<r_super_y) maxy = min(maxy, floor(stm_y_max/dg(2)+1) )
          if(i_job==4.or.i_job==5) then ! STM not band density
             if(stm_z_min>zero) then
                minz = minz - floor(stm_z_min/dg(3))
             end if
             if(minz<1) minz = 1
             maxz = min(maxz, nptsz)
          end if
          ! Loop over grid points
          do i_grid_z = minz, maxz
             ! Find z grid position and dz
             dz = dg(3)*real(i_grid_z-1,double)+stm_z_min - atom_coord(3,i_atom)
             iz = i_grid_z
             ! Wrap if we're making band densities, but not for STM simulation
             krz = zero
             if(i_job==3) then
                if(i_grid_z<1) then
                   iz = i_grid_z + nptsz
                   krz = kz(i_kp)*r_super_z
                end if
                if(i_grid_z>nptsz) then
                   iz = i_grid_z - nptsz
                   krz = -kz(i_kp)*r_super_z
                end if
             end if
             do i_grid_y = miny, maxy
                ! Find y grid position and dy and wrap grid point
                dy = dg(2)*real(i_grid_y-1,double)+stm_y_min - atom_coord(2,i_atom)
                iy = i_grid_y
                kry = zero
                if(i_grid_y<1) then
                   iy = i_grid_y + nptsy
                   kry = ky(i_kp)*r_super_y
                end if
                if(i_grid_y>nptsy) then
                   iy = i_grid_y - nptsy
                   kry = -ky(i_kp)*r_super_y
                end if
                do i_grid_x = minx, maxx
                   ! Find x grid position and dx and wrap grid point
                   dx = dg(1)*real(i_grid_x-1,double)+stm_x_min - atom_coord(1,i_atom)
                   ix = i_grid_x
                   krx = zero
                   if(i_grid_x<1) then
                      ix = i_grid_x + nptsx
                      krx = kx(i_kp)*r_super_x
                   end if
                   if(i_grid_x>nptsx) then
                      ix = i_grid_x - nptsx
                      krx = -kx(i_kp)*r_super_x
                   end if
                   ! Calculate dr
                   dr = sqrt(dx*dx + dy*dy + dz*dz)
                   if(dr<=RadiusAtomf(i_spec)) then
                      phase = cmplx(cos(kr+krx+kry+krz),sin(kr+krx+kry+krz))
                      npao = 1
                      ! Loop over l
                      do i_l = 0, pao(i_spec)%greatest_angmom
                         ! Loop over zeta
                         do i_zeta = 1, pao(i_spec)%angmom(i_l)%n_zeta_in_angmom
                            ! Find f(r), df/dr
                            del_r = pao(i_spec)%angmom(i_l)%zeta(i_zeta)%delta
                            j = floor(dr/del_r) + 1
                            if(j+1<=pao(i_spec)%angmom(i_l)%zeta(i_zeta)%length) then
                               rr = real(j,double)*del_r
                               a = (rr - dr)/del_r
                               b = one - a
                               c = a * ( a * a - one ) * del_r * del_r / six
                               d = b * ( b * b - one ) * del_r * del_r / six
                               r1 = pao(i_spec)%angmom(i_l)%zeta(i_zeta)%table(j)
                               r2 = pao(i_spec)%angmom(i_l)%zeta(i_zeta)%table(j+1)
                               r3 = pao(i_spec)%angmom(i_l)%zeta(i_zeta)%table2(j)
                               r4 = pao(i_spec)%angmom(i_l)%zeta(i_zeta)%table2(j+1)
                               f_r = a*r1 + b*r2 + c*r3 + d*r4
                            else
                               f_r = zero
                            end if
                            ! Loop over m
                            do i_m = -i_l, i_l
                               ! Get spherical harmonic and gradient
                               ! NB returns r^l times spherical harmonic
                               call spherical_harmonic_rl(dx, dy, dz, i_l, i_m, sph_rl, dsph_rl)
                               ! Accumulate into psi, grad psi
                               psi(ix, iy, iz) = psi(ix, iy, iz) + &
                                    phase*evec_coeff(npao,i_atom,i_band, i_kp, i_spin) * sph_rl * f_r
                               npao = npao + 1
                            end do ! i_m
                         end do ! i_zeta
                      end do ! i_l
                   end if ! dr <= RadiusAtomf
                end do ! i_grid_x
             end do ! i_grid_y
          end do ! i_grid_z
       end if ! Atom is in STM region
    end do ! i_atom
    return
  end subroutine pao_to_grid

  ! Return spherical harmonic times r^l (and derivative of this)
  subroutine spherical_harmonic_rl(x, y, z, l, m, sph, dsph)

    use datatypes
    use numbers

    implicit none

    ! Passed variables
    integer :: l, m
    real(double) :: x, y, z, sph
    real(double), dimension(3) :: dsph

    ! Local variables
    real(double) :: r
    real(double) :: prefac

    dsph = zero
    if(l==0) then
       prefac = one/sqrt(fourpi)
       sph = prefac
       dsph = zero
    else if(l==1) then
       prefac = sqrt(3/fourpi)
       select case(m)
       case(-1) ! py
          sph = prefac*y
          dsph(2) = prefac
       case(0)  ! pz
          sph = prefac*z
          dsph(3) = prefac
       case(1)  ! px
          sph = prefac*x
          dsph(1) = prefac
       end select
    else if(l==2) then
       select case(m)
       case(-2) ! xy
          prefac = sqrt(fifteen/fourpi)
          sph = prefac*x*y
          dsph(1) = prefac*y
          dsph(2) = prefac*x
       case(-1) ! yz
          prefac = sqrt(fifteen/fourpi)
          sph = prefac*y*z
          dsph(2) = prefac*z
          dsph(3) = prefac*y
       case(0) ! 3z^2 - r^2
          prefac = sqrt(five/(sixteen*pi))
          sph = prefac*(two*z*z - x*x - y*y)
          dsph(1) = -prefac*two*x
          dsph(2) = -prefac*two*y
          dsph(3) =  prefac*four*z
       case(1) ! xz
          prefac = sqrt(fifteen/fourpi)
          sph = prefac*z*x
          dsph(1) = prefac*z
          dsph(3) = prefac*x
       case(2) ! x^2 - y^2
          prefac = sqrt(fifteen/(sixteen*pi))
          sph = prefac*(x*x - y*y)
          dsph(1) =  prefac*two*x
          dsph(2) = -prefac*two*y
       end select
    end if
  end subroutine spherical_harmonic_rl

  subroutine read_domain(lun,proc,data)

    use datatypes
    use numbers
    use local, ONLY: block_store, nxmin, nymin, nzmin, current, nptsx, nptsy, nptsz
    use block_module, only: n_pts_in_block, in_block_x,in_block_y,in_block_z

    implicit none

    ! Passed
    integer :: lun, proc
    real(double), dimension(nptsx,nptsy,nptsz) :: data

    ! Local
    real(double), dimension(n_pts_in_block) :: local_grid
    integer :: iblock, point, ptx, pty, ptz, npx, npy, npz

    do iblock=1,block_store(proc)%num_blocks
       local_grid = zero
       ! Read block
       do point = 1,n_pts_in_block
          read(lun,*) local_grid(point)
       end do
       point = 0
       if(block_store(proc)%active(iblock)==1) then
          do ptz = 1, in_block_z
             npz = in_block_z*(block_store(proc)%nz(iblock)-1) + ptz - nzmin
             if(npz>0.AND.npz<=nptsz) then
                do pty = 1, in_block_y
                   npy = in_block_y*(block_store(proc)%ny(iblock)-1) + pty - nymin
                   if(npy>0.AND.npy<=nptsy) then
                      do ptx = 1, in_block_x
                         npx = in_block_x*(block_store(proc)%nx(iblock)-1) + ptx - nxmin
                         point = point + 1
                         if(npx>0.AND.npx<=nptsx) then
                            data(npx,npy,npz) = data(npx,npy,npz) + local_grid(point)
                         end if
                      end do
                   else
                      do ptx = 1, in_block_x
                         point = point + 1
                      end do
                   end if
                end do
             else
                do pty = 1, in_block_y
                   do ptx = 1, in_block_x
                      point = point + 1
                   end do
                end do
             end if
          end do
       end if ! if active block
    end do ! iblock
  end subroutine read_domain

  subroutine occupy(occu, ebands, Ef, spin)

    use datatypes
    use numbers
    use local, ONLY: nkp, n_bands_total, kT, flag_smear_type, iMethfessel_Paxton, wtk

    implicit none

    ! Passed variables
    real(double), dimension(:) :: Ef
    real(double), dimension(:,:) :: occu
    real(double), dimension(:,:,:) :: ebands
    integer :: spin

    ! Local variables
    integer :: i_kp, i_band

    do i_kp = 1, nkp
       do i_band = 1, n_bands_total
          select case(flag_smear_type)
          case (0) ! Fermi smearing
             occu(i_band,i_kp) = &
                  fermi(ebands(i_band,i_kp,spin) - Ef(spin), kT)
          case (1) ! Methfessel Paxton smearing
             occu(i_band,i_kp) = &
                  MP_step(ebands(i_band,i_kp,spin) - Ef(spin), &
                  iMethfessel_Paxton, kT)
          end select
       end do
    end do
    return
  end subroutine occupy
  ! -----------------------------------------------------------------------------
  ! Function fermi
  ! -----------------------------------------------------------------------------

  !!****f* DiagModule/fermi *
  !!
  !!  NAME
  !!   fermi - evaluate fermi function
  !!  USAGE
  !!   fermi(E,kT)
  !!  PURPOSE
  !!   Evaluates the fermi occupation of an energy
  !!
  !!   I'm assuming (for the sake of argument) that if both the energy and
  !!   the smearing (kT) are zero then we get an occupation of 0.5 - this is
  !!   certainly the limit if E and kT are equal and heading to zero, or if
  !!   E is smaller than kT and both head for zero.
  !!  INPUTS
  !!   real(double), intent(in) :: E - energy
  !!   real(double), intent(in) :: kT - smearing energy
  !!  USES
  !!   datatypes, numbers
  !!  AUTHOR
  !!   D.R.Bowler
  !!  CREATION DATE
  !!   23/04/2002
  !!  MODIFICATION HISTORY
  !!   2006/10/02 17:54 dave
  !!    Small fix to prevent maths overflows by only calculating
  !!    exponential if x well bounded
  !!   2012/01/22 L.Tong
  !!    Small change to use FORTRAN 90 function declaration notation
  !!    This works better with etags
  !!  SOURCE
  !!
  function fermi(E,kT)

    use datatypes
    use numbers, only: zero, one, half

    implicit none

    ! result
    real(double) :: fermi

    ! Passed variables
    real(double), intent(in) :: E
    real(double), intent(in) :: kT

    ! Local variables
    real(double) :: x
    real(double), parameter :: cutoff = 10.0_double

    if(kT==zero) then
       if(E>zero) then
          fermi = zero
       else if(E<zero) then
          fermi = one
       else if(E==zero) then
          fermi = half
       end if
    else
       x = E/kT
       if(x > cutoff) then
          fermi = zero
       elseif(x < -cutoff) then
          fermi = one
       else
          fermi = one/(one + exp(x))
       endif
    end if
  end function fermi
  !!***

  ! -----------------------------------------------------------------------------
  ! Function MP_step
  ! -----------------------------------------------------------------------------

  !!****f* DiagModule/MP_step *
  !!
  !!  NAME
  !!   MP_step - evaluate Methfessel-Paxton step function
  !!  USAGE
  !!   MP_step(E,order,smear)
  !!  PURPOSE
  !!   Evaluates the order (order) Methfessel-Paxton approximation to
  !!   step function
  !!  INPUTS
  !!   real(double), intent(in) :: E - energy
  !!   integer, intent(in) :: order - order of Methfessel expansion
  !!   real(double), intent(in) :: smear - smearing energy, nothing to
  !!                               do with physical temperature
  !!  USES
  !!   datatypes, numbers
  !!  AUTHOR
  !!   L.Tong (lt)
  !!  CREATION DATE
  !!   2010/06/15 00:17
  !!  MODIFICATION HISTORY
  !!   2012/01/22 L.Tong
  !!     - Small change to use FORTRAN 90 function declaration notation
  !!       This works better with etags
  !!  SOURCE
  !!
  function MP_step(E,order,smear)

    use datatypes
    use numbers, only: zero, one, half, two, four, pi
    use functions, ONLY: erfc_cq

    implicit none

    ! Result
    real(double) :: MP_step

    ! Passed variables
    real(double), intent(in) :: E
    integer,      intent(in) :: order
    real(double), intent(in) :: smear

    ! Internal variables
    real(double) :: x, A, H0, H1, H2, nd, x2
    integer      :: n

    ! in case of smear==0, we have the exact step function
    if(smear==zero) then
       if(E>zero) then
          MP_step = zero
       else if(E<zero) then
          MP_step = one
       else if(E==zero) then
          MP_step = half
       end if
    else if(smear>zero) then
       x = E/smear
       if(order==0) then
          MP_step = half*erfc_cq(x)
       else
          x2 = x*x
          A = one/sqrt(pi)
          H0 = one
          H1 = two*x
          MP_step = half*erfc_cq(x)
          nd = one
          do n=1,order
             A = A/((-four)*real(n,double))
             MP_step = MP_Step + A*H1*exp(-x2)
             H2 = two*x*H1 - two*nd*H0
             H0 = H1
             H1 = H2
             nd = nd + one
             H2 = two*x*H1 - two*nd*H0
             H0 = H1
             H1 = H2
             nd = nd + one
          end do
       end if
    end if
  end function MP_step
  !!***

end module process


C   IMSL ROUTINE NAME   - ZSPWB                                         ZSPS0010
C                                                                       ZSPS0020
C-----------------------------------------------------------------------ZSPS0030
C                                                                       ZSPS0040
C   COMPUTER            - VAX/SINGLE                                    ZSPS0050
C                                                                       ZSPS0060
C   LATEST REVISION     - JUNE 1, 1982                                  ZSPS0070
C                                                                       ZSPS0080
C   PURPOSE             - NUCLEUS CALLED ONLY BY IMSL SUBROUTINE ZSPOW  ZSPS0090
C                                                                       ZSPS0100
C   PRECISION/HARDWARE  - SINGLE AND DOUBLE/H32                         ZSPS0110
C                       - SINGLE/H36,H48,H60                            ZSPS0120
C                                                                       ZSPS0130
C   REQD. IMSL ROUTINES - NONE REQUIRED                                 ZSPS0140
C                                                                       ZSPS0150
C   NOTATION            - INFORMATION ON SPECIAL NOTATION AND           ZSPS0160
C                           CONVENTIONS IS AVAILABLE IN THE MANUAL      ZSPS0170
C                           INTRODUCTION OR THROUGH IMSL ROUTINE UHELP  ZSPS0180
C                                                                       ZSPS0190
C   COPYRIGHT           - 1982 BY IMSL, INC. ALL RIGHTS RESERVED.       ZSPS0200
C                                                                       ZSPS0210
C   WARRANTY            - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN ZSPS0220
C                           APPLIED TO THIS CODE. NO OTHER WARRANTY,    ZSPS0230
C                           EXPRESSED OR IMPLIED, IS APPLICABLE.        ZSPS0240
C                                                                       ZSPS0250
C-----------------------------------------------------------------------ZSPS0260
C                                                                       ZSPS0270
      SUBROUTINE ZSPWB1(FCN1,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,WA1ZSPS0280
     *                  ,WA2,PAR)                                       ZSPS0290
C                                  SPECIFICATIONS FOR ARGUMENTS         ZSPS0300
      INTEGER            N,LDFJAC,IFLAG,ML,MU                           ZSPS0310
      REAL               X(N),FVEC(N),FJAC(LDFJAC,N),EPSFCN,WA1(N),     ZSPS0320
     *                   WA2(N),PAR(N+1)                                  ZSPS0330
C                                  SPECIFICATIONS FOR LOCAL VARIABLES   ZSPS0340
      INTEGER            I,J,K,MSUM                                     ZSPS0350
      REAL               EPSMCH,EPS,H,SPMPAR,TEMP,ZERO                  ZSPS0360
c      DATA               SPMPAR /2.2204E-16/                            ZSPS0370
      DATA				 SPMPAR /1.1921E-07/
      DATA               ZERO /0.0E0/                                   ZSPS0380
C                                  EPSMCH IS THE MACHINE PRECISION.     ZSPS0390
C                                  FIRST EXECUTABLE STATEMENT           ZSPS0400
      EPSMCH = SPMPAR                                                   ZSPS0410
      EPS = sqrt(amax1(EPSFCN,EPSMCH))                                  ZSPS0420
      MSUM = ML+MU+1                                                    ZSPS0430
      IF (MSUM.LT.N) GO TO 20                                           ZSPS0440
C                                  COMPUTATION OF DENSE APPROXIMATE     ZSPS0450
C                                  JACOBIAN.                            ZSPS0460
      DO 10 J=1,N                                                       ZSPS0470
         TEMP = X(J)                                                    ZSPS0480
         H = EPS*abs(TEMP)                                              ZSPS0490
         IF (H.EQ.ZERO) H = EPS                                         ZSPS0500
         X(J) = TEMP+H                                                  ZSPS0510
         CALL FCN1(X,WA1,N,PAR)                                          ZSPS0520
         IF (IFLAG.LT.0) GO TO 15                                       ZSPS0530
         X(J) = TEMP                                                    ZSPS0540
         DO 5 I=1,N                                                     ZSPS0550
            FJAC(I,J) = (WA1(I)-FVEC(I))/H                              ZSPS0560
    5    CONTINUE                                                       ZSPS0570
   10 CONTINUE                                                          ZSPS0580
   15 CONTINUE                                                          ZSPS0590
      GO TO 50                                                          ZSPS0600
   20 CONTINUE                                                          ZSPS0610
C                                  COMPUTATION OF BANDED APPROXIMATE    ZSPS0620
C                                  JACOBIAN.                            ZSPS0630
      DO 40 K=1,MSUM                                                    ZSPS0640
         DO 25 J=K,N,MSUM                                               ZSPS0650
            WA2(J) = X(J)                                               ZSPS0660
            H = EPS*abs(WA2(J))                                         ZSPS0670
            IF (H.EQ.ZERO) H = EPS                                      ZSPS0680
            X(J) = WA2(J)+H                                             ZSPS0690
   25    CONTINUE                                                       ZSPS0700
         CALL FCN1(X,WA1,N,PAR)                                          ZSPS0710
         IF (IFLAG.LT.0) GO TO 45                                       ZSPS0720
         DO 35 J=K,N,MSUM                                               ZSPS0730
            X(J) = WA2(J)                                               ZSPS0740
            H = EPS*abs(WA2(J))                                         ZSPS0750
            IF (H.EQ.ZERO) H = EPS                                      ZSPS0760
            DO 30 I=1,N                                                 ZSPS0770
               FJAC(I,J) = ZERO                                         ZSPS0780
               IF (I.GE.J-MU .AND. I.LE.J+ML) FJAC(I,J) =               ZSPS0790
     *         (WA1(I)-FVEC(I))/H                                       ZSPS0800
   30       CONTINUE                                                    ZSPS0810
   35    CONTINUE                                                       ZSPS0820
   40 CONTINUE                                                          ZSPS0830
   45 CONTINUE                                                          ZSPS0840
   50 CONTINUE                                                          ZSPS0850
      RETURN                                                            ZSPS0860
      END                                                               ZSPS0870


!-------------------------------------------------------------------------------
!> module ATMOSPHERE driver
!!
!! @par Description
!!          Atmosphere module
!!
!! @author Team SCALE
!!
!! @par History
!! @li      2011-11-11 (H.Yashiro) [new]
!! @li      2012-02-15 (H.Yashiro) [add] Microphysics
!! @li      2012-03-23 (H.Yashiro) [mod] Cleaning
!! @li      2013-08-31 (T.Yamaura) [add] Coupler
!!
!<
!-------------------------------------------------------------------------------
module mod_atmos
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use scale_precision
  use scale_stdio
  use scale_prof
  use scale_grid_index
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: ATMOS_setup
  public :: ATMOS_step

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

  !-----------------------------------------------------------------------------
  !> Setup atmosphere
  !-----------------------------------------------------------------------------
  subroutine ATMOS_setup
    use scale_time, only: &
       TIME_NOWDATE
    use mod_atmos_vars, only: &
       ATMOS_DYN_TYPE, &
       ATMOS_PHY_SF_TYPE, &
       ATMOS_PHY_TB_TYPE, &
       ATMOS_PHY_MP_TYPE, &
       ATMOS_PHY_RD_TYPE, &
       ATMOS_PHY_AE_TYPE, &
       ATMOS_PHY_CH_TYPE, &
       DENS, &
       MOMZ, &
       MOMX, &
       MOMY, &
       RHOT, &
       QTRC, &
       DENS_tp, &
       MOMZ_tp, &
       MOMX_tp, &
       MOMY_tp, &
       RHOT_tp, &
       QTRC_tp, &
       sw_dyn    => ATMOS_sw_dyn,    &
       sw_phy_sf => ATMOS_sw_phy_sf, &
       sw_phy_tb => ATMOS_sw_phy_tb, &
       sw_phy_mp => ATMOS_sw_phy_mp, &
       sw_phy_rd => ATMOS_sw_phy_rd, &
       sw_phy_ae => ATMOS_sw_phy_ae
    use scale_atmos_solarins, only: &
       ATMOS_SOLARINS_setup
    use scale_atmos_refstate, only: &
       ATMOS_REFSTATE_setup
    use scale_atmos_boundary, only: &
       ATMOS_BOUNDARY_setup
    use mod_atmos_dyn_driver, only: &
       ATMOS_DYN_setup => ATMOS_DYN_driver_setup
    use mod_atmos_phy_sf_driver, only: &
       ATMOS_PHY_SF_setup => ATMOS_PHY_SF_driver_setup
    use mod_atmos_phy_tb_driver, only: &
       ATMOS_PHY_TB_setup => ATMOS_PHY_TB_driver_setup
    use mod_atmos_phy_mp_driver, only: &
       ATMOS_PHY_MP_setup => ATMOS_PHY_MP_driver_setup
    use mod_atmos_phy_rd_driver, only: &
       ATMOS_PHY_RD_setup => ATMOS_PHY_RD_driver_setup
    use mod_atmos_phy_ae_driver, only: &
       ATMOS_PHY_AE_setup => ATMOS_PHY_AE_driver_setup
    implicit none
    !---------------------------------------------------------------------------

    !--- setup solar insolation
    call ATMOS_SOLARINS_setup( TIME_NOWDATE(1) )

    call ATMOS_REFSTATE_setup( DENS, RHOT, QTRC ) ! (in)

    call ATMOS_BOUNDARY_setup( &
         DENS, MOMZ, MOMX, MOMY, RHOT, QTRC ) ! (in)

    ! setup each components
    if ( sw_dyn    ) call ATMOS_DYN_setup   ( ATMOS_DYN_TYPE    )

    if ( sw_phy_sf ) call ATMOS_PHY_SF_setup( ATMOS_PHY_SF_TYPE )

    if ( sw_phy_tb ) call ATMOS_PHY_TB_setup( ATMOS_PHY_TB_TYPE )

    if ( sw_phy_mp ) call ATMOS_PHY_MP_setup( ATMOS_PHY_MP_TYPE )

    if ( sw_phy_rd .or. sw_phy_ae ) call ATMOS_PHY_AE_setup( ATMOS_PHY_AE_TYPE )

    if ( sw_phy_rd ) call ATMOS_PHY_RD_setup( ATMOS_PHY_RD_TYPE )

    !########## initialize tendencies ##########
    DENS_tp(:,:,:)   = 0.0_RP
    MOMZ_tp(:,:,:)   = 0.0_RP
    MOMX_tp(:,:,:)   = 0.0_RP
    MOMY_tp(:,:,:)   = 0.0_RP
    RHOT_tp(:,:,:)   = 0.0_RP
    QTRC_tp(:,:,:,:) = 0.0_RP

    return
  end subroutine ATMOS_setup

  !-----------------------------------------------------------------------------
  !> advance atmospheric state
  !-----------------------------------------------------------------------------
  subroutine ATMOS_step
    use scale_time, only: &
       do_dyn    => TIME_DOATMOS_DYN,    &
       do_phy_sf => TIME_DOATMOS_PHY_SF, &
       do_phy_tb => TIME_DOATMOS_PHY_TB, &
       do_phy_mp => TIME_DOATMOS_PHY_MP, &
       do_phy_rd => TIME_DOATMOS_PHY_RD, &
       do_phy_ae => TIME_DOATMOS_PHY_AE
    use mod_atmos_vars, only: &
       DENS, &
       RHOT, &
       QTRC, &
       DENS_tp, &
       MOMZ_tp, &
       MOMX_tp, &
       MOMY_tp, &
       RHOT_tp, &
       QTRC_tp, &
       sw_dyn    => ATMOS_sw_dyn,    &
       sw_phy_sf => ATMOS_sw_phy_sf, &
       sw_phy_tb => ATMOS_sw_phy_tb, &
       sw_phy_mp => ATMOS_sw_phy_mp, &
       sw_phy_rd => ATMOS_sw_phy_rd, &
       sw_phy_ae => ATMOS_sw_phy_ae, &
       ATMOS_vars_history
    use mod_atmos_dyn_driver, only: &
       ATMOS_DYN => ATMOS_DYN_driver
    use mod_atmos_phy_sf_driver, only: &
       ATMOS_PHY_SF => ATMOS_PHY_SF_driver, &
       ATMOS_PHY_SF_driver_first,  &
       ATMOS_PHY_SF_driver_final
    use mod_atmos_phy_tb_driver, only: &
       ATMOS_PHY_TB => ATMOS_PHY_TB_driver
    use mod_atmos_phy_mp_driver, only: &
       ATMOS_PHY_MP => ATMOS_PHY_MP_driver
    use mod_atmos_phy_rd_driver, only: &
       ATMOS_PHY_RD => ATMOS_PHY_RD_driver
    use mod_atmos_phy_ae_driver, only: &
       ATMOS_PHY_AE => ATMOS_PHY_AE_driver
    use scale_atmos_refstate, only: &
       ATMOS_REFSTATE_update, &
       ATMOS_REFSTATE_UPDATE_FLAG
    use mod_cpl_vars, only: &
       sw_AtmLnd => CPL_sw_AtmLnd, &
       sw_AtmOcn => CPL_sw_AtmOcn
    implicit none
    !---------------------------------------------------------------------------

    !########## Reference State ###########
    if ( ATMOS_REFSTATE_UPDATE_FLAG ) then
       call ATMOS_REFSTATE_update( DENS, RHOT, QTRC ) ! (in)
    endif

    !########## Surface First ##########
    if ( sw_phy_sf ) then
       call PROF_rapstart('ATM SurfaceFlux')
       if ( sw_AtmLnd .or. sw_AtmOcn ) then
          call ATMOS_PHY_SF_driver_first
       else
          call ATMOS_PHY_SF( do_phy_sf, .true. )
       endif
       call PROF_rapend  ('ATM SurfaceFlux')
    endif

    !########## Turbulence ##########
    if ( sw_phy_tb ) then
       call PROF_rapstart('ATM Turbulence')
       call ATMOS_PHY_TB( do_phy_tb, .true. )
       call PROF_rapend  ('ATM Turbulence')
    endif

    !########## Microphysics ##########
    if ( sw_phy_mp ) then
       call PROF_rapstart('ATM Microphysics')
       call ATMOS_PHY_MP( do_phy_mp, .true. )
       call PROF_rapend  ('ATM Microphysics')
    endif

    !########## Aerosol ##########
    if ( sw_phy_ae ) then
       call PROF_rapstart('ATM Aerosol')
       call ATMOS_PHY_AE( do_phy_ae, .true. )
       call PROF_rapend  ('ATM Aerosol')
    endif

    !########## Radiation ##########
    if ( sw_phy_rd ) then
       call PROF_rapstart('ATM Radiation')
       call ATMOS_PHY_RD( do_phy_rd, .true. )
       call PROF_rapend  ('ATM Radiation')
    endif

    !########## Dynamics ##########
    if ( sw_dyn ) then
       call PROF_rapstart('ATM Dynamics')
       call ATMOS_DYN( do_dyn )
       call PROF_rapend  ('ATM Dynamics')
    endif

    !########## Surface Final ##########
    if ( sw_phy_sf ) then
       call PROF_rapstart('ATM SurfaceFlux')
       if ( sw_AtmLnd .or. sw_AtmOcn ) then
          call ATMOS_PHY_SF_driver_final
       endif
       call PROF_rapend  ('ATM SurfaceFlux')
    endif

    !########## History & Monitor ##########
    call PROF_rapstart('ATM History Vars')
    call ATMOS_vars_history
    call PROF_rapend  ('ATM History Vars')

    !########## reset tendencies ##########
    DENS_tp(:,:,:)   = 0.0_RP
    MOMZ_tp(:,:,:)   = 0.0_RP
    MOMX_tp(:,:,:)   = 0.0_RP
    MOMY_tp(:,:,:)   = 0.0_RP
    RHOT_tp(:,:,:)   = 0.0_RP
    QTRC_tp(:,:,:,:) = 0.0_RP

    return
  end subroutine ATMOS_step

end module mod_atmos


!-------------------------------------------------------------------------------
!> module Atmosphere / Dynamics FENT + FCT
!!
!! @par Description
!!          Dynamical core for Atmospheric process
!!          Full explicit, no terrain + tracer FCT limiter
!!
!! @author Team SCALE
!!
!! @par History
!! @li      2013-12-04 (S.Nishizawa) [mod] splited from scale_atmos_dyn.f90
!!
!<
!-------------------------------------------------------------------------------
#include "inc_openmp.h"
module mod_atmos_dyn_driver
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use scale_precision
  use scale_stdio
  use scale_prof
  use scale_grid_index
  use scale_tracer
#ifdef DEBUG
  use scale_debug, only: &
     CHECK
  use scale_const, only: &
     UNDEF  => CONST_UNDEF, &
     IUNDEF => CONST_UNDEF2
#endif
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: ATMOS_DYN_driver_setup
  public :: ATMOS_DYN_driver

  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
  ! time integration scheme
  integer,  private, parameter :: RK = 3             ! order of Runge-Kutta scheme

  ! numerical filter
  integer,  private :: ATMOS_DYN_numerical_diff_order        = 1
  real(RP), private :: ATMOS_DYN_numerical_diff_coef         = 1.0E-4_RP ! nondimensional numerical diffusion
  real(RP), private :: ATMOS_DYN_numerical_diff_sfc_fact     = 1.0_RP
  logical , private :: ATMOS_DYN_numerical_diff_use_refstate = .true.
  real(RP), private :: ATMOS_DYN_DIFF4                                   ! for numerical filter

  ! Coriolis force
  logical,  private              :: ATMOS_DYN_enable_coriolis = .false. ! enable coriolis force?

  ! divergence damping
  real(RP), private :: ATMOS_DYN_divdmp_coef = 0.0_RP      ! Divergence dumping coef

  ! fct
  logical,  private :: ATMOS_DYN_FLAG_FCT_rho      = .false.
  logical,  private :: ATMOS_DYN_FLAG_FCT_momentum = .false.
  logical,  private :: ATMOS_DYN_FLAG_FCT_T        = .false.

  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  !> Setup
  subroutine ATMOS_DYN_driver_setup( DYN_TYPE )
    use scale_process, only: &
       PRC_MPIstop
    use scale_time, only: &
       TIME_DTSEC_ATMOS_DYN
    use scale_grid, only: &
       GRID_CDZ, &
       GRID_CDX, &
       GRID_CDY, &
       GRID_FDZ, &
       GRID_FDX, &
       GRID_FDY
    use scale_grid_real, only: &
       REAL_LAT
    use scale_atmos_dyn, only: &
       ATMOS_DYN_setup
    implicit none

    character(len=H_SHORT), intent(in) :: DYN_TYPE

    NAMELIST / PARAM_ATMOS_DYN / &
       ATMOS_DYN_numerical_diff_order,        &
       ATMOS_DYN_numerical_diff_coef,         &
       ATMOS_DYN_numerical_diff_sfc_fact,     &
       ATMOS_DYN_numerical_diff_use_refstate, &
       ATMOS_DYN_enable_coriolis,             &
       ATMOS_DYN_divdmp_coef,                 &
       ATMOS_DYN_FLAG_FCT_rho,                &
       ATMOS_DYN_FLAG_FCT_momentum,           &
       ATMOS_DYN_FLAG_FCT_T

    real(RP) :: DT

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

    if( IO_L ) write(IO_FID_LOG,*)
    if( IO_L ) write(IO_FID_LOG,*) '+++ Module[Dynamics]/Categ[ATMOS]'

    !--- read namelist
    rewind(IO_FID_CONF)
    read(IO_FID_CONF,nml=PARAM_ATMOS_DYN,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_ATMOS_DYN. Check!'
       call PRC_MPIstop
    endif
    if( IO_L ) write(IO_FID_LOG,nml=PARAM_ATMOS_DYN)

    !-- Block size must be divisible
    if    ( mod(IMAX,IBLOCK) > 0 ) then
       if( IO_L ) write(IO_FID_LOG,*) 'xxx number of grid size IMAX must be divisible by IBLOCK! ', IMAX, IBLOCK
       call PRC_MPIstop
    elseif( mod(JMAX,JBLOCK) > 0 ) then
       if( IO_L ) write(IO_FID_LOG,*) 'xxx number of grid size JMAX must be divisible by JBLOCK! ', JMAX, JBLOCK
       call PRC_MPIstop
    endif

    DT = real(TIME_DTSEC_ATMOS_DYN,kind=RP)

    call ATMOS_DYN_setup( ATMOS_DYN_DIFF4,                & ! [OUT]
                          DYN_TYPE,                       & ! [IN]
                          GRID_CDZ, GRID_CDX, GRID_CDY,   & ! [IN]
                          GRID_FDZ, GRID_FDX, GRID_FDY,   & ! [IN]
                          ATMOS_DYN_numerical_diff_order, & ! [IN]
                          ATMOS_DYN_numerical_diff_coef,  & ! [IN]
                          DT,                             & ! [IN]
                          ATMOS_DYN_enable_coriolis,      & ! [IN]
                          REAL_LAT                        ) ! [IN]

    return
  end subroutine ATMOS_DYN_driver_setup

  !-----------------------------------------------------------------------------
  !> Dynamical Process (Wrapper)
  subroutine ATMOS_DYN_driver( do_flag )
    use scale_time, only: &
       TIME_DTSEC,           &
       TIME_DTSEC_ATMOS_DYN, &
       TIME_NSTEP_ATMOS_DYN
    use scale_grid, only: &
       GRID_CDZ,  &
       GRID_CDX,  &
       GRID_CDY,  &
       GRID_FDZ,  &
       GRID_FDX,  &
       GRID_FDY,  &
       GRID_RCDZ, &
       GRID_RCDX, &
       GRID_RCDY, &
       GRID_RFDZ, &
       GRID_RFDX, &
       GRID_RFDY
    use scale_grid_real, only: &
       REAL_PHI
    use scale_gridtrans, only: &
       GTRANS_GSQRT, &
       GTRANS_J13G,  &
       GTRANS_J23G,  &
       GTRANS_J33G
    use scale_history, only: &
       HIST_in
    use mod_atmos_vars, only: &
       ATMOS_vars_total,  &
       ATMOS_USE_AVERAGE, &
       DENS,    &
       MOMZ,    &
       MOMX,    &
       MOMY,    &
       RHOT,    &
       QTRC,    &
       DENS_av, &
       MOMZ_av, &
       MOMX_av, &
       MOMY_av, &
       RHOT_av, &
       QTRC_av, &
       DENS_tp, &
       MOMZ_tp, &
       MOMX_tp, &
       MOMY_tp, &
       RHOT_tp, &
       QTRC_tp
    use scale_atmos_thermodyn, only: &
       AQ_CV
    use scale_atmos_refstate, only: &
       ATMOS_REFSTATE_dens, &
       ATMOS_REFSTATE_pott, &
       ATMOS_REFSTATE_qv,   &
       ATMOS_REFSTATE_pres
    use scale_atmos_boundary, only: &
       ATMOS_BOUNDARY_var,   &
       ATMOS_BOUNDARY_alpha
    use scale_atmos_dyn, only: &
       ATMOS_DYN
    implicit none
    logical, intent(in) :: do_flag
    !---------------------------------------------------------------------------

    if ( do_flag ) then

    if( IO_L ) write(IO_FID_LOG,*) '*** Dynamics step'

    call ATMOS_DYN( &
         DENS, MOMZ, MOMX, MOMY, RHOT, QTRC,                   & ! [INOUT]
         DENS_av, MOMZ_av, MOMX_av, MOMY_av, RHOT_av, QTRC_av, & ! [INOUT]
         DENS_tp, MOMZ_tp, MOMX_tp, MOMY_tp, RHOT_tp, QTRC_tp, & ! [IN]
         GRID_CDZ,  GRID_CDX,  GRID_CDY,                       & ! [IN]
         GRID_FDZ,  GRID_FDX,  GRID_FDY,                       & ! [IN]
         GRID_RCDZ, GRID_RCDX, GRID_RCDY,                      & ! [IN]
         GRID_RFDZ, GRID_RFDX, GRID_RFDY,                      & ! [IN]
         REAL_PHI,                                             & ! [IN]
         GTRANS_GSQRT,                                         & ! [IN]
         GTRANS_J13G, GTRANS_J23G, GTRANS_J33G,                & ! [IN]
         AQ_CV,                                                & ! [IN]
         ATMOS_REFSTATE_dens,                                  & ! [IN]
         ATMOS_REFSTATE_pott,                                  & ! [IN]
         ATMOS_REFSTATE_qv,                                    & ! [IN]
         ATMOS_REFSTATE_pres,                                  & ! [IN]
         ATMOS_DYN_DIFF4,                                      & ! [IN]
         ATMOS_DYN_numerical_diff_order,                       & ! [IN]
         ATMOS_DYN_numerical_diff_sfc_fact,                    & ! [IN]
         ATMOS_DYN_numerical_diff_use_refstate,                & ! [IN]
         ATMOS_BOUNDARY_var,                                   & ! [IN]
         ATMOS_BOUNDARY_alpha,                                 & ! [IN]
         ATMOS_DYN_divdmp_coef,                                & ! [IN]
         ATMOS_DYN_FLAG_FCT_rho,                               & ! [IN]
         ATMOS_DYN_FLAG_FCT_momentum,                          & ! [IN]
         ATMOS_DYN_FLAG_FCT_T,                                 & ! [IN]
         ATMOS_USE_AVERAGE,                                    & ! [IN]
         TIME_DTSEC,                                           & ! [IN]
         TIME_DTSEC_ATMOS_DYN,                                 & ! [IN]
         TIME_NSTEP_ATMOS_DYN                                  ) ! [IN]

    call ATMOS_vars_total

    end if

    return
  end subroutine ATMOS_DYN_driver

end module mod_atmos_dyn_driver


c###setluf.for
      SUBROUTINE SETLUF
C--------------------------------
C.....THIS SUBROUTINE SETS THE LUF USING THE FREQUENCY COMPLEMENT AND
C.....COMPUTED RELIABILITIES. THESE VALUES ARE CHANGED IN SUBROUTINE
C.....GETLUF IF THE LUF IS ACTUALLY COMPUTED
C
      COMMON/FRQ/FREA(13),FREL(29),FREQ,JMODE,ITXRCP(2)
      COMMON / ION / IHRE, IHRO, IHRS, LUFP, METHOD, NOISE, NPSL
      COMMON / MUFS / EMUF(24), F1MUF(24), F2MUF(24), ESMUF(24),
     A ALLMUF(24), FOT(24), XLUF(24), HPF(24), ANGMUF(24), MODMUF,
     B SIGL(4), SIGU(4), DELMUF(4), HPMUF(4), HTMUF(4), FVMUF(4),
     C AFMUF(4), NHOPMF(4), YFOT(4), YHPF(4), YMUF(4)
      COMMON / SON / ANGLE(13), ANGLER(13), CPROB(13), DBLOS(13),
     A DBLOSL(13), DBLOSU(13), DBU(13), DELAY(13), DBW(13), NHP(13),
     B XNYNOIS(13), PROBMP(13), RELIAB(13), SNDB(13), SNPR(13),
     C SNRLW(13), SNRUP(13), SPROB(13), VHIGH(13), RNEFF(13),MDL(13)
       CHARACTER MDL*1
      COMMON / TIME / IT, GMT, UTIME(24), GMTR, XLMT(24), ITIM, JTX
C
      RF = FREL(1)
      REL = RELIAB(1)
      PLUF = LUFP
      PLUF = 0.01 * PLUF
      DO 200 IF = 1,11
      IF(FREL(IF)) 200, 200, 105
  105 IF(RELIAB(IF) - PLUF) 115, 110, 110
  110 XLUF(IT) = FREL(IF)
      FREL(13) = FREL(IF)
      GO TO 205
  115 IF(RELIAB(IF) - REL) 200, 200, 120
  120 REL = RELIAB(IF)
      RF = FREL(IF)
  200 CONTINUE
      XLUF(IT) = - RF
      FREL(13) = RF
  205 CONTINUE
      RETURN
      END
C--------------------------------