module SolutionGroupModule
  use KindModule,         only: DP, I4B
  use ListsModule,        only: basesolutionlist
  use BaseSolutionModule, only: BaseSolutionType, AddBaseSolutionToList, &
                                GetBaseSolutionFromList
  use ListModule,         only: ListType

  implicit none
  private
  public :: SolutionGroupType, AddSolutionGroupToList, &
            GetSolutionGroupFromList, solutiongroup_create
  private :: CastAsSolutionGroupClass

  type :: SolutionGroupType
    integer(I4B), pointer                                :: id
    integer(I4B), pointer                                :: mxiter
    integer(I4B), pointer                                :: nsolutions
    integer(I4B), dimension(:), allocatable              :: idsolutions          !array of solution ids in basesolutionlist
  contains
    procedure          :: sgp_ca
    procedure          :: sgp_da
    procedure, private :: allocate_scalars
    procedure          :: add_solution
  end type SolutionGroupType

  contains

  subroutine solutiongroup_create(sgp, id)
! ******************************************************************************
! solutiongroup_create -- Create a new solution group
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    type(SolutionGroupType), pointer :: sgp
    integer(I4B), intent(in)              :: id
! ------------------------------------------------------------------------------
    !
    allocate(sgp)
    call sgp%allocate_scalars()
    sgp%id = id
    !
    ! -- return
    return
  end subroutine solutiongroup_create

  subroutine sgp_ca(this)
! ******************************************************************************
! sgp_ca -- Calculate the solution group
!    Solve each solution group and each solution.  Start with converge
!    flag equal true and reset to zero if any non-convergence triggers
!    are encountered.
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use ConstantsModule,        only: LINELENGTH
    use SimVariablesModule,     only: iout, isimcnvg, lastStepFailed
    use SimModule,              only: store_error, ustop
    use TdisModule,             only: kstp, kper
    ! -- dummy
    class(SolutionGroupType) :: this
    ! -- local
    class(BaseSolutionType),  pointer :: sp
    integer(I4B) :: kpicard, isgcnvg, isuppress_output
    integer(I4B) :: is, isoln
    ! -- formats
    character(len=*), parameter :: fmtnocnvg =                                 &
      "(1X,'Solution Group ', i0, ' did not converge for stress period ', i0,  &
       &' and time step ', i0)"
! ------------------------------------------------------------------------------
    !
    ! -- Suppress output during picard iterations
    if(this%mxiter > 1) then
      isuppress_output = 1
    else
      isuppress_output = 0
    endif
    !
    ! -- set failed flag
    lastStepFailed = 0
    !
    ! -- Picard loop
    picardloop: do kpicard = 1, this%mxiter
      if (this%mxiter > 1) then
        write(iout,'(/a,i6/)') 'SOLUTION GROUP PICARD ITERATION: ', kpicard
      end if
      isgcnvg = 1
      do is = 1, this%nsolutions
        isoln = this%idsolutions(is)
        sp => GetBaseSolutionFromList(basesolutionlist, isoln)
        call sp%sln_ca(isgcnvg, isuppress_output)
      enddo
      if(isgcnvg == 1) exit picardloop
    enddo picardloop
    !
    ! -- if a picard loop was used and the solution group converged
    !    then rerun the timestep and save the output.  Or if there
    !    is only one picard iteration, then do nothing as models
    !    are assumed to be explicitly coupled.
    if(isgcnvg == 1) then
      if(this%mxiter > 1) then
        isuppress_output = 0
        do is = 1, this%nsolutions
          isoln = this%idsolutions(is)
          sp => GetBaseSolutionFromList(basesolutionlist, isoln)
          call sp%sln_ca(isgcnvg, isuppress_output)
        enddo
      endif
    else
      isimcnvg = 0
      lastStepFailed = 1
      write(iout, fmtnocnvg) this%id, kper, kstp
    endif
    !
    ! -- return
    return
  end subroutine sgp_ca

  subroutine sgp_da(this)
! ******************************************************************************
! deallocate
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    class(SolutionGroupType) :: this
! ------------------------------------------------------------------------------
    !
    deallocate(this%id)
    deallocate(this%mxiter)
    deallocate(this%nsolutions)
    deallocate(this%idsolutions)
    !
    ! -- return
    return
  end subroutine sgp_da

  subroutine allocate_scalars(this)
! ******************************************************************************
! allocate_scalars
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    class(SolutionGroupType) :: this
! ------------------------------------------------------------------------------
    !
    allocate(this%id)
    allocate(this%mxiter)
    allocate(this%nsolutions)
    this%id = 0
    this%mxiter = 1
    this%nsolutions = 0
    !
    ! -- return
    return
  end subroutine allocate_scalars

  subroutine add_solution(this, isoln, sp)
! ******************************************************************************
! add_solution
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use ArrayHandlersModule, only: ExpandArray
    ! -- dummy
    class(SolutionGroupType) :: this
    integer(I4B), intent(in) :: isoln
    class(BaseSolutionType), pointer, intent(in) :: sp
    ! -- local
    integer(I4B) :: ipos
! ------------------------------------------------------------------------------
    !
    call ExpandArray(this%idsolutions)
    ipos = size(this%idsolutions)
    this%idsolutions(ipos) = isoln
    this%nsolutions = this%nsolutions + 1
    !
    ! -- return
    return
  end subroutine add_solution

  function CastAsSolutionGroupClass(obj) result (res)
    implicit none
    class(*), pointer, intent(inout) :: obj
    class(SolutionGroupType), pointer :: res
    !
    res => null()
    if (.not. associated(obj)) return
    !
    select type (obj)
    class is (SolutionGroupType)
      res => obj
    end select
    return
  end function CastAsSolutionGroupClass

  subroutine AddSolutionGroupToList(list, solutiongroup)
    implicit none
    ! -- dummy
    type(ListType),       intent(inout) :: list
    type(SolutionGroupType), pointer, intent(inout) :: solutiongroup
    ! -- local
    class(*), pointer :: obj
    !
    obj => solutiongroup
    call list%Add(obj)
    !
    return
  end subroutine AddSolutionGroupToList

  function GetSolutionGroupFromList(list, idx) result (res)
    implicit none
    ! -- dummy
    type(ListType),           intent(inout) :: list
    integer(I4B),                  intent(in)    :: idx
    class(SolutionGroupType), pointer       :: res
    ! -- local
    class(*), pointer :: obj
    !
    obj => list%GetItem(idx)
    res => CastAsSolutionGroupClass(obj)
    !
    return
  end function GetSolutionGroupFromList

end module SolutionGroupModule


#include "rundeck_opts.h"

      MODULE TRACER_DIAG_COM
!@sum Tracer diagnostic arrays
!@+    Mostly tracer independent, but this may deped on applications
!@auth Jean Lerner
!ver   1.0
      USE MODEL_COM, only: im,jm,lm
      USE DAGCOM, only: npts !npts are conservation quantities
      USE TRACER_COM, only: ntm
#ifdef TRACERS_ON
     *     , ntsurfsrcmax, nt3Dsrcmax
#endif
      IMPLICIT NONE
      SAVE

C**** TAIJS  <<<< KTAIJS and IJTS_xx are Tracer-Dependent >>>>
C**** TAJLS  <<<< KTAJLS and JLS_xx are Tracer-Dependent >>>>

!@dbparam to_volume_MixRat: For printout of tracer concentration
!@+   to_volume_MixRat=1: printout is in Volume Mixing Ratio
!@+   to_volume_MixRat=0: printout is in Mass Mixing Ratio
#ifdef TRACERS_SPECIAL_Shindell
      INTEGER, DIMENSION(NTM) :: to_volume_MixRat=1
#else
      INTEGER, DIMENSION(NTM) :: to_volume_MixRat=0
#endif
#if (defined TRACERS_WATER) || (defined TRACERS_OCEAN)
!@dbparam to_per_mil For printout of tracer concentration in permil
      INTEGER, DIMENSION(NTM) :: to_per_mil = 0
#endif
#ifdef TRACERS_ON
!@var MMR_to_VMR: converts tracer mass mixing ratio to volume mr
      REAL*8, DIMENSION(NTM) :: MMR_to_VMR

C**** TAIJLN
!@var TAIJLN 3D tracer diagnostics (all tracers)
      real*8, dimension(im,jm,lm,ntm) :: taijln
!@var SNAME_IJT, UNITS_IJT: Names and units of lat-sigma tracer IJ diags
      character(len=30), dimension(lm,ntm) :: sname_ijt,units_ijt
!@var LNAME_IJT: descriptions of tracer IJ diagnostics
      character(len=80), dimension(lm,ntm) :: lname_ijt = 'unused'
!@var SCALE_IJT: printout scaling factor for tracer IJ diagnostics
      REAL*8, dimension(lm,ntm) :: scale_ijt
!@var IR_IJT: range index of IJ diagnosts
      integer, dimension(ntm) :: ir_ijt
!@var IA_IJT: idacc-number for tracer IJ diags (same for all tracers)
      integer ia_ijt
!@var IJTC_POWER: power of 10 used for tracer IJ concentration diags
      integer, dimension(ntm) :: ijtc_power
!@var IJTM_POWER: power of 10 used for tracer IJ mass unit diags
      integer, dimension(ntm) :: ijtm_power
!@var IJT_XX Names for TAIJLN diagnostics (Not currently used)

C**** TAIJN
!@param KTAIJ number of 3D diagnostics for each tracer
#ifdef TRACERS_WATER
      integer, parameter :: ktaij=11
#else
      integer, parameter :: ktaij=3
#endif
!@var IJT_XX names for taijn diagnostics
      integer tij_conc,tij_surf,tij_mass
#ifdef TRACERS_WATER
!@var IJT_XX names for water-based taijn diagnostics
      integer tij_rvr,tij_seaice,tij_prec,tij_evap,tij_grnd,tij_lk1
     *     ,tij_lk2,tij_soil
#endif
!@var TAIJN lat/lon tracer diagnostics (all tracers)
      real*8, dimension(im,jm,ktaij,ntm) :: taijn
!@var SCALE_TIJ: printout scaling factor for tracer IJK diagnostics
      REAL*8, dimension(ktaij,ntm) :: scale_tij
!@var SNAME_TIJ,UNITS_TIJ: Names and units of lat-sigma tracer diags
      character(len=30), dimension(ktaij,ntm) :: sname_tij,units_tij
!@var LNAME_TIJ: descriptions of tracer IJK diags
      character(len=80), dimension(ktaij,ntm) :: lname_tij = 'unused'

