	PROGRAM GDPLOT
C************************************************************************
C* PROGRAM GDPLOT							*
C*									*
C* This program draws contours and/or plots vectors/barbs from gridded 	*
C* data.  Multiple sets of contours and vectors can be generated for	*
C* each frame.  This program was adapted from GDCNTR and GDWIND.	*
C**									*
C* Log:									*
C* G. Krueger/EAI	 5/93	Multiple overlay/plot ability		*
C* G. Krueger/EAI	 8/93	Added REFVEC, HILO, HLSYM, & CLRBAR	*
C* S. Jacobs/EAI	 9/93	Changed IN_CBAR & GR_CBAR to GG_CBAR	*
C* G. Krueger/EAI	10/93	Changed GFUNC & GVECT,fixed CLRBAR parse*
C* S. Jacobs/EAI	10/93	Changed call to IN_RVEC and plotting of *
C*				   reference arrow			*
C* S. Jacobs/EAI         2/94   Added COLADD flag to DG_OFIL            *
C* S. Jacobs/NMC         3/94   Added satellite display routines        *
C* L. Williams/EAI       3/94	Clean up declarations of user input	*
C*				variables				*
C* S. Jacobs/NMC         4/94   Removed unused variables        	*
C* S. Jacobs/NMC         6/94   DEVICE*12 --> *72                       *
C* L. Williams/EAI	 7/94	Removed call to GDBUPD and added shrttl	*
C*				to the user input variables		*
C* P. Bruehl/Unidata	 8/94	Increased size of character string tmfnd*
C*				from 20 to 36 for grids w/2 times	*
C*				Added .and.clear to IF for drop sat img	*
C* P. Bruehl/Unidata	 9/94	Added more checks for drop sat img	*
C* S. Jacobs/NMC	10/94	Check for proces=.true. before GDBTIM	*
C* P. Bruehl/Unidata	12/94	Fixed call to GR_VSCL			*
C* J. Cowie/COMEt	 8/95	Changed GSATIM to IM_DROP, add IM_LUTF,	*
C*				use idrpfl				*
C* P. Bruehl/NWS	12/95	Added code to allow looping		*
C* D. Keiser/GSC	12/95	Added STNPLT as a parameter		*
C* S. Jacobs/NCEP	 5/96	Fixed vector staggering			*
C* D. Keiser/GSC	 8/96	Added FL_MFIL to search for file type	*
C* G. Krueger/EAI	 8/96	Increased user variables to 72 chars.	*
C* K. Tyle/GSC		 8/96	Added ER_WMSG call after FL_MFIL call,	*
C*				use filnam in call to GDBDSP		*
C* D.W.Plummer/NCEP	10/96	Reorganized and cleaned up code.	*
C* D.W.Plummer/NCEP	11/96	Reorganized code for NMAP access.	*
C* D.W.Plummer/NCEP	 1/97	Added POSN, COLORS, MARKER, GRDLBL	*
C* D.W.Plummer/NCEP	 2/97	Moved CALL IM_LUTF into GDPLTB.f	*
C* D.W.Plummer/NCEP	 7/97	Increased input string sizes		*
C* D.W.Plummer/NCEP	 7/97	Added FILTER filter processing          *
C* S. Maxwell/GSC        7/97   Increased input character length        *
C* D.W.Plummer/NCEP	 8/98	Changed calling sequence of GDPTMS	*
C* T. Lee/GSC		 7/99	Implemented cycle			*
C* D.W.Plummer/NCEP	 4/00	Changes for multiple fcst hr processing	*
C* T. Lee/GSC		 7/00	Increased array size for satfnd & radfnd*
C* K. Brill/HPC		12/02	Add IJSKIP				*
C* K. Brill/HPC		 4/03	CALL DG_INTL				*
C* M. Li/SAIC		11/03	Added color bar for images		*
C* R. Tian/SAIC         11/03   Added nuflg to DG_INTL call             *
C* R. Tian/SAIC          2/04   Removed nuflg fromo DG_INTL call        *
C* T. Piper/SAIC	08/04	Added mscale				*
C* R. Tian/SAIC         12/04   Removed call to DG_CLAL			*
C* T. Lee/SAIC		01/06	GDPLOT3					*
C* T. Piper/SAIC        01/08   Added GD_INIT; removed from IN_BDTA     *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'gdplot.cmn'
C*
C*	Input parameter string definitions.
C*
C*	These may contain filenames
C*
	CHARACTER	gdfile*256, satfil*256, radfil*256, stnplt*256
C*
C*	These are ordinary
C*
	CHARACTER	gdatim*(LLMXLN), glevel*(LLMXLN),
     +			gvcord*(LLMXLN), gdpfun*(LLMXLN),
     +			cint*(LLMXLN), line*(LLMXLN), map*(LLMXLN),
     +			title*(LLMXLN), device*(LLMXLN), proj*(LLMXLN),
     +			garea*(LLMXLN), panel*(LLMXLN), text*(LLMXLN),
     +			scale*(LLMXLN), latlon*(LLMXLN),
     +		        contur*(LLMXLN), wind*(LLMXLN), refvec*(LLMXLN),
     +			skip*128, fline*(LLMXLN), type*(LLMXLN),
     +			hilo*(LLMXLN), hlsym*(LLMXLN), clrbar*(LLMXLN),
     +			lutfil*(LLMXLN), stream*(LLMXLN), fint*(LLMXLN),
     +			posn*(LLMXLN), colors*(LLMXLN), marker*(LLMXLN),
     +			grdlbl*(LLMXLN), filter*(LLMXLN),
     +			ijskip*(LLMXLN), imcbar*(LLMXLN),
     +			mscale*(LLMXLN), boxlin*(LLMXLN),
     +			region*(LLMXLN), txtcol*(LLMXLN),
     +			txtype*(LLMXLN), txtfil*(LLMXLN),
     +			txtloc*(LLMXLN), column*(LLMXLN),
     +			shape*(LLMXLN), info*(LLMXLN), loci*144,
     +			anotln*(LLMXLN), anotyp*(LLMXLN)
C*
C*	Other variables
C*
	LOGICAL		clear
C*
	CHARACTER	timfnd(LLMXGT)*256, gdfilo*256,
     +			satfnd (LLMXGT)*256, radfnd (LLMXGT)*256
	LOGICAL		respnd, done, proces, first
	LOGICAL		ltmp
C*
	CHARACTER       satfls(MXLOOP)*132, radfls(MXLOOP)*132
C*
	CHARACTER	gdfilx*256, prfxtt*20
C*
        PARAMETER       ( NEXP = 32 )
        INTEGER         icolr ( NEXP )
C*
C-----------------------------------------------------------------------
C*  Initialize TAE.
C
	CALL IP_INIT  ( respnd, iperr )
	IF  ( iperr .eq. 0 )  THEN
	    CALL IP_IDNT ('GDPLOT3', ier)
C
C*  Initialize GEMPLT.
C
	    CALL GG_INIT  ( 1, ier )
	    IF  ( ier .eq. 0 )  THEN
C
C*  Initialize grid library common area grdcmn.cmn
C
		CALL GD_INIT  ( ier )
C
C*  Initialize the DG library.
C
		CALL DG_INTL ( ier )
C
		prfxtt = " "
C
		CALL GDPSTT ( 'PLOT_MAP', .true., ier )
		CALL GDPSTT (  'VERBOSE', .true., ier )
		done = .false.
	    ELSE
		done = .true.
	    END IF
	ELSE
	    done = .true.
	END IF
C
C*	Main loop to cycle through reading input parameters and plotting.
C
	DO WHILE  ( .not. done )
C
C*	    Set flag to indicate processing will be done.
C
	    proces = .true.
C*	    Read in the input parameters.
C
	    CALL GDBINP ( gdfile, gdatim, glevel, gvcord, gdpfun,
     +			  cint, line, map, mscale, title, device, proj,
     +			  garea, clear, panel, text, imcbar, scale,
     +			  latlon, contur, wind, refvec, skip, fint,
     +			  fline, type, hilo, hlsym, clrbar, stnplt,
     +                    satfil, radfil, lutfil, stream, posn, colors,
     +			  marker, grdlbl, filter, ijskip, boxlin, region,
     +			  txtcol, txtype, txtfil, txtloc, column, shape,
     +			  info, loci, anotln, anotyp, iperr )
