subroutine s_rmsd_inner_product(num_atoms,do_count,x1,x2,A,E0)
!
! This subroutine is part of the implementation of Quaternion Characteristic
! Polynomial (QCP) method, based on the code published by Naoto Hori at:
!
! https://github.com/naotohori/fQCP
!
! under BSD license. His code, in turn, is based on the C code written by Pu Liu
! and Douglas L. Theobald. The code bellow is improved and partially revised by
! Veselin Kolev <vesso.kolev@gmail.com>.
!
! To cite QCP:
!
! 1. Douglas L. Theobald (2005) "Rapid calculation of RMSD using a quaternion-based
!    characteristic polynomial." Acta Crystallographica A 61(4):478-480.
!
! 2. Pu Liu, Dmitris K. Agrafiotis, and Douglas L. Theobald (2010) "Fast
!    determination of the optimal rotational matrix for do_counted  superpositions."
!    Journal of Computational Chemistry 31(7):1561-1563
!
! Author : Veselin Kolev <vesso.kolev@gmail.com>
! License: BSD
! Version: 2018121200
!
use iso_c_binding,only:C_INT,C_FLOAT
!
implicit none
!
! Interface variables:
!
integer(C_INT),intent(in) :: num_atoms
logical,intent(in)        :: do_count(num_atoms)
real(C_FLOAT),intent(in)  :: x1(3,num_atoms)
real(C_FLOAT),intent(in)  :: x2(3,num_atoms)
real(C_FLOAT),intent(out) :: A(9)
real(C_FLOAT),intent(out) :: E0
!
! Local variables:
!
integer(C_INT)            :: i
integer(C_INT)            :: j
integer(C_INT)            :: k(2)
real(C_FLOAT)             :: G
real(C_FLOAT)             :: tmp

! Nullify the elements of the array 'A':
!
A=0.0
!
! ... and do the same for the value of 'G':
!
G=0.0
!
do i=1,num_atoms
   !
   if (do_count(i)) then
      !
      tmp=0.0
      !
      do j=1,3
         !
         k(1)=3*(j-1)
         !
         k(1)=k(1)+1
         k(2)=k(1)+2
         !
         A(k(1):k(2))=A(k(1):k(2))+x1(j,i)*x2(:,i)
         !
         tmp=tmp+x1(j,i)**2+x2(j,i)**2
         !
      end do
      !
      G=G+tmp
      !
   end if
   !
end do
!
E0=G/2

end subroutine s_rmsd_inner_product


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc              mnprof : profil test program                          cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real fac,facx,u
      integer i,ier,iopt,j,kx,kx1,ky,ky1,m,mx,my,m0,m1,m2,m3,nc,
     * nkx1,nky1,nx,ny
      real tx(15),ty(15),c(100),x(6),y(6),z(36),cc(15)
c  we set up the grid points for evaluating the tensor product splines.
      mx = 6
      my = 6
      m = mx*my
      do 10 i=1,6
      x(i) = (i-1)*0.2
      y(i) = x(i)
  10  continue
c  loop for different spline degrees with respect to the x-variable
      do 300 kx=3,5,2
c  the knots in the x-direction
        tx(kx+2) = 0.4
        tx(kx+3) = 0.7
        tx(kx+4) = 0.9
        kx1 = kx+1
        nx = 3+2*kx1
        j = nx
        do 20 i=1,kx1
          tx(i) = 0.
          tx(j) = 1.
          j = j-1
  20    continue
c  loop for different spline degrees with respect to the y-variable
      do 200 ky=2,3
c  the knots in the y-direction
        ty(ky+2) = 0.3
        ty(ky+3) = 0.8
        ky1 = ky+1
        ny = 2+2*ky1
        j = ny
        do 30 i=1,ky1
          ty(i) = 0.
          ty(j) = 1.
          j = j-1
  30    continue
c  we generate the b-spline coefficients for the test function x*y
        nkx1 = nx-kx1
        nky1 = ny-ky1
        do 40 i=1,nky1
          c(i) = 0.
  40    continue
        do 50 i=2,nkx1
          c((i-1)*nky1+1) = 0.
  50    continue
        fac = kx*ky
        m0 = 1
        do 70 i=2,nkx1
          m1 = m0+nky1
          facx = (tx(i+kx)-tx(i))/fac
          do 60 j=2,nky1
            m2 = m0+1
            m3 = m1+1
            c(m3) = c(m1)+c(m2)-c(m0)+facx*(ty(j+ky)-ty(j))
            m0 = m0+1
            m1 = m1+1
  60      continue
          m0 = m0+1
  70    continue
c  printing of the spline information
        write(6,900) kx,ky
        write(6,910)
        write(6,920) (tx(i),i=1,nx)
        write(6,930)
        write(6,920) (ty(i),i=1,ny)
        nc = nkx1*nky1
        write(6,940)
        write(6,950) (c(i),i=1,nc)