C**** TAIJS  <<<< KTAIJS and IJTS_xx are Tracer-Dependent >>>>
!@parm KTAIJS number of special lat/lon tracer diagnostics
#ifdef TRACERS_SPECIAL_Shindell
      integer, parameter :: ktaijs=26
#else
      integer, parameter :: ktaijs=25
#endif
!@var TAIJS  lat/lon special tracer diagnostics; sources, sinks, etc.
      REAL*8, DIMENSION(IM,JM,ktaijs) :: TAIJS
!@var ijts_source tracer independent array for TAIJS surface src. diags
      INTEGER ijts_source(ntsurfsrcmax,ntm)
!@var SNAME_IJTS, UNITS_IJTS: Names & units of lat-sigma tracer diags
      character(len=30), dimension(ktaijs) :: sname_ijts,units_ijts
!@var LNAME_IJTS: descriptions of tracer IJTS diags
      character(len=80), dimension(ktaijs) :: lname_ijts = 'unused'
!@var SCALE_IJTS: printout scaling factor for tracer IJTS diagnostics
      REAL*8, dimension(ktaijs) :: scale_ijts
!@var IA_IJTS: idacc-number for tracer source/sink IJ diags
      integer ia_ijts(ktaijs)
!@var ijts_power: power of 10 used for tracer IJ source/sink diags
      INTEGER, DIMENSION(ktaijs) :: ijts_power
!@var ijts_index: tracer index associated with a TAIJS diagnostic
      INTEGER, DIMENSION(ktaijs) :: ijts_index

C**** TAJLN
!@parm ktajl,ktajlx number of TAJL tracer diagnostics;
!@+          ktajlx includes composits
      INTEGER, PARAMETER :: ktajl=8, ktajlx=ktajl+2
!@var TAJLN  vertical tracer diagnostics (all tracers)
      REAL*8, DIMENSION(JM,LM,ktajlx,NTM) :: TAJLN
!@var jlnt_xx Names for TAJLN diagnostics
      INTEGER jlnt_conc,jlnt_nt_tot,jlnt_nt_mm,jlnt_vt_tot,
     &  jlnt_vt_mm,jlnt_mc,jlnt_turb,jlnt_lscond
!@var SNAME_JLN: Names of lat-sigma tracer JL diagnostics
      character(len=30), dimension(ktajlx,ntm) :: sname_jln
!@var LNAME_JLN,UNITS_JLN: descriptions/units of tracer JL diagnostics
      character(len=50), dimension(ktajlx,ntm) :: lname_jln = 'unused'
     *     ,units_jln
!@var SCALE_JLQ: printout scaling factor for tracer JL diagnostics
      REAL*8, dimension(ktajlx) :: scale_jlq
!@var IA_JLQ,JGRID_JLQ: idacc-numbers,gridtypes for tracer JL diags
      integer, dimension(ktajlx) :: ia_jlq,jgrid_jlq
!@var JLQ_POWER: power of 10 used for tracer JL diagnostics
!@+        It is associated with a specific physical process
      integer jlq_power(ktajlx)
      integer ktajlp !@var helps keeps track of
!@var scale_jln: Scale for jl maps
      REAL*8, DIMENSION(ntm) :: scale_jln

C**** TAJLS  <<<< KTAJLS and JLS_xx are Tracer-Dependent >>>>
!@parm ktajls number of source/sink TAJLS tracer diagnostics;
#ifdef TRACERS_SPECIAL_Shindell
      INTEGER, PARAMETER :: ktajls=58
#else
      INTEGER, PARAMETER :: ktajls=34
#endif
!@var TAJLS  JL special tracer diagnostics for sources, sinks, etc
      REAL*8, DIMENSION(JM,LM,ktajls) :: TAJLS
!@var jls_source tracer independent array for TAJLS surface src. diags
      INTEGER jls_source(ntsurfsrcmax,ntm)
!@var jls_3Dsource tracer independent array for TAJLS 3D source diags
      INTEGER jls_3Dsource(nt3Dsrcmax,ntm)
!@var jls_decay tracer independent array for radioactive sinks
      INTEGER, DIMENSION(NTM) :: jls_decay
!@var jls_grav tracer independent array for grav. settling sink
      INTEGER, DIMENSION(NTM) :: jls_grav
!@var jls_index: Number of source/sink tracer JL diagnostics/tracer
      integer, dimension(ktajls) :: jls_index
!@var SNAME_JLS: Names of lat-sigma tracer JL sources/sinks
      character(len=30), dimension(ktajls) :: sname_jls
!@var LNAME_JLS,UNITS_JLS: descriptions/units of tracer JLS diags
      character(len=50), dimension(ktajls) :: lname_jls = 'unused'
     *     ,units_jls
!@var SCALE_JLS: printout scaling factor for tracer JLS diagnostics
      REAL*8, dimension(ktajls) :: scale_jls
!@var IA_JLS,JGRID_JLS: idacc-numbers,gridtypes for tracer JL diags
      integer, dimension(ktajls) :: ia_jls,jgrid_jls
!@var JLS_POWER: power of 10 used for tracer JLS diagnostics
      integer jls_power(ktajls)
!@var jls_ltop: Top layer for this diagnostic
      integer jls_ltop(ktajls)

C**** TCONSRV
!@parm NTCONS Maximum Number of special tracer conservation points
      INTEGER, PARAMETER :: ntcons=20
!@parm KTCON total number of conservation diagnostics for tracers
      INTEGER, PARAMETER :: KTCON=npts+ntcons+2
!@var TCONSRV conservation diagnostics for tracers
      REAL*8, DIMENSION(JM,ktcon,ntm) :: TCONSRV
!@var SCALE_TCON scales for tracer conservation diagnostics
      REAL*8, DIMENSION(ktcon,ntm) :: SCALE_TCON
!@var TITLE_TCON titles for tracer conservation diagnostics
      CHARACTER*38, DIMENSION(ktcon,ntm) :: TITLE_TCON
!@var IA_TCON IDACC numbers for tracer conservation diagnostics
      INTEGER, DIMENSION(ktcon,ntm) ::  IA_TCON
!@var NSUM_TCON indices for summation of conservation diagnostics
      INTEGER, DIMENSION(ktcon,ntm) :: NSUM_TCON
!@var NOFMT indices for TCONSRV array
      INTEGER, DIMENSION(ktcon,ntm) :: NOFMT
!@var CONPTS names of special processes for tracer conservation diags
      CHARACTER*16, DIMENSION(ntcons) :: CONPTS
!@var kt_power_inst,kt_power_change: Exponents for tracer conservation
      INTEGER, DIMENSION(ntm) :: kt_power_inst,kt_power_change
!@var name_tconsrv,lname_tconsrv,units_tconsrv: for tracer conservation
      character(len=20), dimension(ktcon,ntm) ::
     &   name_tconsrv,units_tconsrv
      character(len=80), dimension(ktcon,ntm) :: lname_tconsrv
!@var SCALE_INST,SCALE_CHANGE: Scale factors for tracer conservation
      REAL*8, dimension(ntm) :: SCALE_INST,SCALE_CHANGE
!@var itcon_surf Index array for surface source/sink conservation diags
      INTEGER, DIMENSION(ntsurfsrcmax,NTM) :: itcon_surf
!@var itcon_3D Index array for 3D source/sink conservation diags
      INTEGER, DIMENSION(nt3Dsrcmax,NTM) :: itcon_3Dsrc
!@var itcon_decay Index array for decay conservation diags
      INTEGER, DIMENSION(NTM) :: itcon_decay
!@var itcon_grav Index array for gravitational settling conserv. diags
      INTEGER, DIMENSION(NTM) :: itcon_grav
!@var itcon_mc Index array for moist convection conserv. diags
      INTEGER, DIMENSION(NTM) :: itcon_mc
!@var itcon_grav Index array for large-scale condensation conserv. diags
      INTEGER, DIMENSION(NTM) :: itcon_ss

C----------------------------------------------------
!@param KTACC total number of tracer diagnostic words
!@var TACC: Contains all tracer diagnostic accumulations
      INTEGER, PARAMETER ::
     *  ktacc=IM*JM*LM*NTM + IM*JM*ktaij*NTM + IM*JM*ktaijs +
     *        JM*LM*ktajlx*NTM + JM*LM*ktajls + JM*NTM*ktcon
      COMMON /TACCUM/ TAIJLN,TAIJN,TAIJS,TAJLN,TAJLS,TCONSRV
      REAL*8, DIMENSION(KTACC) :: TACC
      EQUIVALENCE (TACC,TAIJLN)
C----------------------------------------------------
#endif
      END MODULE TRACER_DIAG_COM

#ifdef TRACERS_ON
      SUBROUTINE SET_TCON(QCON,NAME_CON,QSUM,INST_UNIT,SUM_UNIT
     *     ,INST_SC,CHNG_SC, itr,CONPTs)
!@sum  SET_TCON assigns conservation diagnostic array indices
!@auth Gavin Schmidt
!@ver  1.0
      USE CONSTANT, only: sday
      USE MODEL_COM, only: dtsrc,nfiltr
      USE DAGCOM, only: npts,ia_d5d,ia_d5s,ia_filt,ia_12hr,ia_src,conpt0
      USE TRACER_DIAG_COM, only: ktcon,title_tcon,scale_tcon,nsum_tcon
     *     ,nofmt,ia_tcon,name_tconsrv,lname_tconsrv,units_tconsrv
     *     ,ntcons
      IMPLICIT NONE
!@var QCON denotes at which points conservation diags are saved
      LOGICAL, INTENT(IN),DIMENSION(ktcon-1) :: QCON
!@var QSUM sets whether each diag is included in final sum
!@+   should be zero for diags set using DIAGTCB (i.e. using difference)
      LOGICAL, INTENT(IN),DIMENSION(ktcon-1) :: QSUM
      LOGICAL, DIMENSION(ktcon-1) :: QSUM_CON   ! local version
!@var INST_SC scale for instantaneous value
      REAL*8, INTENT(IN) :: INST_SC
!@var CHNG_SC scale for changes
      REAL*8, INTENT(IN) :: CHNG_SC
!@var NAME_CON name of conservation quantity
      CHARACTER*8, INTENT(IN) :: NAME_CON
!@var sname name of conservation quantity (no spaces)
      CHARACTER*8 :: sname
!@var INST_UNIT string for unit for instant. values
      CHARACTER*20, INTENT(IN) :: INST_UNIT
