module derivsmod
!$$$   module documentation block
!                .      .    .                                       .
! module:    derivsmod
!
! abstract:  This module defines and holds bundles that contain 
!            guess derivative fields.
!
! program history log:
!   2013-10-19 Todling - Initial code.
!   2014-06-18 Carley - add lgues and dlcbasdlog
!   2015-07-10 Pondeca - add cldchgues and dcldchdlog
!   2016-05-10 Thomas - remove references to cwgues0
!   2019-05-08 mtong - replace set_ with init_anadv 
!   2019-05-08 eliu - recover logic (drv_set_) to indicate the derivative
!                     vars are allocated and defined
!
! public subroutines:
!  drv_initialized         - initialize name of fields to calc derivs for
!  create_ges_derivatives  - initialize bundles holding derivatives
!  destroy_ges_derivatives - finalize bundles holding derivatives

! public variables:
!  gsi_xderivative_bundle  - bundle holding longitudinal derivatives
!  gsi_yderivative_bundle  - bundle holding latitudinal derivatives
!  dvars2d, dvars3d        - names of 2d/3d derivatives
!  dsrcs2d, dsrcs3d        - names of where original fields reside
!  drv_initialized         - flag indicating initialization status
!  drv_set_                - flag indicating the variables are allocated and defined 
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP; SGI Origin 2000; Compaq/HP
!
!$$$ end documentation block

use kinds, only: i_kind, r_kind
use mpimod, only: mype
use gridmod, only: lat2,lon2,nsig
use constants, only: zero,max_varname_length
use state_vectors, only: svars2d,svars3d
use GSI_BundleMod, only : GSI_BundleCreate
use GSI_BundleMod, only : GSI_Bundle
use GSI_BundleMod, only : GSI_BundleGetPointer
use GSI_BundleMod, only : GSI_BundleDestroy
use GSI_BundleMod, only : GSI_BundleUnset

use GSI_BundleMod, only : GSI_Grid
use GSI_BundleMod, only : GSI_GridCreate

use GSI_MetGuess_Mod, only: gsi_metguess_bundle
use GSI_ChemGuess_Mod, only: gsi_chemguess_bundle

use mpeu_util, only: getindex
implicit none
save
private

public :: drv_initialized
public :: drv_set_         
public :: create_ges_derivatives
public :: destroy_ges_derivatives

public :: gsi_xderivative_bundle
public :: gsi_yderivative_bundle
public :: dvars2d, dvars3d
public :: dsrcs2d, dsrcs3d
public :: cwgues,cfgues 
public :: ggues,vgues,pgues,lgues,dvisdlog,dlcbasdlog
public :: w10mgues,howvgues,cldchgues,dcldchdlog
public :: qsatg,qgues,dqdt,dqdrh,dqdp
public :: init_anadv

logical :: drv_initialized = .false.

type(gsi_bundle),pointer :: gsi_xderivative_bundle(:)
type(gsi_bundle),pointer :: gsi_yderivative_bundle(:)
character(len=max_varname_length),allocatable,dimension(:):: dvars2d, dvars3d
character(len=max_varname_length),allocatable,dimension(:):: dsrcs2d, dsrcs3d

real(r_kind),allocatable,dimension(:,:,:):: qsatg,qgues,dqdt,dqdrh,dqdp
real(r_kind),allocatable,dimension(:,:):: ggues,vgues,pgues,lgues,dvisdlog,dlcbasdlog
real(r_kind),allocatable,dimension(:,:):: w10mgues,howvgues,cldchgues,dcldchdlog
real(r_kind),target,allocatable,dimension(:,:,:):: cwgues,cfgues 

! below this point: declare vars not to be made public

character(len=*),parameter:: myname='derivsmod'
logical,save :: drv_set_=.false.  
integer(i_kind),allocatable,dimension(:):: levels
contains

subroutine init_anadv
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:	 define derivatives
!   prgmmr:	 todling
!      org:	 NASA/GSFC, Global Modeling and Assimilation Office, 610.1
!     date:	 2013-10-19
!
! abstract: - set which derivatives to calculate from guess fields
!
! program history log:
!   2013-09-27  todling  - initial code
!   2014-02-03  todling  - negative levels mean rank-3 array
!   2019-05-08  mtong    - replace set_ with init_anadv 
!   2019-05-08  eliu     - recover logic (drv_set_) to indicate the derivative
!                          vars are allocated and defined
!
!   input argument list: see Fortran 90 style document below
!
!   output argument list: see Fortran 90 style document below
!
! attributes:
!   language: Fortran 90 and/or above
!   machine:
!
!$$$  end subprogram documentation block
use mpeu_util, only: gettablesize
use mpeu_util, only: gettable
use mpeu_util, only: getindex
implicit none