c  we calculate a number of profiles f(y)=s(u,y)
        iopt = 0
        m0 = 1
        do 80 i=1,mx
          u = x(i)
          call profil(iopt,tx,nx,ty,ny,c,kx,ky,u,15,cc,ier)
          write(6,955) u
          write(6,950) (cc(j),j=1,nky1)
c  evaluation of the one-dimensional spline f(y)
          call splev(ty,ny,cc,ky,y,z(m0),my,ier)
          m0 = m0+my
  80    continue
        write(6,960)
        write(6,970) (y(i),i=1,my)
        write(6,980)
        m2 = 0
        do 100 i=1,mx
          m1 = m2+1
          m2 = m2+my
          write(6,990) x(i),(z(j),j=m1,m2)
 100    continue
c  we calculate a number of profiles g(x)=s(x,u)
        iopt = 1
        m0 = 1
        do 120 i=1,my
          u = y(i)
          call profil(iopt,tx,nx,ty,ny,c,kx,ky,u,15,cc,ier)
          write(6,995) u
          write(6,950) (cc(j),j=1,nkx1)
c  evaluation of the one-dimensional spline g(x)
          call splev(tx,nx,cc,kx,x,z(m0),mx,ier)
          m0 = m0+mx
 120    continue
        write(6,960)
        write(6,970) (y(i),i=1,my)
        write(6,980)
        do 140 i=1,mx
          write(6,990) x(i),(z(j),j=i,m,mx)
 140    continue
 200    continue
 300  continue
      stop
c  format statements.
 900  format(33h0tensor product spline of degrees,2i3)
 910  format(1x,40hposition of the knots in the x-direction)
 920  format(1x,15f5.1)
 930  format(1x,40hposition of the knots in the y-direction)
 940  format(23h b-spline coefficients )
 950  format(1x,8f9.4)
 955  format(45h0b-spline coefficients of the profile f(y)=s(,f3.1,
     * 3h,y))
 960  format(1h0,37hspline values at selected grid points)
 970  format(1h0,8x,1hy,4x,6(4x,f4.1))
 980  format(1h ,7x,1hx)
 990  format(6x,f4.1,5x,6f8.2)
 995  format(47h0b-spline coefficients of the profile g(x)=s(x,,f3.1,
     * 1h))
      end


!**********************************************************************************************!
!                                   NEURAL NETWORK MODULE                                      !
!**********************************************************************************************!
module NobleNeuron
    use NNLayers

    implicit none

    integer,parameter,private   :: dp = kind(1.d0)

    !------------------------------------------------------
    ! Neural Network Class
    !------------------------------------------------------
    type :: NeuralNetwork
        type(Layer),pointer :: head => null()
        type(Layer),pointer :: tail => null()

        integer             :: LayerNumber = 0
        integer             :: input_size

        character(len=20)   :: lossType
        character(len=20)   :: Optimizer

        ! Adam
        real(dp)            :: beta1,beta2,beta1n,beta2n

        contains

        ! Add Layers
        procedure           :: addLayer
        procedure,private   :: insertLayer

        ! Feedforward & backpropagation
        procedure           :: backpropagate
        procedure           :: feedforward
        procedure           :: applyGrads
        procedure           :: Loss, gradLoss
        procedure           :: output

    end type

    interface NeuralNetwork
        procedure   :: NN_Constructor
    end interface

    contains

    !------------------------------------------------------
    ! Neural Network Constructor
    !------------------------------------------------------
    function NN_Constructor(isize,loss,optimizer) result(self)
        implicit none

        type(NeuralNetwork) :: self
        integer,intent(in)              :: isize
        character(len=*),intent(in)     :: loss
        character(len=*),intent(in)     :: optimizer

        nullify(self%head)
        nullify(self%tail)

        self%LayerNumber = 0
        self%input_size = isize
        self%lossType = loss
        self%Optimizer = optimizer

        ! Adam
        self%beta1 = 0.9
        self%beta2 = 0.999
        self%beta1n = 0.9
        self%beta2n = 0.999
    end function

    !------------------------------------------------------
    ! Output
    !------------------------------------------------------