!@var SUM_UNIT string for unit for summed changes
      CHARACTER*20, INTENT(IN) :: SUM_UNIT
!@var ITR index for the tracer
      INTEGER, INTENT(IN) :: ITR
!@var CONPTS conservation diag points for special tracer diags
      CHARACTER*16, INTENT(IN), DIMENSION(ntcons) :: CONPTS
      CHARACTER*11 CHGSTR
      INTEGER NI,NM,NS,N,k

C**** remove spaces in NAME_CON for netcdf names
      sname=TRIM(NAME_CON)
      do k=1,len_trim(NAME_CON)
        if (sname(k:k).eq." ") sname(k:k)="_"
      end do
C****
      NI=1
      NOFMT(1,itr) = NI
      TITLE_TCON(NI,itr) =
     *     "0INSTANT "//TRIM(NAME_CON)//" "//TRIM(INST_UNIT)
      SCALE_TCON(NI,itr) = INST_SC
      name_tconsrv(NI,itr) ="inst_"//sname
      lname_tconsrv(NI,itr) = "INSTANT "//TRIM(NAME_CON)
      units_tconsrv(NI,itr) = INST_UNIT
      NSUM_TCON(NI,itr) = -1
      IA_TCON(NI,itr) = 12
      NM=NI
      DO N=2,ktcon-1
        IF (QCON(N)) THEN
          NM = NM + 1
          NOFMT(N,itr) = NM
          QSUM_CON(NM)=.FALSE.
          IF (QSUM(N)) QSUM_CON(NM)=.TRUE.
          CHGSTR=" CHANGE OF "
          if (n.le.npts+1) then
            TITLE_TCON(NM,itr) = CHGSTR//TRIM(NAME_CON)//" BY "//
     *         CONPT0(N-1)
            name_tconsrv(NM,itr) =
     *           "chg_"//trim(sname)//"_"//TRIM(CONPT0(N-1)(1:3))
          else
            IF (.not. QSUM(N)) CHGSTR="     DELTA "
            TITLE_TCON(NM,itr) = CHGSTR//TRIM(NAME_CON)//" BY "//
     *           CONPTs(N-npts-1)
            name_tconsrv(NM,itr) =
     *           "chg_"//trim(sname)//"_"//TRIM(CONPTs(N-npts-1)(1:3))
          end if
          lname_tconsrv(NM,itr) = TITLE_TCON(NM,itr)
          units_tconsrv(NM,itr) = SUM_UNIT
          SELECT CASE (N)
          CASE (2)
            SCALE_TCON(NM,itr) = CHNG_SC/DTSRC
            IA_TCON(NM,itr) = ia_d5d
          CASE (3,4,5,6,7,9,11,12)
            SCALE_TCON(NM,itr) = CHNG_SC/DTSRC
            IA_TCON(NM,itr) = ia_d5s
          CASE (8)
            SCALE_TCON(NM,itr) = CHNG_SC/(NFILTR*DTSRC)
            IA_TCON(NM,itr) = ia_filt
          CASE (10)
            SCALE_TCON(NM,itr) = CHNG_SC*2./SDAY
            IA_TCON(NM,itr) = ia_12hr
          CASE (13:)   ! special tracer sources
            SCALE_TCON(NM,itr) = CHNG_SC/DTSRC
            IA_TCON(NM,itr) = ia_src
          END SELECT
        ELSE
          NOFMT(N,itr) = 0
        END IF
      END DO
      NS=NM+1
      IF (NS.gt.KTCON) THEN
        WRITE(6,*) "KTCON not large enough for extra conserv diags",
     *       KTCON,NI,NM,NS,NAME_CON
        call stop_model(
     &       "Change KTCON in tracer diagnostic common block",255)
      END IF
      DO NM=NI+1,NS-1
        NSUM_TCON(NM,itr) = -1
        IF (QSUM_CON(NM)) NSUM_TCON(NM,itr) = NS
      END DO
      TITLE_TCON(NS,itr) = " SUM OF CHANGES "//TRIM(SUM_UNIT)
      name_Tconsrv(NS,itr) ="sum_chg_"//trim(sname)
      lname_Tconsrv(NS,itr) = " SUM OF CHANGES OF "//TRIM(NAME_CON)
      units_Tconsrv(NS,itr) = SUM_UNIT
      SCALE_TCON(NS,itr) = 1.
      IA_TCON(NS,itr) = 12
      NSUM_TCON(NS,itr) = 0
      RETURN
      END SUBROUTINE set_tcon

#endif


        PROGRAM M3CPLE

    !!***********************************************************************
    !! Version "$Id: m3cple.f90 108 2018-09-07 18:59:37Z coats $"
    !!   EDSS/Models-3 M3TOOLS.
    !!   Copyright (C) 1992-2002 MCNC,
    !!   (C) 1995-2002,2005-2013, 2018- Carlie J. Coats, Jr.,
    !!   (C) 2003-2010 Baron Advanced Meteorological Systems. LLC., and
    !!   (C) 2014-2016 UNC Institute for the Environment.
    !!   Distributed under the GNU GENERAL PUBLIC LICENSE version 2
    !!   See file "GPL.txt" for conditions of use.
    !!.........................................................................
    !!  program body starts at line  136
    !!
    !!  DESCRIPTION:
    !!       For each time step in the specified time step sequence,
    !!       reads all variables from the specified input file, optionally
    !!       under the control of the specified synchronization file,
    !!       interpolate it to the specified output grid, and write them
    !!       to the specified output file.
    !!
    !!  PRECONDITIONS REQUIRED:
    !!       setenv <logical name> <physical (path) name> for the input,
    !!       output, and GRIDDESC files.
    !!       Input file and output grid use the same coordinate system.
    !!       Specified time step sequence is valid for both the input and
    !!       synch files.
    !!
    !!  SUBROUTINES AND FUNCTIONS CALLED:
    !!       I/O API
    !!
    !!  REVISION  HISTORY:
    !!       Prototype 8/99 by Carlie J. Coats, Jr., NCSC
    !!       Version  11/2001 by CJC for I/O API Version 2.1
    !!       Version  10/2002 by CJC for I/O API Version 2.2:  support for
    !!       many additional coordinate transformations, direct calls to GCTP
    !!       Version   6/2005 by CJC:  improved default for NRECS
    !!       Version  11/2005 by CJC:  eliminate unused vbles and functions
    !!       Version   9/2006 by CJC:  sphere/spheroid support
    !!       Version   3/2008 by CJC:  INSPHERE default-value bug-fix.
    !!       No resolution-warning for to/from-Lat-Lon conversions.
    !!       Version    6/2008 by CJC:  Albers map-projection support,
    !!       additional spheres 20, 21 from Steve Howard, NOAA/ASMD
    !!       Version   12/2008 by CJC:  heuristic to compensate for WMO screw-up
    !!       that declares all longitudes should be positive
    !!       Version   4/2009 by CJC:  corrections for TRM, EQM
    !!       Version  02/2010 by CJC for I/O API v3.1:  Fortran-90 only;
    !!       USE M3UTILIO, and related changes.
    !!       Version  01/2013 by CJC:  use new LASTTIME() to find EDATE:ETIME
    !!       Version  12/2014 by CJC for I/O API v3.2:  USE MODGCTP: GRID2INDX(),
    !!       INDXMULT();  F90 free-format source; use generics for "GET*()"
    !!       Version  06/2016 by CJC:  copy CMAQ metadata, if present
    !!       Version  01/2018 by CJC:  copy-operations for variables of
    !!       types M3INT, M3DBLE.
    !!       Version  08/2018 by CJC:  fix coordinate-check error
    !!***********************************************************************

      USE M3UTILIO
      USE MODGCTP
      USE MODATTS3

      IMPLICIT NONE

      !!...........   PARAMETERS and their descriptions:

      CHARACTER*16, PARAMETER :: PNAME = 'M3CPLE'
      CHARACTER*16, PARAMETER :: BLANK = ' '
      CHARACTER*72, PARAMETER :: BAR = '-=-=-=-=-=-=-=-=-=-=-=-=-=-'
 !     &  BAR = '-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-'

      !!...........   LOCAL VARIABLES and their descriptions:

      CHARACTER*16    FNAME   !  input data  file logical name
      CHARACTER*16    SNAME   !  input synch file logical name
      CHARACTER*16    SVBLE   !  input   synch variable   name
      CHARACTER*16    ONAME   !  output data file logical name
      CHARACTER*16    CNAME   !  output coordinate system name
      CHARACTER*16    GNAME   !  output grid name

      LOGICAL         IFLAG   !  true iff interp (instead of copy)
      LOGICAL         SFLAG   !  true iff controlled by synch file

      LOGICAL         EFLAG
      CHARACTER*256   MESG

      INTEGER         LDEV        !  log-device
      INTEGER         ISTAT       !  allocation-status

      LOGICAL         AFLAG, BFLAG, CFLAG, XFLAG, YFLAG

      INTEGER         C, R, V, N, NSIZE  !  loop counters

      INTEGER         NCOLS1      ! number of grid columns
      INTEGER         NROWS1      ! number of grid rows
      INTEGER         NLAYS1      ! number of layers
      INTEGER         GDTYP1      ! grid type:  1=LAT-LON, 2=UTM, ...
      REAL*8          P_ALP1      ! first, second, third map
      REAL*8          P_BET1      ! projection descriptive
      REAL*8          P_GAM1      ! parameters.
      REAL*8          XCENT1      ! lon for coord-system X=0
      REAL*8          YCENT1      ! lat for coord-system Y=0
      REAL*8          XORIG1      ! X-coordinate origin of grid (map units)
      REAL*8          YORIG1      ! Y-coordinate origin of grid
      REAL*8          XCELL1      ! X-coordinate cell dimension
      REAL*8          YCELL1      ! Y-coordinate cell dimension

      INTEGER         NCOLS2       ! number of grid columns
      INTEGER         NROWS2       ! number of grid rows
      INTEGER         GDTYP2       ! grid type:  1=LAT-LON, 2=UTM, ...
      REAL*8          P_ALP2       ! first, second, third map
      REAL*8          P_BET2       ! projection descriptive
      REAL*8          P_GAM2       ! parameters.
      REAL*8          XCENT2       ! lon for coord-system X=0
      REAL*8          YCENT2       ! lat for coord-system Y=0
      REAL*8          XORIG2       ! X-coordinate origin of grid (map units)
      REAL*8          YORIG2       ! Y-coordinate origin of grid
      REAL*8          XCELL2       ! X-coordinate cell dimension
      REAL*8          YCELL2       ! Y-coordinate cell dimension

      INTEGER         JDATE, JTIME, TSTEP
      INTEGER         EDATE, ETIME, TSECS, NRECS

      REAL,    ALLOCATABLE :: BUF1( :,: )
      REAL,    ALLOCATABLE :: BUF2( :,: )
      INTEGER, ALLOCATABLE ::  IX2( : )
      REAL,    ALLOCATABLE ::  PX2( : )
      REAL,    ALLOCATABLE ::  PY2( : )
      INTEGER, ALLOCATABLE :: IBUF( :,: )
      REAL(8), ALLOCATABLE :: DBUF( :,: )