character(len=*),parameter:: rcname='anavinfo'

character(len=*),parameter::myname_=myname//'*set_'
character(len=*),parameter:: tbname='state_derivatives::'
integer(i_kind) luin,ii,nrows,ntot,ipnt,istatus
integer(i_kind) i2d,i3d,n2d,n3d,irank
integer(i_kind),allocatable,dimension(:)::nlevs
character(len=256),allocatable,dimension(:):: utable
character(len=max_varname_length),allocatable,dimension(:):: vars
character(len=max_varname_length),allocatable,dimension(:):: sources
logical matched

if(drv_set_) return 

open(newunit=luin,file=trim(rcname),form='formatted')

! Scan file for desired table first
! and get size of table
call gettablesize(tbname,luin,ntot,nrows)
if(nrows==0) then
   if(luin/=5) close(luin)
   return
endif

! Get contents of table
allocate(utable(nrows))
call gettable(tbname,luin,ntot,nrows,utable)

! release file unit
if(luin/=5) close(luin)

! allocate space for entries from table
allocate(vars(nrows),nlevs(nrows),sources(nrows))

! Retrieve each token of interest from table and define
! variables participating in state vector
n2d=0; n3d=0
do ii=1,nrows
   read(utable(ii),*) vars(ii),&  ! variable name
                      nlevs(ii),& ! number of levels
                      sources(ii) ! source
   if (nlevs(ii)==1) then
      n2d=n2d+1
   else
      n3d=n3d+1
   endif
enddo

deallocate(utable)

allocate(dvars2d(n2d),dvars3d(n3d),&
         dsrcs2d(n2d),dsrcs3d(n3d),levels(n3d))

! loop over variables and identify them by comparison
i2d=0; i3d=0
do ii=1,nrows
   matched=.false.
   if(trim(sources(ii))=='met_guess') then
      if(associated(gsi_metguess_bundle)) then
         call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(vars(ii)),ipnt,istatus,irank=irank);
         if (ipnt>0) then
            if(irank==2) then 
               i2d=i2d+1
               dvars2d(i2d)=trim(vars(ii))
               dsrcs2d(i2d)=trim(sources(ii))
               matched=.true.
            endif
            if(irank==3) then 
               i3d=i3d+1
               dvars3d(i3d)=trim(vars(ii))
               dsrcs3d(i3d)=trim(sources(ii))
               levels(i3d) =abs(nlevs(ii))
               matched=.true.
            endif
         endif
      endif
   endif
   if(trim(sources(ii))=='chem_guess') then
      if(associated(gsi_chemguess_bundle)) then
         call gsi_bundlegetpointer(gsi_chemguess_bundle(1),trim(vars(ii)),ipnt,istatus,irank=irank);
         if (ipnt>0) then
            if(irank==2) then
               i2d=i2d+1
               dvars2d(i2d)=trim(vars(ii))
               dsrcs2d(i2d)=trim(sources(ii))
               matched=.true.
            endif
            if(irank==3) then 
               i3d=i3d+1
               dvars3d(i3d)=trim(vars(ii))
               dsrcs3d(i3d)=trim(sources(ii))
               levels(i3d) =abs(nlevs(ii))
               matched=.true.
            endif
         endif
      endif
   endif
   ! now care for variables not in guess (usually, derived tendencies)
   if (.not.matched) then
      if(nlevs(ii)==1) then
         i2d=i2d+1
         dvars2d(i2d)=trim(vars(ii))
         dsrcs2d(i2d)='derived'
      else
         i3d=i3d+1
         dvars3d(i3d)=trim(vars(ii))
         dsrcs3d(i3d)='derived'
         levels(i3d) =abs(nlevs(ii))
      endif
   endif
enddo

if (mype == 0) then
    write(6,*) myname_,':  DERIVATIVE VARIABLES: '
    write(6,*) myname_,':  2D-DERV STATE VARIABLES: '
    do ii=1,n2d
       write(6,*) trim(dvars2d(ii))
    enddo
    write(6,*) myname_,':  3D-DERV STATE VARIABLES:'
    do ii=1,n3d
       write(6,*) trim(dvars3d(ii))
    enddo
end if

deallocate(vars,nlevs,sources)
drv_set_=.true.  

 end subroutine init_anadv

 subroutine create_ges_derivatives(switch_on_derivatives,nfldsig)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:	 create derivatives
!   prgmmr:	 todling
!      org:	 NASA/GSFC, Global Modeling and Assimilation Office, 610.1
!     date:	 2013-10-19
!
! abstract: - allocate space for bundle-kept derivatives
!
! program history log:
!   2013-09-27  todling  - initial code
!
!   input argument list: see Fortran 90 style document below
!
!   output argument list: see Fortran 90 style document below
!
! attributes:
!   language: Fortran 90 and/or above
!   machine:
!
!$$$  end subprogram documentation block
 implicit none

 logical, intent(in) :: switch_on_derivatives
 integer(i_kind),intent(in) :: nfldsig

 integer nt,ierror
 character(len=32) bname
 type(gsi_grid) :: grid