!     subroutine output(self,Z)
!         implicit none
!
!         class(NeuralNetwork),intent(in) :: self
!         real(dp),intent(out)            :: Z(:,:)
!
!         Z = self%tail%Z
!     end subroutine

    !------------------------------------------------------
    ! Feed Forward
    !------------------------------------------------------
    subroutine feedforward(self,X)
        implicit none

        class(NeuralNetwork),intent(inout)  :: self
        real(dp),intent(in)                 :: X(:,:)

        class(Layer),pointer    :: tmp
        integer                 :: i

        tmp => self%head
        do while(associated(tmp))

            if (associated(tmp,self%head)) then
                call tmp%feed(X)
            else
                call tmp%feed(tmp%prev%Z)
            end if

            tmp => tmp%next
        end do

    end subroutine

    !------------------------------------------------------
    ! BackPropagation
    !------------------------------------------------------
    subroutine backpropagate(self,X,dL)
        implicit none

        class(NeuralNetwork),intent(inout)  :: self
        real(dp),intent(in)                 :: X(:,:)
        real(dp),intent(in)                 :: dL(:,:)

        class(Layer),pointer    :: tmp

        tmp => self%tail
        do while(associated(tmp))
            !---------- TAIL ----------!
            if (associated(tmp,self%tail)) then
                !----- Binary X-Entropy -----!
                if (self%lossType .eq. "BCE" .or. self%lossType .eq. "REINFORCE") then
                    call tmp%back(tmp%prev%Z,dL,.true.)
                else
                    !--- Single Layer: Head = Tail ---!
                    if (associated(tmp,self%head)) then
                        call tmp%back(X,dL,.false.)
                    else
                    !--- Multilayer: Head != Tail ---!
                        call tmp%back(tmp%prev%Z,dL,.false.)
                    end if
                end if
            !--- INTERMEDIATE LAYER ---!
            else
                !--- Head ---!
                if (associated(tmp,self%head)) then
                    call tmp%back(X,tmp%next%dL,.false.)
                else
                !--- Intermediate layer ---!
                    call tmp%back(tmp%prev%Z,tmp%next%dL,.false.)
                end if

            end if

            tmp => tmp%prev
        end do
    end subroutine

    !======================================================
    ! OPTIMIZERS & GRADIENT
    !======================================================
    ! Update filters
    subroutine applyGrads(self,learning_rate)
        implicit none

        class(NeuralNetwork),intent(inout)  :: self
        real                                :: learning_rate

        class(Layer),pointer    :: tmp

        tmp => self%head

        ! Flatten, Pooling have no learnable parameters
        do while(associated(tmp))
            select case(self%Optimizer)
                case ("SGD")
                    call tmp%ApplyLayerGrads(learning_rate)
                case ("SGA")
                    call tmp%ApplyLayerAscent(learning_rate)
                case ("Adam")
                    call tmp%ApplyLayerAdam(learning_rate,self%beta1,self%beta2,self%beta1n,self%beta2n)
                    self%beta1n = self%beta1n*self%beta1
                    self%beta2n = self%beta2n*self%beta2
            end select

            call tmp%ZeroLayerGrads()

            tmp => tmp%next
        end do
    end subroutine

    ! ZeroGradients
    subroutine ZeroGrads(self)
        implicit none

        class(NeuralNetwork),intent(inout)  :: self

        class(Layer),pointer    :: tmp

        tmp => self%head
        do while(associated(tmp))
            call tmp%ZeroLayerGrads()

            tmp => tmp%next
        end do
    end subroutine

    ! Output of neural network
    function output(self) result(Z)
        implicit none

        class(NeuralNetwork),intent(in) :: self
        real(dp)                        :: Z(size(self%tail%Z,1),size(self%tail%Z,2))

        Z = self%tail%Z
    end function

    ! Backpropagate error
    function dL(self) result(Z)
        implicit none

        class(NeuralNetwork),intent(in) :: self
        real(dp)                        :: Z(size(self%head%dL,1),size(self%head%dL,2))

        Z = self%head%dL
    end function

    !======================================================
    ! LOSS
    !======================================================
    function Loss(self,expected) result(L)
        use NNLoss
        implicit none

        class(NeuralNetwork),intent(in) :: self
        real(dp),intent(in)             :: expected(:,:)
        real(dp)                        :: L

        select case(self%lossType)
            case("BCE")
                L = sum(elementalLoss(self%tail%Y,expected,self%LossType))/size(self%tail%Y)

            case("REINFORCE")
                L = sum((expected - self%tail%Z)*self%tail%Y)

            case default
                L = sum(elementalLoss(self%tail%Z,expected,self%LossType))/size(self%tail%Z)

        end select

    end function

    ! Last gradient
    function GradLoss(self,expected) result(Z)
        use NNLoss
        implicit none

        class(NeuralNetwork),intent(inout)  :: self
        real(dp),intent(in)                 :: expected(:,:)
        real(dp)                            :: Z(size(expected,2),size(expected,1))

        select case(self%lossType)
            case("REINFORCE")
                Z = expected - self%tail%Z

            case default
                Z = deLoss(self%tail%Z,expected,self%lossType)
        end select
    end function

    !======================================================
    ! ADD LAYERS
    !======================================================

    ! Add Generic Layer
    function insertLayer(self,activation) result(no)
        implicit none

        class(NeuralNetwork),intent(inout)  :: self
        character(len=*),intent(in)         :: activation
        integer                             :: no

        class(Layer),pointer    :: tmp

        self%LayerNumber = self%LayerNumber + 1
        no = self%LayerNumber

        allocate(tmp)
        tmp%layerNumber = no
        tmp%activation = activation

        ! Link layer
        tmp%next => null()
        if (.not. associated(self%head)) then
            tmp%prev => null()
            tmp%isize = self%input_size
            self%head => tmp
            self%tail => tmp
        else
            tmp%prev => self%tail
            tmp%isize = size(self%tail%Z)
            self%tail%next => tmp
            self%tail => tmp
        end if
    end function

    ! Add Dense Layer
    function addLayer(self,output_size,activation) result(no)
        implicit none

        class(NeuralNetwork),intent(inout)  :: self
        integer,intent(in)                  :: output_size
        character(len=*),intent(in)         :: activation
        integer                             :: no

        ! Allocate
        no = self%insertLayer(activation)
        allocate(self%tail%W(output_size,self%tail%isize))
        allocate(self%tail%dW(self%tail%isize,output_size))
        allocate(self%tail%B(output_size,1))
        allocate(self%tail%dB(1,output_size))
        allocate(self%tail%Y(output_size,1))
        allocate(self%tail%Z(output_size,1))
        allocate(self%tail%dL(1,self%tail%isize))
        ! Adam
        allocate(self%tail%Wm(self%tail%isize,output_size))
        allocate(self%tail%Wv(self%tail%isize,output_size))
        allocate(self%tail%Bm(1,output_size))
        allocate(self%tail%Bv(1,output_size))

        ! Zero gradients
        self%tail%dW = 0.0
        self%tail%dB = 0.0
        self%tail%Wm = 0.0
        self%tail%Wv = 0.0
        self%tail%Bm = 0.0
        self%tail%Bv = 0.0

        ! Randomize filters
        call random_number(self%tail%W)
        self%tail%W = 2*(self%tail%W - 0.5)/sqrt(real(self%tail%isize))
        self%tail%B = 0.0

        write(*,*) "Added Dense layer,       #",no,"in :",self%tail%isize
        write(*,*) "                         #",no,"out:",shape(self%tail%Z),self%tail%activation
    end function