C
C*	    Set up the graphics device.
C
	    CALL GG_SDEV  ( device, iret )
	    IF  ( iret .ne. 0 )  proces = .false.
C
	    proces = iret .eq. 0
C
	    IF ( proces )  THEN
C
C*              Set up parameters.
C
		CALL ST_LCUC ( proj, proj, iret )
		CALL GDPSTP (   'PROJ',   proj, iret )
		CALL GDPSTP (  'GAREA',  garea, iret )
		CALL GDPSTP ( 'IJSKIP', ijskip, iret )
		CALL GDPSTP (    'MAP',    map, iret )
		CALL GDPSTP ( 'MSCALE', mscale, iret )
		CALL GDPSTP ( 'LATLON', latlon, iret )
		CALL GDPSTP (   'TEXT',   text, iret )
		CALL GDPSTP ( 'IMCBAR', imcbar, iret )
		CALL GDPSTP ( 'CONTUR', contur, iret )
		CALL GDPSTP (   'WIND',   wind, iret )
		CALL GDPSTP ( 'REFVEC', refvec, iret )
		CALL GDPSTP (   'SKIP',   skip, iret )
		CALL GDPSTP (   'HILO',   hilo, iret )
		CALL GDPSTP (  'HLSYM',  hlsym, iret )
		CALL GDPSTP ( 'CLRBAR', clrbar, iret )
		CALL GDPSTP ( 'STNPLT', stnplt, iret )
		CALL GDPSTP ( 'STREAM', stream, iret )
		CALL GDPSTP (   'POSN',   posn, iret )
		CALL GDPSTP ( 'COLORS', colors, iret )
		CALL GDPSTP ( 'MARKER', marker, iret )
		CALL GDPSTP ( 'GRDLBL', grdlbl, iret )
		CALL GDPSTP ( 'GDFILE', gdfile, iret )
		CALL GDPSTP ( 'GLEVEL', glevel, iret )
		CALL GDPSTP ( 'GVCORD', gvcord, iret )
		CALL GDPSTP ( 'GDPFUN', gdpfun, iret )
		CALL GDPSTP (   'CINT',   cint, iret )
		CALL GDPSTP (   'LINE',   line, iret )
		CALL GDPSTP (  'TITLE',  title, iret )
		CALL GDPSTP (  'PANEL',  panel, iret )
		CALL GDPSTP (  'SCALE',  scale, iret )
		CALL GDPSTP (   'FINT',   fint, iret )
		CALL GDPSTP (  'FLINE',  fline, iret )
		CALL GDPSTP (   'TYPE',   type, iret )
		CALL GDPSTP ( 'LUTFIL', lutfil, iret )
                CALL GDPSTP ( 'FILTER', filter, iret )
                CALL GDPSTP ( 'BOXLIN', boxlin, iret )
                CALL GDPSTP ( 'REGION', region, iret )
                CALL GDPSTP ( 'TXTCOL', txtcol, iret )
                CALL GDPSTP ( 'TXTYPE', txtype, iret )
                CALL GDPSTP ( 'TXTFIL', txtfil, iret )
                CALL GDPSTP ( 'TXTLOC', txtloc, iret )
                CALL GDPSTP ( 'COLUMN', column, iret )
                CALL GDPSTP (  'SHAPE',  shape, iret )
                CALL GDPSTP (   'INFO',   info, iret )
                CALL GDPSTP (   'LOCI',   loci, iret )
                CALL GDPSTP ( 'ANOTLN', anotln, iret )
                CALL GDPSTP ( 'ANOTYP', anotyp, iret )
C
C*	        Get cycle and times based on first bang entry of GDFILE.
C
	        CALL GDPTMS ( gdatim, gdfile, ' ', LLMXGT,
     +			      ntimes, timfnd, iret )
C
		proces = iret .eq. 0
		IF ( .not. proces )
     +		    write(6,*) "Unable to process GDATTIM = ", gdatim
C
	    END IF
C
	    IF ( proces )  THEN
C
		IF ( verbos )  THEN
                    write(6,*)  "Number of times = ", ntimes
                    DO  n = 1, ntimes
                        CALL ST_LSTR ( timfnd(n), ltf, iret )
                        write(6,*)  n, " ", timfnd(n)(:ltf)
                    END DO
                END IF
C
	        gdfilo = gdfilx
C
C*	        Loop through times to set up image files for each time,
C*		i.e., if projection = SAT or RAD, check for multiple
C*		image files.  First set up images file parameters.
C
		CALL GDPSTP ( 'SATFIL', satfil, iret )
		CALL GDPSTP ( 'RADFIL', radfil, iret )
C
		DO  itime = 1, ntimes
C
		    satfnd(itime) = ' '
		    radfnd(itime) = ' '
C
		    DO  n = 1, MAXB
C
                        IF ( pro(n)(1:3) .eq. 'SAT' .or.
     +			     pro(n)(1:3) .eq. 'RAD' ) THEN
C
                            CALL ST_FLST ( sat(n), ';', ' ', MXLOOP,
     +					   satfls, nsatim, iret )
		            CALL ST_LSTR ( satfnd(itime), lensat, iret )
		            CALL ST_LSTR ( satfls(itime), lenfil, iret )
		            satfnd(itime) = satfnd(itime)(1:lensat) //
     +				satfls(itime)(1:lenfil)	// '!'
C
                            CALL ST_FLST ( rad(n), ';', ' ', MXLOOP,
     +					   radfls, nradim, iret )
		            CALL ST_LSTR ( radfnd(itime), lenrad, iret )
		            CALL ST_LSTR ( radfls(itime), lenfil, iret )
		            radfnd(itime) = radfnd(itime)(1:lenrad) //
     +				radfls(itime)(1:lenfil) // '!'
C
			  ELSE
C
		            CALL ST_LSTR ( satfnd(itime), lensat, iret )
		            satfnd(itime) = satfnd(itime)(1:lensat)//'!'
		            CALL ST_LSTR ( radfnd(itime), lenrad, iret )
		            radfnd(itime) = radfnd(itime)(1:lenrad)//'!'
C
                        END IF
C
		    END DO
C
		END DO
C
C*	        Loop through times to call actual plot routines.
C
		DO  itime = 1, ntimes
C
		    IF ( itime .eq. 1 )  THEN
			first = .true.
			CALL GSTANM ( iret )
		      ELSE
			first = .false.
			CALL GSPLOT ( iret )
		    END IF
C
		    ltmp = clear .or. ( first .and. ntimes .gt. 1 )
		    CALL GDPSTT ( 'CLEAR', ltmp, iret )
C
		    ltmp = clear .or. ( first .and. ntimes .gt. 1 )
		    CALL GDPSTT ( 'SHORT_TITLE', ltmp, iret )
C
C*	            Set up time and image files.
C
		    CALL GDPSTP ( 'GDATTIM', timfnd(itime), iret )
		    CALL GDPSTP (  'SATFIL', satfnd(itime), iret )
		    CALL GDPSTP (  'RADFIL', radfnd(itime), iret )
C
C*	            All parameters set up, call main GDPLOT function.
C
		    CALL GDPLTB ( itime, prfxtt, iret )
C
		    CALL GEPLOT ( iret )
C
C*		END DO for times (counter itime)
C
		END DO
C
		CALL GENANM ( iret )
C
	    END IF
C
C*	    Prompt for next contour/wind plot to be done.
C
	    CALL IP_DYNM  ( done, ier )
C
C*	    Print general error messages if necessary.
C
	    IF (iperr .ne. 0)
     +		CALL ER_WMSG ( 'GDPLOT', iperr, ' ', ier )
	    iret  = 0
	    ier  = 0
	    proces = .false.
	END DO
C
C*	Exit from GEMPLT and the TAE.
C
	CALL GENDP  ( 0, iret )
	CALL IP_EXIT  ( iret )
