!****************************************************************
!*                                                              *
!*   module MO_SALSA_INIT                                       *
!*                                                              *
!*   Contains subroutines and functions that are used           *
!*   to initialize the particle size grid and aerosol           *
!*   processes                                                  *
!*                                                              *
!****************************************************************
MODULE mo_salsa_init

  IMPLICIT NONE

CONTAINS

  ! fxm: when dpmid is used for calculating coagulation coefficients
  ! (only?), would it make more sense to use approximate wet radii
  ! e.g. for sea salt particles?
  !********************************************************************
  !
  ! subroutine SET_SIZEBINS()
  !
  !********************************************************************
  !
  ! Purpose:
  ! --------
  ! Initializes particle size distribution grid by
  ! calculating size bin limits and mid-size for
  ! *dry* particles in each bin
  !
  !
  ! Method:
  ! -------
  ! Size distribution described using
  !   1) moving center method (regimes 1 and 2)
  !   (Jacobson, Atmos. Env., 31, 131-144, 1997)
  !   2) fixed sectional method (regime 3)
  !
  ! Size bins in each regime are spaced logarithmically
  ! based on given regime size limits and bin number.
  !
  !
  ! Interface:
  ! ----------
  ! Called from model driver
  ! (only at the beginning of simulation)
  !
  !
  ! Coded by:
  ! ---------
  ! Hannele Korhonen (FMI) 2005
  ! Harri Kokkola (FMI) 2006
  !
  ! Bug fixes for box model + updated for the new aerosol datatype:
  ! ----------
  ! Juha Tonttila (FMI) 2014
  !
  !---------------------------------------------------------------------

  SUBROUTINE set_sizebins()

    USE mo_submctl, ONLY : &
         pi6,         & ! pi/6
         reglim,      & ! diameter limits for size regimes [m]
         nbin,        & ! number of size bins in each (sub)regime
         in1a, fn1a,  & ! size regime bin indices: 1a
         in2a, fn2a,  & !     - " -       2a
         in2b, fn2b,  & !     - " -       2b
         nbin2, nbin3,& !
         nbins,  &
         aerobins

    USE mo_salsa_driver, ONLY : &
         kbdim,klev,  &
         aero

    IMPLICIT NONE

    !-- local variables ----------
    INTEGER :: ii, jj,cc,dd,vv ! loop indices

    REAL ::  ratio ! ratio of regime upper and lower diameter

    ! -------------------------
    ! Allocate aerosol tracers
    !--------------------------
    ALLOCATE(aero(kbdim,klev,nbins))

    ! Juha: Corrected some bugs with the section volume definitions
    !-------------------------------------------------------------------------------

    DO jj = 1,klev
       DO ii = 1,kbdim

          !-- 1) size regime 1: --------------------------------------
          !  - minimum & maximum *dry* volumes [fxm]
          !  - bin mid *dry* diameter [m]
          ratio = reglim(2)/reglim(1)   ! section spacing

          DO cc = in1a,fn1a
             aero(ii,jj,cc)%vlolim = pi6*(reglim(1)*ratio**(real(cc-1)/nbin(1)))**3
             aero(ii,jj,cc)%vhilim = pi6*(reglim(1)*ratio**(real(cc)/nbin(1)))**3
             aero(ii,jj,cc)%dmid = ( (aero(ii,jj,cc)%vhilim + aero(ii,jj,cc)%vlolim) /  &
                                     (2.*pi6) )**(1./3.)
             aero(ii,jj,cc)%vratiohi = aero(ii,jj,cc)%vhilim/(pi6*aero(ii,jj,cc)%dmid**3)
             aero(ii,jj,cc)%vratiolo = aero(ii,jj,cc)%vlolim/(pi6*aero(ii,jj,cc)%dmid**3)
          END DO

          !-- 2) size regime 2: --------------------------------------
          !  - minimum & maximum *dry* volumes [fxm]
          !  - bin mid *dry* diameter [m]

          !-- 2.1) first for subregime 2a
          ratio = reglim(3)/reglim(2)   ! section spacing

          DO dd = in2a,in2a+nbin2-1
             cc = dd - in2a
             aero(ii,jj,dd)%vlolim = pi6*(reglim(2)*ratio**(real(cc)/nbin2))**3
             aero(ii,jj,dd)%vhilim = pi6*(reglim(2)*ratio**(real(cc+1)/nbin2))**3
             aero(ii,jj,dd)%dmid = ( (aero(ii,jj,dd)%vhilim + aero(ii,jj,dd)%vlolim) /  &
                                     (2.*pi6) )**(1./3.)
             aero(ii,jj,dd)%vratiohi = aero(ii,jj,dd)%vhilim/(pi6*aero(ii,jj,dd)%dmid**3)
             aero(ii,jj,dd)%vratiolo = aero(ii,jj,dd)%vlolim/(pi6*aero(ii,jj,dd)%dmid**3)
          END DO

          !-- 3) size regime 3: --------------------------------------
          !  - bin mid *dry* diameter [m]
          ratio = reglim(4)/reglim(3)   ! section spacing

          DO dd = in2a+nbin2,fn2a
             cc = dd - (fn2a-(nbin3-1))

             aero(ii,jj,dd)%vlolim = pi6*(reglim(3)*ratio**(real(cc)/nbin3))**3
             aero(ii,jj,dd)%vhilim = pi6*(reglim(3)*ratio**(real(cc+1)/nbin3))**3
             aero(ii,jj,dd)%dmid = ( (aero(ii,jj,dd)%vhilim + aero(ii,jj,dd)%vlolim) /  &
                                     (2.*pi6) )**(1./3.)
             aero(ii,jj,dd)%vratiohi = aero(ii,jj,dd)%vhilim/(pi6*aero(ii,jj,dd)%dmid**3)
             aero(ii,jj,dd)%vratiolo = aero(ii,jj,dd)%vlolim/(pi6*aero(ii,jj,dd)%dmid**3)
          END DO

          !-- 2.2) same values for subregime 2b
          aero(ii,jj,in2b:fn2b)%vlolim = aero(ii,jj,in2a:fn2a)%vlolim
          aero(ii,jj,in2b:fn2b)%vhilim = aero(ii,jj,in2a:fn2a)%vhilim
          aero(ii,jj,in2b:fn2b)%dmid = aero(ii,jj,in2a:fn2a)%dmid
          aero(ii,jj,in2b:fn2b)%vratiohi = aero(ii,jj,in2a:fn2a)%vratiohi
          aero(ii,jj,in2b:fn2b)%vratiolo = aero(ii,jj,in2a:fn2a)%vratiolo

          ! Initialize the wet diameter with the bin dry diameter to avoid numerical proplems later
          aero(ii,jj,:)%dwet = aero(ii,jj,:)%dmid

          ! Set volume and number concentrations to zero
          aero(ii,jj,:)%numc = 0.
          aero(ii,jj,:)%core = 0.
          DO vv=1,8
             aero(ii,jj,:)%volc(vv) = 0.
          END DO

       END DO !ii
    END DO !!jj

    ! Save bin limits to be delivered e.g. to host model if needed
    ALLOCATE(aerobins(nbins))
    DO cc = 1,nbins
       aerobins(cc) = (aero(1,1,cc)%vlolim/pi6)**(1./3.)
    END DO
    aerobins = 0.5*aerobins ! to radius

  END SUBROUTINE set_sizebins

  !--------------------------------------------------------------------------
  !
  ! *******************************
  ! SUBROUTINE set_cloudbins
  ! *******************************
  !
  ! Setup of hydrometeor size bins similar to the subroutine *set_sizebins*
  !
  ! Juha Tonttila (FMI) 2014
  !
  !---------------------------------------------------------------------------

  SUBROUTINE set_cloudbins()
    USE mo_submctl, ONLY : pi6,             &
                               ica,icb,         &
                               fca,fcb,         &
                               ira,fra,         &
                               ncld,nprc,        &
                               ncldbin,         &
                               dmincld,         &
                               in1a,fn2a,       &
                               in2b,fn2b,       &
                               cloudbins,       &
                               precpbins
    USE mo_salsa_driver, ONLY : kbdim, klev, &
                                 cloud,precp,aero

    IMPLICIT NONE

    INTEGER :: ii,jj,cc,bb

    ! For cloud bins
    REAL :: zvoldiff(fn2a)
    INTEGER :: zindex(fn2a)
    INTEGER :: imin, nba,nbb
    INTEGER :: armin(1)
    LOGICAL :: l_min(fn2a)

    REAL :: tmplolim(7), tmphilim(7)

    ! Helper arrays to set up precipitation size bins
    tmplolim = (/50.,55.,65.,100.,200.,500.,1000./)*1.e-6
    tmphilim = (/55.,65.,100.,200.,500.,1000.,2000./)*1.e-6

    ! For setting cloud droplet bins
    DO ii = in1a,fn2a
       zindex(ii) = ii
    END DO

    ! Determine the smallest full aerosol bin with which the smallest cloud droplet bin will coincide
    zvoldiff(in1a:fn2a) = ABS(aero(1,1,in1a:fn2a)%vlolim - pi6*dmincld**3)
    l_min = ( zvoldiff(in1a:fn2a) == MINVAL(zvoldiff(in1a:fn2a)) )
    IF (COUNT(l_min) /= 1) STOP 'Initialization error! Try changing the cloud droplet bin lower bound slightly'
    armin = PACK(zindex,l_min)
    imin = armin(1)
    IF (aero(1,1,imin)%vlolim < pi6*dmincld**3) imin=imin+1
    IF (imin < in1a .OR. imin > fn2a) STOP 'Invalid first cloud bin'

    ! Number of cloud bins in regime a (soluble nuclei)
    nba = fn2a-imin+1
    ! Number of cloud bins in regime b (insoluble nuclei)
    IF (aero(1,1,imin)%dmid > aero(1,1,in2b)%dmid) THEN
       ! All cloud bins are within regime 2
       nbb = nba
    ELSE
       ! The smallest regime a cloud bins go to regime 1
       nbb = fn2b-fn2a
    END IF

    ncldbin(1) = nba
    ncldbin(2) = nbb

    ! Reset cloud bin indices accordingly. The two components give the cloud regime index,
    ! and the aerosol bin index with which they are parallel
    ica%cur = 1;                      ica%par = imin
    fca%cur = ica%cur + ncldbin(1)-1; fca%par = ica%par + ncldbin(1)-1
    icb%cur = fca%cur + 1;            icb%par = fn2b - ncldbin(2) + 1
    fcb%cur = icb%cur + ncldbin(2)-1; fcb%par = icb%par + ncldbin(2)-1

    ncld = fcb%cur

    ! Rain/drizzle bins
    ira = 1; fra = 7;
    nprc = fra

    ! ----------------------------------------
    ! Allocate cloud and precipitation arrays
    ! ----------------------------------------
    ALLOCATE(cloud(kbdim,klev,ncld), precp(kbdim,klev,nprc))

    DO jj = 1,klev
       DO ii = 1,kbdim

          ! -------------------------------------------------
          ! Set cloud properties (parallel to aerosol bins)
          ! -------------------------------------------------
          cloud(ii,jj,ica%cur:fca%cur)%vhilim = aero(ii,jj,ica%par:fca%par)%vhilim
          cloud(ii,jj,icb%cur:fcb%cur)%vhilim = aero(ii,jj,icb%par:fcb%par)%vhilim

          cloud(ii,jj,ica%cur:fca%cur)%vlolim = aero(ii,jj,ica%par:fca%par)%vlolim
          cloud(ii,jj,icb%cur:fcb%cur)%vlolim = aero(ii,jj,icb%par:fcb%par)%vlolim

          cloud(ii,jj,ica%cur:fca%cur)%vratiohi = aero(ii,jj,ica%par:fca%par)%vratiohi
          cloud(ii,jj,icb%cur:fcb%cur)%vratiohi = aero(ii,jj,icb%par:fcb%par)%vratiohi

          cloud(ii,jj,ica%cur:fca%cur)%vratiolo = aero(ii,jj,ica%par:fca%par)%vratiolo
          cloud(ii,jj,icb%cur:fcb%cur)%vratiolo = aero(ii,jj,icb%par:fcb%par)%vratiolo

          cloud(ii,jj,ica%cur:fca%cur)%dmid = aero(ii,jj,ica%par:fca%par)%dmid
          cloud(ii,jj,icb%cur:fcb%cur)%dmid = aero(ii,jj,icb%par:fcb%par)%dmid

          ! Initialize the droplet diameter ("wet diameter") as the dry
          ! mid diameter of the nucleus to avoid problems later.
          cloud(ii,jj,ica%cur:fcb%cur)%dwet = cloud(ii,jj,ica%cur:fcb%cur)%dmid

          ! Initialize the volume and number concentrations for clouds.
          ! First "real" values are only obtained upon the first calculation
          ! of the cloud droplet activation.
          DO cc = 1,8
             cloud(ii,jj,ica%cur:fcb%cur)%volc(cc) = 0.
          END DO
          cloud(ii,jj,ica%cur:fcb%cur)%numc = 0.
          cloud(ii,jj,ica%cur:fcb%cur)%core = 0.
          cloud(ii,jj,ica%cur:fcb%cur)%veqh2o = 0.

          ! ---------------------------------------------------------------------------------------
          ! Set the precipitation properties; unlike aerosol and cloud bins, the size distribution
          ! goes according to the *wet* radius
          ! ---------------------------------------------------------------------------------------
          DO bb = ira,fra
             precp(ii,jj,bb)%vhilim = pi6*tmphilim(bb)**3
             precp(ii,jj,bb)%vlolim = pi6*tmplolim(bb)**3
             precp(ii,jj,bb)%dmid = ( (precp(ii,jj,bb)%vlolim + precp(ii,jj,bb)%vhilim) /  &
                                      (2.*pi6) )**(1./3.)
             precp(ii,jj,bb)%vratiohi = precp(ii,jj,bb)%vhilim / ( pi6*precp(ii,jj,bb)%dmid**3 )
             precp(ii,jj,bb)%vratiolo = precp(ii,jj,bb)%vlolim / ( pi6*precp(ii,jj,bb)%dmid**3 )

             ! Initialize the wet diameter as the bin mid diameter
             precp(ii,jj,bb)%dwet = precp(ii,jj,bb)%dmid

             DO cc = 1,8
                precp(ii,jj,bb)%volc(cc) = 0.
             END DO
             precp(ii,jj,bb)%numc = 0.
             precp(ii,jj,bb)%core = 0.
             precp(ii,jj,bb)%veqh2o = 0.

          END DO

       END DO
    END DO

    ! Save bin limits to be delivered e.g. to host model if needed
    ALLOCATE(cloudbins(ncld))
    DO bb = 1,ncld
       cloudbins(bb) = (cloud(1,1,bb)%vlolim/pi6)**(1./3.)
    END DO
    cloudbins = 0.5*cloudbins ! To radius
    ALLOCATE(precpbins(nprc))
    DO bb = 1,nprc
       precpbins(bb) = (precp(1,1,bb)%vlolim/pi6)**(1./3.)
    END DO
    precpbins = 0.5*precpbins ! To radius

  END SUBROUTINE set_cloudbins

  !--------------------------------------------------------------------------
  !
  ! *******************************
  ! SUBROUTINE set_icebins
  ! *******************************
  !
  ! Setup of ice size bins similar to the subroutines *set_sizebins* & *set_cloudbins*
  !
  ! Jaakko Ahola (FMI) 2015
  !
  !---------------------------------------------------------------------------
  SUBROUTINE set_icebins()
    USE mo_submctl, ONLY : pi6,             &
                               iia,iib,         &
                               fia,fib,         &
                               isa,fsa,         &
                               nice,nsnw,        &
                               nicebin,         &
                               dminice,         &
                               in1a,fn2a,       &
                               in2b,fn2b,       &
                               icebins,         &
                               snowbins
    USE mo_salsa_driver, ONLY : kbdim, klev, &
                                 ice,snow,aero

    IMPLICIT NONE

    INTEGER :: ii,jj,cc,bb

    ! For ice bins
    REAL :: zvoldiff(fn2a)
    INTEGER :: zindex(fn2a)
    INTEGER :: imin, nba,nbb
    INTEGER :: armin(1)
    LOGICAL :: l_min(fn2a)

    REAL :: tmplolim(7), tmphilim(7)

    ! Helper arrays to set up snow size bins
    tmplolim = (/50.,55.,65., 100.,200.,500., 1000./)*1.e-6
    tmphilim = (/55.,65.,100.,200.,500.,1000.,2000./)*1.e-6

    ! For setting ice particle bins
    DO ii = in1a,fn2a
       zindex(ii) = ii
    END DO

    ! Determine the smallest full aerosol bin with which the smallest ice particle bin will coincide
    zvoldiff(in1a:fn2a) = ABS(aero(1,1,in1a:fn2a)%vlolim - pi6*dminice**3)
    l_min = ( zvoldiff(in1a:fn2a) == MINVAL(zvoldiff(in1a:fn2a)) )
    IF (COUNT(l_min) /= 1) STOP 'Initialization error! Try changing the ice particle bin lower bound slightly'
    armin = PACK(zindex,l_min)
    imin = armin(1)
    IF (aero(1,1,imin)%vlolim < pi6*dminice**3) imin=imin+1
    IF (imin < in1a .OR. imin > fn2a) STOP 'Invalid first ice bin'

    ! Number of ice bins in regime a (soluble nuclei)
    nba = fn2a-imin+1
    ! Number of cloud bins in regime b (insoluble nuclei) !!huomhuom insoluble
    IF (aero(1,1,imin)%dmid > aero(1,1,in2b)%dmid) THEN
       ! All cloud bins are within regime 2
       nbb = nba
    ELSE
       ! The smallest regime a cloud bins go to regime 1
       nbb = fn2b-fn2a
    END IF

    nicebin(1) = nba
    nicebin(2) = nbb

    ! Reset ice bin indices accordingly. The two components give the cloud regime index,
    ! and the aerosol bin index with which they are parallel
    iia%cur = 1;                       iia%par = imin
    fia%cur = iia%cur + nicebin(1)-1;  fia%par = iia%par + nicebin(1)-1
    iib%cur = fia%cur + 1;             iib%par = fn2b - nicebin(2) + 1
    fib%cur = iib%cur + nicebin(2)-1;  fib%par = iib%par + nicebin(2)-1

    nice = fib%cur

    ! snow bins
    isa = 1; fsa = 7;
    nsnw = fsa

    ! ----------------------------------------
    ! Allocate ice arrays
    ! ----------------------------------------
    ALLOCATE(ice(kbdim,klev,nice), snow(kbdim,klev,nsnw))

    DO jj = 1,klev
       DO ii = 1,kbdim

          ! -------------------------------------------------
          ! Set iceproperties (parallel to aerosol bins) !!!huomhuom tehdäänkö jäälle myös näin?
          ! -------------------------------------------------
          ice(ii,jj,iia%cur:fia%cur)%vhilim = aero(ii,jj,iia%par:fia%par)%vhilim

          ice(ii,jj,iib%cur:fib%cur)%vhilim = aero(ii,jj,iib%par:fib%par)%vhilim

          ice(ii,jj,iia%cur:fia%cur)%vlolim = aero(ii,jj,iia%par:fia%par)%vlolim
          ice(ii,jj,iib%cur:fib%cur)%vlolim = aero(ii,jj,iib%par:fib%par)%vlolim

          ice(ii,jj,iia%cur:fia%cur)%vratiohi = aero(ii,jj,iia%par:fia%par)%vratiohi
          ice(ii,jj,iib%cur:fib%cur)%vratiohi = aero(ii,jj,iib%par:fib%par)%vratiohi

          ice(ii,jj,iia%cur:fia%cur)%vratiolo = aero(ii,jj,iia%par:fia%par)%vratiolo
          ice(ii,jj,iib%cur:fib%cur)%vratiolo = aero(ii,jj,iib%par:fib%par)%vratiolo

          ice(ii,jj,iia%cur:fia%cur)%dmid = aero(ii,jj,iia%par:fia%par)%dmid
          ice(ii,jj,iib%cur:fib%cur)%dmid = aero(ii,jj,iib%par:fib%par)%dmid

          ! Initialize the droplet diameter ("wet diameter") as the dry
          ! mid diameter of the nucleus to avoid problems later. !!huomhuom mitä tehdään jäälle
          ice(ii,jj,iia%cur:fib%cur)%dwet = ice(ii,jj,iia%cur:fib%cur)%dmid

          ! Initialize the volume and number concentrations for ice.
          ! First "real" values are only obtained upon the first calculation
          ! of the cloud droplet activation. !! huomhuom

          DO cc = 1,8
             ice(ii,jj,iia%cur:fib%cur)%volc(cc) = 0.
          END DO
          ice(ii,jj,iia%cur:fib%cur)%numc = 0.
          ice(ii,jj,iia%cur:fib%cur)%core = 0.
          ice(ii,jj,iia%cur:fib%cur)%veqh2o = 0.

          ! ---------------------------------------------------------------------------------------
          ! Set the snow properties; unlike aerosol and cloud bins, the size distribution
          ! goes according to the *wet* radius !!huomhuom minkä säteen mukaan menee?
          ! ---------------------------------------------------------------------------------------

          DO bb = isa,fsa

             snow(ii,jj,bb)%vhilim = pi6*tmphilim(bb)**3
             snow(ii,jj,bb)%vlolim = pi6*tmplolim(bb)**3
             snow(ii,jj,bb)%dmid = ( (snow(ii,jj,bb)%vlolim + snow(ii,jj,bb)%vhilim) /  &
                                      (2.*pi6) )**(1./3.)
             snow(ii,jj,bb)%vratiohi = snow(ii,jj,bb)%vhilim / ( pi6*snow(ii,jj,bb)%dmid**3 )
             snow(ii,jj,bb)%vratiolo = snow(ii,jj,bb)%vlolim / ( pi6*snow(ii,jj,bb)%dmid**3 )

             ! Initialize the wet diameter as the bin mid diameter
             snow(ii,jj,bb)%dwet = snow(ii,jj,bb)%dmid

             DO cc = 1,8
                snow(ii,jj,bb)%volc(cc) = 0.
             END DO
             snow(ii,jj,bb)%numc = 0.
             snow(ii,jj,bb)%core = 0.
             snow(ii,jj,bb)%veqh2o = 0.

          END DO

       END DO
    END DO

    ! Save bin limits to be delivered e.g. to host model if needed
    ALLOCATE(icebins(nice))
    DO bb = 1,nice
       icebins(bb) = (ice(1,1,bb)%vlolim/pi6)**(1./3.)
    END DO
    icebins = 0.5*icebins ! To radius
    ALLOCATE(snowbins(nsnw))
    DO bb = 1,nsnw
       snowbins(bb) = (snow(1,1,bb)%vlolim/pi6)**(1./3.)
    END DO
    snowbins = 0.5*snowbins ! To radius

  END SUBROUTINE set_icebins

  !----------------------------------------------------------------------
  !
  ! *************************
  ! SUBROUTINE define_salsa
  ! *************************
  !
  ! Reads logical switches and aerosol/hydrometeor size bin definitions
  ! from a namelist.
  !
  ! Juha Tonttila (FMI) 2014
  !
  !----------------------------------------------------------------------
  SUBROUTINE define_salsa()

    USE mo_submctl, ONLY : nlcoag,                &
                               nlcgaa,nlcgcc,nlcgpp,  &
                               nlcgca,nlcgpa,nlcgpc,  &
                               nlcgia,nlcgic,nlcgii,  &
                               nlcgip,nlcgsa,nlcgsc,  &
                               nlcgsi,nlcgsp,nlcgss,  &
                               nlcnd,                 &
                               nlcndgas,              &
                               nlcndh2oae,nlcndh2ocl, &
                               nlcndh2oic,            &
                               nlauto,nlautosnow,     &
                               nlactiv,               &
                               nlactintst,            &
                               nlactbase,            &
                               nlichom,               &
                               nlichet,               &
                               nlicimmers,            &
                               nlicmelt,              &
                               dmincld,nbin,reglim,   &
                               nice,nsnw,             &
                               nspec,listspec,        &
                               volDistA, volDistB,    &
                               initliqice,            &
                               liqFracA, iceFracA,    &
                               liqFracB, iceFracB,    &
                               nf2a, isdtyp,          &
                               sigmag,dpg,n,nldebug,  &
                               rhlim

    IMPLICIT NONE

    NAMELIST /salsa/  &
         nldebug,     & ! switch for debug printing
         nlcoag,      & ! Coagulation master switch
         nlcgaa,      & ! Coagulation between aerosols
         nlcgcc,      & ! Collision-coalescence between cloud droplets
         nlcgpp,      & ! Collisions between rain drops
         nlcgca,      & ! Cloud collection of aerosols
         nlcgpa,      & ! Collection of aerosols by precip
         nlcgpc,      & ! Collection of cloud droplets by rain
         nlcgia,      & ! Ice collection of aerosols
         nlcgic,      & ! Collection of cloud droplets by ice particles
         nlcgii,      & ! Collision-coalescence between ice particles
         nlcgip,      & ! Collection of precipitation by ice particles
         nlcgsa,      & ! Collection of aerosols by snow
         nlcgsc,      & ! Collection of cloud droplets by snow
         nlcgsi,      & ! Collection of ice by snow
         nlcgsp,      & ! Collection of precipitation by snow
         nlcgss,      & ! Collision-coalescence between snow particles
         nlcnd,       & ! Switch for condensation subroutine
         nlcndgas,    & ! Condensation of precursor gases
         nlichom,     & ! Switch for homogeneous ice nucleation
         nlichet,     & ! Switch for heterogeneous ice nucleation
         nlicimmers,  & ! Switch for ice nucleation by immersion
         nlicmelt,    & ! Switch for ice'n'snow melting
         nbin,        & ! Number of bins used for each of the aerosol size regimes (1d table with length 2)
         nice,        & ! number of ice bins
         nsnw,        & ! number of snow bins
         nlcndh2ocl,    & ! Condensation of water vapour on clouds (drizzle)
         nlcndh2oic,    & ! Condensation of water vapour on ice particles ! ice'n'snow
         nlcndh2oae,    & ! Condensation of water vapour on aerosols (FALSE -> equilibrium calc.)
         nlauto,        & ! Switch for autoconversion of cloud droplets to drizzle and rain
         nlautosnow,    & ! Switch for autoconversion of ice particles to snowing
         nlactiv,       & ! Master switch for cloud droplet activation
         nlactbase,     & ! Switch for parameterized cloud base activation
         nlactintst,    & ! Switch for interstitial activation based on particle growth and host model S
         isdtyp,        & ! Type of initial size distribution: 0 - uniform; 1 - vertical profile, read from file
         reglim,        & ! Low/high diameter limits of the 2 aerosol size regimes (1d table with length 4)
         nbin,          & ! Number of bins used for each of the aerosol size regimes (1d table with length 2)
         dmincld,       & ! Minimum hydrometeor bin diameter: the lower limit of the smallest hydrometeor bin
                          ! is set at or above. For now this is also the only way to control the number of
                          ! hydrometeor bins as they are assumed fully parallel with the aerosol bins.
                          ! Implementing different bin limits for hydromets than aerosols would require
                          ! somewhat extensive modification of the microphysical SALSA dynamics calculations
         nspec,         & ! Number of aerosol species used in the model
         listspec,      & ! List of strings specifying the names of the aerosol species that are active.
                          ! Must be an array of length 7, with empty strings for unused stuff.
         volDistA,      & ! Initial relative contribution [0-1] of each species to particle volume in a-bins. Must be
                          ! an array of length 7, with zero for unused species.
         volDistB,      & ! Same as above but for b-bins
         nf2a,          & ! Number fraction of particles allocated to a-bins in regime 2. b-bins will get 1-nf2a

         ! ------------
         ! -- Juha: These should eventually be replaced with physical processing !!!! Dont use for liquid clouds!
         initliqice,  & ! initialize ice and liquid cloud particles from aerosol bins
         liqFracA,      & ! fraction of aerosols that are activated to liquid cloud droplets in A bins
         iceFracA,      & ! fraction of aerosols that are activated to ice cloud particles in A bins
         liqFracB,      & ! fraction of aerosols that are activated to liquid cloud droplets  in B bins
         iceFracB,      & ! fraction of aerosols that are activated to    ice cloud particles in B bins
         ! ---------------------------------------------------------------------------------------------------
         rhlim,         & ! Upper limit RH/100 for sals during initialization and spinup

         sigmag,        & ! Stdev for the 7 initial lognormal modes
         dpg,           & ! Mean diameter for the 7 initial lognormal modes
         n                ! Number concentration for the 7 initial lognormal modes

    OPEN(11,STATUS='old',FILE='NAMELIST')
    READ(11,NML=salsa)
    CLOSE(11)

  END SUBROUTINE define_salsa

  !-------------------------------------------------------------------------------
  !
  ! *****************************
  ! SUBROUTINE salsa_initialize
  ! *****************************
  !
  ! SALSA initializations. Modified and rewritten for more dynamic control
  ! and LES implementation.
  !
  ! Juha Tonttila (FMI) 2014
  !
  !-------------------------------------------------------------------------------
  SUBROUTINE salsa_initialize()

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

    USE mo_submctl, ONLY : nbin, nbin2, nbin3,     &
                               in1a,fn1a,in2a,fn2a,in2b,fn2b,  &
                               nbins, &
                               massacc

    IMPLICIT NONE

    ! Remember to call 'define_salsa' for namelist paramers before calling this subroutine!

    ! --1) Set derived indices
    nbin2 = 4
    nbin3 = nbin(2) - nbin2

    in1a = 1
    in2a = in1a + nbin(1)
    in2b = in2a + nbin(2)

    fn1a = in2a - 1
    fn2a = fn1a + nbin(2)
    fn2b = fn2a + nbin(2)

    nbins = fn2b

    ! --2) Allocate arrays

    ALLOCATE(massacc(nbins))

    massacc = 1.

    ! -- Aerosol tracers are allocated in *set_sizebins*
    ! -- Hydrometeor tracer in *set_cloudbins*

    ! --3) Call other initialization routines
    CALL set_sizebins()

    CALL set_cloudbins()

    CALL set_icebins()

  END SUBROUTINE salsa_initialize