end module


  MODULE constants

  use input, only: control_lve

  implicit none

  public

    real :: g,rd,rv,cp,cpinv,cv,cpv,cvv,rcp,                                 &
            cpdcv,rovcp,rddcp,rddcv,rddrv,cvdrd,cpdrd,eps,reps,repsm1,       &
            cpt,cvt,pnum,xlv,lathv,xls,lvdcp,condc,cpl,cpi,lv1,lv2,ls1,ls2,  &
            rhow,c_e1,c_e2,c_s,rcs,earth_radius,govtwo

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

      real, parameter ::  pi     = 3.1415926535897932384626433
      real, parameter ::  th0r   = 300.0
      real, parameter ::  to     = 273.15
      real, parameter ::  p00    = 1.0e5
      real, parameter ::  rp00   = 1.0/p00
      real, parameter ::  piddeg = pi/180.0
      real, parameter ::  degdpi = 180.0/pi
      real, parameter ::  clwsat = 1.e-6
      real, parameter ::  karman = 0.40
      real, parameter ::  omega  = 2.0*pi/86400.0

      !----------------
      ! Implicit vertical diffusion.  For vialpha:
      !      0.0 = explicit forward-in-time (unstable if K dt / (dz^2) > 0.5)
      !      0.5 = implicit centered-in-time (Crank-Nicholson)
      !      1.0 = implicit backward-in-time (implicit Euler)
      real, parameter ::  vialpha = 0.5

      ! DO NOT CHANGE VIBETA:
      real, parameter ::  vibeta = 1.0 - vialpha

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

      ! open bc phase velocity:
      real, parameter ::  cstar = 30.0

      ! open bc max velocity:
      real, parameter ::  csmax = 350.0

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

      ! parameters for LES subgrid turbulence:
      real, parameter ::  c_m  = 0.10
      real, parameter ::  c_l  = 0.8165
      real, parameter ::  ri_c = 0.25

      !----------------
      ! stuff for weno / advection:
      real, parameter :: epsilon = 1.0e-18
      !----------------

      integer, parameter :: nrkmax = 3

      real, parameter :: grads_undef  =  -999999.9

  CONTAINS

    !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      subroutine set_constants( testcase )
      implicit none

      integer, intent(in) :: testcase

      !--------------------
      !  For test cases:

      IF( testcase.eq.4 )THEN

        !  nonprecipitating stratocumulus (Stevens et al, 2005, MWR)
        g      = 9.81
        rd     = 287.0
        cp     = 1015.0
        cpv    = 1870.0
        xlv    = 2.47e6
        xls    = 2834000.0
        earth_radius  =  6370000.0

      ELSEIF( testcase.eq.5 )THEN

        !  drizzling stratocumulus (Ackerman et al, 2009, MWR)
        g      = 9.81
        rd     = 287.0
        cp     = 1004.0
        cpv    = 1870.0
        xlv    = 2.50e6
        xls    = 2834000.0
        earth_radius  =  6370000.0

      ELSE

        !  RCEMIP