C MSK CHANGE START 19.09.2019 (J. Bieser)
        INTEGER         IOS
        CHARACTER*16    STARTDATE
C MSK CHANGE END

      !!***********************************************************************
      !!   begin body of program M3CPLE

        LDEV  = INIT3()
        EFLAG = .FALSE.

        WRITE( *, '( 5X, A )' ) BLANK, BAR, BLANK,
     & 'If you wish to copy time steps, instead of interpolate them,',
     & 'Program M3CPLE to read all variables in each time step in',
     & 'the specified time step sequence from the specified input',
     & 'file, optionally under the control of the specified',
     & 'synchronization file, copy or interpolate them to the output',
     & 'grid, and write them to the specified output file.',
     & '',
     & 'THE PROGRAM WILL PROMPT YOU for the logical names of the input',
     & 'data file, the input synch file, and the output file, the time',
     & 'step sequence, and the GRIDDESC name of the output grid.',
     & '',
     & 'Default responses are indicated in square brackets [LIKE THIS]',
     & 'and may be accepted by hitting the RETURN key.',
     & '',
     & 'If you wish to copy time steps, instead of interpolate them,',
     & 'respond "SAME" to the prompt for output grid name.',
     & '',
     & 'PRECONDITIONS REQUIRED:',
     & '',
     & '    setenv <input data  file>    <path-name>',
     & '    setenv <input synch file>    <path-name, or "NONE">',
     & '    setenv GRIDDESC              <path-name> (if interp)',
     & '    setenv IOAPI_ISPH            <USGS spheroid, or REARTH>',
     & '',
     & '    Time step sequence is valid for both input files',
     & '',
     & '    For COPY:  file type must be GRIDDED, BOUNDARY, or CUSTOM.',
     & '    (respond "SAME" to the prompt for output grid name).',
     & ' ',
     & '    For INTERPOLATION:  the files must be of type GRIDDED,',
     & '    all of the variables must be of type REAL, and',
     & '    the output grid should have a finer resolution than the',
     & '    input grid (else you should use an aggregation program',
     & '    like "mtxcple" instead of an interpolation program).',
     & ' ',
     & 'See URL',
     & ' ',
     & 'https://www.cmascenter.org/ioapi/documentation/3.1/',
     & 'html/AA.html#tools',
     &  '',
     & 'Program copyright (C) 1992-2002 MCNC',
     & '(C) 1995-2013, 2018- Carlie J. Coats, Jr.',
     & '(C) 2003-2010 Baron Advanced Meteorological Systems, LLC., and',
     & '(C) 2014-2016 UNC Institute for the Environment.',
     & 'Released under Version 2 of the GNU General Public License.',
     & 'See enclosed GPL.txt, or URL',
     & ''  ,
     & '    https://www.gnu.org/licenses/old-licenses/gpl-2.0.html',
     & ''  ,
     & 'Comments and questions are welcome and can be sent to'  ,
     & '',
     & '    Carlie J. Coats, Jr.    carlie@jyarborough.com',
     & 'or',
     & '    UNC Institute for the Environment',
     & '    100 Europa Dr., Suite 490 Rm 405',
     & '    Campus Box 1105',
     & '    Chapel Hill, NC 27599-1105',
     & ' ',
     & 'Program version: ',
     & '$Id: m3cple.f90 108 2018-09-07 18:59:37Z coats $',
     & ' '

        IF ( .NOT. GETVAL( 'Continue with program?', .TRUE. ) ) THEN
            CALL M3EXIT( PNAME, 0, 0,
     &                   'Program terminated at user request', 2 )
        END IF

        !!...............  Open and get description for optional synch file

        MESG  = 'Enter name for input synch file, or "NONE"'
        SNAME = PROMPTMFILE( MESG, FSREAD3, 'NONE', PNAME )
        SFLAG = ( SNAME .NE. 'NONE' )

        IF ( SFLAG ) THEN

            IF ( DESC3( SNAME ) ) THEN
                SVBLE  = VNAME3D( 1 )
            ELSE
                MESG = 'Could not get file description for ' // SNAME
                CALL M3EXIT( PNAME, 0, 0, MESG, 2 )
            END IF

        END IF          !  if synch-flag option taken

        !!...............  Open and get description for input data file

        MESG  = 'Enter name for input data file'
        FNAME = PROMPTMFILE( MESG, FSREAD3, 'INFILE', PNAME )

        IF ( DESC3( FNAME ) ) THEN
            NCOLS1 = NCOLS3D
            NROWS1 = NROWS3D
            NLAYS1 = NLAYS3D
            GDTYP1 = GDTYP3D
            P_ALP1 = P_ALP3D
            P_BET1 = P_BET3D
            P_GAM1 = P_GAM3D
            XCENT1 = XCENT3D
            YCENT1 = YCENT3D
            XORIG1 = XORIG3D
            YORIG1 = YORIG3D
            XCELL1 = XCELL3D
            YCELL1 = YCELL3D

            IF ( ISCMAQ( FNAME ) ) THEN
                CFLAG = ENVYN( 'COPY_META',
     &            'Copy CMAQ metadata to output file?', .TRUE., ISTAT )
                IF ( ISTAT .GT. 0 ) THEN
                    EFLAG = .TRUE.
                 CALL M3MESG( 'Bad environment variable "COPY_META"')
                ELSE IF ( .NOT.CFLAG ) THEN
                    CONTINUE
                ELSE IF ( .NOT.GETCMAQ( FNAME ) ) THEN
                    EFLAG = .TRUE.
            CALL M3MESG( 'Could not get CMAQ metadata for '// FNAME )
                END IF
            END IF

        ELSE
            MESG = 'Could not get file description for ' // FNAME
            CALL M3EXIT( PNAME, 0, 0, MESG, 2 )
        END IF

        !!...............  Get CMAQ metadata

        !!...............  Get output grid description, time step sequence

        WRITE( *, '( 5X, A )' ) BLANK,
     & 'If you wish to copy time steps (keeping the output grid',
     & 'the same) instead of interpolating them to a new output',
     & 'grid, respond [SAME] to the prompt for output grid name.',
     & 'Otherwise, give the GRIDDESC name for the output grid.',
     &  ' '

         CALL GETSTR( 'Enter output grid name, or "SAME"',
     & 'SAME', GNAME )

         IF ( TSTEP3D .EQ. 0 ) THEN
             JDATE = 0
             JTIME = 0
             TSTEP = 0
            NRECS = 1
            GO TO  11
         END IF

! MSK START CHANGE 19.08.2019
! MSK         JDATE = GETVAL( SDATE3D, 9999999, SDATE3D,
! MSK     & 'Enter STARTING DATE for time step sequence' )

        CALL ENVSTR( 'NEWDATE','Enter STARTING DATE, or "SAME"',
     &               'SAME', STARTDATE, IOS )

C now read startdate into JDATE
        READ(STARTDATE(1:7),'(I7)') JDATE

	WRITE( MESG,* ) 'Start Date: ', JDATE
	CALL M3MESG( MESG )

C MSK END CHANGE

         JTIME = GETVAL(       0, 9999999, STIME3D,
     & 'Enter STARTING TIME for time step sequence' )

         TSTEP = GETVAL( TSTEP3D, 9999999, TSTEP3D,
     & 'Enter   TIME STEP   for time step sequence' )

         CALL LASTTIME( SDATE3D,STIME3D,TSTEP3D, MXREC3D, EDATE,ETIME )
         N     = CURREC( EDATE, ETIME, JDATE, JTIME, TSTEP, C, R )
         NRECS = GETVAL( 1, 9999999, N,
     & 'Enter     NRECS     for time step sequence' )

         SDATE3D = JDATE
         STIME3D = JTIME
         TSTEP3D = TSTEP

11       CONTINUE        !  target of "if tstep3d is zero"

    !!...............  Setup for mode of operation:  copy or interpolate:

         CNAME = GNAME
         CALL LUSTR( CNAME )
         IF ( ( CNAME .EQ. 'SAME' ) ) THEN   !  set up for copy

           IFLAG = .FALSE.

           IF ( FTYPE3D .EQ. GRDDED3 ) THEN
               NSIZE = NCOLS3D * NROWS3D
           ELSE IF ( FTYPE3D .EQ. BNDARY3 ) THEN
               NSIZE = 2*NTHIK3D*( NCOLS3D + NROWS3D + 2*NTHIK3D )
           ELSE IF ( FTYPE3D .EQ. CUSTOM3 ) THEN
               NSIZE = NCOLS3D
           ELSE
               MESG = 'Cannot copy--' //
     & 'file type not GRIDDED, BOUNDARY, or CUSTOM'
               CALL M3EXIT( PNAME, 0, 0, MESG, 2 )
               EFLAG = .TRUE.
           END IF

           ALLOCATE( BUF1( NSIZE, NLAYS3D ),
     &                  IBUF( NSIZE, NLAYS3D ),
     &                  DBUF( NSIZE, NLAYS3D ),   STAT = ISTAT )
           IF ( ISTAT .NE. 0 ) THEN
           WRITE( MESG,'( A, I10 )') 'Buffer allocation failed: STAT=',
     &              ISTAT
               CALL M3EXIT( PNAME, 0, 0, MESG, 2 )
           END IF

         ELSE IF ( FTYPE3D .NE. GRDDED3 ) THEN

           MESG = 'File type not GRIDDED--cannot interpolate'
           CALL M3EXIT( PNAME, 0, 0, MESG, 2 )

         ELSE    !  set up for interpolate:

           IFLAG = .TRUE.

           GDNAM3D = GNAME
           IF ( DSCGRID( GNAME, CNAME, GDTYP3D,
     &                P_ALP3D, P_BET3D, P_GAM3D, XCENT3D, YCENT3D,
     &                XORIG3D, YORIG3D, XCELL3D, YCELL3D,
     &                NCOLS3D, NROWS3D, NTHIK3D ) ) THEN

            NCOLS2 = NCOLS3D
            NROWS2 = NROWS3D
            GDTYP2 = GDTYP3D
            P_ALP2 = P_ALP3D
            P_BET2 = P_BET3D
            P_GAM2 = P_GAM3D
            XCENT2 = XCENT3D
            YCENT2 = YCENT3D
            XORIG2 = XORIG3D
            YORIG2 = YORIG3D
            XCELL2 = XCELL3D
            YCELL2 = YCELL3D

            CALL M3MESG( BAR )
            CALL M3MESG( 'Input grid parameters' )
            WRITE( MESG, '( A, I10 )' ) 'NCOLS=', NCOLS1
            CALL M3MESG( MESG )
            WRITE( MESG, '( A, I10 )' ) 'NROWS=', NROWS1
            CALL M3MESG( MESG )
            WRITE( MESG, '( A, I10 )' ) 'GDTYP=', GDTYP1
            CALL M3MESG( MESG )
            WRITE( MESG, '( A, 1PE24.16 )' ) 'P_ALP', P_ALP1
            CALL M3MESG( MESG )
            WRITE( MESG, '( A, 1PE24.16 )' ) 'P_BET', P_BET1
            CALL M3MESG( MESG )
            WRITE( MESG, '( A, 1PE24.16 )' ) 'P_GAM', P_GAM1
            CALL M3MESG( MESG )
            WRITE( MESG, '( A, 1PE24.16 )' ) 'XCENT', XCENT1
            CALL M3MESG( MESG )
            WRITE( MESG, '( A, 1PE24.16 )' ) 'YCENT', YCENT1
            CALL M3MESG( MESG )
            WRITE( MESG, '( A, 1PE24.16 )' ) 'XORIG', XORIG1
            CALL M3MESG( MESG )
            WRITE( MESG, '( A, 1PE24.16 )' ) 'YORIG', YORIG1
            CALL M3MESG( MESG )
            WRITE( MESG, '( A, 1PE24.16 )' ) 'XCELL', XCELL1
            CALL M3MESG( MESG )
            WRITE( MESG, '( A, 1PE24.16 )' ) 'YCELL', YCELL1
            CALL M3MESG( MESG )
            CALL M3MESG( BAR )
            CALL M3MESG( 'Output grid parameters' )
            WRITE( MESG, '( A, I10 )' ) 'NCOLS=', NCOLS2
            CALL M3MESG( MESG )
            WRITE( MESG, '( A, I10 )' ) 'NROWS=', NROWS2
            CALL M3MESG( MESG )
            WRITE( MESG, '( A, I10 )' ) 'GDTYP=', GDTYP2
            CALL M3MESG( MESG )
            WRITE( MESG, '( A, 1PE24.16 )' ) 'P_ALP', P_ALP2
            CALL M3MESG( MESG )
            WRITE( MESG, '( A, 1PE24.16 )' ) 'P_BET', P_BET2
            CALL M3MESG( MESG )
            WRITE( MESG, '( A, 1PE24.16 )' ) 'P_GAM', P_GAM2
            CALL M3MESG( MESG )
            WRITE( MESG, '( A, 1PE24.16 )' ) 'XCENT', XCENT2
            CALL M3MESG( MESG )
            WRITE( MESG, '( A, 1PE24.16 )' ) 'YCENT', YCENT2
            CALL M3MESG( MESG )
            WRITE( MESG, '( A, 1PE24.16 )' ) 'XORIG', XORIG2
            CALL M3MESG( MESG )
            WRITE( MESG, '( A, 1PE24.16 )' ) 'YORIG', YORIG2
            CALL M3MESG( MESG )
            WRITE( MESG, '( A, 1PE24.16 )' ) 'XCELL', XCELL2
            CALL M3MESG( MESG )
            WRITE( MESG, '( A, 1PE24.16 )' ) 'YCELL', YCELL2
            CALL M3MESG( MESG )
            CALL M3MESG( BAR )

          ELSE

              MESG   = '"' // TRIM( GNAME ) //
     & '" not found in GRIDDESC file'
              CALL M3EXIT( PNAME, 0, 0, MESG, 2 )

          END IF

    !!...............  Allocate buffers; compute re-gridding matrix

          ALLOCATE( BUF1( NCOLS1*NROWS1, NLAYS1 ),
     &                  BUF2( NCOLS2*NROWS2, NLAYS1 ),
     &                  IX2 ( NCOLS2*NROWS2 ),
     &                  PX2 ( NCOLS2*NROWS2 ),
     &                  PY2 ( NCOLS2*NROWS2 ),  STAT = ISTAT )

          IF ( ISTAT .NE. 0 ) THEN
              WRITE( MESG,
     & '( A, I10)' ) 'Buffer allocation failed:  STAT=', ISTAT
              CALL M3EXIT( PNAME, 0, 0, MESG, 2 )
          END IF

          CALL GRID2INDX( GDTYP1,P_ALP1,P_BET1,P_GAM1,XCENT1,YCENT1,
     &                        GDTYP2,P_ALP2,P_BET2,P_GAM2,XCENT2,YCENT2,
     &                        NCOLS1,NROWS1,XORIG1,YORIG1,XCELL1,YCELL1,
     &                        NCOLS2,NROWS2,XORIG2,YORIG2,XCELL2,YCELL2,
     &                        IX2, PX2, PY2 )

         END IF      !  if gname = "SAME", or not

      !!...............  Open output file

        CALL GETSTR( 'Enter name for output data file',
     &  'OUTFILE', ONAME )

        IF ( .NOT. OPEN3( ONAME, FSUNKN3, PNAME ) ) THEN
          MESG = 'Could not open ' // ONAME
          CALL M3EXIT( PNAME, 0, 0, MESG, 2 )
        END IF

      !!...............  Process output time step sequence

        CALL NEXTIME( JDATE, JTIME, -TSTEP )

        DO  N = 1, NRECS

          CALL NEXTIME( JDATE, JTIME, TSTEP )

          IF ( SFLAG ) THEN           !!  Synch-file processing
              IF ( .NOT. CHECK3( SNAME, SVBLE, JDATE, JTIME ) ) THEN
                  EFLAG = .TRUE.
                  CALL M3MESG( 'ERROR:  synch-failure' )
                  CYCLE
              END IF
          END IF

          WRITE( MESG,
     & '( A, I7.7, A, I6.6 )' ) 'Processing  ', JDATE, ':', JTIME
          CALL M3MSG2( ' ' )
          CALL M3MSG2( MESG )

          IF ( IFLAG ) THEN   !  bilin-interpolate vs. copy

              DO  V = 1, NVARS3D

                IF ( VTYPE3D( V ) .NE. M3REAL ) THEN
                    EFLAG = .TRUE.
                    MESG  = 'ERROR:  variable "' // TRIM( VNAME3D( V ) ) // '" not of type REAL'
                    CALL M3MESG( MESG )
                    CYCLE
                ELSE IF ( .NOT. READ3( FNAME, VNAME3D( V ), ALLAYS3,
     &           JDATE, JTIME, BUF1 ) ) THEN
                     EFLAG = .TRUE.
                     CALL M3MESG( 'ERROR:  read-failure' )
                     CYCLE
                END IF

                CALL INDXMULT( NCOLS2*NROWS2, NLAYS1,
     &                               NCOLS1, NROWS1, IX2, PX2, PY2,
     &                               BUF2, BUF1 )

                IF ( .NOT.WRITE3( ONAME, VNAME3D(V), JDATE,
     &           JTIME, BUF2 ) ) THEN
                    EFLAG = .TRUE.
                    CALL M3MESG( 'ERROR:  write-failure' )
                    CYCLE
                END IF

             END DO      !  end loop on variables

         ELSE        !  else no interpolation:  copy only.

            DO  V = 1, NVARS3D

                IF ( VTYPE3D( V ) .EQ. M3REAL ) THEN

                    IF ( .NOT. READ3( FNAME, VNAME3D( V ),
     &         ALLAYS3, JDATE, JTIME, BUF1 ) ) THEN
                        EFLAG = .TRUE.
                        CALL M3MESG( 'ERROR:  read-failure' )
                    ELSE IF ( .NOT.WRITE3( ONAME,
     &         VNAME3D( V ), JDATE, JTIME, BUF1 ) ) THEN
                        EFLAG = .TRUE.
                        CALL M3MESG( 'ERROR:  write-failure' )
                    END IF

                ELSE IF ( VTYPE3D( V ) .EQ. M3INT ) THEN

                    IF ( .NOT. READ3( FNAME, VNAME3D( V ),
     &                ALLAYS3, JDATE, JTIME, IBUF ) ) THEN
                        EFLAG = .TRUE.
                        CALL M3MESG( 'ERROR:  read-failure' )
                    ELSE IF ( .NOT.WRITE3( ONAME, VNAME3D( V ),
     &                JDATE, JTIME, IBUF ) ) THEN
                        EFLAG = .TRUE.
                        CALL M3MESG( 'ERROR:  write-failure' )
                    END IF

                ELSE IF ( VTYPE3D( V ) .EQ. M3DBLE ) THEN

                  IF ( .NOT. READ3( FNAME, VNAME3D( V ),
     &                ALLAYS3, JDATE, JTIME, DBUF ) ) THEN
                        EFLAG = .TRUE.
                        CALL M3MESG( 'ERROR:  read-failure' )
                    ELSE IF ( .NOT.WRITE3( ONAME, VNAME3D( V ),
     &               JDATE, JTIME, DBUF ) ) THEN
                        EFLAG = .TRUE.
                        CALL M3MESG( 'ERROR:  write-failure' )
                    END IF

                END IF

            END DO      !  end loop on variables

         END IF      !  if iflag, or not

       END DO          !  end loop on output time steps

       IF ( EFLAG ) THEN
         MESG  = 'Failure in program'
         ISTAT = 2
       ELSE
         MESG  = 'Success in program'
         ISTAT = 0
       END IF

       CALL M3EXIT( PNAME, 0, 0, MESG, ISTAT )

       END PROGRAM M3CPLE


      module comrxnb
!     comrxnb
!***********************************************************************
!  Copyright, 1993, 2004,  The  Regents of the University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!**********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 Include file containing passed parameters and pointers related to
!D1 solute module.
!D1
!**********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 Revision                    ECD
!D2 Date         Programmer     Number  Comments
!D2
!D2 09-13-93     B. Robinson    00022   Initial Implementation
!D2
!D2 $Log:   /pvcs.config/fehm90/src/comrxnb.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:42:40   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 08:59:12   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:07:38   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:22:40   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 11:58:12   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:39:56 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
!D2
!D2    Rev 1.1   03/18/94 16:23:22   gaz
!D2 Added solve_new and cleaned up memory management.
!D2
!D2    Rev 1.0   01/20/94 10:22:18   pvcs
!D2 original version in process of being certified
!D2
!**********************************************************************
!D3
!D3 INTERFACES
!D3
!D3 None
!D3
!**********************************************************************
!D4
!D4 GLOBAL OBJECTS
!D4
!D4 Global Constants
!D4
!D4   None
!D4
!D4 Global Types
!D4
!D4   None
!D4
!D4 Global Variables
!D4
!D4                                 COMMON
!D4   Identifier           Type     Block    Description
!D4
!D4   ***** COMMON Block comrxnb pointers and associated variables *****
!D4   ipstored_derivative  POINTER  comrxnb  Pointer for array stored_derivative
!D4   ipstored_residual    POINTER  comrxnb  Pointer for array stored_residual
!D4   stored_derivatives   REAL*8   comrxnb  Array of derivatives for each
!D4                                            solute at each node
!D4   stored_residual      REAL*8   comrxnb  Array of residuals for each
!D4                                            solute at each node
!D4
!**********************************************************************
!D5
!D5 LOCAL IDENTIFIERS
!D5
!D5 None
!D5
!**********************************************************************
!D6
!D6 FUNCTIONAL DESCRIPTION
!D6
!D6 None
!D6
!**********************************************************************
!D7
!D7 ASSUMPTIONS AND LIMITATIONS
!D7
!D7 None
!D7
!**********************************************************************
!D8
!D8 SPECIAL COMMENTS
!D8
!D8 None
!D8
!**********************************************************************
!D9
!D9 REQUIREMENTS TRACEABILITY
!D9
!D9 None
!D9
!**********************************************************************
!DA
!DA REFERENCES
!DA
!DA None
!DA
!**********************************************************************
!PS
!PS PSEUDOCODE
!PS
!PS None
!PS
!**********************************************************************

      real*8, allocatable ::  stored_derivative(:)
      real*8, allocatable ::  stored_residual(:)

      end module comrxnb


      SUBROUTINE SEPUSH (XMAR,X,XTAIL,XBIT)
C     PUSH AN ELEMENT IN A SET
C
      INCLUDE 'PARS.f'
      INCLUDE 'SETS.f'
      INTEGER*2 PARASK
     = ,I
     = ,I1       ! -> THE ELEMENT BEFORE 'I2'
     = ,I2       ! -> CURRENT ELEMENT
     = ,X        ! ELEMENT TO BE MARKED
     = ,XBIT     ! THE BIT THAT IS MARKED
     = ,XHEAD    ! -> BEGIN AND
     = ,XMAR(1)  ! ARRAY THAT CONTAINS THE MARKINGS
     = ,XTAIL    ! APPEND TO THIS SET
C
CXML
C     XML3 (SEPUSH, X, XTAIL, XBIT)
      CALL XML3 ('SEPUSH', 1, 6, X,XTAIL,XBIT)
      IF (MOD(XMAR(X),XBIT+XBIT) .GE. XBIT) GOTO 3 ! NOT YET IN THE SET
        XMAR(X) = XMAR(X) + XBIT ! MARK THE VALUE
        IF (FSET .GE. SETHIB) GOTO 4
          SETELE(XTAIL) = X ! STORE THE VALUE
          SET   (XTAIL) = FSET
          XTAIL = FSET
          FSET = SET(FSET)
        GOTO 5 ! 'SET' NOT EXHAUSTED
4       CONTINUE
          CALL ASSERT(20,XTAIL,X)
5     CONTINUE
3     CONTINUE ! NOT MARKED
      RETURN ! SEPUSH
C------------------------------------------------------
      ENTRY SETALL (XHEAD,XTAIL,XBIT)
C     ALLOCATE A NEW SET
C
      XBIT = POT2
      POT2 = POT2 + POT2
      IF (FSET .GE. SETHIB) GOTO 1
        XHEAD = FSET
        XTAIL = XHEAD
        FSET = SET(FSET)
      GOTO 2 ! .GE. SETHIB
1     CONTINUE
        CALL ASSERT(5,FSET,SETHIB)
2     CONTINUE
      RETURN ! SETALL
C----------------------------------------------------------
      ENTRY SETBIN
C     RESET 'POT2' FOR SUCCESSIVE CALLS OF 'SETALL'
C
      POT2 = 1
      RETURN ! SETBIN
C----------------------------------------------------------
      ENTRY SETDEL (XMAR,X,XHEAD,XTAIL,XBIT)
C     DELETE A SINGLE ELEMENT OF A LIST/SET
C
      IF (MOD(XMAR(X),XBIT+XBIT)  .LT. XBIT) GOTO 8 ! 'X' IS MARKED
        XMAR(X) = XMAR(X) - XBIT
        SET(1) = XHEAD
        I1 = 1
        I2 = SET(I1)!
13      IF(I2 .EQ. XTAIL) GOTO 9
          IF (SETELE(I2) .NE. X) GOTO 10 ! RIGHT ELEMENT FOUND
            SET(I1) = SET(I2)
            SET(I2) = FSET
            FSET = I2!
            GOTO 100
10        CONTINUE ! FOUND
          I1 = I2
          I2 = SET(I1)!
        GOTO 13
9       CONTINUE ! ALL ELEMENTS
        ! 'X' WAS NOT FOUND HERE
        CALL ASSERT(13,X,XTAIL)
C
100     CONTINUE
        XHEAD = SET(1)
8     CONTINUE ! WAS MARKED
      RETURN ! SETDEL
C------------------------------------------------------------------
      ENTRY SETFRE (XMAR,XHEAD,XTAIL,XBIT)
C     DELETE AN ENTIRE SET AND UNMARK ALL ELEMENTS
C
14    IF(XHEAD .EQ. XTAIL) GOTO 12
        I1 = SETELE(XHEAD)
        XMAR(I1) = XMAR(I1) - XBIT
        I = XHEAD
        XHEAD = SET(XHEAD)
        SET(I) = FSET
        FSET = I!
      GOTO 14
12    CONTINUE ! WHILE NOT EMPTY
      RETURN ! SETFRE
C------------------------------------------------------------
      ENTRY SETPOP (XMAR,X,XHEAD,XBIT)
C     TAKE AN ELEMENT FROM THE HEAD OF A QUEUE
C
      X = SETELE(XHEAD)
      XMAR(X) = XMAR(X) - XBIT
      I = XHEAD
      XHEAD = SET(XHEAD)
      SET(I) = FSET
      FSET = I!
      RETURN ! SETPOP
      END


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!

subroutine s1 ! error
  implicit none
  integer :: x(10)
  real :: results
  integer :: i

  do i=1,10
    x(i) = i
  enddo
  !{error "PGF90-S-0074-Illegal number or type of arguments to norm2 - keyword argument x"}
  results = norm2(x)
end

subroutine s2 ! error
  implicit none
  real :: y(10)
  real :: results
  integer :: i
  do i=1,10
    y(i)=i
  end do
  !{error "PGF90-S-0423-Constant DIM= argument is out of range"}
  results = norm2(y, 2)
end

subroutine s3
  implicit none
  real :: z(10)
  real :: results
  integer :: i
  do i=1,10
    z(i)=i
  end do
  !{error "PGF90-S-0074-Illegal number or type of arguments to norm2 - keyword argument position 3"}
  results = norm2(z, 1, 0)
end

subroutine s4
  implicit none
  real :: z(10)
  real :: results
  integer :: i
  do i=1,10
    z(i)=i
  end do
  !{error "PGF90-S-0074-Illegal number or type of arguments to norm2 - 0 argument(s) present, 1-3 argument(s) expected"}
  results = norm2()
end

subroutine s5
  implicit none
  !{error "PGF90-S-0155-Intrinsic not supported in initialization: norm2"}
  real :: results = norm2([real :: 2, 3, 4, 5])
end

  call s1
  call s2
  call s3
  call s4
  call s4
  call s5
end


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

module opt_PLBFGS
use, intrinsic :: iso_c_binding
use typedef
use miscellaneous
use opt_PSTD, only : xk, descent
use opt_LBFGS, only : save_LBFGS, update_LBFGS, sk, yk

private
real, allocatable, dimension(:) :: alpha_plb,rho_plb
public PLBFGS

contains

subroutine plbfgs_centry(n,x,fcost,grad,grad_preco,q_plb,optim,flag,lb,ub) bind(c, name='PLBFGS')
  !IN
  integer(c_int), value  :: n                    !dimension of the problem
  real(c_float)   :: fcost                       !cost associated with x
  real(c_float),dimension(n) :: grad,grad_preco !gradient and preconditioned gradient at x
  real(c_float),dimension(n) :: q_plb
  !IN/OUT
  integer(c_int)  :: flag
  real(c_float),dimension(n) :: x               !current point
  type(optim_type) :: optim            !data structure
  type(c_ptr), value  :: lb,ub
  real(c_float), pointer, dimension(:) :: lb_pass, ub_pass

  nullify(lb_pass)
  nullify(ub_pass)
  if (c_associated(ub)) call c_f_pointer(ub, ub_pass, (/n/))
  if (c_associated(lb)) call c_f_pointer(lb, lb_pass, (/n/))
  call plbfgs(n,x,fcost,grad,grad_preco,q_plb,optim,flag,lb_pass,ub_pass)
end subroutine plbfgs_centry

!*****************************************************!
!*          SEISCOPE OPTIMIZATION TOOLBOX            *!
!*****************************************************!
! This file contains the two parts of the computation !
! of the l-BFGS descent direction following the two   !
! recursion loop algorithm                            !
! Nocedal, 2nd edition, 2006 Algorithm 7.5 p. 179     !
! Basically, the two loops have been split, compared  !
! to the standard l-BFGS algorithm, to allow the user !
! to use its preconditioner as an initial estimation  !
! of the inverse Hessian operator                     !
!-----------------------------------------------------!

!-----------------------------------------------------!
!FIRST LOOP: descent1_PLBFGS                          !
!------------------------------------------------------
! INPUT : integer n dimension                         !
!         real,dimension(n) grad current gradient     !
!         real,dimension(n,l) sk yk pairs of vectors  !
!                             for l-BFGS approximation!
!         integer cpt_lbfgs current number of stored  !
!                           pairs                     !
!         integer l maximum number of stored pairs    !
! OUTPUT : real,dimension(n) descent                  !
!-----------------------------------------------------!
subroutine descent1_PLBFGS(n,grad,sk,yk,cpt_lbfgs,l,q_plb)

  implicit none

  !IN
  integer :: n,cpt_lbfgs,l
  real,dimension(n) :: grad, q_plb
  real,dimension(n,l) :: sk,yk
  !Local variables
  integer :: i,borne_i

  borne_i=cpt_lbfgs-1
  allocate(alpha_plb(cpt_lbfgs))
  allocate(rho_plb(cpt_lbfgs))
  q_plb(:)=grad(:)
  do i=1,borne_i
     rho_plb(borne_i-i+1)= dot_product(yk(:,borne_i-i+1),sk(:,borne_i-i+1))
     rho_plb(borne_i-i+1)=1./rho_plb(borne_i-i+1)
     alpha_plb(borne_i-i+1)= dot_product (sk(:,borne_i-i+1),q_plb(:))
     alpha_plb(borne_i-i+1)=rho_plb(borne_i-i+1)*alpha_plb(borne_i-i+1)
     q_plb(:)=q_plb(:)-alpha_plb(borne_i-i+1)*yk(:,borne_i-i+1)
  enddo

end subroutine descent1_PLBFGS

!-----------------------------------------------------!
!SECOND LOOP: descent2_PLBFGS                         !
!------------------------------------------------------
! INPUT : integer n dimension                         !
!         real,dimension(n) grad current gradient     !
!         real,dimension(n,l) sk yk pairs of vectors  !
!                             for l-BFGS approximation!
!         integer cpt_lbfgs current number of stored  !
!                           pairs                     !
!         integer l maximum number of stored pairs    !
! OUTPUT : real,dimension(n) descent                  !
!-----------------------------------------------------!
subroutine descent2_PLBFGS(n,sk,yk,cpt_lbfgs,l,descent,q_plb)

  implicit none

  !IN
  integer :: n,cpt_lbfgs,l
  real,dimension(n,l) :: sk,yk
  !IN/OUT
  real,dimension(n) :: descent, q_plb
  !Local variables
  real :: beta,gamma,gamma_num,gamma_den
  integer :: i,borne_i

  borne_i=cpt_lbfgs-1
  gamma_num = dot_product(sk(:,borne_i),yk(:,borne_i))
  gamma_den = norm2 (yk(:,borne_i))
  gamma=gamma_num/(gamma_den**2)
  descent(:)=gamma*q_plb(:)
  do i=1,borne_i
     beta = dot_product(yk(:,i),descent(:))
     beta= rho_plb(i)*beta
     descent(:)=descent(:)+(alpha_plb(i)-beta)*sk(:,i)
  enddo
  descent(:)=-1.*descent(:)
  deallocate(alpha_plb,rho_plb)

end subroutine descent2_PLBFGS
!*********************************************!
!*    SEISCOPE OPTIMIZATION TOOLBOX          *!
!*********************************************!
! This routine is used to deallocate all the  !
! arrays that have been used during the       !
! PSTD optimization                           !
!---------------------------------------------!
! INPUT/OUT:  optim_type optim                !
!---------------------------------------------!
subroutine finalize_PLBFGS()

  implicit none

  deallocate(xk)
  deallocate(descent)
  deallocate(sk)
  deallocate(yk)

end subroutine finalize_PLBFGS
!*****************************************************!
!*          SEISCOPE OPTIMIZATION TOOLBOX            *!
!*****************************************************!
! This routine is used for the initialization of the  !
! reverse communication mode preconditioned l-BFGS    !
! algorithm from the TOOLBOX.                         !
!                                                     !
! The parameters for the linesearch are set here, as  !
! well as the data structure allocations required for !
! the use of the algorithm                            !
!-----------------------------------------------------!
! INPUT : integer n, dimension of the problem         !
!       : real fcost                                  !
!       : real,dimension(n) x,grad,grad_preco         !
!                           initial guess, gradient   !
!                           preconditioned gradient   !
!                           at first iteration        !
! INPUT/OUTPUT : optim_type optim data structure      !
!-----------------------------------------------------!
subroutine init_PLBFGS(n,l,x,fcost,grad,grad_preco,optim)

  implicit none

  !IN
  integer :: n,l
  real :: fcost
  real,dimension(n) :: x,grad,grad_preco
  !IN/OUT
  type(optim_type) :: optim !data structure

  !---------------------------------------!
  ! set counters                          !
  !---------------------------------------!
  optim%cpt_iter=0
  optim%f0=fcost
  optim%nfwd_pb=0
  optim%cpt_lbfgs=1

  !---------------------------------------!
  ! initialize linesearch parameters      !
  ! by default, the max number of         !
  ! linesearch iteration is set to 20     !
  ! and the initial steplength is set to 1!
  !---------------------------------------!
  optim%m1=1e-4 ! Wolfe conditions parameter 1 (Nocedal value)
  optim%m2=0.9  ! Wolfe conditions parameter 2 (Nocedal value)
  optim%mult_factor=10 ! Bracketting parameter (Gilbert value)
  optim%fk=fcost
  optim%nls_max=20 ! max number of linesearch
  optim%cpt_ls=0
  optim%first_ls=.true.
  optim%alpha=1. ! first value for the linesearch steplength

  !---------------------------------------!
  ! memory allocations                    !
  !---------------------------------------!
  allocate(xk(n))
  xk(:)=x(:)
  allocate(descent(n))
  allocate(sk(n,l),yk(n,l))
  sk(:,:)=0.
  yk(:,:)=0.

  !---------------------------------------!
  ! first descent direction               !
  !---------------------------------------!
  descent(:)=-1.*grad_preco(:)

  call save_LBFGS(n,optim%cpt_lbfgs,l,x,grad,sk,yk)

end subroutine init_PLBFGS
!*****************************************************!
!*          SEISCOPE OPTIMIZATION TOOLBOX            *!
!*****************************************************!
! This routine is the reverse communication mode      !
! preconditioned l-BFGS algorithm. This algorithm is  !
! described in :                                      !
! Numerical Optimization, Nocedal, 2nd edition, 2006  !
! Algorithm 7.4 p. 178, Algorithm 7.5 p. 179          !
!                                                     !
! This routine performs an iterative                  !
! minimization of a function f following the          !
! recurrence                                          !
!                                                     !
! x_{0}=x0                                            !
! x_{k+1}=x_k+\alpha_k d_k                            !
!                                                     !
! where the descent direction d_k is                  !
!                                                     !
! d_k=-Q_k \nabla f_k                                 !
!                                                     !
! with Q_k        : l-BFGS approximation of the       !
!                   inverse Hessian at iteration k    !
!                   including preconditioning info    !
!\nabla f_k       : gradient of f in x_k              !
!                                                     !
! and alpha_k is the steplength computed through the  !
! common linesearch algorithm of the TOOLBOX          !
!                                                     !
! The only difference with the l-BFGS algorithm is in !
! the computation of the descent direction d_k which  !
! can now include a prior information on the inverse  !
! hessian operator.                                   !
!                                                     !
! The first call to the algorithm must be done with   !
! FLAG='INIT'. For this first call, the initial point !
! x0 is given through the variable x, and the input   !
! variable fcost and grad must correspond respectively!
! to the misfit and gradient at x0.                   !
!                                                     !
! The reverse communication with the user is          !
! performed through the variable FLAG. This           !
! variable indicates to the user on return what action!
! he has to do, or the state of the algorithm.        !
! Possible values are                                 !
! - FLAG='GRAD' => the user must compute the cost and !
!                  (preconditioned) gradient at       !
!                  current point x                    !
! - FLAG='PREC' => the user must multiply the vector   !
!                  optim%q_plb by its preconditioner  !
! - FLAG='CONV' => a minimizer has been found         !
! - FLAG='NSTE' => a new step is performed            !
! - FLAG='FAIL' => the linesearch has failed          !
!-----------------------------------------------------!
! INPUT  : integer :: n (dimension)                   !
!          real fcost (current cost)                  !
!          real,dimension(n) grad                     !
!          real,dimension(n) grad_preco               !
! INPUT/OUTPUT : real,dimension(n) x                  !
!                optim_typ optim (data structure)     !
!                character*4 FLAG (communication)     !
!-----------------------------------------------------!
subroutine PLBFGS(n,x,fcost,grad,grad_preco,q_plb,optim,flag,lb,ub)

  implicit none

  !IN
  integer  :: n                            !dimension of the problem
  real :: fcost                          !cost associated with x
  real,dimension(n) :: grad              !associated gradient
  real,dimension(n) :: grad_preco        !preconditioned gradient (first iteration only)
  real,dimension(n) :: q_plb
  !IN/OUT
  integer  :: flag
  real,dimension(n) :: x          !current point
  type(optim_type) :: optim                !data structure
  real(c_float),optional, dimension(n) :: lb,ub
  !Local variables
  logical :: test_conv

  if(FLAG.eq. 0) then
     !-----------------------------------------------------!
     ! if FLAG is INIT, call the dedicated initialization  !
     ! subroutine to allocate data structure optim and     !
     ! initialize the linesearch process                   !
     !-----------------------------------------------------!
     call init_PLBFGS(n,optim%l,x,fcost,grad,grad_preco,optim)
     call std_linesearch(n,x,fcost,grad,xk,descent,optim,lb,ub)
     call print_info(n,'PL',optim,fcost,grad,FLAG)
     FLAG=1
     optim%nfwd_pb=optim%nfwd_pb+1
  elseif(FLAG.eq. 5) then
     !-----------------------------------------------------!
     ! if FLAG is PREC, we return from a call to the       !
     ! user preconditioner, then we have to finish the     !
     ! computation of the descent direction                !
     !-----------------------------------------------------!
     call descent2_PLBFGS(n,sk,yk,optim%cpt_lbfgs,&
          optim%l,descent,q_plb)
     !LBFGS save
     call save_LBFGS(n,optim%cpt_lbfgs,optim%l,x,grad,sk,yk)
     optim%cpt_iter=optim%cpt_iter+1
     !-----------------------------------------------------!
     ! before continuing we test for convergence           !
     !-----------------------------------------------------!
     call std_test_conv(optim,fcost,test_conv)
     if(test_conv) then
        FLAG=2
        !print info on current iteration
        call print_info(n,'PL',optim,fcost,grad,FLAG)
        call finalize_PLBFGS
     else
        FLAG=3
        !print info on current iteration
        call print_info(n,'PL',optim,fcost,grad,FLAG)
     endif
  else
     !-----------------------------------------------------!
     ! else call the linesearch process                    !
     !-----------------------------------------------------!
     call std_linesearch(n,x,fcost,grad,xk,descent,optim,lb,ub)
     if(optim%task.eq. 0) then
        !LBFGS update
        call update_LBFGS(n,optim%cpt_lbfgs,optim%l,x,grad,sk,yk)
        !Start the computation of the new descent direction
        call descent1_PLBFGS(n,grad,sk,yk,optim%cpt_lbfgs,optim%l,q_plb)
        !Set FLAG to PREC for asking user to perform preconditioning
        FLAG=5
     elseif(optim%task.eq. 1) then
        !-----------------------------------------------------!
        ! if the linesearch needs a new gradient then ask the !
        ! user to provide it
        !-----------------------------------------------------!
        FLAG=1
        optim%nfwd_pb=optim%nfwd_pb+1
     elseif(optim%task.eq. 2) then
        !-----------------------------------------------------!
        ! if the linesearch has failed, inform the user       !
        !-----------------------------------------------------!
        FLAG=4
        !print info on current iteration
        call print_info(n,'PL',optim,fcost,grad,FLAG)
        call finalize_PLBFGS
     endif
  endif

end subroutine PLBFGS

end module opt_PLBFGS


! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! H0 X
! H0 X   libAtoms+QUIP: atomistic simulation library
! H0 X
! H0 X   Portions of this code were written by
! H0 X     Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode,
! H0 X     Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield.
! H0 X
! H0 X   Copyright 2006-2010.
! H0 X
! H0 X   These portions of the source code are released under the GNU General
! H0 X   Public License, version 2, http://www.gnu.org/copyleft/gpl.html
! H0 X
! H0 X   If you would like to license the source code under different terms,
! H0 X   please contact Gabor Csanyi, gabor@csanyi.net
! H0 X
! H0 X   Portions of this code were written by Noam Bernstein as part of
! H0 X   his employment for the U.S. Government, and are not subject
! H0 X   to copyright in the USA.
! H0 X
! H0 X
! H0 X   When using this software, please cite the following reference:
! H0 X
! H0 X   http://www.libatoms.org
! H0 X
! H0 X  Additional contributions by
! H0 X    Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras
! H0 X
! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

program test_CASTEP_MM_buffer_crack
use libatoms_module
use potential_module
implicit none
  type(Atoms) :: at, cluster_qm, cluster_mm
  type(Inoutput) :: io
  character(len=STRING_LENGTH) :: infile, init_args, calc_args
  real(dp) :: rqm, rmm, g_width
  type(Potential) :: pot
  type(Dictionary) :: cli
  type(Table) :: cluster_info
  integer, pointer :: idx(:)
  logical, pointer :: is_in_qm(:)
  real(dp), allocatable :: f(:,:)
  integer :: i
  real(dp) :: charge(128)

  call system_initialise()

  call initialise(cli)
  infile = ""
  call param_register(cli, "infile", "stdin", infile, help_string="No help yet.  This source file was $LastChangedBy$")
  init_args = ""
  call param_register(cli, "init_args", param_mandatory, init_args, help_string="No help yet.  This source file was $LastChangedBy$")
  calc_args = ""
  call param_register(cli, "calc_args", "", calc_args, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(cli, "rqm", param_mandatory, rqm, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(cli, "rmm", "0.0", rmm, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(cli, "g_width", "0.25", rmm, help_string="No help yet.  This source file was $LastChangedBy$")
  if (.not. param_read_args(cli, ignore_unknown=.false.)) &
    call system_abort("Failed to parse CLI parameters")

  charge = 0.0_dp
  charge(6) = -1.25_dp
  charge(14) = 1.25_dp

  call finalise(cli)

  call read(at, infile)

  call initialise(pot, init_args)

  call create_hybrid_weights(at, "hysteretic_buffer hysteretic_buffer_inner_radius="//(rqm+rmm)//" hysteretic_buffer_outer_radius="//(rqm+rmm))
  cluster_info = create_cluster_info_from_hybrid_mark(at, "cluster_periodic_z")
  call carve_cluster(at, "randomise_buffer=F cluster_periodic_z" , cluster_info, cluster_mm)

  call create_hybrid_weights(cluster_mm, "hysteretic_buffer hysteretic_buffer_inner_radius="//rqm//" hysteretic_buffer_outer_radius="//rqm)
  cluster_info = create_cluster_info_from_hybrid_mark(cluster_mm, "cluster_periodic_z")
  call carve_cluster(cluster_mm, "randomise_buffer=F cluster_periodic_z" , cluster_info, cluster_qm)
  call finalise(cluster_info)

  call add_property(cluster_mm, "is_in_qm", .false.)
  if (.not. assign_pointer(cluster_mm, "is_in_qm", is_in_qm)) &
    call system_abort("Failed to assign pointer for is_in_qm in cluster_mm")
  if (.not. assign_pointer(cluster_qm, "index", idx)) &
    call system_abort("Failed to assign pointer for index in cluster_qm")

  call initialise(io, "extcharges", OUTPUT)
  do i=1, cluster_qm%N
    is_in_qm(idx(i)) = .true.
  end do
  do i=1, cluster_mm%N
    if (.not. is_in_qm(i)) then
      call print(charge(cluster_mm%Z(i))//" "//cluster_mm%pos(:,i)//" "//g_width, file=io)
    endif
  end do
  call finalise(io)

  allocate(f(3,cluster_qm%N))
  call calc(pot, cluster_qm, f=f)

  do i=1, cluster_qm%N
    call print(i// " " // cluster_qm%pos(:,i) // " " // f(:,i))
  end do

  call system_finalise()

end program test_CASTEP_MM_buffer_crack


! ******************************************************************************************************************************** !
! cpl_flux_atchem.f90
! AtCheM interface flux integrator
! ******************************************************************************************************************************** !

! ******************************************************************************************************************************** !
! COUPLE AtChem fluxes
SUBROUTINE cpl_flux_ocnatm(     &
     & dum_dts,                 &
     & dum_n_atm,               &
     & dum_n_i_atm,dum_n_j_atm, &
     & dum_n_i_ocn,dum_n_j_ocn, &
     & dum_sfxatm1,             &
     & dum_sfxsumatm            &
     & )
  USE atchem_lib
  IMPLICIT NONE
  ! dummy arguments
  real,intent(in)::dum_dts
  integer,intent(in)::dum_n_atm
  integer,intent(in)::dum_n_i_atm,dum_n_j_atm
  integer,intent(in)::dum_n_i_ocn,dum_n_j_ocn
  real,dimension(dum_n_atm,dum_n_i_ocn,dum_n_j_ocn),intent(inout)::dum_sfxatm1   ! atmosphere-surface fluxes; ocn grid
  real,dimension(dum_n_atm,dum_n_i_atm,dum_n_j_atm),intent(inout)::dum_sfxsumatm ! atmosphere-surface fluxes; integrated, atm grid
  ! ---------------------------------------------------------- !
  ! START
  ! ---------------------------------------------------------- !
  IF (ctrl_debug_lvl1) print*, '*** COUPLE AtChem fluxes ***'
  IF (ctrl_debug_lvl1) print*, '    >>>'
  ! ---------------------------------------------------------- !
  ! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/ !
  ! ANY DIFFERENCE BETWEEN OCEAN AND ATMOSPHERE GRIDS WILL HAVE TO BE TAKEN INTO ACCOUNT HERE
  ! integrate flux to atmosphere <dum_sfxatm1> (mol m-2 s-1)
  ! running total <dum_sfxsumatm> is in units of (mol m-2)
  dum_sfxsumatm(:,:,:) = dum_sfxsumatm(:,:,:) + dum_dts*dum_sfxatm1(:,:,:)
  ! zero flux
  dum_sfxatm1(:,:,:) = 0.0
  ! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/ /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ !
  ! ---------------------------------------------------------- !
  ! END
  ! ---------------------------------------------------------- !
  IF (ctrl_debug_lvl1) print*, '    <<<'
  ! ---------------------------------------------------------- !
END SUBROUTINE cpl_flux_ocnatm
! ******************************************************************************************************************************** !

! ******************************************************************************************************************************** !
! COUPLE AtChem fluxes
SUBROUTINE cpl_flux_lndatm(     &
     & dum_dts,                 &
     & dum_n_atm,               &
     & dum_n_i_atm,dum_n_j_atm, &
     & dum_n_i_lnd,dum_n_j_lnd, &
     & dum_sfxatm_lnd,          &
     & dum_sfxsumatm            &
     & )
  USE atchem_lib
  IMPLICIT NONE
  ! dummy arguments
  real,intent(in)::dum_dts
  integer,intent(in)::dum_n_atm
  integer,intent(in)::dum_n_i_atm,dum_n_j_atm
  integer,intent(in)::dum_n_i_lnd,dum_n_j_lnd
  real,dimension(dum_n_atm,dum_n_i_lnd,dum_n_j_lnd),intent(inout)::dum_sfxatm_lnd   ! atmosphere-surface fluxes; lnd grid
  real,dimension(dum_n_atm,dum_n_i_atm,dum_n_j_atm),intent(inout)::dum_sfxsumatm ! atmosphere-surface fluxes; integrated, atm grid
  ! ---------------------------------------------------------- !
  ! START
  ! ---------------------------------------------------------- !
  IF (ctrl_debug_lvl1) print*, '*** COUPLE AtChem fluxes ***'
  IF (ctrl_debug_lvl1) print*, '    >>>'
  ! ---------------------------------------------------------- !
  ! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/ !
  ! ANY DIFFERENCE BETWEEN OCEAN AND ATMOSPHERE GRIDS WILL HAVE TO BE TAKEN INTO ACCOUNT HERE
  ! integrate flux to atmosphere <dum_sfxatm_lnd> (mol m-2 s-1)
  ! running total <dum_sfxsumatm> is in units of (mol m-2)
  dum_sfxsumatm(:,:,:) = dum_sfxsumatm(:,:,:) + dum_dts*dum_sfxatm_lnd(:,:,:)
  ! zero flux
  dum_sfxatm_lnd(:,:,:) = 0.0
  ! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/ /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ !
  ! ---------------------------------------------------------- !
  ! END
  ! ---------------------------------------------------------- !
  IF (ctrl_debug_lvl1) print*, '    <<<'
  ! ---------------------------------------------------------- !
END SUBROUTINE cpl_flux_lndatm
! ******************************************************************************************************************************** !