! Extra mambo-jambo
  call create_auxiliar_

  if (.not.switch_on_derivatives) return
  if (drv_initialized) return 

! create derivative grid
  call GSI_GridCreate(grid,lat2,lon2,nsig)

! allocate structures
  allocate(gsi_xderivative_bundle(nfldsig))
  allocate(gsi_yderivative_bundle(nfldsig))

! Note: 
!   Original code needed ps derivatives in all time slots
!   Present code creates all derivatives in all time slots
  do nt=1,nfldsig

!    create logitudinal derivative bundle
     write(bname,'(a,i3.3)') 'Lon Derivative Vector-',nt
     call GSI_BundleCreate(gsi_xderivative_bundle(nt),grid,bname,ierror, &
                           names2d=dvars2d,names3d=dvars3d,levels=levels,bundle_kind=r_kind)

!    create latidutinal derivative bundle
     write(bname,'(a,i3.3)') 'Lat Derivative Vector-',nt
     call GSI_BundleCreate(gsi_yderivative_bundle(nt),grid,bname,ierror, &
                           names2d=dvars2d,names3d=dvars3d,levels=levels,bundle_kind=r_kind)

  enddo

  drv_initialized = .true.

  if(mype==0) write(6,*) 'create_ges_derivatives: successfully complete'
  end subroutine create_ges_derivatives

  subroutine destroy_ges_derivatives
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:	 destroy derivatives
!   prgmmr:	 todling
!      org:	 NASA/GSFC, Global Modeling and Assimilation Office, 610.1
!     date:	 2013-10-19
!
! abstract: - deallocates bundles keeping derivatives
!
! program history log:
!   2013-09-27  todling  - initial code
!
!   input argument list: see Fortran 90 style document below
!
!   output argument list: see Fortran 90 style document below
!
! attributes:
!   language: Fortran 90 and/or above
!   machine:
!
!$$$  end subprogram documentation block
  use mpimod, only: mpi_comm_world
  implicit none
  integer(i_kind) nt,ierror

  if(.not.drv_initialized) return

! destroy mambo-jambo
  call destroy_auxiliar_

! destroy each instance of derivatives
  do nt=1,size(gsi_yderivative_bundle)

!    create logitudinal derivative bundle
     call GSI_BundleDestroy(gsi_yderivative_bundle(nt),ierror)
     if(ierror/=0) then
        if(mype==0) write(6,*)'warning: y-derivative not properly destroyed'
     endif

!    create latidutinal derivative bundle
     call GSI_BundleDestroy(gsi_xderivative_bundle(nt),ierror)
     if(ierror/=0) then
        if(mype==0) write(6,*)'warning: x-derivative not properly destroyed'
     endif

  enddo

! deallocate structures
  deallocate(gsi_xderivative_bundle)
  deallocate(gsi_yderivative_bundle)