C*
	END


subroutine ensctl2model_ad(eval,mval,grad)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    ensctl2model
!   prgmmr: kleist
!
! abstract:  Contribution from state space to ensemble control vector
!
! program history log:
!   2011-11-17  kleist - initial code
!   2013-10-28  todling - rename p3d to prse
!   Todling: this routine is simply a PLACE HOLDER for now - not working yet
!
!   input argument list:
!     eval - Ensemble state variable variable
!     grad - Control variable
!
!   output argument list:
!     grad - Control variable
!
!$$$ end documentation block

use kinds, only: r_kind,i_kind
use control_vectors, only: control_vector,cvars3d
use gsi_4dvar, only: ibin_anl
use hybrid_ensemble_parameters, only: uv_hyb_ens,dual_res,nval_lenz_en,ntlevs_ens,n_ens,q_hyb_ens
use hybrid_ensemble_isotropic, only: ensemble_forward_model_ad
use hybrid_ensemble_isotropic, only: ckgcov_a_en_new_factorization_ad
use hybrid_ensemble_isotropic, only: ensemble_forward_model_ad_dual_res
use hybrid_ensemble_isotropic, only: sqrt_beta_s_mult,sqrt_beta_e_mult
use balmod, only: strong_bk_ad
use gsi_bundlemod, only: gsi_bundlecreate
use gsi_bundlemod, only: gsi_bundle
use gsi_bundlemod, only: gsi_bundlegetpointer
use gsi_bundlemod, only: gsi_bundlegetvar
use gsi_bundlemod, only: gsi_bundleputvar
use gsi_bundlemod, only: gsi_bundledestroy
use gsi_bundlemod, only: assignment(=)
use gsi_bundlemod, only : self_add
use constants, only: zero,max_varname_length
use mpeu_util, only: getindex
use gsi_metguess_mod, only: gsi_metguess_get
use mod_strong, only: tlnmc_option
use timermod, only: timer_ini,timer_fnl
implicit none

! Declare passed variables
type(control_vector), intent(inout) :: grad
type(gsi_bundle)    , intent(inout) :: mval
type(gsi_bundle)    , intent(in   ) :: eval(ntlevs_ens)

! Declare local variables
character(len=*),parameter::myname='ensctl2state'
character(len=max_varname_length),allocatable,dimension(:) :: clouds
integer(i_kind) :: ii,jj,ic,id,istatus,nclouds,nn

integer(i_kind), parameter :: ncvars = 5
integer(i_kind) :: icps(ncvars)
type(gsi_bundle):: wbundle_c ! work bundle
type(gsi_bundle),allocatable :: ebundle(:)
real(r_kind) :: grade(nval_lenz_en)
character(len=3), parameter :: mycvars(ncvars) = (/  &  ! vars from CV needed here
                               'sf ', 'vp ', 'ps ', 't  ',    &
                               'q  '/)
logical :: lc_sf,lc_vp,lc_ps,lc_t,lc_rh
real(r_kind),pointer,dimension(:,:)   :: cv_ps
real(r_kind),pointer,dimension(:,:,:) :: cv_sf,cv_vp,cv_rh,cv_tv
! Declare required local state variables
integer(i_kind), parameter :: nsvars = 5
integer(i_kind) :: isps(nsvars)
character(len=4), parameter :: mysvars(nsvars) = (/  &  ! vars from ST needed here
                               'u   ', 'v   ', 'prse', 'q   ', 'tsen' /)
logical :: ls_u,ls_v,ls_prse,ls_q,ls_tsen
real(r_kind),pointer,dimension(:,:)   :: rv_ps,rv_sst
real(r_kind),pointer,dimension(:,:,:) :: rv_u,rv_v,rv_prse,rv_q,rv_tsen,rv_tv,rv_oz
real(r_kind),pointer,dimension(:,:,:) :: rv_rank3

logical :: do_getuv,do_tv_to_tsen_ad,do_normal_rh_to_q_ad,do_getprs_ad
logical :: do_tlnmc,lstrong_bk_vars,do_q_copy

!****************************************************************************

! Initialize timer
call timer_ini(trim(myname))

! Inquire about chemistry
call gsi_metguess_get('clouds::3d',nclouds,istatus)
if (nclouds>0) then
    allocate(clouds(nclouds))
    call gsi_metguess_get('clouds::3d',clouds,istatus)
endif

! Since each internal vector of grad has the same structure, pointers are
! the same independent of the subwindow jj
call gsi_bundlegetpointer (grad%step(1),mycvars,icps,istatus)
lc_sf =icps(1)>0; lc_vp =icps(2)>0; lc_ps =icps(3)>0
lc_t  =icps(4)>0; lc_rh =icps(5)>0

! Since each internal vector of grad has the same structure, pointers are
! the same independent of the subwindow jj
call gsi_bundlegetpointer (eval(1),mysvars,isps,istatus)
ls_u  =isps(1)>0; ls_v   =isps(2)>0; ls_prse=isps(3)>0
ls_q  =isps(4)>0; ls_tsen=isps(5)>0

! Define what to do depending on what's in CV and SV
lstrong_bk_vars     =lc_sf.and.lc_vp.and.lc_ps .and.lc_t
do_getuv            =lc_sf.and.lc_vp.and.ls_u  .and.ls_v
do_tv_to_tsen_ad    =lc_t .and.ls_q .and.ls_tsen
do_normal_rh_to_q_ad=lc_t .and.lc_rh.and.ls_prse.and.ls_q.and.(.not.q_hyb_ens)
do_q_copy=.false.
if(.not. do_normal_rh_to_q_ad) then
  do_q_copy = lc_rh.and.lc_t .and.ls_prse.and.ls_q.and.q_hyb_ens
end if
do_getprs_ad        =lc_t .and.lc_ps.and.ls_prse

! Initialize
mval%values=zero

do jj=1,ntlevs_ens

   do_tlnmc = lstrong_bk_vars .and. ( (tlnmc_option==3) .or. &
         (jj==ibin_anl .and. tlnmc_option==2) )

   !allocate(grade(nval_lenz_en))
   allocate(ebundle(n_ens))
   do nn=1,n_ens
      call gsi_bundlecreate (ebundle(nn),grad%aens(1,1),'m2c ensemble work',istatus)
      if(istatus/=0) then
         write(6,*) trim(myname), ': trouble creating work ens-bundle'
         call stop2(999)
      endif
   enddo

!  Create a temporary bundle similar to grad, and copy contents of grad into it
   call gsi_bundlecreate ( wbundle_c, grad%step(1), 'stat2ensctl work', istatus )
   if(istatus/=0) then
      write(6,*) trim(myname), ': trouble creating work bundle'
      call stop2(999)
   endif
   wbundle_c%values=zero

   call gsi_bundlegetpointer (wbundle_c,'sf' ,cv_sf ,istatus)
   call gsi_bundlegetpointer (wbundle_c,'vp' ,cv_vp ,istatus)
   call gsi_bundlegetpointer (wbundle_c,'q'  ,cv_rh ,istatus)
   call gsi_bundlegetpointer (wbundle_c,'t'  ,cv_tv, istatus)
   call gsi_bundlegetpointer (wbundle_c,'ps' ,cv_ps ,istatus)

! Get sv pointers here
!  Get pointers to required state variables
   call gsi_bundlegetpointer (eval(jj),'u'   ,rv_u,   istatus)
   call gsi_bundlegetpointer (eval(jj),'v'   ,rv_v,   istatus)
   call gsi_bundlegetpointer (eval(jj),'ps'  ,rv_ps,  istatus)
   call gsi_bundlegetpointer (eval(jj),'prse',rv_prse,istatus)
   call gsi_bundlegetpointer (eval(jj),'tv'  ,rv_tv,  istatus)
   call gsi_bundlegetpointer (eval(jj),'tsen',rv_tsen,istatus)
   call gsi_bundlegetpointer (eval(jj),'q'   ,rv_q ,  istatus)
   call gsi_bundlegetpointer (eval(jj),'oz'  ,rv_oz , istatus)
   call gsi_bundlegetpointer (eval(jj),'sst' ,rv_sst, istatus)