!!!        g      = 9.79764
!!!        rd     = 287.04
!!!        cp     = 1004.64
!!!        cpv    = 1846.0
!!!        xlv    = 2501000.0
!!!        xls    = 2834700.0
!!!        earth_radius  =  6371000.0

        !  cm1 defaults:
        g      = 9.81
        rd     = 287.04
        cp     = 1005.7
        cpv    = 1870.0
        xlv    = control_lve*2501000.0
        xls    = control_lve*2834000.0
        earth_radius  =  6370000.0

      ENDIF

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

      govtwo = 0.5*g
      rv     = 461.5
      cpinv  = 1.0/cp
      cv     = cp-rd
      cvv    = cpv-rv
      rcp    = 1.0/cp
      cpdcv  = cp/cv
      rovcp  = rd/cp
      rddcp  = rd/cp
      rddcv  = rd/cv
      rddrv  = rd/rv
      cvdrd  = cv/rd
      cpdrd  = cp/rd
      eps    = rd/rv
      reps   = rv/rd
      repsm1 = rv/rd-1.0
      cpt    = (cpv/cp)-1.0
      cvt    = (cvv/cv)-1.0
      pnum   = (cp*rv)-(cpv*rd)
      lathv  = xlv
      lvdcp  = xlv/cp
      condc  = xlv*xlv/(rv*cp)
      cpl    = 4190.0
      cpi    = 2106.0
      lv1    = xlv+(cpl-cpv)*to
      lv2    = cpl-cpv
      ls1    = xls+(cpi-cpv)*to
      ls2    = cpi-cpv
      rhow   = 1.0e3

      IF( testcase.eq.4 .or. testcase.eq.5 )THEN
        lv1 = xlv
        lv2 = 0.0
      ENDIF

      ! DO NOT CHANGE THESE:
      c_e1 = c_m * c_l * c_l * ( 1.0 / ri_c - 1.0 )
      c_e2 = max( 0.0 , c_m * pi * pi - c_e1 )
      c_s = ( c_m * c_m * c_m / ( c_e1 + c_e2 ) )**0.25   ! Smagorinsky constant
      rcs = 1.0/c_s

      end subroutine set_constants

    !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

  END MODULE constants


      SUBROUTINE slS2C6 ( A, B, R, AD, BD, RD, V )
*+
*     - - - - - -
*      S 2 C 6
*     - - - - - -
*
*  Conversion of position & velocity in spherical coordinates
*  to Cartesian coordinates (single precision)
*
*  Given:
*     A     r      longitude (radians)
*     B     r      latitude (radians)
*     R     r      radial coordinate
*     AD    r      longitude derivative (radians per unit time)
*     BD    r      latitude derivative (radians per unit time)
*     RD    r      radial derivative
*
*  Returned:
*     V     r(6)   Cartesian position & velocity vector
*
*  Last revision:   11 September 2005
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      REAL A, B, R, AD, BD, RD, V(6)

      REAL SA, CA, SB, CB, RCB, X, Y, RBD, W

*  Useful functions.
      SA = SIN(A)
      CA = COS(A)
      SB = SIN(B)
      CB = COS(B)
      RCB = R*CB
      X = RCB*CA
      Y = RCB*SA
      RBD = R*BD
      W = RBD*SB-CB*RD

*  Position.
      V(1) = X
      V(2) = Y
      V(3) = R*SB

*  Velocity.
      V(4) = -Y*AD-W*CA
      V(5) = X*AD-W*SA
      V(6) = RBD*CB+SB*RD

      END


      subroutine gday(idd,imm,iyy,icc,kd,ierr)
C!
C!  GIVEN DAY,MONTH,YEAR AND CENTURY(EACH 2 DIGITS), GDAY RETURNS
C!  THE DAY#, KD BASED ON THE GREGORIAN CALENDAR.
C!  THE GREGORIAN CALENDAR, CURRENTLY 'UNIVERSALLY' IN USE WAS
C!  INITIATED IN EUROPE IN THE SIXTEENTH CENTURY. NOTE THAT GDAY
C!  IS VALID ONLY FOR GREGORIAN CALENDAR DATES.
C
C   KD=1 CORRESPONDS TO JANUARY 1, 0000
C
c       Note that the Gregorian reform of the Julian calendar
c       omitted 10 days in 1582 in order to restore the date
c       of the vernal equinox to March 21 (the day after
c       Oct 4, 1582 became Oct 15, 1582), and revised the leap
c       year rule so that centurial years not divisible by 400
c       were not leap years.
c
C   THIS ROUTINE WAS WRITTEN BY EUGENE NEUFELD, AT IOS, IN JUNE 1990.
C
c       STOP statements replaced by error returns.
c       Mar 1999, Bruce Hackett DNMI

      INTEGER NDP(13)
      INTEGER NDM(12)
      integer     idd,imm,iyy,icc,kd,lp,kkd,jfh,jcc,jfy,kk,jyy,jyyy
      integer     i,j,k,l
      integer     ierr
      DATA NDP/0,31,59,90,120,151,181,212,243,273,304,334,365/
      DATA NDM/31,28,31,30,31,30,31,31,30,31,30,31/