! destroy derivative grid
! call GSI_GridDestroy(grid,lat2,lon2,nsig)

  deallocate(dvars2d,dvars3d,&
             dsrcs2d,dsrcs3d,levels)

  if(mype==0) write(6,*) 'destroy_ges_derivatives: successfully complete'
  end subroutine destroy_ges_derivatives

  subroutine create_auxiliar_
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    create_auxiliar_
!   prgmmr: treadon          org: np23               date:  2003-11-24
!
! abstract: allocate memory for cost function variables
!
! program history log:
!   2003-11-24  treadon
!   2004-05-18  kleist, documentation
!   2004-07-28  treadon - simplify subroutine argument list
!   2005-03-28  wu - replace mlath with mlat, modify dim of varq 
!   2005-06-15  treadon - remove "use guess_grids"
!   2008-05-12  safford - rm unused uses
!   2011-02-16  zhu     - add ggues,vgues,pgues
!   2011-07-15  zhu     - add cwgues
!   2013-10-25  todling - revisit variable initialization
!   2013-11-12  lueken - revisit logic around cwgues
!   2014-02-03  todling - CV length and B-dims here (no longer in observer)
!   2014-03-19  pondeca - add w10mgues
!   2014-05-07  pondeca - add howvgues
!   2014-06-18  carley - add lgues and dlcbasdlog
!   2015-07-10  pondeca- add cldchgues and dcldchdlog
!
!   input argument list:
!    mlat
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!$$$
    use constants, only: zero
    use gridmod, only: lat2,lon2,nsig
    implicit none

    integer(i_kind) i,j,k

    if (getindex(svars3d,'q')>0) then
       allocate(qsatg(lat2,lon2,nsig),&
            dqdt(lat2,lon2,nsig),dqdrh(lat2,lon2,nsig),&
            dqdp(lat2,lon2,nsig),&
            qgues(lat2,lon2,nsig))

       do k=1,nsig
          do j=1,lon2
             do i=1,lat2
                qsatg(i,j,k)=zero
                dqdt(i,j,k)=zero
                dqdrh(i,j,k)=zero
                dqdp(i,j,k)=zero
                qgues(i,j,k)=zero
             end do
          end do
       end do
    endif

    allocate(cwgues(lat2,lon2,nsig))
    do k=1,nsig
       do j=1,lon2
          do i=1,lat2
             cwgues(i,j,k)=zero
          end do
        end do
    end do

    allocate(cfgues(lat2,lon2,nsig))
    do k=1,nsig
       do j=1,lon2
          do i=1,lat2
             cfgues(i,j,k)=zero
          end do
        end do
    end do

    if (getindex(svars2d,'gust')>0) then
       allocate(ggues(lat2,lon2))
       do j=1,lon2
          do i=1,lat2
             ggues(i,j)=zero
          end do
       end do
    end if
    if (getindex(svars2d,'vis')>0) then
       allocate(vgues(lat2,lon2),dvisdlog(lat2,lon2))
       do j=1,lon2
          do i=1,lat2
             vgues(i,j)=zero
             dvisdlog(i,j)=zero
          end do
       end do
    end if
    if (getindex(svars2d,'pblh')>0) then
       allocate(pgues(lat2,lon2))
       do j=1,lon2
          do i=1,lat2
             pgues(i,j)=zero
          end do
       end do
    end if
    if (getindex(svars2d,'lcbas')>0) then
       allocate(lgues(lat2,lon2),dlcbasdlog(lat2,lon2))
       do j=1,lon2
          do i=1,lat2
             lgues(i,j)=zero
             dlcbasdlog(i,j)=zero
          end do
       end do
    end if
    if (getindex(svars2d,'wspd10m')>0) then
       allocate(w10mgues(lat2,lon2))
       do j=1,lon2
          do i=1,lat2
             w10mgues(i,j)=zero
          end do
       end do
    end if
    if (getindex(svars2d,'howv')>0) then
       allocate(howvgues(lat2,lon2))
       do j=1,lon2
          do i=1,lat2
             howvgues(i,j)=zero
          end do
       end do
    end if
    if (getindex(svars2d,'cldch')>0) then
       allocate(cldchgues(lat2,lon2),dcldchdlog(lat2,lon2))
       do j=1,lon2
          do i=1,lat2
             cldchgues(i,j)=zero
             dcldchdlog(i,j)=zero
          end do
       end do
    end if


    return
  end subroutine create_auxiliar_
    
  subroutine destroy_auxiliar_
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    destroy_auxliar_
!   prgmmr: treadon          org: np23               date:  2003-11-24
!
! abstract: deallocate memory from cost function variables
!
! program history log:
!   2003-11-24  treadon
!   2004-05-18  kleist, documentation
!   2011-02-16  zhu     - add ggues,vgues,pgues
!   2011-07-15  zhu     - add cwgues
!   2013-10-25  todling, revisit deallocs
!   2014-03-19  pondeca - add w10mgues
!   2014-05-07  pondeca - add howvgues
!   2014-06-18  carley - add lgues and dlcbasdlog 
!   2015-07-10  pondeca- add cldchgues and dcldchdlog
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!$$$
    implicit none

    if(allocated(dqdt)) deallocate(dqdt)
    if(allocated(dqdrh)) deallocate(dqdrh)
    if(allocated(dqdp)) deallocate(dqdp)
    if(allocated(qsatg)) deallocate(qsatg)
    if(allocated(qgues)) deallocate(qgues)
    if(allocated(cwgues)) deallocate(cwgues)
    if(allocated(cfgues)) deallocate(cfgues) 
    if(allocated(ggues)) deallocate(ggues)
    if(allocated(vgues)) deallocate(vgues)
    if(allocated(dvisdlog)) deallocate(dvisdlog)
    if(allocated(pgues)) deallocate(pgues)
    if(allocated(lgues)) deallocate(lgues)
    if(allocated(dlcbasdlog)) deallocate(dlcbasdlog)
    if(allocated(w10mgues)) deallocate(w10mgues)
    if(allocated(howvgues)) deallocate(howvgues)
    if(allocated(cldchgues)) deallocate(cldchgues)
    if(allocated(dcldchdlog)) deallocate(dcldchdlog)

    return
  end subroutine destroy_auxiliar_
end module derivsmod