!  Adjoint of consistency for sensible temperature, calculate sensible temperature
   if(do_tv_to_tsen_ad) call tv_to_tsen_ad(rv_tv,rv_q,rv_tsen)

!  If calling TLNMC, already have u,v (so set last argument to true)
   if(do_tlnmc) then

!     Adjoint to convert ps to 3-d pressure
      if(do_getprs_ad) call getprs_ad(rv_ps,rv_tv,rv_prse)
      rv_prse=zero

!     Adjoint of strong_bk
      call strong_bk_ad(rv_u,rv_v,rv_ps,rv_tv,.true.)
   end if

   call self_add(mval,eval(jj))

!  Adjoint of control to initial state
   call gsi_bundleputvar ( wbundle_c, 't' ,  rv_tv,  istatus )
   call gsi_bundleputvar ( wbundle_c, 'ps',  rv_ps,  istatus )
   call gsi_bundleputvar ( wbundle_c, 'oz',  rv_oz,  istatus )
   call gsi_bundleputvar ( wbundle_c, 'sst', rv_sst, istatus )

!  Since cloud-vars map one-to-one, take care of them together
   do ic=1,nclouds
      id=getindex(cvars3d,clouds(ic))
      if (id>0) then
          call gsi_bundlegetpointer (eval(jj),clouds(ic),rv_rank3,istatus)
          call gsi_bundleputvar     (wbundle_c, clouds(ic),rv_rank3,istatus)
      endif
   enddo

!  Convert RHS calculations for u,v to st/vp
   if (do_getuv) then
      if(uv_hyb_ens) then
         call gsi_bundleputvar ( wbundle_c, 'sf', rv_u, istatus )
         call gsi_bundleputvar ( wbundle_c, 'vp', rv_v, istatus )
      else
         call getuv(rv_u,rv_v,cv_sf,cv_vp,1)
      end if
   end if

   if(do_q_copy) then
      call gsi_bundleputvar (wbundle_c, 'q', rv_q, istatus )
   else

!     Adjoint of convert input normalized RH to q to add contribution of moisture
!     to t, p , and normalized rh
      if(do_normal_rh_to_q_ad) call normal_rh_to_q_ad(cv_rh,cv_tv,rv_prse,rv_q)

!     Adjoint to convert ps to 3-d pressure
      if(do_getprs_ad) call getprs_ad(cv_ps,cv_tv,rv_prse)
   end if

   do nn=1,n_ens
      ebundle(nn)%values=grad%aens(jj,nn)%values
   enddo
   if(dual_res) then
      call ensemble_forward_model_ad_dual_res(wbundle_c,ebundle,jj)
   else
      call ensemble_forward_model_ad(wbundle_c,ebundle,jj)
   end if
   call sqrt_beta_s_mult(wbundle_c)

!  Apply square-root of ensemble error covariance
   call sqrt_beta_e_mult(ebundle)
   call ckgcov_a_en_new_factorization_ad(grade,ebundle)

   call gsi_bundledestroy(wbundle_c,istatus)
   if (istatus/=0) then
      write(6,*) trim(myname),': trouble destroying work bundle'
      call stop2(999)
   endif

   do ii=1,n_ens
      grad%aens(jj,ii)%values=grad%aens(jj,ii)%values + grade
   enddo
!  do ii=1,nval_lenz_en
!     grad%aens(jj,1)%values(ii)=grad%aens(jj,1)%values(ii)+grade(ii)
!  enddo

   do nn=n_ens,1,-1 ! first in; last out
      call gsi_bundledestroy(ebundle(nn),istatus)
      if(istatus/=0) then
         write(6,*) trim(myname), ': trouble destroying work ens bundle', nn, istatus
         call stop2(999)
      endif
   enddo
   deallocate(ebundle)
!  deallocate(grade)

end do

if (nclouds>0) deallocate(clouds)

! Finalize timer
call timer_fnl(trim(myname))

return
end subroutine ensctl2model_ad


!******************************************************************************************
! HYDROLOGICAL MODEL CONTINUUM
! Version 3.1.5
! Date: 2021/06/25
!
!
! 0) COMMAND LINE:
!   TYPE 1 [VERSION < 3.x.x]:
!       ./Continuum.x --> parameter(s): uc=20 uh=1.5 ct=0.5 cf=0.02 domain=marche cpi=0.3 Rf=1 Vmax=500 slopemax=70
!       ./Continuum.x 20 1.5 0.5 0.02 marche 0.3 500 1 70
!   TYPE 1 [VERSION >= 3.x.x]:
!       ./Continuum.x --> parameter(s): uc=20 uh=1.5 ct=0.5 cf=0.02 domain=marche cpi=0.3 Rf=1 Vmax=500 slopemax=70
!                                       cn=60.01 dFrac=0.0 ws=3.6780000000000003e-09 wdl=3.6780000000000003e-09
!       ./Continuum.x 20 1.5 0.5 0.02 marche 0.3 500 1 70 60.01 0.0 3.6780000000000003e-09 3.6780000000000003e-09
!   TYPE 2:
!       ./Continuum.x --> parameter(s): file.info.txt
!       ./Continuum.x marche.info.txt
!
!
! 1) SET NETCDF LIBRARY CONFIGURATION:
!
! /home/fabio/Documents/Work_Area/Code_Development/Library/nc4_fortran-4.4.3_HMC
!
! Add in: Project --> Properties --> Linker --> Libraries --> Add library
!   netcdff.a and netcdff.so (note double f for fortran libraries)
! Add in: Project --> Properties --> Linker --> Additional Options:
!   -I/home/fabio/Documents/Work_Area/Code_Development/Library/nc4_fortran-4.4.3_HMC/include/
!   -L/home/fabio/Documents/Work_Area/Code_Development/Library/nc4_fortran-4.4.3_HMC/lib/
!   -lnetcdff -lnetcdff
! Add in: Project --> Properties --> Fortran Compiler --> Additional Options:
!   -I/home/fabio/Documents/Work_Area/Code_Development/Library/nc4_fortran-4.4.3_HMC/include/
!   -L/home/fabio/Documents/Work_Area/Code_Development/Library/nc4_fortran-4.4.3_HMC/lib/
!   -lnetcdff -lnetcdff
! Add in: Project --> Properties --> Fortran Compiler --> Additional Options:
!   gfortran (version >  7.0): -cpp -DLIB_NC -DDYNARRAY
!   gfortran (version <= 7.0): -cpp -DLIB_NC
!   ifort: -fpp -DLIB_NC
! Add in: Project --> Properties --> Run --> Environment --> NewValue
!   LD_LIBRARY_PATH $LD_LIBRARY_PATH:/home/fabio/Documents/Work_Area/Code_Development/Library/nc4_fortran-4.4.3_HMC/lib/
!
! 2) SET COMMAND LINE OPTION:
! Add in: Project --> Properties --> Debug --> Debug Command
!   TYPE 1:
!       ${OUTPUT_PATH} 20 1.5 0.5 0.02 marche 0.3 500 1 70  # marche
!       ${OUTPUT_PATH} 30 1.7 0.4 0.1 vda 0.15 1000.0 5 30  # vda
!   TYPE 2:
!       ${OUTPUT_PATH} marche.info.txt
!       ${OUTPUT_PATH} vda.info.txt
!
! 3) DEBUG USING GNUPLOT (gnufor2):
! call surf(dble(VAR),pm3d='pm3d implicit map', palette='rgbformulae 31, -11, 32')
! 4) DEBUG USING FORTRAN+MATLAB: [ var*8 = dble(var*4) ]
! call debug_2dVar(dble(a2dVarTa), iRows, iCols, 1) + debug_2dVar.m
!
! NOTE ABOUT FP_MARCHE:
!   1) iCols 643 iY jdim iRows 534 iX idim
!
! NOTE ABOUT FP_TEVERE:
!   1) in HMC_Module_Data_Static_Gridded:867: coefficient equal to 0.0009 (previously 0.0007)
!   2) in HMC_Phys_Convolution_Apps_Horton:1701: change intensity equation
!   3) in HMC_Phys_Convolution_Apps_SurfaceFlow:924: add DeepFlow terms to intensity update
!   4) in HMC_Phys_Convolution_Apps_SurfaceFlow:1031: delete 0.1 in UC equation
!
! NOTE ABOUT FP_ITALY VERSION:
!   1) in HMC_Phys_Convolution_Apps_SurfaceFlow:1031: delete 0.1 in UC equation
!******************************************************************************************