C!
      LP = 6
      ierr = 0
C!  TEST FOR INVALID INPUT:
      IF(ICC.LT.0)THEN
         WRITE(LP,5000)ICC
         ierr = -1
         return
      ENDIF
      IF(IYY.LT.0.OR.IYY.GT.99)THEN
         WRITE(LP,5010)IYY
         ierr = -1
         return
      ENDIF
      IF(IMM.LE.0.OR.IMM.GT.12)THEN
         WRITE(LP,5020)IMM
         ierr = -1
         return
      ENDIF
      IF(IDD.LE.0)THEN
         WRITE(LP,5030)IDD
         ierr = -1
         return
      ENDIF
      IF(IMM.NE.2.AND.IDD.GT.NDM(IMM))THEN
         WRITE(LP,5030)IDD
         ierr = -1
         return
      ENDIF
      IF(IMM.EQ.2.AND.IDD.GT.29)THEN
         WRITE(LP,5030)IDD
         ierr = -1
         return
      ENDIF
      IF(IMM.EQ.2.AND.IDD.GT.28.AND.((IYY/4)*4-IYY.NE.0.OR.(IYY.EQ.0.AND
     .    .(ICC/4)*4-ICC.NE.0)))THEN
         WRITE(LP,5030)IDD
         ierr = -1
         return
      ENDIF
5000  FORMAT(' INPUT ERROR. ICC = ',I7)
5010  FORMAT(' INPUT ERROR. IYY = ',I7)
5020  FORMAT(' INPUT ERROR. IMM = ',I7)
5030  FORMAT(' INPUT ERROR. IDD = ',I7)
C!
C!  CALCULATE DAY# OF LAST DAY OF LAST CENTURY:
      KD = ICC*36524 + (ICC+3)/4
C!
C!  CALCULATE DAY# OF LAST DAY OF LAST YEAR:
      KD = KD + IYY*365 + (IYY+3)/4
C!
C!  ADJUST FOR CENTURY RULE:
C!  (VIZ. NO LEAP-YEARS ON CENTURYS EXCEPT WHEN THE 2-DIGIT
C!  CENTURY IS DIVISIBLE BY 4.)
      IF(IYY.GT.0.AND.(ICC-(ICC/4)*4).NE.0) KD=KD-1
C!  KD NOW TRULY REPRESENTS THE DAY# OF THE LAST DAY OF LAST YEAR.
C!
C!  CALCULATE DAY# OF LAST DAY OF LAST MONTH:
      KD = KD + NDP(IMM)
C!
C!  ADJUST FOR LEAP YEARS:
      IF(IMM.GT.2.AND.((IYY/4)*4-IYY).EQ.0.AND.((IYY.NE.0).OR.
     .   (((ICC/4)*4-ICC).EQ.0)))   KD=KD+1
C!  KD NOW TRULY REPRESENTS THE DAY# OF THE LAST DAY OF THE LAST
C!  MONTH.
C!
C!  CALCULATE THE CURRENT DAY#:
      KD = KD + IDD
      RETURN
C!
C!
      ENTRY DMY(IDD,IMM,IYY,ICC,KD,ierr)
C!
C!  GIVEN THE (GREGORIAN) DAY#, KD, AS CALCULATED ABOVE IN THIS ROUTINE,
C!  ENTRY DMY RETURNS THE (GREGORIAN) DAY, MONTH, YEAR AND CENTURY.
C!
      lp = 6

C!  TEST FOR VALID INPUT:
      IF(KD.LE.0) WRITE(LP,5040)KD
5040  FORMAT(' DMY: KD = ',I7,'  INVALID INPUT.')
C!
C!  SAVE KD
      KKD=KD
C!  CALCULATE ICC AND SUBTRACT THE NUMBER OF DAYS REPRESENTED BY ICC
C!  FROM KKD
C!  JFH IS THE NUMBER OF 400 YEAR INTERVALS UP TO KKD
C!  JCC IS THE NUMBER OF ADDITIONAL CENTURIES UP TO KKD
      JFH = KKD/146097
      KKD = KKD - JFH*146097
      IF(KKD.LT.36525)THEN
         JCC = 0
      ELSE
         KKD = KKD - 36525
         JCC = 1 + KKD/36524
         KKD = KKD - (JCC-1)*36524
      END IF
      ICC = 4*JFH + JCC
      IF(KKD.EQ.0)THEN
         ICC = ICC-1
         IYY = 99
         IMM = 12
         IDD = 31
         RETURN
      ENDIF