END MODULE mo_salsa_init


!==========================================================================
elemental subroutine gsw_enthalpy_second_derivatives (sa, ct, p, h_sa_sa, &
                                                      h_sa_ct, h_ct_ct)
! =========================================================================
!
!  Calculates the following three second-order derivatives of specific
!  enthalpy (h),using the computationally-efficient expression for
!  specific volume in terms of SA, CT and p (Roquet et al., 2014).
!   (1) h_SA_SA, second-order derivative with respect to Absolute Salinity
!       at constant CT & p.
!   (2) h_SA_CT, second-order derivative with respect to SA & CT at
!       constant p.
!   (3) h_CT_CT, second-order derivative with respect to CT at constant SA
!       and p.
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  CT  =  Conservative Temperature (ITS-90)                       [ deg C ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  h_SA_SA  =  The second derivative of specific enthalpy with respect to
!              Absolute Salinity at constant CT & p.    [ J/(kg (g/kg)^2) ]
!  h_SA_CT  =  The second derivative of specific enthalpy with respect to
!              SA and CT at constant p.                  [ J/(kg K(g/kg)) ]
!  h_CT_CT  =  The second derivative of specific enthalpy with respect to
!              CT at constant SA and p.                      [ J/(kg K^2) ]
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_sfac, offset

use gsw_mod_specvol_coefficients

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct, p
real (r8), intent(out), optional :: h_sa_sa, h_sa_ct, h_ct_ct

real (r8) :: dynamic_h_ct_ct_part, dynamic_h_sa_ct_part, dynamic_h_sa_sa_part
real (r8) :: xs, xs2, ys, z

xs = sqrt(gsw_sfac*sa + offset)
ys = ct*0.025_r8
z = p*1e-4_r8

if (present(h_sa_sa)) then

    xs2 = xs**2
    dynamic_h_sa_sa_part = z*(-h101 + xs2*(3.0_r8*h301 + xs*(8.0_r8*h401 &
        + xs*(15.0_r8*h501 + 24.0_r8*h601*xs))) + ys*(- h111 &
	+ xs2*(3.0_r8*h311 + xs*(8.0_r8*h411 + 15.0_r8*h511*xs)) + ys*(-h121 &
        + xs2*(3.0_r8*h321 + 8.0_r8*h421*xs) + ys*(-h131 + 3.0_r8*h331*xs2 &
	+ ys*(-h141 - h151*ys)))) + z*(-h102 + xs2*(3.0_r8*h302 &
	+ xs*(8.0_r8*h402 + 15.0_r8*h502*xs)) + ys*(-h112 + xs2*(3.0_r8*h312 &
	+ 8.0_r8*h412*xs) + ys*(-h122 + 3.0_r8*h322*xs2 + ys*(-h132 &
	- h142*ys ))) + z*(xs2*(8.0_r8*h403*xs + 3.0_r8*h313*ys) &
        + z*(-h103 + 3.0_r8*h303*xs2 + ys*(-h113 + ys*(-h123 - h133*ys)) &
        + z*(-h104 - h114*ys - h105*z)))))

    h_sa_sa = 1e8_r8*0.25_r8*gsw_sfac*gsw_sfac*dynamic_h_sa_sa_part/xs**3

end if

if (present(h_sa_ct)) then

    dynamic_h_sa_ct_part = z*(h111 + xs*(2.0_r8*h211 + xs*(3.0_r8*h311 &
        + xs*(4.0_r8*h411 + 5.0_r8*h511*xs))) + ys*(2.0_r8*h121 &
	+ xs*(4.0_r8*h221 + xs*(6.0_r8*h321 + 8.0_r8*h421*xs)) &
	+ ys*(3.0_r8*h131 + xs*(6.0_r8*h231 + 9.0_r8*h331*xs) &
	+ ys*(4.0_r8*h141 + 8.0_r8*h241*xs + 5.0_r8*h151*ys ))) + z*(h112 &
	+ xs*(2.0_r8*h212 + xs*(3.0_r8*h312 + 4.0_r8*h412*xs)) &
	+ ys*(2.0_r8*h122 + xs*(4.0_r8*h222 + 6.0_r8*h322*xs) &
	+ ys*(3.0_r8*h132 + 6.0_r8*h232*xs + 4.0_r8*h142*ys)) + z*(h113 &
	+ xs*(2.0_r8*h213 + 3.0_r8*h313*xs) + ys*(2.0_r8*h123 &
	+ 4.0_r8*h223*xs + 3.0_r8*h133*ys) + h114*z)))

    h_sa_ct = 1e8_r8*0.025_r8*0.5_r8*gsw_sfac*dynamic_h_sa_ct_part/xs

end if

if (present(h_ct_ct)) then

    dynamic_h_ct_ct_part = z*(2.0_r8*h021 + xs*(2.0_r8*h121 + xs*(2.0_r8*h221 &
        + xs*(2.0_r8*h321 + 2.0_r8*h421*xs))) + ys*(6.0_r8*h031 &
	+ xs*(6.0_r8*h131 + xs*(6.0_r8*h231 + 6.0_r8*h331*xs)) &
        + ys*(12.0_r8*h041 + xs*(12.0_r8*h141 + 12.0_r8*h241*xs) &
	+ ys*(20.0_r8*h051 + 20.0_r8*h151*xs + 30.0_r8*h061*ys))) &
	+ z*(2.0_r8*h022 + xs*(2.0_r8*h122 + xs*(2.0_r8*h222 &
	+ 2.0_r8*h322*xs)) + ys*(6.0_r8*h032 + xs*(6.0_r8*h132 &
	+ 6.0_r8*h232*xs) + ys*(12.0_r8*h042 + 12.0_r8*h142*xs &
	+ 20.0_r8*h052*ys)) + z*(2.0_r8*h023 + xs*(2.0_r8*h123 &
	+ 2.0_r8*h223*xs) + ys*(6.0_r8*h133*xs + 6.0_r8*h033 &
	+ 12.0_r8*h043*ys) + 2.0_r8*h024*z)))

    h_ct_ct = 1e8_r8*6.25e-4_r8*dynamic_h_ct_ct_part

end if

return
end subroutine

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


!---------------------------------------------------------------------------------------------------
! All the formulations  have been taken from the original
! article,the Span-Wagner EoS for CO2.
! The EoS has been published in J. Phys. Chem. Ref. Data, Vol.25,
! pp. 1509-1596, 1996.
!---------------------------------------------------------------------------------------------------

!--------------------------------------------------------------------------------------------------
! SUBROUTINE   helmholtz_dimless
! @brief   Compute dimensionless helmotz energy:  phi_0 (perfect gas part) and  phi_r (residul part)
!                                                 derivative of phi_0
! @authors Marco De Lorenzo, Yu Fang
! @date    25-10-2016
!----------------------------------------------------------------------------------------------------
SUBROUTINE helmholtz_dimless (T,v,phi_0,phi_r,phi0_ddelt,phi0_dtau,&
                              phi0_dddelt,phi0_ddtau)

    USE def_constants

    IMPLICIT NONE

!IN/OUT
    REAL(pr) :: v, T
    REAL(pr) :: phi_0,phi_r
    REAL(pr) :: phi0_ddelt
    REAL(pr) :: phi0_dtau,phi0_dddelt,phi0_ddtau                    !,phi_0_ddeltdtau

!Local
    REAL(pr) ::  tau,   tau2,  tau3,  tau4,  tau6,  tau7,    tau8,           &
                tau12,  tau14, tau16, tau22, tau24, tau28, tau0_75, tau1_5,  &
                tau2_5, taum1, taum1_s,                                      &
                rho,    del,   del2,  del3,  del4,  del5,  del6,    del7,    &
                del8,   del10, delm1, delm1_s
!
    REAL(pr) :: phi_r_sum1, phi_r_sum2, phi_r_sum3, phi_r_sum4,              &
                tau_g2_35,  tau_g2_36, tau_g2_37, tau_g2_38,  tau_g2_39,     &
                braces,     braces_s

!--------------------------------------------------------------------------------------------------------
! Normalization of temperature and density and powers useful to speed up calculations
! di in Table31 is computed in this part
!-------------------------------------------------------------------------------------------------------
    tau     = T_cr / T
    tau2    = tau  * tau
    tau3    = tau2 * tau
    tau4    = tau2 * tau2
    tau6    = tau3 * tau3
    tau7    = tau4 * tau3
    tau8    = tau4 * tau4
    tau12   = tau6 * tau6
    tau14   = tau7 * tau7
    tau16   = tau8 * tau8
    tau22   = tau14* tau8
    tau24   = tau12* tau12
    tau28   = tau14* tau14
    tau0_75 = tau**0.75_pr
    tau1_5  = tau0_75 * tau0_75
    tau2_5  = tau1_5  * tau
    taum1   = tau  - 1_pr
    taum1_s = taum1 * taum1
!
!
!    rho     = 1_pr  / v
    del     = 1.0_pr / (rho_cr*v)
    del2    = del  * del
    del3    = del2 * del
    del4    = del2 * del2
    del5    = del3 * del2
    del6    = del3 * del3
    del7    = del4 * del3
    del8    = del4 * del4
    del10   = del5 * del5
    delm1   = del  - 1_pr
    delm1_s = delm1 * delm1
!
!-----------------------------------------------------------------------------------------------------
!
!Compute the perfect gas part of helhmoltz energy (p.1543 Eq.6.3)
!
!-----------------------------------------------------------------------------------------------------

    phi_0 = a1_0  +  a2_0 * tau + a3_0 * log(tau)  + log(del)+ &     !!!
    &       a4_0 * log(1_pr - exp(-tau*th4_0))                  +&
    &       a5_0 * log(1_pr - exp(-tau*th5_0))                  +&
    &       a6_0 * log(1_pr - exp(-tau*th6_0))                   + &
    &       a7_0 * log(1_pr - exp(-tau*th7_0))                   + &
    &       a8_0 * log(1_pr - exp(-tau*th8_0))

!-----------------------------------------------------------------------------------------------------
!
!Compute the  derivatives of the gas part of helhmoltz energy (p.1541 Table28)
!
!-----------------------------------------------------------------------------------------------------
    phi0_ddelt  = 1_pr/del
!
!
    phi0_dddelt = -1_pr/del2
!
!
!   phi_0_ddeltdtau
!
     phi0_dtau  =  a2_0 + a3_0 / tau +&
     &             a4_0 * th4_0* ( (1.0_pr - exp(-tau*th4_0))**(-1.0_pr) - 1.0_pr )  + &
     &             a5_0 * th5_0* ( (1.0_pr - exp(-tau*th5_0))**(-1.0_pr) - 1.0_pr )  + &
     &             a6_0 * th6_0* ( (1.0_pr - exp(-tau*th6_0))**(-1.0_pr) - 1.0_pr )  + &
     &             a7_0 * th7_0* ( (1.0_pr - exp(-tau*th7_0))**(-1.0_pr) - 1.0_pr )  + &
     &             a8_0 * th8_0* ( (1.0_pr - exp(-tau*th8_0))**(-1.0_pr) - 1.0_pr )
!
!
    phi0_ddtau = -a3_0/tau2 - (&
    &            a4_0 * th4_0*th4_0 * exp(-tau*th4_0) *  (1_pr - exp(-tau*th4_0))**(-2_pr)    + &
    &            a5_0 * th5_0*th5_0 * exp(-tau*th5_0) *  (1_pr - exp(-tau*th5_0))**(-2_pr)    + &
    &            a6_0 * th6_0*th6_0 * exp(-tau*th6_0) *  (1_pr - exp(-tau*th6_0))**(-2_pr)    + &
    &            a7_0 * th7_0*th7_0 * exp(-tau*th7_0) *  (1_pr - exp(-tau*th7_0))**(-2_pr)    + &
    &            a8_0 * th8_0*th8_0 * exp(-tau*th8_0) *  (1_pr - exp(-tau*th8_0))**(-2_pr))
!
!
!
!-----------------------------------------------------------------------------------------------------
!
!Compute the residul part of helhmoltz energy (p.1544 Eq.6.5)
!
!-----------------------------------------------------------------------------------------------------
! It is composed by 4 summations, here splitted in 4 different variables
! for easiness.
!
    phi_r_sum1 = n1 * del            +  n2 * del * tau0_75      + &
    &            n3 * del * tau      +  n4 * del * tau2         + &
    &            n5 * del2* tau0_75  +  n6 * del2* tau2         + &
    &            n7 * del3* tau0_75
!
!
    phi_r_sum2 =                                                      &
    & n8 * del  * tau1_5 *exp(-del)  + n9 * del2 * tau1_5 *exp(-del) +&
    & n10* del4 * tau2_5 *exp(-del)  + n11* del5          *exp(-del) +&
    & n12* del5 * tau1_5 *exp(-del)  + n13* del5 * tau2   *exp(-del) +&
    & n14* del6          *exp(-del)  + n15* del6 * tau    *exp(-del) +&
    & n16* del6 * tau2   *exp(-del)  + n17* del  * tau3   *exp(-del2)+&
    & n18* del  * tau6   *exp(-del2) + n19* del4 * tau3   *exp(-del2)+&
    & n20* del4 * tau6   *exp(-del2) + n21* del4 * tau8   *exp(-del2)+&
    & n22* del7 * tau6   *exp(-del2) + n23* del8          *exp(-del2)+&
    & n24* del2 * tau7   *exp(-del3) + n25* del3 * tau12  *exp(-del3)+&
    & n26* del3 * tau16  *exp(-del3) + n27* del5 * tau22  *exp(-del4)+&
    & n28* del5 * tau24  *exp(-del4) + n29* del6 * tau16  *exp(-del4)+&
    & n30* del7 * tau24  *exp(-del4) + n31* del8 * tau8   *exp(-del4)+&
    & n32* del10* tau2   *exp(-del4) + n33* del4 * tau28  *exp(-del5)+&
    & n34* del8 * tau14  *exp(-del6)
!
!
    tau_g2_35 = (tau-gam35)*(tau-gam35)
    tau_g2_36 = (tau-gam36)*(tau-gam36)
    tau_g2_37 = (tau-gam37)*(tau-gam37)
    tau_g2_38 = (tau-gam38)*(tau-gam38)
    tau_g2_39 = (tau-gam39)*(tau-gam39)
!
    phi_r_sum3 =                                                   &
    & n35 * del2 * tau  *exp(-alp35*delm1_s - bet35*tau_g2_35)  +  &
    & n36 * del2        *exp(-alp36*delm1_s - bet36*tau_g2_36)  +  &
    & n37 * del2 * tau  *exp(-alp37*delm1_s - bet37*tau_g2_37)  +  &
    & n38 * del3 * tau3 *exp(-alp38*delm1_s - bet38*tau_g2_38)  +  &
    & n39 * del3 * tau3 *exp(-alp39*delm1_s - bet39*tau_g2_39)
!
!
    braces   = - taum1 + AA40 * delm1_s**(0.5_pr/bet40)
    braces_s = braces * braces
!
!
    phi_r_sum4 =                                           &
    & n40 * del *exp(-CC40*delm1_s - DD40*taum1_s)         &
    &           *   (braces_s + BB40*delm1_s**a40)**b40  + &
    & n41 * del *exp(-CC41*delm1_s - DD40*taum1_s)         &
    &           *   (braces_s + BB41*delm1_s**a41)**b41  + &
    & n42 * del *exp(-CC42*delm1_s - DD40*taum1_s)         &
    &           *   (braces_s + BB42*delm1_s**a42)**b42
!
!
    phi_r =  phi_r_sum1 + phi_r_sum2 + phi_r_sum3 + phi_r_sum4
!
!
END SUBROUTINE helmholtz_dimless


module global_stage

  use Structure
  use Matrix_op
  use local_stage
  !use local_stage_vec
  !use Elastic_sol
  use Elastic_sol_PGD
  use bar
  use Time_matrices

  implicit none

  type :: global

    ! Global stage elastic initial solution:

    double precision, dimension(:,:), allocatable :: Utot_o ! Displacement.
    double precision, dimension(:,:,:,:), allocatable :: eps_o ! Strain.
    double precision, dimension(:,:,:,:), allocatable :: sigma_o ! Stress.
    double precision, dimension(:,:,:,:), allocatable :: d_Ep_o ! Plastic deformation.

    ! Global stage general solution:
    double precision, dimension(:,:), allocatable :: Utot ! Displacement.
    double precision, dimension(:,:,:,:), allocatable :: eps ! Strain.
    double precision, dimension(:,:,:,:), allocatable :: sigma ! Stress.
    double precision, dimension(:,:,:,:), allocatable :: d_Ep ! Plastic deformation.

    ! PGD modes:
    double precision, dimension(:,:), allocatable :: U, T_s, dT_s ! Space and Temporal modes
    double precision, dimension(:,:,:,:), allocatable :: S_eps, S_Sigma, S_d_Ep ! Spatial modes.

    ! Constants factors:
    logical :: saved_const = .false.
    double precision, dimension(:,:), allocatable :: A11,A10,A01,A00

  end type global

  type(global) :: G

  contains

subroutine assign_elastic(Elast,I)
  implicit none
  type(Init_sol), intent(inout) :: Elast
  type(Input), intent(inout) :: I

  ! Initial elastic solution:
  allocate(G%Utot_o( I%n, I%Tngpt ))
  allocate(G%eps_o( Sop%comp,I%ngps,I%Nx, I%Tngpt ))
  allocate(G%sigma_o( Sop%comp,I%ngps,I%Nx, I%Tngpt ))
  allocate(G%d_Ep_o( Sop%comp,I%ngps,I%Nx, I%Tngpt ))

  ! Initialize the general global stage solution:
  allocate(G%Utot( I%n, I%Tngpt ))
  allocate(G%eps( Sop%comp,I%ngps,I%Nx, I%Tngpt ))
  allocate(G%sigma( Sop%comp,I%ngps,I%Nx, I%Tngpt ))
  allocate(G%d_Ep( Sop%comp,I%ngps,I%Nx, I%Tngpt ))

  G%Utot_o = Elast%U
  G%eps_o = Elast%eps
  G%sigma_o = Elast%sigma
  G%d_Ep_o = 0

  G%Utot = Elast%U
  G%eps = Elast%eps
  G%sigma = Elast%sigma
  G%d_Ep = 0

  !print*, "BLAAAAA" ,shape(G%d_Ep)

  allocate(G%A11(1,1))
  allocate(G%A10(1,1))
  allocate(G%A01(1,1))
  allocate(G%A00(1,1))

  G%A11 = 0
  G%A10 = 0
  G%A01 = 0
  G%A00 = 0

end subroutine assign_elastic

subroutine global_stage_vp(Elast,Top,Sop,L,I,iter)  ! [global_stage]=Global_stage_plasticity(global_stage,local,I,iter)

  type(Init_sol), intent(inout) :: Elast
  type(Input), intent(inout) :: I
  type(local), intent(inout) :: L
  type(Space_op), intent(inout) :: Sop
  type(Time_op), intent(inout) :: Top

  integer :: iter,iter_pgd
  double precision, dimension(Sop%comp,Sop%comp) :: H
  double precision, dimension(Sop%comp,I%ngps,I%Nx,I%Tngpt) :: Q
  double precision, dimension(I%n,1) :: U
  double precision, dimension(I%ns,1) :: Uss
  double precision, dimension(Sop%comp,I%ngps,I%Nx,1) :: S,D,E
  double precision, dimension(I%Tngpt,1) :: Ta,T,dT
  double precision :: snorm,stagn
  double precision, dimension(:,:), allocatable :: Tn,Td ! numerator and denominator.
  double precision, dimension(:,:), allocatable :: T_up,dT_up ! Temporal functions of preliminary step.
  integer :: nbmi,nbme,dnbm

  ! Choice of the constant operator:

  H = inv(I%Hooke)  ! Constant operator.
  Q = G%d_Ep - L%d_Ep ! Difference between the global and local quantities.

  if (I%PGD_eval) then !(.true.) then

    ! PGD method to calculate the corrections functions:
    iter_pgd = 0; stagn = 100
    T = reshape(Top%vect_gpt, (/I%Tngpt,1/) ); dT = ones(I%Tngpt,1)
    Ta=T  ! Initial assignation to the temporal function.

    do while (iter_pgd<I%PGD_iter_max .and. stagn > I%PGD_ind)

      iter_pgd = iter_pgd + 1

      ! Space problem:
      call Space_problem(T,dT,H,Q,Sop,Top,I,E,D,S)        ![S,D,E,U] = Space_problem(T,dT,H,Q)

      ! Time problem:
      call Time_problem(S,D,E,H,Q,Sop,Top,I,T,dT)  ![T,dT] = Time_problem(S,D,E,H,Q)

      snorm = norm2(S)
      S = S/snorm; D = D/snorm; E = E/snorm; U = U/snorm
      T = T*snorm; dT = dT*snorm

      stagn = abs( norm2(T-Ta)/norm2(Ta) )
      !print*, "STAGNATION PGD", stagn
      Ta = T

    end do ! end while
    print*, "PGD mode determined."

    T = I%relax*T ; dT = I%relax*dT
    call Add_modes(S,D,E,U,T,dT,iter) ! Add the PGD modes (verificar)

    I%PGD_eval = .false.
    G%saved_const = .false.
  else ! Preliminary step:

    I%up_iter = I%up_iter + 1
    call Preliminary_step(H,Q,Sop,Top,I,nbmi,nbme,dnbm,T_up,dT_up)
    G%saved_const = .true. ! re-use the constants

    !call plot(dT_up(:,1))
    !stop

    ! Update indicator calculation:
    if (size(G%T_s,2)==1) then
      I%update_ind = (sum(0.5*abs(T_up)/( 1e-12 + abs(G%T_s) + abs(T_up)))/I%Tngpt)
      !call plot(dT_up(:,1))
      !stop
    else
      !I%update_ind = (maxval(reshape(sum(0.5*abs(T_up)/( 1e-12 + abs(G%T_s) + abs(T_up)),1)/I%Tngpt,(/size(G%T_s,2)/)),1))
      I%update_ind = maxval(sum(0.5*abs(T_up)/( 1e-12 + abs(G%T_s) + abs(T_up)),1)/I%Tngpt,1)
      !call plot(dT_up(:,1))
      !stop
    end if
    print*, I%update_ind

    if (I%update_ind < I%update_limit .or. I%up_iter > I%N_up_max) then
      I%PGD_eval = .true.
      I%up_iter = 0
      print*, "Preliminary step done."
    end if

    ! Add final relaxed corrections:
    G%T_s = G%T_s + I%relax*T_up
    G%dT_s = G%dT_s + I%relax*dT_up

  end if

  call assign_global(S,D,E,U,T,dT)  ! Assignation of the global quantities.

end subroutine global_stage_vp

subroutine Space_problem(T,dT,H,Q,Sop,Top,I,E,D,S) ! [S,D,E,U] output

  type(Input), intent(inout) :: I
  type(Space_op), intent(inout) :: Sop
  type(Time_op), intent(inout) :: Top

  double precision, dimension(I%n,I%n) :: M
  double precision, dimension(I%ns,I%ns) :: Mss
  double precision, dimension(I%n,1) :: F
  double precision, dimension(I%ns,1) :: Fss
  double precision :: term1, term2

  double precision, dimension(:,:,:,:) :: Q
  double precision, dimension(I%Tngps,1) :: delta
  double precision, dimension(Sop%comp,Sop%comp) :: H,W,invW

  double precision, dimension(I%Tngpt,1) :: T, dT ! Time modes.
  double precision, dimension(I%n,1) :: U ! space function of the dispacement correction.
  double precision, dimension(Sop%comp,I%ngps,I%Nx,1) :: E,D,S ! output spatial modes.
  double precision, dimension(:,:), allocatable :: E_aux, D_aux, S_aux
  double precision, dimension(:,:), allocatable :: aux1, aux2

  integer, dimension(4) :: siz
  integer, dimension(4) :: sizr
  integer :: ns, nrhs, lda, ldb, info
  double precision, dimension(:), allocatable :: ipiv, x
  double precision, dimension(:,:), allocatable :: plot_vec
  double precision, dimension(:,:), allocatable :: Integrant

  siz = shape(Q)
  term1 = sum( (T**2)*Top%IntT )
  term2 = sum( (T*dT)*Top%IntT )

  !print*, "NORM T", norm2(T)
  !print*, "NORM dT", norm2(dT)
  !print*, "NORM T INTEGRAL", norm2(T*Top%IntT)

  allocate(Integrant( size(Q)/I%Tngpt , I%Tngpt ))
  Integrant = spread( reshape( transpose(T*Top%IntT), (/I%Tngpt/) ) ,1,size(Q)/I%Tngpt )

  !print*, "SHAPE INTEGRANT:", shape(spread( reshape( transpose(T*Top%IntT), (/I%Tngpt/) ) ,1,size(Q)/I%Tngpt ))
  !print*, "NORMA PTM", norm2(sum( reshape(Q, (/size(Q)/I%Tngpt,I%Tngpt/) )*Integrant,2))

  invW = H*term1 + inv(Sop%He)*term2
  delta = reshape(sum( reshape(Q, (/size(Q)/I%Tngpt,I%Tngpt/) )*Integrant,2), (/size(delta),1/) )

  !call plot(delta(:,1))
  !stop

  ! Spatial Correction in displacement.
  U = 0 ! Initialization

  W = inv(invW)
  F = I%A*W*( matmul( transpose(Sop%Bw) , delta ) )
  Fss = F(Sop%dof_free,:)

  if (.false.) then

    M = I%A*W*( matmul( transpose(Sop%B) , Sop%Bw ) )
    Mss = M(Sop%dof_free,Sop%dof_free)

    !!!!!!!!!! Fast inverse:
    !ns, nrhs, lda, ldb, ipiv, x
    ns = size(Mss,1)
    nrhs = size(Fss,2)
    lda = ns; ldb = ns
    allocate(ipiv(ns)); allocate(x(ns))
    x = -Fss(:,1)
    call dgesv(ns,nrhs,Mss,lda,ipiv,x,ldb,info)
    U(Sop%dof_free,1) = x

  else

    allocate(x(ns))
    x = -Fss(:,1)
    call inv_chol(Elast%ChKss,x)
    U(Sop%dof_free,1) = (1/(term1 + term2))*x

  end if

  allocate( E_aux( size(delta),1 ) )
  allocate( D_aux( size(delta),1 ) )
  allocate( S_aux( size(delta),1 ) )

  ! Spatial Correction in deformation:
  E_aux = matmul(Sop%B,U)

  ! Spatial Correction in stress:
  allocate( aux1(Sop%comp,size(delta)/Sop%comp)  )
  aux1 = matmul( W, reshape( (E_aux + delta), (/Sop%comp, size(delta)/Sop%comp /) ))
  D_aux = reshape( aux1 , (/size(delta),1/) ) ! matmul( W, (E + delta) )  ! inv(invW)*(E + delta)

  ! Spatial Correction in plastic deformation:
  allocate( aux2(Sop%comp,size(delta)/Sop%comp)  )
  aux2 = matmul(H, reshape(D_aux, (/Sop%comp, size(delta)/Sop%comp/)))
  S_aux = ( reshape( aux2 , (/size(delta),1/) )*term1 - delta )/term2     ! ( (H*D)*term1 - delta )/term2

  ! Reshape of all the spatial fields:
  sizr = siz; sizr(4) = 1

  E = reshape(E_aux,sizr)
  D = reshape(D_aux,sizr)
  S = reshape(S_aux,sizr)

end subroutine Space_problem

subroutine Time_problem(S,D,E,H,Q,Sop,Top,I,T,dT)  !result(alfa,alfat) ! [alfa,alfat]

! S,D,E,H,Q,Sop,Top,I

  implicit none

  type(Input), intent(inout) :: I
  type(Space_op), intent(inout) :: Sop
  type(Time_op), intent(inout) :: Top

  double precision , dimension(:,:,:,:) :: Q
  double precision, dimension(:,:,:,:) :: S,D,E
  double precision, dimension(:,:,:,:), allocatable :: Sg,Dg,Eg,aux
  double precision, dimension(:,:), allocatable :: aux1
  double precision, dimension(:,:) :: H
  integer, dimension(4) :: siz
  integer, dimension(3) :: sizr
  double precision :: A11,A10,A00
  double precision, dimension(I%ngpt,1) :: IntTe
  double precision, dimension(I%ntc-1,I%ntc-1) :: Mt
  double precision, dimension(I%ntc,1) :: Fti
  double precision, dimension(I%ntc-1,1) :: Ft

  integer :: j
  integer :: ns, nrhs, lda, ldb, info
  double precision, dimension(:), allocatable :: ipiv, x
  double precision, dimension(I%ntc,1) :: alfa_fem
  integer , dimension(I%Nsft*I%NT) :: IDvtc
  double precision, dimension(I%Nsft*I%NT,1) :: alfac
  double precision, dimension(I%Nsft,I%NT) :: alfac2, alfacc
  double precision, dimension(I%ngpt,I%NT) :: alfae, alfate
  double precision, dimension(I%Tngpt,1) :: T, dT
  double precision, dimension(I%Tngpt,1) :: D1, D0

  !double precision, dimension(:,:), allocatable :: IntS
  !double precision, dimension(:,:,:,:), allocatable :: t1
  double precision, dimension(:,:), allocatable :: IntSg
  double precision, dimension(:,:), allocatable :: to,t1
  double precision, dimension(I%Nsft,I%NT) :: Felm, Felm1, Felm2
  double precision, dimension(:,:), allocatable :: oper

  ! multiplication quantities blas:
  double precision, dimension(I%Nsft,I%ngpt) :: a1,a2
  double precision, dimension(I%ngpt, I%NT) :: b1,b2

  siz = shape(Q); sizr = siz(1:3)

  ! Constants:
  allocate( aux1( size(D) , 1 ) )
  aux1 = reshape( matmul(H, reshape(D, (/Sop%comp, size(D)/Sop%comp /) ) ), (/size(D),1/) )
  A11 =  sum( (reshape(S, (/ size(S),1 /) )**2)*Sop%IntS )  !matmul( transpose(reshape(S, (/ size(S),1 /) )**2) ,  Sop%IntS )
  A10 = -sum( reshape(S, (/ size(S),1 /) )*aux1*Sop%IntS )  !matmul( transpose(reshape(S, (/ size(S),1 /) )*reshape(H*D,  (/ size(D),1 /)  )) , Sop%IntS )
  A00 =  sum( (aux1**2)*Sop%IntS )  !matmul( transpose(reshape(H*D,  (/ size(D),1 /) )**2) , Sop%IntS )

  allocate(Sg( siz(1),siz(2),siz(3),siz(4) ))
  allocate(Dg( siz(1),siz(2),siz(3),siz(4) ))
  allocate(Eg( siz(1),siz(2),siz(3),siz(4) ))

  Sg = spread( reshape(S, (/siz(1),siz(2),siz(3)/) ) ,4,I%Tngpt)  ! dim = 4, count = I%Tngpt
  Dg = spread( reshape(D, (/siz(1),siz(2),siz(3)/) ) ,4,I%Tngpt)
  Eg = spread( reshape(E, (/siz(1),siz(2),siz(3)/) ) ,4,I%Tngpt)

  !print*, "NEEEPEEE   2", shape(spread( reshape(S, (/siz(1),siz(2),siz(3)/) ) ,4,I%Tngpt))

  !print*, "HASTA AQUI" ,shape(Sop%IntS*reshape( (Sg*Q), (/size(Q)/I%Tngpt,I%Tngpt/)  ))

  allocate(IntSg( size(Sop%IntS,1), I%Tngpt  ))  ! operator used to integrate in space.

  !IntSg = spread(  reshape(Sop%IntS, (/size(Sop%IntS,1)/) ) , 2, I%Tngpt )
  IntSg = spread(  Sop%IntS(:,1) , 2, I%Tngpt )

  allocate(t1( 1 , I%Tngpt ))
  !t1 =  matmul( transpose(Sop%IntS), reshape( (Sg*Q), (/size(Q)/I%Tngpt,I%Tngpt/)  ) )
  D1(:,1) = -reshape(sum( IntSg*reshape( (Sg*Q), (/size(Q)/I%Tngpt,I%Tngpt/)),1), (/I%Tngpt/))
  !D1(:,1) = - reshape( t1, (/I%Tngpt/) )    !sum( t1 ,1 )

  !call plot(D1(:,1))
  !stop

  allocate( to( 1 , I%Tngpt) )
  allocate(aux( siz(1),siz(2),siz(3),siz(4) ))
  aux = reshape( matmul(H, reshape( Dg,  (/Sop%comp, size(Dg)/Sop%comp /) ) ) , (/siz(1),siz(2),siz(3),siz(4)/)  )
  !to = matmul( transpose(Sop%IntS) , reshape( aux*Q , (/size(Q)/I%Tngpt , I%Tngpt/) ) )
  D0(:,1) = reshape(sum( IntSg*reshape( aux*Q , (/size(Q)/I%Tngpt , I%Tngpt/)),1), (/I%Tngpt/))
  !D0(:,1) =  reshape( to, (/I%Tngpt/) ) ! sum(to,1)

  !call plot( D1(:,1) + D0(:,1)  )
  !stop

  Mt = (Top%I11Tr)*A11 + (Top%I01Tr)*A10 + (Top%I10Tr)*A10 + (Top%I00Tr)*A00

  if (.true.) then

    a1 = Top%vwalfat
    b1 = reshape(D1,  (/ I%ngpt, I%NT /) )
    a2 = Top%vwalfa
    b2 = reshape(D0,  (/ I%ngpt, I%NT /) )

    !CALL DGEMM (transa, transb, l, n, m, alpha, a, lda, b, ldb, beta, c, ldc)
    call dgemm('n','n',size(Felm1,1),size(Felm1,2),size(a1,2),1.D0,a1,size(a1,1),b1,size(b1,1),0.D0,Felm1,size(Felm1,1))
    call dgemm('n','n',size(Felm2,1),size(Felm2,2),size(a2,2),1.D0,a2,size(a2,1),b2,size(b2,1),0.D0,Felm2,size(Felm2,1))

  else

    Felm1 = matmul( Top%vwalfat , reshape(D1,  (/ I%ngpt, I%NT /) )  )   ! N shape functions x ngpt
    Felm2 = matmul( Top%vwalfa  , reshape(D0,  (/ I%ngpt, I%NT /) )  ) ! N shape functions x ngpt

    !stop

  end if

  Felm = Felm1 + Felm2  ! Elemental vectors.
  Fti = 0; Ft = 0
  do j=1,I%NT
      Fti(Top%IDvtc(:,j),1) = Fti(Top%IDvtc(:,j),1) + Felm(:,j)
  end do
  Ft = Fti(Top%dof_free,:)  ! Null initial condition.

  ! Obtention of the time functions over all the gauss points:

  !!!!!!!!!! Fast inverse matrix:
  !ns, nrhs, lda, ldb, ipiv, x
  ns = size(Mt,1)
  nrhs = size(Ft,2)
  lda = ns; ldb = ns
  allocate(ipiv(I%ntc-1)); allocate(x(I%ntc-1))
  x = Ft(:,1)
  call dgesv(ns,nrhs,Mt,lda,ipiv,x,ldb,info)
  alfa_fem(Top%dof_free,1) = x

  IDvtc = reshape(Top%IDvtc, (/ size(Top%IDvtc) /)  )
  alfac = reshape(alfa_fem(IDvtc,1), (/size(alfac),1/) )

  alfacc=reshape( alfac,  (/I%Nsft,I%NT/) )

  allocate( oper( I%ngpt,I%Nsft ) )
  oper = transpose(Top%valfa)
  T = reshape( matmul( oper , alfacc ) , (/I%Tngpt,1/) )  ! alfa in each gauss point

  !call plot(T(:,1))
  !stop

  !alfate =  matmul(  transpose(Top%Tmat_vectauxalfat), alfacc )
  dT =  reshape( matmul(  transpose(Top%valfat), alfacc ), (/I%Tngpt,1/) )  ! alfa in each gauss point

  !call plot(dT(:,1))
  !stop

end subroutine Time_problem

!!!!!!!!!!!!!!!!!!!!!!!!!!! Preliminary step !!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine Preliminary_step(H,Q,Sop,Top,I,nbmi,nbme,dnbm,T,dT)  !result(alfa,alfat) ! [alfa,alfat]

! S,D,E,H,Q,Sop,Top,I

  implicit none

  type(Input), intent(inout) :: I
  type(Space_op), intent(inout) :: Sop
  type(Time_op), intent(inout) :: Top

  double precision, dimension(:,:) :: H  ! constant operator.
  double precision , dimension(:,:), allocatable :: Qr ! reshape of Q
  double precision , dimension(:,:,:,:) :: Q
  double precision, dimension(:,:,:,:), allocatable :: S,D  ! S: Plastic deformation tensor; D: Stress tensor.

  ! vector determination:
  double precision, dimension(:,:), allocatable :: aux ! auxiliar variable for vetors calculation.
  double precision, dimension(:,:), allocatable :: Sr
  double precision, dimension(:,:), allocatable :: D1, D0 !

  ! constants determination:
  double precision, dimension(:,:), allocatable :: aux1 ! auxiliar variable for constants calculation.
  double precision, dimension(:,:), allocatable :: A11,A10,A01,A00 ! constants factors.

  double precision, dimension(I%ngpt,1) :: IntTe
  !double precision, dimension(I%Nsft,I%NT) :: Felm1, Felm2  ! elemental vector
  double precision, dimension(:,:), allocatable :: Felm1, Felm2  ! elemental vector
  double precision, dimension(:,:,:), allocatable :: Felm

  double precision, dimension(:,:), allocatable :: Mt
  double precision, dimension(:,:), allocatable :: Ft,Fti ! assembly vector
  !double precision, dimension(I%ntc,1) :: Fti  ! assembly vector

  integer, dimension(4) :: siz
  integer, dimension(3) :: sizr
  integer :: Nelms
  integer :: nbmi, nbme, dnbm, nbm

  integer :: i1,j1,it,im
  integer :: ns, nrhs, lda, ldb, info
  double precision, dimension(:), allocatable :: ipiv, x
  integer , dimension(I%Nsft*I%NT) :: IDvtc

  double precision, dimension(:,:), allocatable :: alfa_fem
  double precision, dimension(:,:), allocatable :: alfac
  double precision, dimension(:,:), allocatable :: alfacc
  double precision, dimension(:,:), allocatable :: T, dT

  ! multiplication quantities blas:
  double precision, dimension(I%Nsft,I%ngpt) :: a1,a2
  double precision, dimension(:,:), allocatable :: b1,b2

  double precision, dimension(:), allocatable :: IntS

  ! Determination  of the modes that need to be actualized
  siz = shape(G%S_d_Ep); sizr = siz(1:3)
  nbm = siz(4)
  !print*, siz

  if (siz(4)==I%interval_act_modes) then
    nbmi = 1
    nbme = I%interval_act_modes

  else if (siz(4)>I%interval_act_modes) then
    nbmi = siz(4)-I%interval_act_modes + 1
    nbme = siz(4)

  else  ! siz(4) < I%interval_act_modes
    nbmi = 1
    nbme = siz(4)
  end if

  dnbm = nbme - nbmi + 1 ! number of modes that will be actualized.

  !print*, "dnbm:", dnbm
  !print*, "nbm:", siz(4)

  ! End Determination  of the modes that need to be actualized

  ! Assignation of the spatial functions from global_stage:

  allocate( S( siz(1),siz(2),siz(3),dnbm ) )
  allocate( D( siz(1),siz(2),siz(3),dnbm ) )

  S = G%S_d_Ep(:,:,:,nbmi:nbme)  ! Plastic deformation tensor.
  D = G%S_Sigma(:,:,:,nbmi:nbme) ! Stress tensor.

  ! end Assignation of the spatial functions from global_stage:

  ! Constants factors determination:

  allocate(A11(dnbm,dnbm)); allocate(A10(dnbm,dnbm))
  allocate(A01(dnbm,dnbm)); allocate(A00(dnbm,dnbm))

  Nelms = size(S(:,:,:,1)) ! Number of elements in space.

  !print*, Nelms
  !stop

  if (G%saved_const .eqv. .false.) then

    allocate( aux1( Nelms , dnbm ) )
    aux1 = reshape( matmul(H, reshape(D, (/Sop%comp, size(D)/Sop%comp /) ) ), (/Nelms,dnbm/) )

    do i1=1,dnbm
      do j1=1,dnbm
        A11(i1,j1) =  sum( (reshape(S(:,:,:,i1)*S(:,:,:,j1), (/ Nelms,1 /) ))*Sop%IntS)
        A10(i1,j1) = -sum( reshape(S(:,:,:,i1), (/ Nelms,1 /) )*reshape(aux1(:,j1),(/Nelms,1/))*Sop%IntS)
        A01(i1,j1) = -sum( reshape(aux1(:,i1),(/Nelms,1/))*reshape(S(:,:,:,j1), (/ Nelms,1 /) )*Sop%IntS)
        A00(i1,j1) =  sum( ( reshape(aux1(:,i1),(/Nelms,1/))*reshape(aux1(:,j1),(/Nelms,1/)) )*Sop%IntS)
      end do
    end do

    deallocate(G%A11); deallocate(G%A10);
    deallocate(G%A01); deallocate(G%A00);

    allocate(G%A11(dnbm,dnbm)); allocate(G%A10(dnbm,dnbm));
    allocate(G%A01(dnbm,dnbm)); allocate(G%A00(dnbm,dnbm));
    G%A11 = A11; G%A10 = A10; G%A01 = A01; G%A00 = A00

  else ! re-use the constants:
    !print*, "Reutilization of the constants"
    A11 = G%A11; A10 = G%A10; A01 = G%A01; A00 = G%A00
  end if

  !call show(A11)
  !call show(A10)
  !call show(A01)
  !call show(A00)

  !print*, "_______________________"

  ! Temporal functions of the rhs determination:

  siz = shape(Q);

  allocate(D1(I%Tngpt,dnbm)); allocate(D0(I%Tngpt,dnbm))
  D1 = 0.D0; D0 = 0.D0

  allocate(Qr( size(Q)/I%Tngpt , I%Tngpt ))
  allocate(Sr( size(Q)/I%Tngpt , dnbm ))
  allocate(aux( size(Q)/I%Tngpt , dnbm ))

  Sr = reshape( S, (/Nelms,dnbm/) )
  Qr = reshape( Q, (/size(Q)/I%Tngpt , I%Tngpt/) )
  aux = reshape( matmul(H, reshape( D,  (/Sop%comp, size(D)/Sop%comp /) ) ) , (/size(Q)/I%Tngpt , dnbm/)  )

  allocate( IntS( size(Sop%IntS) ) )
  IntS = reshape( Sop%IntS, (/size(Sop%IntS)/) )

  do it = 1,I%Tngpt
    do im = 1,dnbm
      D0(it,im) =  sum( IntS*aux(:,im)*Qr(:,it))
      D1(it,im) = -sum( IntS*Sr(:,im)*Qr(:,it))
    end do
  end do

  if (.false.) then ! (dnbm .eq. 1) then ! (.false.) then
    print*, "TEST PRELIMINAR:"
    call plot(D0(:,1)+D1(:,1))
    stop
  end if

  !print*, it
  !call show(D0)

  !call plot(D1(:,1))
  !call plot(D1(:,1))
  !stop

  ! DETERMINATION OF THE FEM MATRIX AND VECTOR:

  allocate(Mt( (I%ntc-1)*dnbm , (I%ntc-1)*dnbm ))
  Mt = kron(Top%I11Tr,A11) + kron(Top%I01Tr,A01) + kron(transpose(Top%I01Tr),A10) + kron(Top%I00Tr,A00)
  !Mt = (Top%I11Tr)*A11 + (Top%I01Tr)*A10 + (Top%I10Tr)*A10 + (Top%I00Tr)*A00

  allocate( Felm1( I%Nsft,I%NT*dnbm )  )
  allocate( Felm2( I%Nsft,I%NT*dnbm )  )

   Felm1 = 0.D0; Felm2 = 0.D0

  ! calculate the elementary finite vectors of rhs
  if (.false.) then

    a1 = Top%vwalfat
    a2 = Top%vwalfa

    allocate( b1( I%ngpt, I%NT*dnbm ) )
    allocate( b2( I%ngpt, I%NT*dnbm ) )

    b1 = reshape(D1,  (/ I%ngpt, I%NT*dnbm /) )
    b2 = reshape(D0,  (/ I%ngpt, I%NT*dnbm /) )

    !CALL DGEMM (transa, transb, l, n, m, alpha, a, lda, b, ldb, beta, c, ldc)
    call dgemm('n','n',size(Felm1,1),size(Felm1,2),size(a1,2),1.D0,a1,size(a1,1),b1,size(b1,1),0.D0,Felm1,size(Felm1,1))
    call dgemm('n','n',size(Felm2,1),size(Felm2,2),size(a2,2),1.D0,a2,size(a2,1),b2,size(b2,1),0.D0,Felm2,size(Felm2,1))

  else

    Felm1 = matmul( Top%vwalfat , reshape(D1,  (/ I%ngpt, I%NT*dnbm /) )  )   ! N shape functions x ngpt
    Felm2 = matmul( Top%vwalfa  , reshape(D0,  (/ I%ngpt, I%NT*dnbm /) )  ) ! N shape functions x ngpt

  end if

  allocate(Felm( I%Nsft,I%NT, dnbm ))
  !Felm =  reshape( Felm1 + Felm2,  (/ I%Nsft,I%NT,dnbm /) )

  allocate(Fti( I%ntc , dnbm ))
  allocate(Ft( (I%ntc-1)*dnbm , 1 )) ! rhs vector

  !print*, shape(Felm1)
  !print*, shape(Felm2)
  !print*, (/I%Nsft,I%NT, dnbm/)
  !print*, "HASTA ACA:"
  Felm = 0.D0
  Felm = reshape( Felm1 + Felm2, (/I%Nsft,I%NT,dnbm/) ) ! Elemental vectors.

  Fti = 0.D0; Ft = 0.D0
  do j1=1,I%NT
    do im=1,dnbm
      Fti(Top%IDvtc(:,j1),im) = Fti(Top%IDvtc(:,j1),im) + Felm(:,j1,im) !reshape(Felm(:,j1,im),(/I%Nsft/))
    end do
  end do
  Ft =  reshape( Fti(Top%dof_free,:), (/(I%ntc-1)*dnbm,1/) ) ! Null initial condition.

  if (.false.) then !(nbm .eq. 2) then !(.false.) then

    call show(Felm(:,I%NT-1,2))
    call show(Felm(:,I%NT,2))

    print*, "TEST PRELIMINAR Fti:"
    call plot(Fti(:,1))
    stop
  end if

  ! FEM RESOLUTION:
  allocate( alfa_fem( I%ntc, dnbm ) )
  alfa_fem = 0

  !!! Fast inverse matrix:
  !ns, nrhs, lda, ldb, ipiv, x
  ns = size(Mt,1)
  nrhs = size(Ft,2)
  lda = ns; ldb = ns
  allocate(ipiv((I%ntc-1)*dnbm)); allocate(x((I%ntc-1)*dnbm))
  x = Ft(:,1)
  call dgesv(ns,nrhs,Mt,lda,ipiv,x,ldb,info)
  alfa_fem(Top%dof_free,:) = reshape(x, (/ I%ntc-1,dnbm /) )
  !!! end Fast inverse matrix:

  IDvtc = reshape(Top%IDvtc, (/ size(Top%IDvtc) /)  )

  allocate( alfac( I%Nsft*I%NT,dnbm ) )
  alfac = reshape(alfa_fem(IDvtc,:), (/I%Nsft*I%NT,dnbm/) )

  allocate( alfacc( I%Nsft,I%NT*dnbm ) )
  alfacc=reshape( alfac,  (/I%Nsft,I%NT*dnbm/) )

  allocate(T(I%Tngpt,nbm))
  allocate(dT(I%Tngpt,nbm))

  T = 0; dT=0

  T(:,nbmi:nbme) = reshape( matmul( transpose(Top%valfa) , alfacc ) , (/I%Tngpt,dnbm/) )  ! alfa in each gauss point
  dT(:,nbmi:nbme) = reshape( matmul(  transpose(Top%valfat), alfacc ), (/I%Tngpt,dnbm/) )  ! alfa in each gauss point

  if (.false.) then ! (dnbm .eq. 2) then
    print*, "TEST PRELIMINAR Ft:"
    call plot(dT(:,2))
    stop
  end if

  !stop
  !call plot(T(:,1))
  !stop

  !call plot(dT(:,1))
  !stop

end subroutine Preliminary_step

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

! Reviewed:
subroutine Add_modes(S,D,E,U,T,dT,iter) ![global_stage]=Add_modes(global_stage,S,D,E,U,T,dT,iter)

  implicit none

  integer :: nmodes, iter
  integer, dimension(4) :: siz

  double precision, dimension(:,:,:,:) :: S, D, E
  double precision, dimension(:,:) :: U
  double precision, dimension(:,:) :: T, dT
  ! If we have already some modes, variables used to cat the arrays on G%
  double precision, dimension(:,:,:,:), allocatable :: G_Ep, G_Sigma, G_E
  double precision, dimension(:,:), allocatable :: G_U, G_T_s, G_dT_s

  !integer :: ns

  !ns = size(U,1)

  !print*, "Modes Added"

  if (iter==1) then

      siz = shape(S)

      ! PGD modes:
      !double precision, dimension(:,:), allocatable :: U, T_s, dT_s ! Space and Temporal modes
      !double precision, dimension(:,:,:,:), allocatable :: S_eps, S_Sigma, S_d_Ep ! Spatial modes.

      allocate( G%S_d_Ep( siz(1), siz(2), siz(3), 1 ) )
      allocate( G%S_Sigma( siz(1), siz(2), siz(3), 1 ) )
      allocate( G%S_eps( siz(1), siz(2), siz(3), 1 ) )

      allocate( G%U( size(U,1),1) )
      allocate( G%T_s( size(T,1),1) )
      allocate( G%dT_s( size(T,1),1) )

      G%S_d_Ep = S
      G%S_Sigma = D
      G%S_eps = E
      G%U = U
      G%T_s  = T
      G%dT_s = dT

  else

      siz = shape(G%S_d_Ep)

      ! Save last arrays:
      allocate( G_Ep( siz(1), siz(2), siz(3), siz(4) ) )
      allocate( G_Sigma( siz(1), siz(2), siz(3), siz(4) ) )
      allocate( G_E( siz(1), siz(2), siz(3), siz(4) ) )
      allocate( G_U( size(U,1), siz(4) ) )

      allocate( G_T_s( size(T,1), siz(4) ) )
      allocate( G_dT_s( size(dT,1), siz(4) ) )

      G_Ep = G%S_d_Ep
      G_Sigma = G%S_Sigma
      G_E = G%S_eps
      G_U = G%U

      G_T_s = G%T_s
      G_dT_s = G%dT_s

      ! end Save last arrays.

      ! New sized arrays:
      nmodes = siz(4) + 1   ! New quantity of modes.
      siz(4) = nmodes

      deallocate(G%S_d_Ep); deallocate(G%S_Sigma);
      deallocate(G%S_eps); deallocate(G%U);
      deallocate(G%T_s); deallocate(G%dT_s);

      allocate( G%S_d_Ep( siz(1), siz(2), siz(3), siz(4) ) )
      allocate( G%S_Sigma( siz(1), siz(2), siz(3), siz(4) ) )
      allocate( G%S_eps( siz(1), siz(2), siz(3), siz(4) ) )
      allocate( G%U( size(U,1), siz(4) ) )

      allocate( G%T_s( size(T,1), siz(4) ) )
      allocate( G%dT_s( size(dT,1), siz(4) ) )

      ! Adjoint of already computed modes:

      G%S_d_Ep(:,:,:,1:nmodes-1) = G_Ep !cat(4,G%Ep,S)
      G%S_Sigma(:,:,:,1:nmodes-1) = G_Sigma !cat(4,G%Sigma,D)
      G%S_eps(:,:,:,1:nmodes-1) = G_E  ! cat(4,G%E,E)
      G%U(:,1:(nmodes-1)) = G_U !horzcat(G%U,U)

      G%T_s(:,1:(nmodes-1))  = G_T_s !horzcat(G%T_s,T)
      G%dT_s(:,1:(nmodes-1)) = G_dT_s !horzcat(G%dT_s,dT)

      ! Concatenation of the new mode:

      G%S_d_Ep(:,:,:,nmodes) = S(:,:,:,1) !cat(4,G%Ep,S)
      G%S_Sigma(:,:,:,nmodes) = D(:,:,:,1) !cat(4,G%Sigma,D)
      G%S_eps(:,:,:,nmodes) = E(:,:,:,1)  ! cat(4,G%E,E)
      G%U(:,nmodes) = U(:,1) !horzcat(G%U,U)

      G%T_s(:,nmodes)  = T(:,1) !horzcat(G%T_s,T)
      G%dT_s(:,nmodes) = dT(:,1) !horzcat(G%dT_s,dT)

  end if

end subroutine Add_modes ! end Add_modes

subroutine assign_global(S,D,E,U,T,dT)

  implicit none

  double precision, dimension(:,:) :: U,T,dT
  double precision, dimension(:,:,:,:) :: S,D,E

  !call plot(T(:,1))

  if (.false.) then

    G%Utot = G%Utot + full_field(U,T)
    G%eps =  G%eps + full_field(E,T)
    G%sigma = G%sigma + full_field(D,T)
    G%d_Ep = G%d_Ep + full_field(S,dT)

  else

    ! PGD modes:
    !double precision, dimension(:,:), allocatable :: U, T_s, dT_s ! Space and Temporal modes
    !double precision, dimension(:,:,:,:), allocatable :: S_eps, S_Sigma, S_d_Ep ! Spatial modes.

    G%Utot = G%Utot_o + full_field(G%U,G%T_s)
    G%eps =  G%eps_o + full_field(G%S_eps,G%T_s)
    G%sigma = G%sigma_o + full_field(G%S_Sigma,G%T_s)
    G%d_Ep = full_field(G%S_d_Ep,G%dT_s)

  end if

end subroutine assign_global

end module global_stage


!C(t,t')=(A*B)(t,t'), with t=t_max && t'=0,t_max ; t_max_index==N
subroutine convolute_kb_contour_gf_gf(A,B,C,params,dcoeff,ccoeff)
  type(kb_contour_gf)                 :: A,B,C
  type(kb_contour_params)             :: params
  real(8),optional                    :: dcoeff
  complex(8),optional                 :: ccoeff
  integer                             :: N,L
  real(8)                             :: dt,dtau
  complex(8),dimension(:),allocatable :: AxB
  integer                             :: i,j,k,itau,jtau
  logical                             :: checkA,checkB,checkC
  !
  N   = params%Nt      !<== work with the ACTUAL size of the contour
  L   = params%Ntau
  dt  = params%dt
  dtau= params%dtau
  !
  if(N==1) stop "convolute_kb_contour_gf_gf error: called with N=1"
  if(  (.not.A%status).OR.&
       (.not.B%status).OR.&
       (.not.C%status))stop "contour_gf/convolute_kb_contour_gf: A,B,C not allocated"
  checkA=check_dimension_kb_contour(A,params%Ntime,L)
  checkB=check_dimension_kb_contour(B,params%Ntime,L)
  checkC=check_dimension_kb_contour(C,params%Ntime,L)
  !
  allocate(AxB(0:max(L,N)))
  !
  !Ret. component
  !C^R(t,t')=\int_{t'}^t ds A^R(t,s)*B^R(s,t')
  C%ret(N,1:N)=zero
  do j=1,N           !for all t' in 0:t_max
     AxB(0:)  = zero !AxB should be set to zero before integration
     do k=j,N        !store the convolution between t'{=j} and t{=N}
        AxB(k) = A%ret(N,k)*B%ret(k,j)
     enddo
     C%ret(n,j) = C%ret(n,j) + dt*kb_trapz(AxB(0:),j,N)
  enddo
  !
  !Lmix. component
  !C^\lmix(t,tau')=\int_0^{beta} ds A^\lmix(t,s)*B^M(s,tau')
  !                  +\int_0^{t} ds A^R(t,s)*B^\lmix(s,tau')
  !               = I1 + I2
  C%lmix(N,0:L)=zero
  do jtau=0,L
     !I1:
     AxB(0:) = zero
     do k=0,jtau
        AxB(k)=A%lmix(N,k)*B%mats(L+k-jtau)
     end do
     C%lmix(N,jtau)=C%lmix(N,jtau)-dtau*kb_trapz(AxB(0:),0,jtau)
     do k=jtau,L
        AxB(k)=A%lmix(N,k)*B%mats(k-jtau)
     end do
     C%lmix(n,jtau)=C%lmix(n,jtau)+dtau*kb_trapz(AxB(0:),jtau,L)
     !I2:
     AxB(0:) = zero
     do k=1,N
        AxB(k) = A%ret(N,k)*B%lmix(k,jtau)
     enddo
     C%lmix(N,jtau) = C%lmix(N,jtau) + dt*kb_trapz(AxB(0:),1,N)
  enddo
  !
  !Less component
  !C^<(t,t')=-i\int_0^{beta} ds A^\lmix(t,s)*B^\rmix(s,t')
  !             +\int_0^{t'} ds A^<(t,s)*B^A(s,t')
  !             +\int_0^{t} ds A^R(t,s)*B^<(s,t')
  ! (t,t')=>(N,j) <==> Vertical side, with tip (j=1,N) !!no tip (j=1,N-1)
  do j=1,N                      !-1
     C%less(N,j)=zero
     do k=0,L
        AxB(k)=A%lmix(N,k)*get_rmix(B,k,j,L)
     end do
     C%less(N,j)=C%less(N,j)-xi*dtau*kb_trapz(AxB(0:),0,L)
     do k=1,j
        AxB(k)=A%less(N,k)*get_adv(B,k,j)
     end do
     C%less(N,j)=C%less(N,j)+dt*kb_trapz(AxB(0:),1,j)
     do k=1,N
        AxB(k)=A%ret(N,k)*B%less(k,j)
     end do
     C%less(N,j)=C%less(N,j)+dt*kb_trapz(AxB(0:),1,N)
  end do
  !
  ! (t,t`)=>(i,N) <==> Horizontal side, w/ no tip (i=1,N-1)
  do i=1,N-1
     C%less(i,N)=zero
  enddo
  ! do i=1,N-1
  !    C%less(i,N)=zero
  !    do k=0,L
  !       !         AxB(k)=A%lmix(i,k)*conjg(B%lmix(n,L-k))
  !       AxB(k)=A%lmix(i,k)*get_rmix(B,k,N,L)
  !    end do
  !    C%less(i,N)=C%less(i,N)-xi*dtau*kb_trapz(AxB(0:),0,L)
  !    !
  !    do k=1,N
  !       !         AxB(k)=A%less(i,k)*conjg(B%ret(N,k))
  !       AxB(k)=A%less(i,k)*get_adv(B,k,N)
  !    end do
  !    C%less(i,N)=C%less(i,N)+dt*kb_trapz(AxB(0:),1,N)
  !    !
  !    do k=1,i
  !       AxB(k)=A%ret(i,k)*B%less(k,N)
  !    end do
  !    C%less(i,N)=C%less(i,N)+dt*kb_trapz(AxB(0:),1,i)
  ! end do
  !
  if(present(dcoeff))then
     C%lmix(N,0:L) = dcoeff*C%lmix(N,0:L)
     C%less(N,1:N-1)=dcoeff*C%less(N,1:N-1)
     C%less(1:N,N)=dcoeff*C%less(1:N,N)
     C%ret(N,1:N)=dcoeff*C%ret(N,1:N)
  endif
  if(present(ccoeff))then
     C%lmix(N,0:L) = ccoeff*C%lmix(N,0:L)
     C%less(N,1:N-1)=ccoeff*C%less(N,1:N-1)
     C%less(1:N,N)=ccoeff*C%less(1:N,N)
     C%ret(N,1:N)=ccoeff*C%ret(N,1:N)
  endif
  deallocate(AxB)
end subroutine convolute_kb_contour_gf_gf

!C(t,t')=[A*(Bhf*delta + Breg)](t,t'), with t=t_max && t'=0,t_max ; t_max_index==N
subroutine convolute_kb_contour_gf_sigma(A,B,C,params,dcoeff,ccoeff)
  type(kb_contour_gf)                 :: A
  type(kb_contour_sigma)              :: B
  type(kb_contour_gf)                 :: C
  type(kb_contour_params)             :: params
  real(8),optional                    :: dcoeff
  complex(8),optional                 :: ccoeff
  integer                             :: N,L
  real(8)                             :: dt,dtau
  complex(8),dimension(:),allocatable :: AxB
  integer                             :: i,j,k,itau,jtau
  logical                             :: checkA,checkB,checkC
  !
  N   = params%Nt      !<== work with the ACTUAL size of the contour
  L   = params%Ntau
  dt  = params%dt
  dtau= params%dtau
  !
  if(N==1) stop "convolute_kb_contour_gf_sigma error: called with N=1"
  if(  (.not.A%status).OR.&
       (.not.B%status).OR.&
       (.not.C%status))stop "contour_gf/convolute_kb_contour_gf: A,B,C not allocated"
  checkA=check_dimension_kb_contour(A,params)
  checkB=check_dimension_kb_contour(B,params)
  checkC=check_dimension_kb_contour(C,params)
  !
  allocate(AxB(0:max(L,N)))
  !
  !Ret. component
  !C^R(t,t')=A^R(t,t')*Bhf(t') + \int_{t'}^t ds A^R(t,s)*Breg^R(s,t')
  C%ret(N,1:N)=zero
  do j=1,N
     C%ret(N,j) = A%ret(N,j)*B%hf(j)
     AxB(0:)=zero
     do k=j,N
        AxB(k) = A%ret(N,k)*B%reg%ret(k,j)
     enddo
     C%ret(N,j) = C%ret(N,j) + dt*kb_trapz(AxB(0:),j,N)
  enddo
  !
  !Lmix. component
  !C^\lmix(t,tau')= A^\lmix(t,tau')*Bhf(0+) +
  !                 \int_0^{beta} ds A^\lmix(t,s)*Breg^M(s,tau') +
  !                 \int_0^{t} ds A^R(t,s)*Breg^\lmix(s,tau')
  !               = A^\lmix*Bhf + I1 + I2
  C%lmix(N,0:L)=zero
  do jtau=0,L
     !A^\lmix*Bhf:
     C%lmix(N,jtau) = A%lmix(N,jtau)*B%hf(1)
     !I1:
     AxB(0:)=zero
     do k=0,jtau
        AxB(k)=A%lmix(N,k)*B%reg%mats(L+k-jtau)
     end do
     C%lmix(N,jtau)=C%lmix(N,jtau)-dtau*kb_trapz(AxB(0:),0,jtau)
     AxB(0:)=zero
     do k=jtau,L
        AxB(k)=A%lmix(N,k)*B%reg%mats(k-jtau)
     end do
     C%lmix(N,jtau)=C%lmix(N,jtau)+dtau*kb_trapz(AxB(0:),jtau,L)
     !I2:
     AxB(0:)=zero
     do k=1,N
        AxB(k) = A%ret(N,k)*B%reg%lmix(k,jtau)
     enddo
     C%lmix(N,jtau) = C%lmix(N,jtau) + dt*kb_trapz(AxB(0:),1,N)
  enddo
  !
  !Less component
  !C^<(t,t') =  A^<(t,t')*conjg(Bhf(t'))
  !            -i\int_0^{beta} ds A^\lmix(t,s)*Breg^\rmix(s,t')
  !            + \int_0^{t'} ds A^<(t,s)*Breg^A(s,t')
  !            + \int_0^{t} ds A^R(t,s)*Breg^<(s,t')
  !          =  A^<*Bhf* + I1 + I2 + I3
  ! (t,t')=>(N,j) <==> Vertical side, with tip (j=1,N)
  C%less(N,1:N)=zero
  do j=1,N
     !A^<*Bhf*:
     C%less(N,j)=A%less(N,j)*conjg(B%hf(j))
     !I1:
     AxB(0:)=zero
     do k=0,L
        AxB(k)=A%lmix(N,k)*get_rmix(B%reg,k,j,L)
     end do
     C%less(N,j)=C%less(N,j)-xi*dtau*kb_trapz(AxB(0:),0,L)
     !I2:
     AxB(0:)=zero
     do k=1,j
        AxB(k)=A%less(N,k)*get_adv(B%reg,k,j)
     end do
     C%less(N,j)=C%less(N,j)+dt*kb_trapz(AxB(0:),1,j)
     !I3:
     AxB(0:)=zero
     do k=1,N
        AxB(k)=A%ret(N,k)*B%reg%less(k,j)
     end do
     C%less(N,j)=C%less(N,j)+dt*kb_trapz(AxB(0:),1,N)
  end do
  !
  ! (t,t`)=>(i,N) <==> Horizontal side, w/ no tip (i=1,N-1)
  C%less(1:N-1,N)=zero
  !
  if(present(dcoeff))then
     C%lmix(N,0:L) = dcoeff*C%lmix(N,0:L)
     C%less(N,1:N-1)=dcoeff*C%less(N,1:N-1)
     C%less(1:N,N)=dcoeff*C%less(1:N,N)
     C%ret(N,1:N)=dcoeff*C%ret(N,1:N)
  endif
  if(present(ccoeff))then
     C%lmix(N,0:L) = ccoeff*C%lmix(N,0:L)
     C%less(N,1:N-1)=ccoeff*C%less(N,1:N-1)
     C%less(1:N,N)=ccoeff*C%less(1:N,N)
     C%ret(N,1:N)=ccoeff*C%ret(N,1:N)
  endif
  deallocate(AxB)
end subroutine convolute_kb_contour_gf_sigma

!C(t,t')=[(Ahf*delta + Areg)*B](t,t'), with t=t_max && t'=0,t_max ; t_max_index==N
subroutine convolute_kb_contour_sigma_gf(A,B,C,params,dcoeff,ccoeff)
  type(kb_contour_sigma)              :: A
  type(kb_contour_gf)                 :: B
  type(kb_contour_gf)                 :: C
  type(kb_contour_params)             :: params
  real(8),optional                    :: dcoeff
  complex(8),optional                 :: ccoeff
  integer                             :: N,L
  real(8)                             :: dt,dtau
  complex(8),dimension(:),allocatable :: AxB
  integer                             :: i,j,k,itau,jtau
  logical                             :: checkA,checkB,checkC
  !
  N   = params%Nt      !<== work with the ACTUAL size of the contour
  L   = params%Ntau
  dt  = params%dt
  dtau= params%dtau
  !
  if(N==1) stop "convolute_kb_contour_sigma_gf error: called with N=1"
  if(  (.not.A%status).OR.&
       (.not.B%status).OR.&
       (.not.C%status))stop "contour_gf/convolute_kb_contour_gf: A,B,C not allocated"
  checkA=check_dimension_kb_contour(A,params)
  checkB=check_dimension_kb_contour(B,params)
  checkC=check_dimension_kb_contour(C,params)
  !
  allocate(AxB(0:max(L,N)))
  !
  !Ret. component
  !C^R(t,t')=Ahf(t)*B^R(t,t') + \int_{t'}^t ds Areg^R(t,s)*B^R(s,t')
  C%ret(N,1:N)=zero
  do j=1,N
     C%ret(N,j) = A%hf(N)*B%ret(N,j)
     AxB(0:)=zero
     do k=j,N
        AxB(k) = A%reg%ret(N,k)*B%ret(k,j)
     enddo
     C%ret(N,j) = C%ret(N,j) + dt*kb_trapz(AxB(0:),j,N)
  enddo
  !
  !Lmix. component
  !C^\lmix(t,tau')= Ahf(t)*B^\lmix(t,tau') +
  !                 \int_0^{beta} ds A^\lmix(t,s)*Breg^M(s,tau') +
  !                 \int_0^{t} ds A^R(t,s)*Breg^\lmix(s,tau')
  !               = Ahf*B^\lmix + I1 + I2
  C%lmix(N,0:L)=zero
  do jtau=0,L
     !Ahf*B^\lmix:
     C%lmix(N,jtau) = A%hf(N)*B%lmix(N,jtau)
     !I1: take care of the sign of (tau-tau').
     AxB(0:) = zero
     do k=0,jtau
        AxB(k)=A%reg%lmix(N,k)*B%mats(L+k-jtau)
     end do
     C%lmix(N,jtau)=C%lmix(N,jtau)-dtau*kb_trapz(AxB(0:),0,jtau)
     AxB(0:) = zero
     do k=jtau,L
        AxB(k)=A%reg%lmix(N,k)*B%mats(k-jtau)
     end do
     C%lmix(N,jtau)=C%lmix(N,jtau)+dtau*kb_trapz(AxB(0:),jtau,L)
     !I2:
     AxB(0:) = zero
     do k=1,N
        AxB(k) = A%reg%ret(N,k)*B%lmix(k,jtau)
     enddo
     C%lmix(N,jtau) = C%lmix(N,jtau) + dt*kb_trapz(AxB(0:),1,N)
  enddo
  !
  !Less component
  !C^<(t,t') =  Ahf(t)*B^<(t,t')
  !            -i\int_0^{beta} ds A^\lmix(t,s)*Breg^\rmix(s,t')
  !            + \int_0^{t'} ds A^<(t,s)*Breg^A(s,t')
  !            + \int_0^{t} ds A^R(t,s)*Breg^<(s,t')
  !          = Ahf*B^< + I1 + I2 + I3
  ! (t,t')=>(N,j) <==> Vertical side, with tip (j=1,N)
  C%less(N,1:N)=zero
  do j=1,N
     !Ahf*B^<:
     C%less(N,j)=A%hf(N)*B%less(N,j)
     !I1:
     AxB(0:) = zero
     do k=0,L
        AxB(k)=A%reg%lmix(N,k)*get_rmix(B,k,j,L)
     end do
     C%less(N,j)=C%less(N,j)-xi*dtau*kb_trapz(AxB(0:),0,L)
     !I2:
     AxB(0:) = zero
     do k=1,j
        AxB(k)=A%reg%less(N,k)*get_adv(B,k,j)
     end do
     C%less(N,j)=C%less(N,j)+dt*kb_trapz(AxB(0:),1,j)
     !I3:
     AxB(0:) = zero
     do k=1,N
        AxB(k)=A%reg%ret(N,k)*B%less(k,j)
     end do
     C%less(N,j)=C%less(N,j)+dt*kb_trapz(AxB(0:),1,N)
  end do
  !
  ! (t,t`)=>(i,N) <==> Horizontal side, w/ no tip (i=1,N-1)
  C%less(1:N-1,N)=zero
  !
  if(present(dcoeff))then
     C%lmix(N,0:L) = dcoeff*C%lmix(N,0:L)
     C%less(N,1:N-1)=dcoeff*C%less(N,1:N-1)
     C%less(1:N,N)=dcoeff*C%less(1:N,N)
     C%ret(N,1:N)=dcoeff*C%ret(N,1:N)
  endif
  if(present(ccoeff))then
     C%lmix(N,0:L) = ccoeff*C%lmix(N,0:L)
     C%less(N,1:N-1)=ccoeff*C%less(N,1:N-1)
     C%less(1:N,N)=ccoeff*C%less(1:N,N)
     C%ret(N,1:N)=ccoeff*C%ret(N,1:N)
  endif
  deallocate(AxB)
end subroutine convolute_kb_contour_sigma_gf

!C(t,t') = (a_1*a_2*...*a_n)(t,t')with t=t_max && t'=0,t_max; t_max_index==N
! a_i = contour_gf forall i=1,...,n
subroutine convolute_kb_contour_gf_gf_recursive(A,C,params,dcoeff,ccoeff)
  type(kb_contour_gf)                 :: A(:)
  type(kb_contour_gf)                 :: C
  type(kb_contour_gf)                 :: Knew,Kold
  type(kb_contour_params)             :: params
  real(8),optional                    :: dcoeff
  complex(8),optional                 :: ccoeff
  integer                             :: N,L
  integer                             :: i,j,k,itau,jtau,Na
  logical                             :: checkA,checkC
  !
  Na = size(A)
  !
  if(  (.not.C%status))stop "contour_gf/convolute_kb_contour_gf: C not allocated"
  do i=1,Na
     if(  (.not.A(i)%status))stop "contour_gf/convolute_kb_contour_gf: A(i) not allocated"
  enddo
  !
  call allocate_kb_contour_gf(Knew,params)
  call allocate_kb_contour_gf(Kold,params)
  !
  N   = params%Nt      !<== work with the ACTUAL size of the contour
  L   = params%Ntau
  !
  if(N==1) stop "convolute_kb_contour_gf_gf_recursive error: called with N=1"
  checkC=check_dimension_kb_contour(C,params%Ntime,L)
  do i=1,Na
     checkA=check_dimension_kb_contour(A(i),params%Ntime,L)
  enddo
  !
  !Perform the recursive convolution:
  Kold = A(1)
  do i=2,Na-1
     call convolute_kb_contour_gf(Kold,A(i),Knew,params)
     Kold=Knew
  enddo
  call convolute_kb_contour_gf(Knew,A(Na),C,params)
  !
  if(present(dcoeff))then
     C%lmix(N,0:L) = dcoeff*C%lmix(N,0:L)
     C%less(N,1:N-1)=dcoeff*C%less(N,1:N-1)
     C%less(1:N,N)=dcoeff*C%less(1:N,N)
     C%ret(N,1:N)=dcoeff*C%ret(N,1:N)
  endif
  if(present(ccoeff))then
     C%lmix(N,0:L) = ccoeff*C%lmix(N,0:L)
     C%less(N,1:N-1)=ccoeff*C%less(N,1:N-1)
     C%less(1:N,N)=ccoeff*C%less(1:N,N)
     C%ret(N,1:N)=ccoeff*C%ret(N,1:N)
  endif
  call deallocate_kb_contour_gf(Knew)
  call deallocate_kb_contour_gf(Kold)
  !
end subroutine convolute_kb_contour_gf_gf_recursive

!C(t,t') = (a_1*a_2*...*a_n)(t,t')with t=t_max && t'=0,t_max; t_max_index==N
! a_i = contour_gf    for i=j_1,...,j_ng
! a_i = contour_sigma for i=k_1,...,k_ns
subroutine convolute_kb_contour_gf_sigma_recursive(G,S,mask,P,params,dcoeff,ccoeff)
  type(kb_contour_gf),dimension(:)    :: G     !array of contour_GF
  type(kb_contour_sigma),dimension(:) :: S     !array of contour_Sigma
  integer,dimension(:)                :: mask  !mask array to select contour_GF (0) over contour_Sigma (1)
  type(kb_contour_gf)                 :: P     !result
  type(kb_contour_params)             :: params
  real(8),optional                    :: dcoeff
  complex(8),optional                 :: ccoeff
  integer                             :: Ng,Ns,Ntot
  type(kb_contour_gf)                 :: Knew,Kold
  integer                             :: N,L
  integer                             :: i,j,k,ig,is
  logical                             :: checkG,checkP,checkS
  !
  Ng   = size(G)
  Ns   = size(S)
  Ntot = size(Mask)
  !
  N   = params%Nt      !<== work with the ACTUAL size of the contour
  L   = params%Ntau
  !
  if(Ntot/=Ng+Ns)stop "convolute_kb_contour_gf_sigma_recursive error: Ntot != Ns + Ng"
  if(N==1)stop "convolute_kb_contour_gf_sigma_recursive error: call with N=1"
  do i=1,Ng
     if(  (.not.G(i)%status) )stop "convolute_kb_contour_gf_sigma_recursive error: G(i) not allocated"
  enddo
  do i=1,Ns
     if(  (.not.S(i)%status) )stop "convolute_kb_contour_gf_sigma_recursive error: S(i) not allocated"
  enddo
  if(  (.not.P%status) )stop "convolute_kb_contour_gf_sigma_recursive error: P not allocated"
  do i=1,Ng
     checkG=check_dimension_kb_contour(G(i),params)
  enddo
  do i=1,Ns
     checkS=check_dimension_kb_contour(S(i),params)
  enddo
  checkP=check_dimension_kb_contour(P,params)
  !
  call allocate_kb_contour_gf(Knew,params)
  call allocate_kb_contour_gf(Kold,params)
  !
  !check that mask does not contain 2 consecutive ones:
  j=mask(1)
  do i=2,Ntot
     if(j*mask(i)/=0)then
        print*,"convolute_kb_contour_gf_sigma_recursive error: mask has 2 consecutives ones at",i
        stop
     endif
     j=mask(i)
  enddo
  !
  !Perform the recursive convolution:
  !get the first product P1 = g1/s1 * g2/s2 (can not be s1*s2 though)
  !this step features 3 cases: i) g1*g2, ii) g1*s2, iii) s1*g2
  is=1
  ig=1
  if(mask(1)==0.AND.mask(2)==0)then
     ig=ig+1
     call convolute_kb_contour_gf(G(1),G(ig),Kold,params)
  elseif(mask(1)==1.AND.mask(2)==0)then
     ig=ig+1
     call convolute_kb_contour_gf(S(1),G(ig),Kold,params)
  elseif(mask(1)==0.AND.mask(2)==1)then
     is=is+1
     call convolute_kb_contour_gf(G(1),S(is),Kold,params)
  else
     print*,"convolute_kb_contour_gf_sigma_recursive error: mask(1)==mask(2)==1"
     stop
  endif
  !
  do i=2,Ntot-1
     if(mask(i)==0)then
        ig=ig+1
        call convolute_kb_contour_gf(Kold,G(ig),Knew,params)
     elseif(mask(i)==1)then
        is=is+1
        call convolute_kb_contour_gf(Kold,S(is),Knew,params)
     else
        print*,"convolute_kb_contour_gf_sigma_recursive error: mask(i)!=1.OR.0"
        stop
     endif
     Kold = Knew
  enddo
  if(mask(Ntot)==0)then
     ig=ig+1
     call convolute_kb_contour_gf(Kold,G(ig),P,params)
  elseif(mask(Ntot)==1)then
     is=is+1
     call convolute_kb_contour_gf(Kold,S(is),P,params)
  else
     print*,"convolute_kb_contour_gf_sigma_recursive error: mask(Ntot)!=1.OR.0"
     stop
  endif
  !
  if(ig/=Ng.OR.is/=Ns)stop "convolute_kb_contour_gf_sigma_recursive error: ig!=Ng OR is!=Ns"
  !
  if(present(dcoeff))then
     P%lmix(N,0:L) = dcoeff*P%lmix(N,0:L)
     P%less(N,1:N-1)=dcoeff*P%less(N,1:N-1)
     P%less(1:N,N)=dcoeff*P%less(1:N,N)
     P%ret(N,1:N)=dcoeff*P%ret(N,1:N)
  endif
  if(present(ccoeff))then
     P%lmix(N,0:L) = ccoeff*P%lmix(N,0:L)
     P%less(N,1:N-1)=ccoeff*P%less(N,1:N-1)
     P%less(1:N,N)=ccoeff*P%less(1:N,N)
     P%ret(N,1:N)=ccoeff*P%ret(N,1:N)
  endif
  call deallocate_kb_contour_gf(Knew)
  call deallocate_kb_contour_gf(Kold)
  !
end subroutine convolute_kb_contour_gf_sigma_recursive

!C(t,t')=(A*B)(t,t'), with t=t_max && t'=0,t_max; t_max_index==N
! The case A(t,t')=A(t)delta(t,t')
subroutine convolute_kb_contour_gf_delta_left(A,B,C,params)
  type(kb_contour_gf)                 :: B,C
  complex(8),dimension(:)             :: A
  type(kb_contour_params)             :: params
  integer                             :: N,L
  integer                             :: i,j,k,itau,jtau
  logical                             :: checkB,checkC
  if(  (.not.B%status).OR.&
       (.not.C%status))stop "convolute_kb_contour_gf_delta_left error: B,C not allocated"
  N   = params%Nt      !<== work with the ACTUAL size of the contour
  L   = params%Ntau
  !
  if(size(A)<N)stop "convolute_kb_contour_gf_delta_left error: size(A) < N"
  checkB=check_dimension_kb_contour(B,params%Ntime,L)
  checkC=check_dimension_kb_contour(C,params%Ntime,L)
  !
  ! Matsubara
  if (N==1)C%mats = A(1)*B%mats
  !Ret. component
  do j=1,N
     C%ret(n,j) = A(n)*B%ret(n,j)
  enddo
  !Less. component
  do j=1,N
     C%less(n,j) = A(n)*B%less(n,j)
  enddo
  !Lmix. component
  do jtau=0,L
     C%lmix(n,jtau) = A(n)*B%lmix(n,jtau)
  enddo
end subroutine convolute_kb_contour_gf_delta_left

!C(t,t')=(A*B)(t,t'), with t=t_max && t'=0,t_max; t_max_index==N
! The case B(t,t')=B(t)delta(t,t')
subroutine convolute_kb_contour_gf_delta_right(A,B,C,params)
  type(kb_contour_gf)                 :: A,C
  complex(8),dimension(:)             :: B
  type(kb_contour_params)             :: params
  integer                             :: N,L
  integer                             :: i,j,k,itau,jtau
  logical                             :: checkA,checkC
  if(  (.not.A%status).OR.&
       (.not.C%status))stop "convolute_kb_contour_gf_delta_right error: A,C not allocated"
  N   = params%Nt      !<== work with the ACTUAL size of the contour
  L   = params%Ntau
  !
  checkA=check_dimension_kb_contour(A,params%Ntime,L)
  if(size(B)<N)stop "convolute_kb_contour_gf_delta_right error: size(B) < N"
  checkC=check_dimension_kb_contour(C,params%Ntime,L)
  !
  ! Matsubara
  if (N==1)C%mats(0:) = A%mats(0:)*B(1)
  !Ret. component
  do j=1,N
     C%ret(n,j) = A%ret(n,j)*B(j)
  enddo
  !Less. component
  do j=1,N
     C%less(n,j) = A%less(n,j)*B(j)
  enddo
  !Lmix. component
  do jtau=0,L
     C%lmix(N,jtau) = A%lmix(N,jtau)*B(1)
  enddo
end subroutine convolute_kb_contour_gf_delta_right


module type_blockjacobi
#include <messenger.h>
    use mod_kinds,              only: rk, ik
    use mod_inv,                only: inv
    use atype_matrixsolver,     only: matrixsolver_t
    use type_preconditioner,    only: preconditioner_t
    use type_blockmatrix,       only: blockmatrix_t
    use type_blockvector

    !> Direct solve of linear system of equations via
    !! inversion of A in Ax=b
    !!
    !!  @author Nathan A. Wukie
    !!
    !-------------------------------------------
    type, public, extends(matrixsolver_t) :: blockjacobi_t

    contains

        procedure   :: solve
    end type

contains

    !> Solution routine
    !!
    !!  @author Nathan A. Wukie
    !!
    !!
    !!
    !--------------------------------------------------------------
    subroutine solve(self,A,x,b,M)
        class(blockjacobi_t),       intent(inout)           :: self
        type(blockmatrix_t),        intent(inout)           :: A
        type(blockvector_t),        intent(inout)           :: x
        type(blockvector_t),        intent(inout)           :: b
        class(preconditioner_t),    intent(inout), optional :: M

        type(blockvector_t)                     :: r, diff, xold
        integer(ik) :: iparent, ierr
        real(rk)    :: res

        integer(ik) :: i

        print*, '           Matrix Solver: '

        ! Replace the block diagonal D with inverse of D
        do ielem = 1,size(A%lblks,1)
            A%lblks(ielem,7)%mat = inv(A%lblks(ielem,7)%mat)
        end do

        xold = x
        call x%clear()
        call xold%clear()

        self%niter = 0
        res = 1._rk
        do while (res > self%tol)

            ! form b - Ax, except for diagonal
            r = b
            do ielem = 1,size(x%lvecs)
                do iblk = 1,6   ! don't multiply diagonal

                    if (allocated(A%lblks(ielem,iblk)%mat)) then
                        iparent = A%lblks(ielem,iblk)%parent()
                        r%lvecs(ielem)%vec = r%lvecs(ielem)%vec - matmul(A%lblks(ielem,iblk)%mat,xold%lvecs(iparent)%vec)
                    end if

                end do
            end do

            ! Multiply by inverse of block diagonal in A. This was already inverted
            ! and restored to the block diagonal location in A.
            do ielem = 1,size(x%lvecs)
                x%lvecs(ielem)%vec = matmul(A%lblks(ielem,7)%mat,r%lvecs(ielem)%vec)
            end do

            diff = x - xold
            res = diff%norm()

            if (self%report) then
                print*, res
            end if

            xold = x    ! update solution

            !
            ! Update iteration counter
            !
            self%niter = self%niter + 1

        end do ! res > self%tol

    end subroutine solve

end module type_blockjacobi


      SUBROUTINE ECCODR(FPQR)
      DIMENSION FPQR(25,25,25)
      INTEGER P,Q,R
      DIMENSION REC(73)
      DO 150 P=1,N4MAX,2
         QM2=-ONE
         DO 140 Q=1,N4MAX,2
            DO 130 R=1,N4MAX,2
               IF(P.GT.1) THEN
                  FPQR(P,Q,R)= QM2*FPQR(P,Q-2,R)*REC(P+Q-2+R)
               END IF
  130       RM2= RM2+TWO
  140    QM2= QM2+TWO
  150 PM2= PM2+TWO
      END