!------------------------------------------------------------------------------------------
! Hydrological Model Continuum main
program HMC_Main

    !------------------------------------------------------------------------------------------
    ! Use and implicit none
    use HMC_Module_Args,                    only:   HMC_Args_Read

    use HMC_Module_Namelist,                only:   oHMC_Namelist, HMC_Namelist_Read

    use HMC_Module_Info_Gridded,            only:   HMC_Info_Gridded_GetDims_Static, &
                                                     HMC_Info_Gridded_GetDims_Forcing, &
                                                     HMC_Info_Gridded_GetGeo_Static, &
                                                     HMC_Info_Gridded_GetGeo_Forcing

    use HMC_Module_Info_Point,              only:   HMC_Info_Point_Section_GetDims, &
                                                     HMC_Info_Point_WaterBody_GetDims, &
                                                     HMC_Info_Point_HydraulicStructure_GetDims

    use HMC_Module_Info_Time

    use HMC_Module_Vars_Loader,             only:   HMC_Type_Vars, oHMC_Vars
    use HMC_Module_Vars_Manager,            only:   HMC_Vars_InitDefault, HMC_Vars_Allocate

    use HMC_Module_Tools_Time,              only:   HMC_Tools_Time_GetNewDate, &
                                                     HMC_Tools_Time_Printer
    use HMC_Module_Tools_Debug

    use HMC_Module_Data_Static_Gridded,     only:   HMC_Data_Static_Gridded_Cpl
    use HMC_Module_Data_Static_Point,       only:   HMC_Data_Static_Point_Cpl
    use HMC_Module_Data_Forcing_Gridded,    only:   HMC_Data_Forcing_Gridded_Cpl
    use HMC_Module_Data_Forcing_Point,      only:   HMC_Data_Forcing_Point_Cpl
    use HMC_Module_Data_Forcing_TimeSeries, only:   HMC_Data_Forcing_TimeSeries_Cpl
    use HMC_Module_Data_Output_Gridded,     only:   HMC_Data_Output_Gridded_Cpl
    use HMC_Module_Data_Output_Point,       only:   HMC_Data_Output_Point_Cpl
    use HMC_Module_Data_Output_TimeSeries,  only:   HMC_Data_Output_TimeSeries_Cpl
    use HMC_Module_Data_State_Gridded,      only:   HMC_Data_State_Gridded_Cpl
    use HMC_Module_Data_State_Point,        only:   HMC_Data_State_Point_Cpl
    use HMC_Module_Data_Restart_Gridded,    only:   HMC_Data_Restart_Gridded_Cpl
    use HMC_Module_Data_Restart_Point,      only:   HMC_Data_Restart_Point_Cpl
    use HMC_Module_Data_Updating_Gridded,   only:   HMC_Data_Updating_Gridded_Cpl

    use HMC_Module_Phys,                    only:   HMC_Phys_Cpl
    use HMC_Module_Tools_Generic,           only:   getProcessID

    implicit none
    !------------------------------------------------------------------------------------------

    !------------------------------------------------------------------------------------------
    ! Variable(s) declaration
    integer(kind = 4)               :: iArgsType
    character(len = 700)            :: sFileInfo

    integer(kind = 4)               :: iID
    integer(kind = 4)               :: iColsL, iRowsL, iColsF, iRowsF, iTime, iT
    integer(kind = 4)               :: iNSection
    integer(kind = 4)               :: iNLake, iNDam, iNPlant, iNJoint, iNCatch, iNRelease
    integer(kind = 4)               :: iDaySteps, iTMarkedSteps
    real(kind = 4)                  :: dUc, dUh, dCt, dCf, dCPI, dWTableHbr, dKSatRatio, dSlopeMax
    real(kind = 4)                  :: dCN, dFrac, dWS, dWDL
    character(len = 256)            :: sDomainName

    integer(kind = 4)               :: iDtModel, iDtPhysConv
    integer(kind = 4)               :: iDtData_Forcing
    integer(kind = 4)               :: iDtData_Updating
    integer(kind = 4)               :: iDtData_Output_Gridded, iDtData_Output_Point
    integer(kind = 4)               :: iDtData_State_Gridded, iDtData_State_Point
    integer(kind = 4)               :: iSimLength, iNTime, iETime, iNData

    character(len = 19)             :: sTimeOld, sTimeForcing, sTimeUpdating, sTimeRestart, sTimeNew
    character(len = 19)             :: sTimeOutput_Gridded, sTimeOutput_Point
    character(len = 19)             :: sTimeState_Gridded, sTimeState_Point
    character(len = 19)             :: sTimeEndLAI, sTimeEndFC
    character(len = 256)            :: sTime, sNTime, sDtModel
    character(len = 256)            :: sPID

    character(len=10)               :: sDateRunStart, sDateRunStep, sDateRunEnd
    character(len=12)               :: sTimeRunStart, sTimeRunStep, sTimeRunEnd
    !------------------------------------------------------------------------------------------

    !------------------------------------------------------------------------------------------
    ! Initialize variable(s)
    sFileInfo = ""; iArgsType = -9999;
    iID = 1
    iColsL = -9999; iRowsL = -9999; iColsF = -9999; iRowsF = -9999; iTime = -9999;
    iDaySteps = 0; iTMarkedSteps = -9999; iSimLength = 0;
    iNTime = -9999; iT = -9999;
    iNSection = -9999; iNLake = -9999; iNDam = -9999;
    iNPlant = -9999; iNJoint = -9999; iNCatch = -9999; iNRelease = -9999;
    dUc = 0.0; dUh = 0.0; dCt = 0.0; dCf = 0.0; dCPI = 0.0;
    dWTableHbr = 0.0; dKSatRatio = 0.0; dSlopeMax = 0.0; sDomainName = "";
    dCN  = 0.0; dFrac = 0.0; dWS = 0.0; dWDL = 0.0;
    sTimeOld = ""; sTimeForcing = ""; sTimeUpdating = ""; sTimeRestart = ""; sTimeNew = "";
    sTimeOutput_Gridded = ""; sTimeOutput_Point = "";
    sTimeState_Gridded = "";  sTimeState_Point = "";
    sTimeEndLAI = ""; sTimeEndFC = "";
    !------------------------------------------------------------------------------------------

    !------------------------------------------------------------------------------------------
    ! Get unique process ID
    sPID = adjustl(getProcessID())
    !------------------------------------------------------------------------------------------

    !------------------------------------------------------------------------------------------
    ! Call time start
    call HMC_Tools_Time_Printer(sDateRunStart, sTimeRunStart)
    !------------------------------------------------------------------------------------------

    !------------------------------------------------------------------------------------------
    ! Read command line argument(s)
    call HMC_Args_Read(dUc, dUh, dCt, dCf, dCPI, dWTableHbr, dKSatRatio, dSlopeMax, &
                       dCN, dFrac, dWS, dWDL, &
                       sDomainName, &
                       sFileInfo, iArgsType)
    !------------------------------------------------------------------------------------------

    !------------------------------------------------------------------------------------------
    ! Read namelist file
    call HMC_Namelist_Read(dUc, dUh, dCt, dCf, dCPI, dWTableHbr, dKSatRatio, dSlopeMax, &
                           dCN, dFrac, dWS, dWDL, &
                           sDomainName, &
                           sFileInfo, iArgsType, &
                           oHMC_Namelist(iID))

    ! Start simulation message
    call mprintf(.true., iINFO_Basic, ' SIMULATION START :: Time: ' //trim(sDateRunStart)//' '//trim(sTimeRunStart) )

    ! Domain name
    sDomainName = oHMC_Namelist(iID)%sDomainName

    ! Time definition(s)
    sTimeOld = oHMC_Namelist(iID)%sTimeStart
    sTimeForcing = oHMC_Namelist(iID)%sTimeStart
    sTimeUpdating = oHMC_Namelist(iID)%sTimeStart
    sTimeOutput_Gridded = oHMC_Namelist(iID)%sTimeStart
    sTimeOutput_Point = oHMC_Namelist(iID)%sTimeStart
    sTimeRestart = oHMC_Namelist(iID)%sTimeRestart

    call HMC_Tools_Time_GetNewDate(sTimeState_Gridded, oHMC_Namelist(iID)%sTimeStart, &
        nint(real(oHMC_Namelist(iID)%iDtData_State_Gridded - real(oHMC_Namelist(iID)%iDtData_Forcing))))

    call HMC_Tools_Time_GetNewDate(sTimeState_Point, oHMC_Namelist(iID)%sTimeStart, &
        nint(real(oHMC_Namelist(iID)%iDtData_State_Gridded - real(oHMC_Namelist(iID)%iDtData_Forcing))))

    ! Model dt(s)
    iDtModel = oHMC_Namelist(iID)%iDtModel
    iDtData_Forcing = oHMC_Namelist(iID)%iDtData_Forcing
    iDtData_Updating = oHMC_Namelist(iID)%iDtData_Updating
    iDtData_Output_Gridded = oHMC_Namelist(iID)%iDtData_Output_Gridded
    iDtData_Output_Point = oHMC_Namelist(iID)%iDtData_Output_Point
    iDtData_State_Gridded = oHMC_Namelist(iID)%iDtData_State_Gridded
    iDtData_State_Point = oHMC_Namelist(iID)%iDtData_State_Point
    iDtPhysConv = oHMC_Namelist(iID)%iDtPhysConv
    iSimLength = oHMC_Namelist(iID)%iSimLength

    ! Simulation step(s)
    iNTime = oHMC_Namelist(iID)%iNTime
    ! Data step(s)
    iNData = oHMC_Namelist(iID)%iNData
    !------------------------------------------------------------------------------------------

    !------------------------------------------------------------------------------------------
    ! Get static data dimension(s)
    call HMC_Info_Gridded_GetDims_Static(iID, iRowsL, iColsL)
    ! Get forcing data dimension(s)
    call HMC_Info_Gridded_GetDims_Forcing(iID, iRowsF, iColsF)

    ! Get section data dimension(s)
    call HMC_Info_Point_Section_GetDims(iID, iNSection)
    ! Get water-body data dimension(s)
    call HMC_Info_Point_WaterBody_GetDims(iID, iNLake)
    ! Get hydraulic structure data dimension(s)
    call HMC_Info_Point_HydraulicStructure_GetDims(iID, iNDam, iNPlant, iNJoint, iNCatch, iNRelease)

    ! Get time dimension(s)
    call HMC_Info_Time_GetDims(iID, iRowsL, iColsL, iETime, iDaySteps, iTMarkedSteps)
    !------------------------------------------------------------------------------------------

    !------------------------------------------------------------------------------------------
    ! Allocate static and dynamic global variable(s)
    call HMC_Vars_Allocate( iID, &
                            iRowsL, iColsL, &
                            iNSection, &
                            iNLake, iNDam, iNPlant, iNJoint, iNCatch, iNRelease, &
                            iDaySteps, iTMarkedSteps, &
                            iNData, iETime )

    ! Initialize static and dynamic global variable(s) using default value(s)
    call HMC_Vars_InitDefault(iID)
    !------------------------------------------------------------------------------------------

    !------------------------------------------------------------------------------------------
    ! Get land data static geographical information
    call HMC_Info_Gridded_GetGeo_Static(iID)
    ! Get land data forcing geographical information
    call HMC_Info_Gridded_GetGeo_Forcing(iID)
    !------------------------------------------------------------------------------------------

    !------------------------------------------------------------------------------------------
    ! Initialize static gridded variable(s)
    call HMC_Data_Static_Gridded_Cpl(iID, iRowsL, iColsL)

    ! Initialize static point variable(s)
    call HMC_Data_Static_Point_Cpl(iID, iRowsL, iColsL, &
                                   iNSection, &
                                   iNLake, &
                                   iNDam, iNPlant, iNJoint, iNCatch, iNRelease)
    !------------------------------------------------------------------------------------------

    !------------------------------------------------------------------------------------------
    ! Initialize restart data
    call HMC_Data_Restart_Gridded_Cpl(iID, sTimeRestart, &
                                      1, iRowsL, 1, iColsL, &
                                      iDaySteps, iTMarkedSteps)
    call HMC_Data_Restart_Point_Cpl(iID, sTimeRestart, &
                                    iNDam, iNLake)
    !------------------------------------------------------------------------------------------

    !------------------------------------------------------------------------------------------
    ! Cycling on time period (and extra time steps)
    TimeLoop : do iTime = 1, iETime

        !------------------------------------------------------------------------------------------
        ! Time step start
        write(sTime, *) iTime; write(sNTime, *) iNTime;  write(sDtModel, *) iDtModel
        call mprintf(.true., iINFO_Basic, ' ===== TIME STEP START :: Date, iT, iNTime, iDt, Clock :: ' &
                                          //sTimeOld//' '//trim(sTime)//' '// &
                                          trim(sNTime)//' '//trim(sDtModel)// ' ===== ')
        ! Clock step start
        call HMC_Tools_Time_Printer(sDateRunStep, sTimeRunStep)
        call mprintf(.true., iINFO_Basic, ' STEP CLOCK START :: Time: ' //trim(sDateRunStep)//' '//trim(sTimeRunStep) )

        ! Update time step
        oHMC_Vars(iID)%iTime = iTime; oHMC_Vars(iID)%sTimeStep = sTimeOld
        !------------------------------------------------------------------------------------------

        !------------------------------------------------------------------------------------------
        ! Forcing data step
        if(sTimeOld == sTimeForcing) then

            ! Get forcing data point
            call HMC_Data_Forcing_Point_Cpl(iID, sTimeOld, &
                                        iNData, iETime,  &
                                        iNLake, iNDam, iNPlant, iNJoint, iNCatch, iNRelease)

            ! Get forcing data time-series
            call HMC_Data_Forcing_TimeSeries_Cpl(iID, sTimeOld, &
                                        iNData, iETime,  &
                                        iNLake, iNDam, iNPlant, iNJoint, iNCatch, iNRelease)

            ! Get forcing gridded data
            call HMC_Data_Forcing_Gridded_Cpl( iID, sTimeForcing, &
                                       1, iRowsL, 1, iColsL, &
                                       1, iRowsF, 1, iColsF)

            ! Update data forcing time
            call HMC_Tools_Time_GetNewDate(sTimeNew, sTimeForcing, nint(real(iDtData_Forcing)))
            sTimeForcing = sTimeNew
        endif
        !------------------------------------------------------------------------------------------

        !------------------------------------------------------------------------------------------
        ! Updating data step
        if(sTimeOld == sTimeUpdating) then

            ! Get updating gridded data
            call HMC_Data_Updating_Gridded_Cpl( iID, sTimeUpdating, &
                                       1, iRowsL, 1, iColsL)

            ! Update data forcing time
            call HMC_Tools_Time_GetNewDate(sTimeNew, sTimeUpdating, nint(real(iDtData_Updating)))
            sTimeUpdating = sTimeNew
        endif
        !------------------------------------------------------------------------------------------

        !------------------------------------------------------------------------------------------
        ! Physics step
        call HMC_Phys_Cpl(iID, &
                          1, iRowsL, 1, iColsL, &
                          iTime, iNTime, iETime, sTimeOld, &
                          iNSection, iNData, &
                          iNLake, iNDam, iNPlant, iNJoint, iNCatch, iNRelease, &
                          iDaySteps, iTMarkedSteps )
        !------------------------------------------------------------------------------------------

        !------------------------------------------------------------------------------------------
        ! Output data step
        ! Save data output gridded
        if( (sTimeOld .eq. sTimeOutput_Gridded) .and. (iDtData_Output_Gridded .gt. 0) ) then

            ! Save output gridded data
            call HMC_Data_Output_Gridded_Cpl( iID, sTimeOutput_Gridded, &
                                              1, iRowsL, 1, iColsL, &
                                              iTime, iDaySteps)

            ! Update data output time
            call HMC_Tools_Time_GetNewDate(sTimeNew, sTimeOutput_Gridded, nint(real(iDtData_Output_Gridded)))
            sTimeOutput_Gridded = sTimeNew
        endif

        ! Save data output point
        if( (sTimeOld .eq. sTimeOutput_Point) .and. (iDtData_Output_Point .gt. 0)) then

            ! Save output point data
            call HMC_Data_Output_Point_Cpl( iID, sTimeOutput_Point, &
                                            1, iRowsL, 1, iColsL, &
                                            iTime, iETime, &
                                            iNSection, iNData, &
                                            iNLake, iNDam, iNPlant, iNJoint, iNCatch, iNRelease)

            ! Update data output time
            call HMC_Tools_Time_GetNewDate(sTimeNew, sTimeOutput_Point, nint(real(iDtData_Output_Point)))
            sTimeOutput_Point = sTimeNew
        endif
        !------------------------------------------------------------------------------------------

        !------------------------------------------------------------------------------------------
        ! State data step
        ! Save data state gridded
        if( (sTimeOld .eq. sTimeState_Gridded) .and. (iDtData_State_Gridded .gt. 0) ) then

            ! Save state gridded data
            call HMC_Data_State_Gridded_Cpl( iID, sTimeState_Gridded, &
                                             1, iRowsL, 1, iColsL, &
                                             iDaySteps, iTMarkedSteps)

            ! Update data state time
            call HMC_Tools_Time_GetNewDate(sTimeNew, sTimeState_Gridded, nint(real(iDtData_State_Gridded)))
            sTimeState_Gridded = sTimeNew

        endif

        ! Save data state point
        if( (sTimeOld .eq. sTimeState_Point) .and. (iDtData_State_Gridded .gt. 0) ) then

            ! Save state point data
            call HMC_Data_State_Point_Cpl( iID, sTimeState_Point, &
                                           iNDam, iNLake)

            ! Update data state time
            call HMC_Tools_Time_GetNewDate(sTimeNew, sTimeState_Point, nint(real(iDtData_State_Point)))
            sTimeState_Point = sTimeNew

        endif
        !------------------------------------------------------------------------------------------

        !------------------------------------------------------------------------------------------
        ! Save data time-series
        call HMC_Data_Output_TimeSeries_Cpl(iID, sTimeOld, &
                                            iTime, iETime, &
                                            iNSection, iNData, &
                                            iNLake, iNDam, iNPlant, iNJoint, iNCatch, iNRelease)
        !------------------------------------------------------------------------------------------

        !------------------------------------------------------------------------------------------
        ! Clock step end
        call HMC_Tools_Time_Printer(sDateRunStep, sTimeRunStep)
        call mprintf(.true., iINFO_Basic, ' STEP CLOCK END :: Time: ' //trim(sDateRunStep)//' '//trim(sTimeRunStep) )

        ! Global time updating
        call mprintf(.true., iINFO_Basic, ' ===== TIME STEP END :: Date, iT, iNTime, iDt :: ' &
                                          //sTimeOld//' '//trim(sTime)//' '// &
                                          trim(sNTime)//' '//trim(sDtModel)// ' ===== ')

        call HMC_Tools_Time_GetNewDate(sTimeNew, sTimeOld, nint(real(iDtModel)))
        sTimeOld = sTimeNew
        !------------------------------------------------------------------------------------------

    enddo TimeLoop
    !------------------------------------------------------------------------------------------

    !------------------------------------------------------------------------------------------
    ! Call time end
    call HMC_Tools_Time_Printer(sDateRunEnd, sTimeRunEnd)
    ! Ending simulation message
    call mprintf(.true., iINFO_Basic, ' SIMULATION END :: Time: ' //trim(sDateRunEnd)//' '//trim(sTimeRunEnd) )
    call mprintf(.true., iINFO_Basic, '************************************************************************')
    !------------------------------------------------------------------------------------------

end program HMC_Main
!-----------------------------------------------------------------------------------


cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PYINRE
C...Calculates full and effective widths of gauge bosons, stores
C...masses and widths, rescales coefficients to be used for
C...resonance production generation.

      SUBROUTINE PYINRE

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYCOMP
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
      include 'inc/pydat1'
      include 'inc/pydat2'
      include 'inc/pydat3'
      include 'inc/pydat4'
      include 'inc/pysubs'
      include 'inc/pypars'
      include 'inc/pyint1'
      include 'inc/pyint2'
      include 'inc/pyint4'
      include 'inc/pyint6'
      include 'inc/pymssm'

C...Local arrays and data.
      CHARACTER PRTMP*9
      DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
     &WDTEM(0:400,0:5),KCORD(500),PMORD(500)

C...Born level couplings in MSSM Higgs doublet sector.
      XW=PARU(102)
C unvar       XWV=XW
      IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
C unvar       XW1=1D0-XW
      IF(MSTP(4).EQ.2) THEN
        TANBE=PARU(141)
        RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
        SQMZ=PMAS(23,1)**2
        SQMW=PMAS(24,1)**2
        SQMH=PMAS(25,1)**2
        SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
        SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
        SQMHC=SQMA+SQMW
        IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
          WRITE(MSTU(11),5000)
          CALL PYSTOP(101)
        ENDIF
        PMAS(35,1)=SQRT(SQMHP)
        PMAS(36,1)=SQRT(SQMA)
        PMAS(37,1)=SQRT(SQMHC)
        ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
     &  (SQMA-SQMZ)))
        BESU=ATAN(TANBE)
        PARU(142)=1D0
        PARU(143)=1D0
        PARU(161)=-SIN(ALSU)/COS(BESU)
        PARU(162)=COS(ALSU)/SIN(BESU)
        PARU(163)=PARU(161)
        PARU(164)=SIN(BESU-ALSU)
        PARU(165)=PARU(164)
        PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
        PARU(171)=COS(ALSU)/COS(BESU)
        PARU(172)=SIN(ALSU)/SIN(BESU)
        PARU(173)=PARU(171)
        PARU(174)=COS(BESU-ALSU)
        PARU(175)=PARU(174)
        PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
     &  SIN(BESU+ALSU)
        PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
        PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
        PARU(181)=TANBE
        PARU(182)=1D0/TANBE
        PARU(183)=PARU(181)
        PARU(184)=0D0
        PARU(185)=PARU(184)
        PARU(186)=COS(BESU-ALSU)
        PARU(187)=SIN(BESU-ALSU)
        PARU(188)=PARU(186)
        PARU(189)=PARU(187)
        PARU(190)=0D0
        PARU(195)=COS(BESU-ALSU)
      ENDIF

C...Reset effective widths of gauge bosons.
      DO 110 I=1,500
        DO 100 J=1,5
          WIDS(I,J)=1D0
  100   CONTINUE
  110 CONTINUE

C...Order resonances by increasing mass (except Z0 and W+/-).
      NRES=0
      DO 140 KC=1,500
        KF=KCHG(KC,4)
        IF(KF.EQ.0) GOTO 140
        IF(MWID(KC).EQ.0) GOTO 140
        IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
          IF(MSTP(1).LE.3) GOTO 140
        ENDIF
        IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
          IF(IMSS(1).LE.0) GOTO 140
        ENDIF
        NRES=NRES+1
        PMRES=PMAS(KC,1)
        IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
        DO 120 I1=NRES-1,1,-1
          IF(PMRES.GE.PMORD(I1)) GOTO 130
          KCORD(I1+1)=KCORD(I1)
          PMORD(I1+1)=PMORD(I1)
  120   CONTINUE
  130   KCORD(I1+1)=KC
        PMORD(I1+1)=PMRES
  140 CONTINUE

C...Loop over possible resonances.
      DO 180 I=1,NRES
        KC=KCORD(I)
        KF=KCHG(KC,4)

C...Check that no fourth generation channels on by mistake.
        IF(MSTP(1).LE.3) THEN
          DO 150 J=1,MDCY(KC,3)
            IDC=J+MDCY(KC,2)-1
            KFA1=ABS(KFDP(IDC,1))
            KFA2=ABS(KFDP(IDC,2))
            IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
     &      KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
     &      MDME(IDC,1)=-1
  150     CONTINUE
        ENDIF

C...Check that no supersymmetric channels on by mistake.
        IF(IMSS(1).LE.0) THEN
          DO 160 J=1,MDCY(KC,3)
            IDC=J+MDCY(KC,2)-1
            KFA1S=ABS(KFDP(IDC,1))/KSUSY1
            KFA2S=ABS(KFDP(IDC,2))/KSUSY1
            IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
     &      MDME(IDC,1)=-1
  160     CONTINUE
        ENDIF

C...Find mass and evaluate width.
        PMR=PMAS(KC,1)
        IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
        IF(MWID(KC).EQ.3) MINT(63)=1
        CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
        MINT(51)=0

C...Evaluate suppression factors due to non-simulated channels.
        IF(KCHG(KC,3).EQ.0) THEN
          WDTP0I=0D0
          IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
          WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
     &    2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
     &    2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
          WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
          WIDS(KC,3)=0D0
          WIDS(KC,4)=0D0
          WIDS(KC,5)=0D0
        ELSE
          IF(MWID(KC).EQ.3) MINT(63)=1
          CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
          MINT(51)=0
          WDTP0I=0D0
          IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
          WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
     &    (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
     &    (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
     &    WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2
          WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
          WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I
          WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
     &    2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
     &    2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
          WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
     &    2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
     &    2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2
        ENDIF

C...Set resonance widths and branching ratios;
C...also on/off switch for decays.
        IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
          PMAS(KC,2)=WDTP(0)
          PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
          IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
          DO 170 J=1,MDCY(KC,3)
            IDC=J+MDCY(KC,2)-1
            BRAT(IDC)=0D0
            IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
  170     CONTINUE
        ENDIF
  180 CONTINUE

C...Flavours of leptoquark: redefine charge and name.
      KFLQQ=KFDP(MDCY(42,2),1)
      KFLQL=KFDP(MDCY(42,2),2)
      KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*SIGN(1,KFLQQ)+
     &KCHG(PYCOMP(KFLQL),1)*SIGN(1,KFLQL)
      LL=1
      IF(ABS(KFLQL).EQ.13) LL=2
      IF(ABS(KFLQL).EQ.15) LL=3
      CHAF(42,1)='LQ_'//CHAF(ABS(KFLQQ),1)(1:1)//
     &CHAF(ABS(KFLQL),1)(1:LL)//' '
      CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '

C...Special cases in treatment of gamma*/Z0: redefine process name.
      IF(MSTP(43).EQ.1) THEN
        PROC(1)='f + fbar -> gamma*'
        PROC(15)='f + fbar -> g + gamma*'
        PROC(19)='f + fbar -> gamma + gamma*'
        PROC(30)='f + g -> f + gamma*'
        PROC(35)='f + gamma -> f + gamma*'
      ELSEIF(MSTP(43).EQ.2) THEN
        PROC(1)='f + fbar -> Z0'
        PROC(15)='f + fbar -> g + Z0'
        PROC(19)='f + fbar -> gamma + Z0'
        PROC(30)='f + g -> f + Z0'
        PROC(35)='f + gamma -> f + Z0'
      ELSEIF(MSTP(43).EQ.3) THEN
        PROC(1)='f + fbar -> gamma*/Z0'
        PROC(15)='f + fbar -> g + gamma*/Z0'
        PROC(19)='f+ fbar -> gamma + gamma*/Z0'
        PROC(30)='f + g -> f + gamma*/Z0'
        PROC(35)='f + gamma -> f + gamma*/Z0'
      ENDIF

C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
      IF(MSTP(44).EQ.1) THEN
        PROC(141)='f + fbar -> gamma*'
      ELSEIF(MSTP(44).EQ.2) THEN
        PROC(141)='f + fbar -> Z0'
      ELSEIF(MSTP(44).EQ.3) THEN
        PROC(141)='f + fbar -> Z''0'
      ELSEIF(MSTP(44).EQ.4) THEN
        PROC(141)='f + fbar -> gamma*/Z0'
      ELSEIF(MSTP(44).EQ.5) THEN
        PROC(141)='f + fbar -> gamma*/Z''0'
      ELSEIF(MSTP(44).EQ.6) THEN
        PROC(141)='f + fbar -> Z0/Z''0'
      ELSEIF(MSTP(44).EQ.7) THEN
        PROC(141)='f + fbar -> gamma*/Z0/Z''0'
      ENDIF

C...Special cases in treatment of WW -> WW: redefine process name.
      IF(MSTP(45).EQ.1) THEN
        PROC(77)='W+ + W+ -> W+ + W+'
      ELSEIF(MSTP(45).EQ.2) THEN
        PROC(77)='W+ + W- -> W+ + W-'
      ELSEIF(MSTP(45).EQ.3) THEN
        PROC(77)='W+/- + W+/- -> W+/- + W+/-'
      ENDIF

C...Initialize Generic Processes
      KFGEN=9900001
      KCGEN=PYCOMP(KFGEN)
      IF(KCGEN.GT.0) THEN
        IDCY=MDCY(KCGEN,2)
        IF(IDCY.GT.0) THEN
          KFF1=KFDP(IDCY+1,1)
          KFF2=KFDP(IDCY+1,2)
          KCF1=PYCOMP(KFF1)
          KCF2=PYCOMP(KFF2)
          IJ1=1
          IJ2=1
          KCI1=PYCOMP(KFDP(IDCY,1))
          IF(KFDP(IDCY,1).LT.0) IJ1=2
          KCI2=PYCOMP(KFDP(IDCY,2))
          IF(KFDP(IDCY,2).LT.0) IJ2=2
          ITMP1=0
 190      ITMP1=ITMP1+1
          IF(CHAF(KCI1,IJ1)(ITMP1+1:ITMP1+1).NE.' '.AND.ITMP1.LT.4)
     &    GOTO 190
          ITMP2=0
 200      ITMP2=ITMP2+1
          IF(CHAF(KCI2,IJ2)(ITMP2+1:ITMP2+1).NE.' '.AND.ITMP2.LT.4)
     &    GOTO 200
          PRTMP=CHAF(KCI1,IJ1)(1:ITMP1)//'+'//CHAF(KCI2,IJ2)(1:ITMP2)
          ITMP3=0
 205      ITMP3=ITMP3+1
          IF(PRTMP(ITMP3+1:ITMP3+1).NE.' '.AND.ITMP3.LT.9)
     &    GOTO 205
          PROC(481)=PRTMP(1:ITMP3)//' -> '//CHAF(KCGEN,1)
          IJ1=1
          IJ2=1
          IF(KFF1.LT.0) IJ1=2
          IF(KFF2.LT.0) IJ2=2
          ITMP1=0
 210      ITMP1=ITMP1+1
          IF(CHAF(KCF1,IJ1)(ITMP1+1:ITMP1+1).NE.' '.AND.ITMP1.LT.8)
     &    GOTO 210
          ITMP2=0
 220      ITMP2=ITMP2+1
          IF(CHAF(KCF2,IJ2)(ITMP2+1:ITMP2+1).NE.' '.AND.ITMP2.LT.8)
     &    GOTO 220
          PROC(482)=PRTMP(1:ITMP3)//' -> '//CHAF(KCF1,IJ1)(1:ITMP1)//
     &    '+'//CHAF(KCF2,IJ2)(1:ITMP2)
        ENDIF
      ENDIF

C...Format for error information.
 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
     &'combination'/1X,'Execution stopped!')

      RETURN
      END