C!
C!  CALCULATE IYY. JFY IS THE NUMBER OF FOUR YEAR INTERVALS IN THE
C!  CURRENT CENTURY. THE FIRST FOUR YEAR INTERVAL IS SHORT (1460 DAYS
C!  RATHER THAN 1461)IF THE CURRENT CENTURY IS NOT DIVISIBLE BY 4, AND
C!  IN THIS CASE JCC.NE.0 AS CALCULATED ABOVE.
C!
C!  CALCULATE JFY:
      JFY = 0
      IF(JCC.EQ.0)GOTO 10
      IF(KKD.LT.1460)GOTO 10
      JFY = 1
      KKD = KKD - 1460
10    KK = KKD/1461
      JFY = JFY + KK
      KKD = KKD - KK*1461
C!
C!  CALCULATE JYY, THE REMAINING YEARS OF THE CURRENT CENTURY UP TO THE
C!  CURRENT DAY:
      JYY = 0
C!  THE NEXT YEAR IS NOT A LEAP YEAR IF JFY=0 AND JCC.NE.0.
      IF(JFY.EQ.0.AND.JCC.NE.0)GOTO 20
      IF(KKD.LT.366)GOTO 30
      JYY = 1
      KKD = KKD - 366
20    JYYY = KKD/365
      JYY = JYY + JYYY
      KKD = KKD - JYYY*365
30    IYY = 4*JFY + JYY
      IF(KKD.EQ.0) THEN
         IYY=IYY-1
         IMM=12
         IDD=31
         RETURN
      END IF
C!
C!  SET L=1 IF WE HAVE A LEAP YEAR.
      L=0
      IF(IYY-(IYY/4)*4.NE.0)GOTO 40
      IF(IYY.EQ.0.AND.(ICC-(ICC/4)*4).NE.0)GOTO 40
      L=1
C!
C!  CALCULATE IMM AND IDD
40    IF(KKD.GT.31) GOTO 50
      IMM=1
      IDD=KKD
      RETURN
C!
50    IF(KKD.GT.59)GOTO 60
      IMM = 2
      IDD = KKD-31
      RETURN
C!
60    IF(KKD.GT.60)GOTO 70
      IF(L.EQ.0)GOTO 70
      IMM = 2
      IDD = 29
      RETURN
C!
70    IF(L.EQ.1) KKD=KKD-1
      DO 80 I=4,13
         IF(KKD.GT.NDP(I))GOTO 80
         IMM = I-1
         IDD = KKD - NDP(I-1)
         RETURN
C!
80    CONTINUE
90    WRITE(LP,5050)
5050  FORMAT(' ERROR IN DMY.')
      ierr = -1
      return
      END


! calculate bulk's energy band using wannier TB method
  subroutine ek_bulk2D

     use mpi
     use para

     implicit none

     integer :: ik, i, j
     integer :: nkx, nky
	  integer :: knv3
     integer :: ierr
     real(Dp) :: k(3)
     real(dp) :: kx
     real(dp) :: ky
     real(dp) :: kz
     real(Dp) :: W(Num_wann)
     real(dp) :: kxmin, kxmax, kymin, kymax
     real(dp), allocatable :: kxy(:,:)

     ! Hamiltonian of bulk system
     complex(Dp) :: Hamk_bulk(Num_wann,Num_wann)

     ! eigen value of H
	  real(dp), allocatable :: gap(:)
	  real(dp), allocatable :: gap_mpi(:)
	  real(dp), allocatable :: eigv(:,:)
	  real(dp), allocatable :: eigv_mpi(:,:)

     nkx= Nk
     nky= Nk
     knv3= nkx*nky
     allocate( kxy(2, knv3))
     allocate( gap     (   knv3))
     allocate( gap_mpi (   knv3))
     allocate( eigv    (4, knv3))
     allocate( eigv_mpi(4, knv3))
     kxy = 0d0
     gap    = 0d0
     gap_mpi= 0d0
	  eigv    = 0d0
	  eigv_mpi= 0d0

     kxmin= 0.150d0/1d0
     kxmax= 0.170d0/1d0
     kymin= 0.06d0/1d0
     kymax= 0.08d0/1d0
     kz= 0.255
     ik =0
     do i= 1, nkx
     do j= 1, nky
        ik =ik +1
        kxy(1, ik)=kxmin+ (i-1)*(kxmax-kxmin)/dble(nkx-1)
        kxy(2, ik)=kymin+ (j-1)*(kymax-kymin)/dble(nky-1)
     enddo
     enddo

     do ik= 1+cpuid, knv3, num_cpu
	     if (cpuid==0) print * , ik

        k(1:2) = kxy(:, ik)
        k(3)= kz

        ! calculation bulk hamiltonian
        Hamk_bulk= 0d0
        call ham_bulk(k, Hamk_bulk)

        !> diagonalization by call zheev in lapack
        W= 0d0
        call eigensystem_c( 'N', 'U', Num_wann ,Hamk_bulk, W)

        !> for 88 bands
       !eigv(:, ik)= W(55:58)
       !gap (   ik)= W(57)- W(56)

        !> for 44 bands
        eigv(:, ik)= W(27:30)
        gap (   ik)= W(29)- W(28)
     enddo

     call mpi_allreduce(eigv,eigv_mpi,size(eigv),&
                       mpi_dp,mpi_sum,mpi_cmw,ierr)
     call mpi_allreduce(gap ,gap_mpi,size(gap ),&
                       mpi_dp,mpi_sum,mpi_cmw,ierr)

     if (cpuid==0)then
        open(unit=14, file='bulkek2D.dat')
        do ik=1, knv3
           write(14, '(1000f19.9)')kxy(:, ik), eigv_mpi(:, ik)
        enddo
        close(14)
        open(unit=15, file='gap2D.dat')
        do ik=1, knv3
           write(15, '(1000f19.9)')kxy(:, ik), gap_mpi(ik)
        enddo
        close(15)
     endif

   return
   end subroutine ek_bulk2D


C-----------------------------------------------------------------------
      SUBROUTINE SPGRADX(M,INCW,KMAX,MP,CLAT,W,WX)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    SPGRADX    COMPUTE X-GRADIENT IN FOURIER SPACE
C   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-02-20
C
C ABSTRACT: THIS SUBPROGRAM COMPUTES THE X-GRADIENT OF FIELDS
C           IN COMPLEX FOURIER SPACE.
C           THE X-GRADIENT OF A VECTOR FIELD W IS
C             WX=CONJG(W)*L/RERTH
C           WHERE L IS THE WAVENUMBER AND RERTH IS THE EARTH RADIUS,
C           SO THAT THE RESULT IS THE X-GRADIENT OF THE PSEUDO-VECTOR.
C           THE X-GRADIENT OF A SCALAR FIELD W IS
C             WX=CONJG(W)*L/(RERTH*CLAT)
C           WHERE CLAT IS THE COSINE OF LATITUDE.
C           AT THE POLE THIS IS UNDEFINED, SO THE WAY TO GET
C           THE X-GRADIENT AT THE POLE IS BY PASSING BOTH
C           THE WEIGHTED WAVENUMBER 0 AND THE UNWEIGHTED WAVENUMBER 1
C           AMPLITUDES AT THE POLE AND SETTING MP=10.
C           IN THIS CASE, THE WAVENUMBER 1 AMPLITUDES ARE USED
C           TO COMPUTE THE X-GRADIENT AND THEN ZEROED OUT.
C
C PROGRAM HISTORY LOG:
C 1998-12-18  IREDELL
C
C USAGE:    CALL SPGRADX(M,INCW,KMAX,W,WX)
C
C   INPUT ARGUMENT LIST:
C     M        - INTEGER FOURIER WAVENUMBER TRUNCATION
C     INCW     - INTEGER FIRST DIMENSION OF THE COMPLEX AMPLITUDE ARRAY
C                (INCW >= M+1)
C     KMAX     - INTEGER NUMBER OF FOURIER FIELDS
C     MP       - INTEGER (KM) IDENTIFIERS
C                (0 OR 10 FOR SCALAR, 1 FOR VECTOR)
C     CLAT     - REAL COSINE OF LATITUDE
C     W        - COMPLEX(INCW,KMAX) FOURIER AMPLITUDES
C
C   OUTPUT ARGUMENT LIST:
C     W        - COMPLEX(INCW,KMAX) FOURIER AMPLITUDES
C                CORRECTED WHEN MP=10 AND CLAT=0
C     WX       - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES OF X-GRADIENTS
C
C SUBPROGRAMS CALLED:
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C
C REMARKS:
C   THIS SUBPROGRAM IS THREAD-SAFE.
C
C$$$
        IMPLICIT NONE
        INTEGER,INTENT(IN):: M,INCW,KMAX,MP(KMAX)
        REAL,INTENT(IN):: CLAT
        REAL,INTENT(INOUT):: W(2*INCW,KMAX)
        REAL,INTENT(OUT):: WX(2*INCW,KMAX)
        INTEGER K,L
        REAL,PARAMETER:: RERTH=6.3712E6
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
        DO K=1,KMAX
          IF(MP(K).EQ.1) THEN
            DO L=0,M
              WX(2*L+1,K)=-W(2*L+2,K)*(L/RERTH)
              WX(2*L+2,K)=+W(2*L+1,K)*(L/RERTH)
            ENDDO
          ELSEIF(CLAT.EQ.0.) THEN
            DO L=0,M
              WX(2*L+1,K)=0
              WX(2*L+2,K)=0
            ENDDO
            IF(MP(K).EQ.10.AND.M.GE.2) THEN
              WX(3,K)=-W(4,K)/RERTH
              WX(4,K)=+W(3,K)/RERTH
              W(3,K)=0
              W(4,K)=0
            ENDIF
          ELSE
            DO L=0,M
              WX(2*L+1,K)=-W(2*L+2,K)*(L/(RERTH*CLAT))
              WX(2*L+2,K)=+W(2*L+1,K)*(L/(RERTH*CLAT))
            ENDDO
          ENDIF
        ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END SUBROUTINE