MODULE traldf_lap_blp
  USE oce
  USE dom_oce
  USE ldftra
  USE traldf_iso
  USE traldf_triad
  USE diaptr
  USE diaar5
  USE trc_oce
  USE zpshde
  USE in_out_manager
  USE iom
  USE lbclnk
  USE lib_mpp
  USE timing
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: tra_ldf_lap
  PUBLIC :: tra_ldf_blp
  LOGICAL :: l_ptr
  LOGICAL :: l_hst
  CONTAINS
  SUBROUTINE tra_ldf_lap(kt, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, ptb, pta, kjpt, kpass)
    INTEGER, INTENT(IN   ) :: kt
    INTEGER, INTENT(IN   ) :: kit000
    CHARACTER(LEN = 3), INTENT(IN   ) :: cdtype
    INTEGER, INTENT(IN   ) :: kjpt
    INTEGER, INTENT(IN   ) :: kpass
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN   ) :: pahu, pahv
    REAL(KIND = wp), DIMENSION(jpi, jpj, kjpt), INTENT(IN   ) :: pgu, pgv
    REAL(KIND = wp), DIMENSION(jpi, jpj, kjpt), INTENT(IN   ) :: pgui, pgvi
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, kjpt), INTENT(IN   ) :: ptb
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, kjpt), INTENT(INOUT) :: pta
    INTEGER :: ji, jj, jk, jn
    REAL(KIND = wp) :: zsign
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: ztu, ztv, zaheeu, zaheev
    IF (kt == nit000 .AND. lwp) THEN
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) 'tra_ldf_lap : iso-level laplacian diffusion on ', cdtype, ', pass=', kpass
      WRITE(numout, FMT = *) '~~~~~~~~~~~ '
    END IF
    l_hst = .FALSE.
    l_ptr = .FALSE.
    IF (cdtype == 'TRA' .AND. ln_diaptr) l_ptr = .TRUE.
    IF (cdtype == 'TRA' .AND. (iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. iom_use("uadv_salttr") .OR. iom_use("vadv_salttr"))) l_hst = .TRUE.
    IF (kpass == 1) THEN
      zsign = 1._wp
    ELSE
      zsign = - 1._wp
    END IF
    !$ACC KERNELS
    DO jk = 1, jpkm1
      DO jj = 1, jpjm1
        DO ji = 1, jpim1
          zaheeu(ji, jj, jk) = zsign * pahu(ji, jj, jk) * e2_e1u(ji, jj) * e3u_n(ji, jj, jk)
          zaheev(ji, jj, jk) = zsign * pahv(ji, jj, jk) * e1_e2v(ji, jj) * e3v_n(ji, jj, jk)
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    DO jn = 1, kjpt
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 1, jpjm1
          DO ji = 1, jpim1
            ztu(ji, jj, jk) = zaheeu(ji, jj, jk) * (ptb(ji + 1, jj, jk, jn) - ptb(ji, jj, jk, jn))
            ztv(ji, jj, jk) = zaheev(ji, jj, jk) * (ptb(ji, jj + 1, jk, jn) - ptb(ji, jj, jk, jn))
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      IF (ln_zps) THEN
        !$ACC KERNELS
        DO jj = 1, jpjm1
          DO ji = 1, jpim1
            ztu(ji, jj, mbku(ji, jj)) = zaheeu(ji, jj, mbku(ji, jj)) * pgu(ji, jj, jn)
            ztv(ji, jj, mbkv(ji, jj)) = zaheev(ji, jj, mbkv(ji, jj)) * pgv(ji, jj, jn)
          END DO
        END DO
        !$ACC END KERNELS
        IF (ln_isfcav) THEN
          !$ACC KERNELS
          DO jj = 1, jpjm1
            DO ji = 1, jpim1
              IF (miku(ji, jj) > 1) ztu(ji, jj, miku(ji, jj)) = zaheeu(ji, jj, miku(ji, jj)) * pgui(ji, jj, jn)
              IF (mikv(ji, jj) > 1) ztv(ji, jj, mikv(ji, jj)) = zaheev(ji, jj, mikv(ji, jj)) * pgvi(ji, jj, jn)
            END DO
          END DO
          !$ACC END KERNELS
        END IF
      END IF
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            pta(ji, jj, jk, jn) = pta(ji, jj, jk, jn) + (ztu(ji, jj, jk) - ztu(ji - 1, jj, jk) + ztv(ji, jj, jk) - ztv(ji, jj - 1, jk)) / (e1e2t(ji, jj) * e3t_n(ji, jj, jk))
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      IF ((kpass == 1 .AND. .NOT. ln_traldf_blp) .OR. (kpass == 2 .AND. ln_traldf_blp)) THEN
        IF (l_ptr) CALL dia_ptr_hst(jn, 'ldf', - ztv(:, :, :))
        IF (l_hst) CALL dia_ar5_hst(jn, 'ldf', - ztu(:, :, :), - ztv(:, :, :))
      END IF
    END DO
  END SUBROUTINE tra_ldf_lap
  SUBROUTINE tra_ldf_blp(kt, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, ptb, pta, kjpt, kldf)
    INTEGER, INTENT(IN   ) :: kt
    INTEGER, INTENT(IN   ) :: kit000
    CHARACTER(LEN = 3), INTENT(IN   ) :: cdtype
    INTEGER, INTENT(IN   ) :: kjpt
    INTEGER, INTENT(IN   ) :: kldf
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN   ) :: pahu, pahv
    REAL(KIND = wp), DIMENSION(jpi, jpj, kjpt), INTENT(IN   ) :: pgu, pgv
    REAL(KIND = wp), DIMENSION(jpi, jpj, kjpt), INTENT(IN   ) :: pgui, pgvi
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, kjpt), INTENT(IN   ) :: ptb
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, kjpt), INTENT(INOUT) :: pta
    INTEGER :: ji, jj, jk, jn
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, kjpt) :: zlap
    REAL(KIND = wp), DIMENSION(jpi, jpj, kjpt) :: zglu, zglv
    REAL(KIND = wp), DIMENSION(jpi, jpj, kjpt) :: zgui, zgvi
    IF (kt == kit000 .AND. lwp) THEN
      WRITE(numout, FMT = *)
      SELECT CASE (kldf)
      CASE (np_blp)
        WRITE(numout, FMT = *) 'tra_ldf_blp : iso-level   bilaplacian operator on ', cdtype
      CASE (np_blp_i)
        WRITE(numout, FMT = *) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (Standard)'
      CASE (np_blp_it)
        WRITE(numout, FMT = *) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (triad)'
      END SELECT
      WRITE(numout, FMT = *) '~~~~~~~~~~~'
    END IF
    !$ACC KERNELS
    zlap(:, :, :, :) = 0._wp
    !$ACC END KERNELS
    SELECT CASE (kldf)
    CASE (np_blp)
      CALL tra_ldf_lap(kt, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, ptb, zlap, kjpt, 1)
    CASE (np_blp_i)
      CALL tra_ldf_iso(kt, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, ptb, ptb, zlap, kjpt, 1)
    CASE (np_blp_it)
      CALL tra_ldf_triad(kt, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, ptb, ptb, zlap, kjpt, 1)
    END SELECT
    CALL lbc_lnk(zlap(:, :, :, :), 'T', 1.)
    IF (ln_isfcav .AND. ln_zps) THEN
      CALL zps_hde_isf(kt, kjpt, zlap, zglu, zglv, zgui, zgvi)
    ELSE IF (ln_zps) THEN
      CALL zps_hde(kt, kjpt, zlap, zglu, zglv)
    END IF
    SELECT CASE (kldf)
    CASE (np_blp)
      CALL tra_ldf_lap(kt, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, pta, kjpt, 2)
    CASE (np_blp_i)
      CALL tra_ldf_iso(kt, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, ptb, pta, kjpt, 2)
    CASE (np_blp_it)
      CALL tra_ldf_triad(kt, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, ptb, pta, kjpt, 2)
    END SELECT
  END SUBROUTINE tra_ldf_blp
END MODULE traldf_lap_blp


C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 04.03.02/colnam                         *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE COLNAM (U,V, INCODE, CDEX, CNAM)

C  COLNAM returns the English phrase corresponding to the color
C  indicated by the u-v CIELUV coordinates (luminance is ignored).
C  COLNAM returns "none" for locations near borders or outside the
C  color region.
C
C  Input parameters:
C    U,V    : the u', v' CIELUV coordinates
C  Output parameters:
C    INCODE : status of u', v' point: 1-inside color region,
C             2-on edge of color region, 3-outside color region
C    CDEX   : integer identifier of region; 0 if none
C    CNAM   : English description of color, taken from CIELUV diagram

      INTEGER    NUMREG
      PARAMETER (NUMREG=20)
      INTEGER    REGDX(NUMREG), INCODE, PRV, THIS, IX, INAREA, CDEX

      REAL       U,V, REGX(226),REGY(226)

      CHARACTER  CNAM*(*), REGLBL(NUMREG)*16

C  label for 20 CIELUV color regions
      DATA REGLBL / 'purple', 'purplish blue', 'blue', 'greenish blue',
     1     'bluish green', 'green', 'yellowish green', 'yellow green',
     1     'greenish yellow', 'yellow', 'orange yellow', 'orange',
     1     'reddish orange', 'red', 'purplish red', 'reddish purple',
     1     'yellowish pink', 'pink', 'purplish pink', 'white' /

C  list of end-points of color regions
      DATA  REGDX /  15, 33, 47, 58, 69, 81, 94,101,107,113,117,123,
     1              133,146,159,169,178,189,200,226 /

      DATA (REGX(IX), IX=1,90) /
     1 .25484,.23237,.21495,.20258,.19648,.19294,.19700,.20583,.22099,
     2 .23745,.25769,.29662,.32923,.36687,.40575,.18325,.17465,.16730,
     3 .16249,.16390,.17037,.17809,.18313,.19195,.18800,.18660,.18895,
     4 .20126,.20990,.22359,.23853,.25103,.20456,.07929,.09838,.12126,
     5 .14667,.15545,.17306,.16407,.15752,.15980,.16466,.17698,.14187,
     6 .11304,.09178,.03059,.06726,.10519,.13300,.13418,.14292,.12893,
     7 .10735,.08954,.07553,.05056,.00086,.06389,.10422,.14200,.13564,
     8 .13303,.10774,.06856,.02810,.01691,.00574,.00872,.05280,.09182,
     9 .13207,.15469,.14581,.11180,.06265,.02862,.00089,.00100,.00490,
     O .13108,.15366,.17496,.16736,.15850,.13713,.10443,.05786,.01379 /
      DATA (REGX(IX), IX=91,226) /
     1 .02390,.03528,.05294,.08319,.20041,.19780,.19772,.18002,.16874,
     2 .15370,.13739,.22436,.21546,.21036,.20278,.20285,.20419,.26973,
     3 .25200,.23560,.21667,.22429,.23066,.30124,.27216,.25830,.27603,
     4 .35796,.32258,.29858,.28600,.27719,.30754,.52182,.47515,.42344,
     5 .38305,.36665,.35659,.34274,.33014,.35035,.36930,.59218,.54429,
     6 .50143,.43964,.38415,.38294,.37419,.40827,.44612,.48648,.53188,
     7 .57476,.63148,.48565,.44540,.40387,.36360,.33843,.35490,.37138,
     8 .38028,.38413,.41314,.46484,.52157,.58837,.40828,.38070,.32299,
     9 .28910,.30933,.33337,.36987,.41518,.45670,.48311,.35907,.32877,
     O .28964,.26439,.26949,.29477,.31877,.33389,.35279,.37525,.33365,
     1 .28574,.25673,.26184,.28078,.31108,.36409,.37541,.37914,.37908,
     2 .28534,.26400,.23136,.24655,.25418,.28823,.33615,.37397,.35873,
     3 .33720,.31189,.25519,.24000,.22607,.20334,.18441,.16554,.15048,
     4 .14297,.13924,.13807,.14194,.15973,.17365,.20149,.22169,.23935,
     5 .25449,.26709,.28219,.28974,.26446,.25936,.25297,.24026,.22631,
     6 .24012 /

      DATA (REGY(IX), IX=1,90) /
     1 .01485,.06971,.12720,.18469,.23305,.29317,.35723,.35855,.36381,
     2 .37822,.39395,.35219,.30911,.26212,.21122,.08662,.14150,.19247,
     3 .24998,.28397,.32450,.35981,.35851,.35722,.31800,.28401,.24218,
     4 .17162,.12719,.08146,.03574,.00962,.05659,.26028,.29953,.34271,
     5 .38720,.37415,.36241,.32449,.26696,.21076,.16501,.09576,.14536,
     6 .18845,.23024,.37653,.39751,.41980,.43424,.41594,.39373,.36756,
     7 .33353,.29690,.26550,.32558,.50458,.49685,.48908,.47608,.46300,
     8 .44208,.42765,.40666,.38306,.42225,.46537,.57518,.55827,.54004,
     9 .51266,.49441,.48263,.49302,.50208,.50855,.51111,.53856,.56602,
     O .57933,.54931,.51667,.50881,.49964,.51660,.53876,.56220,.57911 /
      DATA (REGY(IX), IX=91,226) /
     1 .58567,.59222,.59226,.58708,.56900,.54808,.52978,.51929,.53626,
     2 .55846,.57934,.56512,.54811,.53503,.53240,.54940,.56901,.55737,
     3 .54034,.54031,.53766,.54944,.56514,.55220,.53515,.53904,.55700,
     4 .54315,.52871,.51951,.52602,.53124,.55090,.51862,.51853,.51713,
     5 .51183,.50918,.51701,.52352,.52611,.53268,.54056,.45339,.46245,
     6 .46760,.47141,.47392,.48568,.50397,.50926,.51194,.51202,.51080,
     7 .51088,.50183,.31594,.34070,.36415,.38499,.39802,.41504,.43599,
     8 .45300,.46738,.46744,.46492,.45980,.44816,.21253,.25300,.32609,
     9 .36525,.37574,.39409,.37585,.35241,.32896,.31071,.50739,.50087,
     O .49304,.48783,.49957,.51261,.52174,.51913,.51261,.45652,.46174,
     1 .46435,.46435,.48000,.48522,.49304,.50217,.49304,.48130,.46696,
     2 .37043,.39522,.43043,.44478,.45913,.45783,.45522,.45130,.42652,
     3 .40435,.38478,.39913,.38609,.37304,.36522,.36391,.37435,.39261,
     4 .40565,.42000,.44087,.46174,.49304,.50478,.52565,.52957,.53217,
     5 .53217,.52826,.52174,.51652,.50478,.49043,.46957,.44739,.43043,
     6 .41478 /

      PRV = 0
      DO 400 IX = 1,NUMREG
         THIS   = REGDX(IX)
         INCODE = INAREA (U,V, THIS-PRV,REGX(PRV+1),REGY(PRV+1))
         PRV    = THIS
         IF (INCODE .EQ. 1 .OR. INCODE .EQ. 2) THEN
            CDEX = IX
            CNAM = REGLBL(IX)
            RETURN
         ENDIF
400   CONTINUE
      CDEX = 0
      CNAM = 'none'

      END

C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 04.03.02/sqgrmk                         *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE SQGRMK (START, FINISH, STEP)

C  SQGRMK draws a square grid of polymarkers.  They are drawn one
C  row at a time to avoid array overflow.

C  Input parameters:
C    START  : First x and y locations
C    FINISH : Upper limit for x and y locations
C    STEP   : Distance between markers

      INTEGER    SIZ, ARRSIZ
      PARAMETER (ARRSIZ=200)

      REAL    XLOC,YLOC, START, FINISH, STEP, XA(ARRSIZ),YA(ARRSIZ)

      IF ((FINISH-START)/STEP .GT. ARRSIZ) THEN
         CALL UNMSG ('Number of polymarkers exceeds array size in ' //
     1               'SQGRMK.')
      ENDIF

      DO 215 XLOC = START, FINISH, STEP
         SIZ = 0
         DO 210 YLOC = START, FINISH, STEP
            SIZ = SIZ + 1
            XA(SIZ) = XLOC
            YA(SIZ) = YLOC
210      CONTINUE
         CALL PPM (SIZ, XA, YA)
215   CONTINUE

      END


      Program DRIVER
c**************************************************************************
c     This is the driver for the whole calculation
c**************************************************************************
      use extra_weights
      use mint_module
      use FKSParams
      implicit none
C
C     CONSTANTS
C
      double precision zero
      parameter       (ZERO = 0d0)
      include 'nexternal.inc'
      include 'genps.inc'
C
C     LOCAL
C
      integer i,j,k,l,l1,l2,kchan
      character*130 buf
c
c     Global
c
cc
      include 'run.inc'
      include 'coupl.inc'

c     Vegas stuff
      integer         nndim
      common/tosigint/nndim

      real*8 sigint
      external sigint

      integer irestart
      logical savegrid

      logical            flat_grid
      common/to_readgrid/flat_grid                !Tells if grid read from file

      integer i_momcmp_count
      double precision xratmax
      common/ccheckcnt/i_momcmp_count,xratmax

      character*4      abrv
      common /to_abrv/ abrv
      integer n_mp, n_disc
      integer ixi_i,iphi_i,iy_ij,vn
      logical putonshell
      logical unwgt
      double precision evtsgn
      common /c_unwgt/evtsgn,unwgt

      logical SHsep
      logical Hevents
      common/SHevents/Hevents
      character*10 dum
c statistics for MadLoop
      integer ntot,nsun,nsps,nups,neps,n100,nddp,nqdp,nini,n10,n1(0:9)
      common/ups_stats/ntot,nsun,nsps,nups,neps,n100,nddp,nqdp,nini,n10,n1

      double precision virtual_over_born
      common/c_vob/virtual_over_born
      include 'orders.inc'

c timing statistics
      include "timing_variables.inc"
      real*4 tOther, tTot

c PineAPPL
      logical pineappl
      common /for_pineappl/ pineappl
c stats for granny_is_res
      double precision deravg,derstd,dermax,xi_i_fks_ev_der_max
     &     ,y_ij_fks_ev_der_max
      integer ntot_granny,derntot,ncase(0:6)
      common /c_granny_counters/ ntot_granny,ncase,derntot,deravg,derstd
     &     ,dermax,xi_i_fks_ev_der_max,y_ij_fks_ev_der_max

      logical useitmax
      common/cuseitmax/useitmax

C-----
C  BEGIN CODE
C-----
c Write the process PID in the log.txt files (i.e., to the screen)
      write (*,*) getpid()

      useitmax=.false. ! to be overwritten in open_output_files.f if need be
c
c     Setup the timing variable
c
      call cpu_time(tBefore)
      fixed_order=.true.
      nlo_ps=.false.

c     Read general MadFKS parameters
c
      call FKSParamReader(paramFileName,.TRUE.,.FALSE.)
      min_virt_fraction_mint=min_virt_fraction
      do kchan=1,maxchannels
         do i=0,n_ave_virt
            average_virtual(i,kchan)=0d0
         enddo
         virtual_fraction(kchan)=max(virt_fraction,min_virt_fraction)
      enddo
      n_ord_virt=amp_split_size

c
c     Read process number
c
      ntot_granny=0
      derntot=0
      do i=0,6
         ncase(i)=0
      enddo
      ntot=0
      nsun=0
      nsps=0
      nups=0
      neps=0
      n100=0
      nddp=0
      nqdp=0
      nini=0
      n10=0
      do i=0,9
        n1(i)=0
      enddo

      call setrun                !Sets up run parameters
      call setpara('param_card.dat')   !Sets up couplings and masses
      call setcuts               !Sets up cuts and particle masses
      call printout              !Prints out a summary of paramaters
      call run_printout          !Prints out a summary of the run settings
      call initcluster
      call check_amp_split
c
c     Get user input
c
      write(*,*) "getting user params"
      call get_user_params(ncalls0,itmax,imode)
      if(imode.eq.0)then
        flat_grid=.true.
      else
        flat_grid=.false.
      endif
      ndim = 3*(nexternal-nincoming)-4
      if (abs(lpp(1)) .ge. 1) ndim=ndim+1
      if (abs(lpp(2)) .ge. 1) ndim=ndim+1
      nndim=ndim
c Don't proceed if muF1#muF2 (we need to work out the relevant formulae
c at the NLO)
      if( ( fixed_fac_scale .and.
     #       (muF1_over_ref*muF1_ref_fixed) .ne.
     #       (muF2_over_ref*muF2_ref_fixed) ) .or.
     #    ( (.not.fixed_fac_scale) .and.
     #      muF1_over_ref.ne.muF2_over_ref ) )then
        write(*,*)'NLO computations require muF1=muF2'
        stop
      endif
      write(*,*) "about to integrate ", ndim,ncalls0,itmax
c PineAPPL
      if (imode.eq.0) pineappl=.False. ! overwrite when starting completely fresh
      if(pineappl) then
         write(6,*) "Initializing PineAPPL ..."
c     Set flavor map, starting from all possible
c     parton lumi configurations defined in initial_states_map.dat
         call setup_flavourmap
c     Fill the number of combined matrix elements for given initial state luminosity
         call find_iproc_map
         write(6,*) "   ... done."
      endif
      if (abrv(1:4).eq.'virt') then
         only_virt=.true.
      else
         only_virt=.false.
      endif
c     Prepare the MINT folding
      do j=1,ndimmax
         if (j.le.ndim) then
            ifold(j)=1
         else
            ifold(j)=0
         endif
      enddo
      ifold_energy=ndim-2
      ifold_yij=ndim-1
      ifold_phi=ndim
c
      i_momcmp_count=0
      xratmax=0.d0
      unwgt=.false.
      call addfil(dum)
      if (imode.eq.-1.or.imode.eq.0) then
         if(imode.eq.0)then
c Don't safe the reweight information when just setting up the grids.
            doreweight=.false.
            do_rwgt_scale=.false.
            do_rwgt_pdf=.false.
         else
            doreweight=do_rwgt_scale.or.do_rwgt_pdf.or.store_rwgt_info
         endif
c
         write (*,*) 'imode is ',imode

         if (ickkw.eq.-1) then
            min_virt_fraction=1d0
            do kchan=1,nchans
               virtual_fraction(kchan)=1d0
            enddo
         endif
         call mint(sigint)
         call topout
         call deallocate_weight_lines
c
      else
         write (*,*) 'Unknown imode',imode
         stop
      endif

      if (ntot.ne.0) then
         write(*,*) "Satistics from MadLoop:"
         write(*,*)
     &        "  Total points tried:                              ",ntot
         write(*,*)
     &        "  Stability unknown:                               ",nsun
         write(*,*)
     &        "  Stable PS point:                                 ",nsps
         write(*,*)
     &        "  Unstable PS point (and rescued):                 ",nups
         write(*,*)
     &        "  Exceptional PS point (unstable and not rescued): ",neps
         write(*,*)
     &        "  Double precision used:                           ",nddp
         write(*,*)
     &        "  Quadruple precision used:                        ",nqdp
         write(*,*)
     &        "  Initialization phase-space points:               ",nini
         write(*,*)
     &        "  Unknown return code (100):                       ",n100
         write(*,*)
     &        "  Unknown return code (10):                        ",n10
         write(*,*)
     &        "  Unit return code distribution (1):               "
         do j=0,9
           if (n1(j).ne.0) then
              write(*,*) "#Unit ",j," = ",n1(j)
           endif
         enddo
      endif

      write (*,*) 'counters for the granny resonances'
      write (*,*) 'ntot     ',ntot_granny
      if (ntot_granny.gt.0) then
         do i=0,6
            write (*,*) '% icase ',i,' : ',ncase(i)/dble(ntot_granny)
         enddo
         write (*,*) 'average,std dev. and max of derivative:',deravg
     &        ,sqrt(abs(derstd-deravg**2)),dermax
         write (*,*)
     &        'and xi_i_fks and y_ij_fks corresponding to max of der.',
     &        xi_i_fks_ev_der_max,y_ij_fks_ev_der_max
      endif
      call cpu_time(tAfter)
      tTot = tAfter-tBefore
      tOther = tTot - (tBorn+tGenPS+tReal+tCount+tIS+tFxFx+tf_nb+tf_all
     &     +t_as+tr_s+tr_pdf+t_plot+t_cuts+t_MC_subt+t_isum+t_p_unw
     $     +t_write)
      write(*,*) 'Time spent in Born : ',tBorn
      write(*,*) 'Time spent in PS_Generation : ',tGenPS
      write(*,*) 'Time spent in Reals_evaluation: ',tReal
      write(*,*) 'Time spent in MCsubtraction : ',t_MC_subt
      write(*,*) 'Time spent in Counter_terms : ',tCount
      write(*,*) 'Time spent in Integrated_CT : ',tIS-tOLP
      write(*,*) 'Time spent in Virtuals : ',tOLP
      write(*,*) 'Time spent in FxFx_cluster : ',tFxFx
      write(*,*) 'Time spent in Nbody_prefactor : ',tf_nb
      write(*,*) 'Time spent in N1body_prefactor : ',tf_all
      write(*,*) 'Time spent in Adding_alphas_pdf : ',t_as
      write(*,*) 'Time spent in Reweight_scale : ',tr_s
      write(*,*) 'Time spent in Reweight_pdf : ',tr_pdf
      write(*,*) 'Time spent in Filling_plots : ',t_plot
      write(*,*) 'Time spent in Applying_cuts : ',t_cuts
      write(*,*) 'Time spent in Sum_ident_contr : ',t_isum
      write(*,*) 'Time spent in Pick_unwgt : ',t_p_unw
      write(*,*) 'Time spent in Write_events : ',t_write
      write(*,*) 'Time spent in Other_tasks : ',tOther
      write(*,*) 'Time spent in Total : ',tTot

      open (unit=12, file='res.dat',status='unknown')
      do kchan=0,nchans
         write (12,*)ans(1,kchan),unc(1,kchan),ans(2,kchan),unc(2,kchan)
     $        ,itmax,ncalls0,tTot
      enddo
      close(12)

      if(i_momcmp_count.ne.0)then
        write(*,*)'     '
        write(*,*)'WARNING: genps_fks code 555555'
        write(*,*)i_momcmp_count,xratmax
      endif

      end

      block data timing
c timing statistics
      include "timing_variables.inc"
      data tOLP/0.0/
      data tGenPS/0.0/
      data tBorn/0.0/
      data tIS/0.0/
      data tReal/0.0/
      data tCount/0.0/
      data tFxFx/0.0/
      data tf_nb/0.0/
      data tf_all/0.0/
      data t_as/0.0/
      data tr_s/0.0/
      data tr_pdf/0.0/
      data t_plot/0.0/
      data t_cuts/0.0/
      data t_MC_subt/0.0/
      data t_isum/0.0/
      data t_p_unw/0.0/
      data t_write/0.0/
      end

      double precision function sigint(xx,vegas_wgt,ifl,f)
      use weight_lines
      use extra_weights
      use mint_module
      implicit none
      include 'nexternal.inc'
      include 'nFKSconfigs.inc'
      include 'run.inc'
      include 'orders.inc'
      include 'fks_info.inc'
      double precision xx(ndimmax),vegas_wgt,f(nintegrals),jac,p(0:3
     $     ,nexternal),rwgt,vol,sig,x(99),MC_int_wgt
      integer ifl,nFKS_born,nFKS_picked,iFKS,nFKS_min,iamp
     $     ,nFKS_max,izero,ione,itwo,mohdr,i,iran_picked
      parameter (izero=0,ione=1,itwo=2,mohdr=-100)
      logical passcuts,passcuts_nbody,passcuts_n1body,sum,firsttime
      data firsttime/.true./
      external passcuts
      integer             ini_fin_fks(maxchannels)
      common/fks_channels/ini_fin_fks
      data sum /.false./
      integer         nndim
      common/tosigint/nndim
      logical       nbody
      common/cnbody/nbody
      double precision p1_cnt(0:3,nexternal,-2:2),wgt_cnt(-2:2)
     $     ,pswgt_cnt(-2:2),jac_cnt(-2:2)
      common/counterevnts/p1_cnt,wgt_cnt,pswgt_cnt,jac_cnt
      double precision p_born(0:3,nexternal-1)
      common /pborn/   p_born
      double precision virtual_over_born
      common/c_vob/virtual_over_born
      logical                calculatedBorn
      common/ccalculatedBorn/calculatedBorn
      character*4      abrv
      common /to_abrv/ abrv
c PineAPPL
      logical pineappl
      common /for_pineappl/ pineappl
      double precision       wgt_ME_born,wgt_ME_real
      common /c_wgt_ME_tree/ wgt_ME_born,wgt_ME_real
      integer ini_fin_fks_map(0:2,0:fks_configs)
      save ini_fin_fks_map
      if (new_point .and. ifl.ne.2) then
         pass_cuts_check=.false.
      endif
      if (firsttime) then
         firsttime=.false.
         call setup_ini_fin_fks_map(ini_fin_fks_map)
         write (*,*) 'initial-final FKS maps:'
         write (*,*) 0 ,':',ini_fin_fks_map(0,:)
         write (*,*) 1 ,':',ini_fin_fks_map(1,:)
         write (*,*) 2 ,':',ini_fin_fks_map(2,:)
      endif
      if (ifl.ne.0) then
         write (*,*) 'ERROR ifl not equal to zero in sigint',ifl
         stop 1
      endif
      if (pineappl .and. sum) then
         write (*,*) 'WARNING: PineAPPL only possible '/
     &        /'with MC over FKS directories',pineappl,sum
         write (*,*) 'Switching to MC over FKS directories'
         sum=.false.
      endif
      sigint=0d0
      icontr=0
      do iamp=0,amp_split_size
         virt_wgt_mint(iamp)=0d0
         born_wgt_mint(iamp)=0d0
      enddo
      virtual_over_born=0d0
      wgt_me_born=0d0
      wgt_me_real=0d0
      if (ickkw.eq.-1) H1_factor_virt=0d0
      if (ickkw.eq.3) call set_FxFx_scale(0,p)
      call update_vegas_x(xx,x)
      call get_MC_integer(max(ini_fin_fks(ichan),1)
     $     ,ini_fin_fks_map(ini_fin_fks(ichan),0),iran_picked,vol)
      nFKS_picked=ini_fin_fks_map(ini_fin_fks(ichan),iran_picked)

c The nbody contributions
      if (abrv.eq.'real') goto 11
      nbody=.true.
      calculatedBorn=.false.
      call get_born_nFKSprocess(nFKS_picked,nFKS_born)
      call update_fks_dir(nFKS_born)
      if (ini_fin_fks(ichan).eq.0) then
         jac=1d0
      else
         jac=0.5d0
      endif
      call generate_momenta(nndim,iconfig,jac,x,p)
      if (p_born(0,1).lt.0d0) goto 12
      call compute_prefactors_nbody(vegas_wgt)
      call set_cms_stuff(izero)
      passcuts_nbody=passcuts(p1_cnt(0,1,0),rwgt)
      if (passcuts_nbody) then
         pass_cuts_check=.true.
         if (ickkw.eq.3) call set_FxFx_scale(1,p1_cnt(0,1,0))
         call set_alphaS(p1_cnt(0,1,0))
         call include_multichannel_enhance(1)
         if (abrv(1:2).ne.'vi') then
            call compute_born
         endif
         if (abrv.ne.'born') then
            call compute_nbody_noborn
         endif
      endif

 11   continue
c The n+1-body contributions (including counter terms)
      if ( abrv(1:4).eq.'born' .or.
     $     abrv(1:4).eq.'bovi' .or.
     $     abrv(1:2).eq.'vi' ) goto 12
      nbody=.false.
      if (sum) then
         nFKS_min=1
         nFKS_max=ini_fin_fks_map(ini_fin_fks(ichan),0)
         MC_int_wgt=1d0
      else
         nFKS_min=iran_picked
         nFKS_max=iran_picked
         MC_int_wgt=1d0/vol
      endif
      do i=nFKS_min,nFKS_max
         iFKS=ini_fin_fks_map(ini_fin_fks(ichan),i)
         calculatedBorn=.false.
         ! MZ this is a temporary fix for processes without
         ! soft singularities associated to the initial state
         ! DO NOT extend this fix to event generation
         wgt_me_born=0d0
         wgt_me_real=0d0
         jac=MC_int_wgt
         call update_fks_dir(iFKS)
         call generate_momenta(nndim,iconfig,jac,x,p)
         if (p_born(0,1).lt.0d0) cycle
         call compute_prefactors_n1body(vegas_wgt,jac)
         call set_cms_stuff(izero)
         passcuts_nbody =passcuts(p1_cnt(0,1,0),rwgt)
         call set_cms_stuff(mohdr)
         passcuts_n1body=passcuts(p,rwgt)
         if (passcuts_nbody .and. abrv.ne.'real') then
            pass_cuts_check=.true.
            call set_cms_stuff(izero)
            if (ickkw.eq.3) call set_FxFx_scale(2,p1_cnt(0,1,0))
            call set_alphaS(p1_cnt(0,1,0))
            call include_multichannel_enhance(3)
            call compute_soft_counter_term(0d0)
            call set_cms_stuff(ione)
            call compute_collinear_counter_term(0d0)
            call set_cms_stuff(itwo)
            call compute_soft_collinear_counter_term(0d0)
         endif
         if (passcuts_n1body) then
            pass_cuts_check=.true.
            call set_cms_stuff(mohdr)
            if (ickkw.eq.3) call set_FxFx_scale(3,p)
            call set_alphaS(p)
            call include_multichannel_enhance(2)
            call compute_real_emission(p,1d0)
         endif
      enddo

 12   continue
c Include PDFs and alpha_S and reweight to include the uncertainties
      if (ickkw.eq.-1) call include_veto_multiplier
      call include_PDF_and_alphas
      if (doreweight) then
         if (do_rwgt_scale .and. ickkw.ne.-1) call reweight_scale
         if (do_rwgt_scale .and. ickkw.eq.-1) call reweight_scale_NNLL
         if (do_rwgt_pdf) call reweight_pdf
      endif

      if (pineappl) then
         if (sum) then
            write (*,*) 'ERROR: PineAPPL only possible '/
     &           /'with MC over FKS directories',pineappl,sum
            stop 1
         endif
         call fill_pineappl_weights(vegas_wgt)
      endif

c Importance sampling for FKS configurations
      if (sum) then
         call get_wgt_nbody(sig)
         call fill_MC_integer(max(ini_fin_fks(ichan),1),iran_picked
     $        ,abs(sig))
      else
         call get_wgt_no_nbody(sig)
         call fill_MC_integer(max(ini_fin_fks(ichan),1),iran_picked
     $        ,abs(sig)*vol)
      endif

c Finalize PS point
      call fill_plots
      call fill_mint_function(f)
      return
      end

      subroutine update_fks_dir(nFKS)
      implicit none
      include 'run.inc'
      integer nFKS
      integer              nFKSprocess
      common/c_nFKSprocess/nFKSprocess
      nFKSprocess=nFKS
      call fks_inc_chooser()
      call leshouche_inc_chooser()
      call setcuts
      call setfksfactor(.false.)
      if (ickkw.eq.3) call configs_and_props_inc_chooser()
      return
      end

      subroutine setup_ini_fin_FKS_map(ini_fin_FKS_map)
      implicit none
      include 'nexternal.inc'
      include 'nFKSconfigs.inc'
      include 'fks_info.inc'
      integer ini_fin_FKS_map(0:2,0:fks_configs),iFKS
      ini_fin_FKS_map(0,0)=0
      ini_fin_FKS_map(1,0)=0
      ini_fin_FKS_map(2,0)=0
      do iFKS=1,fks_configs
         ini_fin_FKS_map(0,0)=ini_fin_FKS_map(0,0)+1
         ini_fin_FKS_map(0,ini_fin_FKS_map(0,0))=iFKS
         if (fks_j_d(iFKS).le.nincoming .and.
     $       fks_j_d(iFKS).gt.0) then
            ini_fin_FKS_map(2,0)=ini_fin_FKS_map(2,0)+1
            ini_fin_FKS_map(2,ini_fin_FKS_map(2,0))=iFKS
         elseif (fks_j_d(iFKS).gt.nincoming .and.
     $           fks_j_d(iFKS).le.nexternal) then
            ini_fin_FKS_map(1,0)=ini_fin_FKS_map(1,0)+1
            ini_fin_FKS_map(1,ini_fin_FKS_map(1,0))=iFKS
         else
            write (*,*) 'ERROR in setup_ini_fin_FKS_map',fks_j_d(iFKS)
     $           ,nincoming,iFKS
            stop 1
         endif
      enddo
      return
      end

      subroutine get_born_nFKSprocess(nFKS_in,nFKS_out)
      implicit none
      include 'nexternal.inc'
      include 'nFKSconfigs.inc'
      include 'fks_info.inc'
      integer nFKS_in,nFKS_out,iFKS,iiFKS,nFKSprocessBorn(fks_configs)
      logical firsttime
      data firsttime /.true./
      save nFKSprocessBorn
c
      if (firsttime) then
         firsttime=.false.
         do iFKS=1,fks_configs
            nFKSprocessBorn(iFKS)=0
            if ( need_color_links_D(iFKS) .or.
     &           need_charge_links_D(iFKS) )then
               nFKSprocessBorn(iFKS)=iFKS
            endif
            if (nFKSprocessBorn(iFKS).eq.0) then
c     try to find the process that has the same j_fks but with i_fks a
c     gluon
               do iiFKS=1,fks_configs
                  if ( (need_color_links_D(iiFKS) .or.
     &                  need_charge_links_D(iiFKS)) .and.
     &                 fks_j_D(iFKS).eq.fks_j_D(iiFKS) ) then
                     nFKSprocessBorn(iFKS)=iiFKS
                     exit
                  endif
               enddo
            endif
c     try to find the process that has the j_fks initial state if
c     current j_fks is initial state (and similar for final state j_fks)
            if (nFKSprocessBorn(iFKS).eq.0) then
               do iiFKS=1,fks_configs
                  if ( need_color_links_D(iiFKS) .or.
     &                 need_charge_links_D(iiFKS) ) then
                     if ( fks_j_D(iiFKS).le.nincoming .and.
     &                    fks_j_D(iFKS).le.nincoming ) then
                        nFKSprocessBorn(iFKS)=iiFKS
                        exit
                     elseif ( fks_j_D(iiFKS).gt.nincoming .and.
     &                        fks_j_D(iFKS).gt.nincoming ) then
                        nFKSprocessBorn(iFKS)=iiFKS
                        exit
                     endif
                  endif
               enddo
            endif
c     If still not found, just pick any one that has a soft singularity
            if (nFKSprocessBorn(iFKS).eq.0) then
               do iiFKS=1,fks_configs
                  if ( need_color_links_D(iiFKS) .or.
     &                 need_charge_links_D(iiFKS) ) then
                     nFKSprocessBorn(iFKS)=iiFKS
                  endif
               enddo
            endif
c     if there are no soft singularities at all, just do something trivial
            if (nFKSprocessBorn(iFKS).eq.0) then
               nFKSprocessBorn(iFKS)=iFKS
            endif
         enddo
         write (*,*) 'Total number of FKS directories is', fks_configs
         write (*,*) 'For the Born we use nFKSprocesses:'
         write (*,*)  nFKSprocessBorn
      endif
      if (nFKSprocessBorn(nFKS_in).eq.0) then
         write(*,*) 'Could not find the correct map to Born '/
     &        /'FKS configuration for the NLO FKS '/
     &        /'configuration', nFKS_in
         stop 1
      else
         nFKS_out=nFKSprocessBorn(nFKS_in)
      endif
      return
      end

      subroutine update_vegas_x(xx,x)
      use mint_module
      implicit none
      integer i
      double precision xx(ndimmax),x(99),ran2
      external ran2
      integer         nndim
      common/tosigint/nndim
      character*4      abrv
      common /to_abrv/ abrv
      do i=1,99
         if (abrv.eq.'born'.or.abrv(1:2).eq.'vi') then
            if(i.le.nndim-3)then
               x(i)=xx(i)
            elseif(i.le.nndim) then
               x(i)=ran2()      ! Choose them flat when not including real-emision
            else
               x(i)=0.d0
            endif
         else
            if(i.le.nndim)then
               x(i)=xx(i)
            else
               x(i)=0.d0
            endif
         endif
      enddo
      return
      end

c
      subroutine get_user_params(ncall,nitmax,irestart)
c**********************************************************************
c     Routine to get user specified parameters for run
c**********************************************************************
      use mint_module
      implicit none
c
c     Constants
c
      include 'genps.inc'
      include 'nexternal.inc'
      include 'nFKSconfigs.inc'
      include 'fks_info.inc'
      include 'run.inc'
      include 'orders.inc'
c
c     Arguments
c
      integer ncall,nitmax
c
c     Local
c
      integer i, j, kchan
      double precision dconfig(maxchannels)
c
c     Global
c
      integer ini_fin_fks(maxchannels)
      common /fks_channels/ini_fin_fks
      integer           isum_hel
      logical                   multi_channel
      common/to_matrix/isum_hel, multi_channel
      integer           use_cut
      common /to_weight/use_cut

      integer        lbw(0:nexternal)  !Use of B.W.
      common /to_BW/ lbw

      character*5 abrvinput
      character*4 abrv
      common /to_abrv/ abrv

      logical nbody
      common/cnbody/nbody

c
c To convert diagram number to configuration
c
      include 'born_conf.inc'
c
c Vegas stuff
c
      integer irestart,itmp
      character * 70 idstring
      logical savegrid

      logical unwgt
      double precision evtsgn
      common /c_unwgt/evtsgn,unwgt
      logical fillh
      integer mc_hel,ihel
      double precision volh
      common/mc_int2/volh,mc_hel,ihel,fillh
      integer random_offset_split
      common /c_random_offset_split/ random_offset_split
      logical done
      character*140 buffer
c-----
c  Begin Code
c-----
      unwgt=.false.
      open (unit=83,file='input_app.txt',status='old')
      done=.false.
      nchans=0
      do while (.not. done)
         read(83,'(a)',err=222,end=222) buffer
         if (buffer(1:7).eq.'NPOINTS') then
            buffer=buffer(10:100)
            read(buffer,*) ncall
            write (*,*) 'Number of phase-space points per iteration:',ncall
         elseif(buffer(1:11).eq.'NITERATIONS') then
            read(buffer(14:),*) nitmax
            write (*,*) 'Maximum number of iterations is:',nitmax
         elseif(buffer(1:8).eq.'ACCURACY') then
            read(buffer(11:),*) accuracy
            write (*,*) 'Desired accuracy is:',accuracy
         elseif(buffer(1:10).eq.'ADAPT_GRID') then
            read(buffer(13:),*) use_cut
            write (*,*) 'Using adaptive grids:',use_cut
         elseif(buffer(1:12).eq.'MULTICHANNEL') then
            read(buffer(15:),*) i
            if (i.eq.1) then
               multi_channel=.true.
               write (*,*) 'Using Multi-channel integration'
            else
               multi_channel=.false.
               write (*,*) 'Not using Multi-channel integration'
            endif
         elseif(buffer(1:12).eq.'SUM_HELICITY') then
            read(buffer(15:),*) i
            if (nincoming.eq.1) then
               write (*,*) 'Sum over helicities in the virtuals'/
     $              /' for decay process'
               mc_hel=0
            elseif (i.eq.0) then
               mc_hel=0
               write (*,*) 'Explicitly summing over helicities'/
     $              /' for the virtuals'
            else
               mc_hel=1
               write(*,*) 'Do MC over helicities for the virtuals'
            endif
            isum_hel=0
         elseif(buffer(1:6).eq.'NCHANS') then
            read(buffer(9:),*) nchans
            write (*,*) 'Number of channels to integrate together:'
     $           ,nchans
            if (nchans.gt.maxchannels) then
               write (*,*) 'Too many integration channels to be '/
     $              /'integrated together. Increase maxchannels',nchans
     $              ,maxchannels
               stop 1
            endif
         elseif(buffer(1:7).eq.'CHANNEL') then
            if (nchans.le.0) then
               write (*,*) '"NCHANS" missing in input files'/
     $              /' (still zero)',nchans
               stop
            endif
            read(buffer(10:),*) (dconfig(kchan),kchan=1,nchans)
            do kchan=1,nchans
               iconfigs(kchan) = int(dconfig(kchan))
               if ( nint(dconfig(kchan)*10)-iconfigs(kchan)*10.eq.0 )
     $              then
                  ini_fin_fks(kchan)=0
               elseif ( nint(dconfig(kchan)*10)-iconfigs(kchan)*10.eq.1
     $                 ) then
                  ini_fin_fks(kchan)=1
               elseif ( nint(dconfig(kchan)*10)-iconfigs(kchan)*10.eq.2
     $                 ) then
                  ini_fin_fks(kchan)=2
               else
                  write (*,*) 'ERROR: invalid configuration number',dconfig
                  stop 1
               endif
               do i=1,mapconfig(0)
                  if (iconfigs(kchan).eq.mapconfig(i)) then
                     iconfigs(kchan)=i
                     exit
                  endif
               enddo
            enddo
            write(*,*) 'Running Configuration Number(s): '
     $           ,(iconfigs(kchan),kchan=1,nchans)
            write(*,*) 'initial-or-final',(ini_fin_fks(kchan),kchan=1,nchans)
         elseif(buffer(1:5).eq.'SPLIT') then
            read(buffer(8:),*) random_offset_split
            write (*,*) 'Splitting channel:',random_offset_split
         elseif(buffer(1:8).eq.'WGT_MULT') then
            read(buffer(11:),*) wgt_mult
            write (*,*) 'Weight multiplier:',wgt_mult
         elseif(buffer(1:8).eq.'RUN_MODE') then
            read(buffer(11:),*) abrvinput
            if(abrvinput(5:5).eq.'0')then
               nbody=.true.
            else
               nbody=.false.
            endif
            abrv=abrvinput(1:4)
            write (*,*) "doing the ",abrv," of this channel"
            if(nbody)then
               write (*,*) "integration Born/virtual with Sfunction=1"
            else
               write (*,*) "Normal integration (Sfunction != 1)"
            endif
         elseif(buffer(1:7).eq.'RESTART') then
            read(buffer(10:),*) irestart
            if (irestart.eq.0) then
               write (*,*) 'RESTART: Fresh run'
            elseif(irestart.eq.-1) then
               write (*,*) 'RESTART: Use old grids, but refil plots'
            elseif(irestart.eq.1) then
               write (*,*) 'RESTART: continue with existing run'
            else
               write (*,*) 'RESTART:',irestart
            endif
         endif
         cycle
 222     done=.true.
      enddo
      close(83)

      if (fks_configs.eq.1) then
         if (pdg_type_d(1,fks_i_d(1)).eq.-21.and.abrv.ne.'born') then
C Two cases can occur
C   1) the process has been generated with the LOonly flav
C   2) the process has only virtual corrections, e.g. z > v v [QED]
C the two cases can be distinguished by looking at the values
C  of AMP_SPLIT_SIZE, AMP_SPLIT_SIZE_BORN (if they are ==, it is 1))
           if (amp_split_size.eq.amp_split_size_born) then
             write (*,*) 'Process generated with [LOonly=QCD]. '/
     $           /'Setting abrv to "born".'
             abrv='born'
             if (ickkw.eq.3) then
               write (*,*) 'FxFx merging not possible with'/
     $              /' [LOonly=QCD] processes'
               stop 1
             endif
           else
             write (*,*) 'Process only with virtual corrections'/
     $           /'Setting abrv to "bovi".'
             abrv='bovi'
           endif
         endif
      endif
c
c     Here I want to set up with B.W. we map and which we don't
c
      lbw(0)=0
      end
c


module photochem_data
  implicit none
  public
  integer, private, parameter :: real_kind = kind(1.0d0)
  ! this module contains stuff that generally does not change from
  ! one integration to the next. Its the unchanging "data" that is read
  ! in at the very beginning before doing a bunch of simulations.

  ! All stuff in here should be considered read-only

  integer :: nz ! number of vertical grid points
  integer :: nz1 !nz-1
  integer :: nq ! number of long lived species
  integer :: nq1
  integer :: np ! number of particles
  integer :: nsp ! total number of species
  integer :: nsp2 ! total number of species, including HV and M
  integer :: nr ! number of reactions
  integer, parameter :: nmax = 300 ! max number of reactions a species can be involved in
  integer :: ks ! number of photo species
  integer :: kj ! number of photo reactions
  ! integer, parameter :: kw = 1000 ! max number of wavelength bins
  integer :: nw
  integer, parameter :: naq = 10 !number of aqueous species
  integer, parameter :: nt = 50 !number of temperatures in sulfate/H2O vapor pressure file (DATA/aerosol.table)
  integer, parameter :: nf = 50 !NT=number of pressures per temperature in DATA/aerosol.table
  integer :: lda
  integer :: neq

  ! Defined in species.dat
  integer :: iSL ! number of sl species
  real(8) :: background_mu
  character(len=8) :: background_spec
  character(len=8), allocatable, dimension(:) :: ISPEC
  real*8, allocatable, dimension(:) :: redoxstate
  real*8, allocatable, dimension(:) :: mass
  integer LSO2, LH2CO, lh2so4, lso4aer, lh2s ! indexes of a few things
  integer LCO, LH2O, LH2, LCH4, LO2, LH
  integer Ls8aer, Lhcaer, Lhcaer2, ls2, ls3, ls4
  integer lno, lo, LCO2, ln2, ls
  integer, allocatable, dimension(:) :: atomsO
  integer, allocatable, dimension(:) :: atomsH
  integer, allocatable, dimension(:) :: atomsC
  integer, allocatable, dimension(:) :: atomsS
  integer, allocatable, dimension(:) :: atomsN
  integer, allocatable, dimension(:) :: atomsCL

  ! Defined in reactions.rx
  Character(len=8), allocatable, dimension(:,:) :: chemj
  integer, allocatable, dimension(:,:) :: jchem
  Character(len=8), allocatable, dimension(:) :: reactype
  real*8, allocatable, dimension(:,:) :: rateparams ! a new one.
  integer, allocatable, dimension(:,:,:) :: iloss
  integer, allocatable, dimension(:,:) :: iprod
  integer, allocatable, dimension(:) :: photoreac
  integer, allocatable, dimension(:) :: photonums
  integer, allocatable, dimension(:) :: photospec
  integer, allocatable, dimension(:) :: NUML, NUMP

  ! needed in read_planet.f90
  real*8 :: grav_surf, Fscale, Alb, ztrop,far,R0,P0
  real(8), allocatable :: grav_z(:)

  ! needed in read_photochem.f90
  real*8 :: AGL, EPSJ, light_disp_rate, hcdens, zy
  integer :: Lgrid, IO2, ino, frak, ihztype
  logical :: lightning
  logical :: rainout_on
  logical :: H2O_strat_condensation
  real(8) :: confac, rhcold
  logical :: fix_water_in_troposphere
  logical :: use_manabe
  real(8) :: relative_humidity
  logical :: estimate_CO2_photo_above_grid

  ! needed in subroutine photgrid (in photgrid.f90)
  real*8, allocatable, dimension(:) :: z ! altitude of middle of grid
  real*8, allocatable, dimension(:) :: dz ! Delta_z of each altitude grid
  real(8) :: top_atmos, bottom_atmos
  integer JTROP

  ! needed in initphoto.f90.
  ! real*8, dimension(kw) :: Flux ! Solar flux photons/(cm2 s)
  ! real*8, dimension(kw) :: wavl, wav, wavu ! wavelength bins
  real*8, allocatable, dimension(:) :: Flux ! Solar flux photons/(cm2 s)
  real*8, allocatable, dimension(:) :: wavl, wav, wavu ! wavelength bins
  real*8, allocatable, dimension(:,:,:) :: sq ! cross sections * qy

  ! needed in initmie.f90
  real*8, dimension(51) :: Rstand
  ! real*8, dimension(kw,51) :: W0HC
  ! real*8, dimension(kw,51) :: GHC, QEXTHC
  real*8, allocatable, dimension(:,:) :: W0HC
  real*8, allocatable, dimension(:,:) :: GHC, QEXTHC

  ! needed in Aertab.f90
  real*8, allocatable, dimension(:,:) :: VH2O
  real*8, allocatable, dimension(:,:) :: VH2SO4
  real*8, dimension(nf) :: ftab

  ! atmosphere_txt contents
  real(8), allocatable :: usol_file(:,:), rpar_file(:,:), &
                          wfall_file(:,:), aersol_file(:,:)
  real(8), allocatable :: T_file(:), edd_file(:), z_file(:)
  integer :: nzf

end module


module neutraldataobj

use phys_consts, only: wp
use inputdataobj, only: inputdata

implicit none (type,external)
public

!> abstract type for neutral data input; this is for 2D or 3D and contains only the data and init
!    other procedures must be defined in concrete class
type, extends(inputdata), abstract :: neutraldata
  ! interpolation site pointer aliases always 3D so defined here in based neutral class
  real(wp), dimension(:,:,:), pointer ::  dnOiprev,dnN2iprev,dnO2iprev,dvn1iprev,dvn2iprev,dvn3iprev, &
                                           dTniprev
  real(wp), dimension(:,:,:), pointer ::  dnOinext,dnN2inext,dnO2inext,dvn1inext,dvn2inext,dvn3inext, &
                                           dTninext
  real(wp), dimension(:,:,:), pointer :: dnOinow,dnN2inow,dnO2inow,dvn1inow,dvn2inow,dvn3inow, &
                                           dTninow
  contains
    procedure :: setptrs_grid
    procedure :: dissociate_neutral_pointers
end type neutraldata

contains
  !> set pointer variables to locations for storage of interpolated data (3D always for neutral input)
  subroutine setptrs_grid(self)
    class(neutraldata), intent(inout) :: self

    ! set aliases for prev data
    self%dnOiprev=>self%data3Di(:,:,:,1,1)
    self%dnN2iprev=>self%data3Di(:,:,:,2,1)
    self%dnO2iprev=>self%data3Di(:,:,:,3,1)
    self%dvn1iprev=>self%data3Di(:,:,:,4,1)
    self%dvn2iprev=>self%data3Di(:,:,:,5,1)
    self%dvn3iprev=>self%data3Di(:,:,:,6,1)
    self%dTniprev=>self%data3Di(:,:,:,7,1)

    ! set pointers for next data
    self%dnOinext=>self%data3Di(:,:,:,1,2)
    self%dnN2inext=>self%data3Di(:,:,:,2,2)
    self%dnO2inext=>self%data3Di(:,:,:,3,2)
    self%dvn1inext=>self%data3Di(:,:,:,4,2)
    self%dvn2inext=>self%data3Di(:,:,:,5,2)
    self%dvn3inext=>self%data3Di(:,:,:,6,2)
    self%dTninext=>self%data3Di(:,:,:,7,2)

    ! set aliases for interpolated data that is "outward facing"
    self%dnOinow=>self%data3Dinow(:,:,:,1)
    self%dnN2inow=>self%data3Dinow(:,:,:,2)
    self%dnO2inow=>self%data3Dinow(:,:,:,3)
    self%dvn1inow=>self%data3Dinow(:,:,:,4)
    self%dvn2inow=>self%data3Dinow(:,:,:,5)
    self%dvn3inow=>self%data3Dinow(:,:,:,6)
    self%dTninow=>self%data3Dinow(:,:,:,7)
  end subroutine setptrs_grid

  !> nullify neutral pointers (dealloc should occur from base class); unclear whether fortran standard automatically
  !    calls for setting pointers to null vs. undefined.
  subroutine dissociate_neutral_pointers(self)
    class(neutraldata), intent(inout) :: self

    nullify(self%dnOiprev,self%dnN2iprev,self%dnO2iprev,self%dvn1iprev,self%dvn2iprev,self%dvn3iprev, &
                                           self%dTniprev)
    nullify(self%dnOinext,self%dnN2inext,self%dnO2inext,self%dvn1inext,self%dvn2inext,self%dvn3inext, &
                                           self%dTninext)
    nullify(self%dnOinow,self%dnN2inow,self%dnO2inow,self%dvn1inow,self%dvn2inow,self%dvn3inow, &
                                           self%dTninow)
  end subroutine dissociate_neutral_pointers
end module neutraldataobj


recursive subroutine amr_step(ilevel,icount)
  use amr_commons
  use pm_commons
  use hydro_commons
  use poisson_commons
#ifdef RT
  use rt_hydro_commons
  use SED_module
#endif
  implicit none
#ifndef WITHOUTMPI
  include 'mpif.h'
#endif
  integer::ilevel,icount
  !-------------------------------------------------------------------!
  ! This routine is the adaptive-mesh/adaptive-time-step main driver. !
  ! Each routine is called using a specific order, don't change it,   !
  ! unless you check all consequences first                           !
  !-------------------------------------------------------------------!
  integer::i,idim,ivar
  logical::ok_defrag
  logical,save::first_step=.true.

  if(numbtot(1,ilevel)==0)return

  if(verbose)write(*,999)icount,ilevel

  !-------------------------------------------
  ! Make new refinements and update boundaries
  !-------------------------------------------
  if(levelmin.lt.nlevelmax .and..not. static)then
     if(ilevel==levelmin.or.icount>1)then
        do i=ilevel,nlevelmax
           if(i>levelmin)then

              !--------------------------
              ! Build communicators
              !--------------------------
              call build_comm(i)

              !--------------------------
              ! Update boundaries
              !--------------------------
              call make_virtual_fine_int(cpu_map(1),i)
              if(hydro)then
#ifdef SOLVERmhd
                 do ivar=1,nvar+3
#else
                 do ivar=1,nvar
#endif
                    call make_virtual_fine_dp(uold(1,ivar),i)
#ifdef SOLVERmhd
                 end do
#else
                 end do
#endif
                 if(simple_boundary)call make_boundary_hydro(i)
              end if
#ifdef RT
              if(rt)then
                 do ivar=1,nrtvar
                    call make_virtual_fine_dp(rtuold(1,ivar),i)
                 end do
                 if(simple_boundary)call rt_make_boundary_hydro(i)
              end if
#endif
              if(poisson)then
                 call make_virtual_fine_dp(phi(1),i)
                 do idim=1,ndim
                    call make_virtual_fine_dp(f(1,idim),i)
                 end do
                 if(simple_boundary)call make_boundary_force(i)
              end if
           end if

           !--------------------------
           ! Refine grids
           !--------------------------
           call refine_fine(i)
        end do
     end if
  end if

  !--------------------------
  ! Load balance
  !--------------------------
  ok_defrag=.false.
  if(levelmin.lt.nlevelmax)then
     if(ilevel==levelmin)then
        if(nremap>0)then
           ! Skip first load balance because it has been performed before file dump
           if(nrestart>0.and.first_step)then
              first_step=.false.
           else
              if(MOD(nstep_coarse,nremap)==0)then
                 call load_balance
                 call defrag
                 ok_defrag=.true.
              endif
           end if
        end if
     endif
  end if

  !-----------------
  ! Update sink cloud particle properties
  !-----------------
  if(sink)call update_cloud(ilevel,.false.)

  !-----------------
  ! Particle leakage
  !-----------------
  if(pic)call make_tree_fine(ilevel)

  !------------------------
  ! Output results to files
  !------------------------
  if(ilevel==levelmin)then
     if(mod(nstep_coarse,foutput)==0.or.aexp>=aout(iout).or.t>=tout(iout))then
        if(.not.ok_defrag)then
           call defrag
        endif

        call dump_all

        if(gas_analytics) call gas_ana

        ! Run the clumpfinder
        if(clumpfind .and. ndim==3) call clump_finder(.true.)

        ! Dump lightcone
        if(lightcone) call output_cone()

     endif

     ! Important can't be done in sink routines because it must be done after dump all
     if(sink)acc_rate=0.

  endif

  !----------------------------
  ! Output frame to movie dump (without synced levels)
  !----------------------------
  if(movie) then
     if(aexp>=amovout(imov).or.t>=tmovout(imov))then
        call output_frame()
     endif
  end if

  !-----------------------------------------------------------
  ! Put here all stuffs that are done only at coarse time step
  !-----------------------------------------------------------
  if(ilevel==levelmin)then
     !----------------------------------------------------
     ! Kinetic feedback from giant molecular clouds
     !----------------------------------------------------
     if(hydro.and.star.and.eta_sn>0.and.f_w>0)call kinetic_feedback

  endif

  !--------------------
  ! Poisson source term
  !--------------------
  if(poisson)then
     !save old potential for time-extrapolation at level boundaries
     call save_phi_old(ilevel)
     call rho_fine(ilevel,icount)
  endif

  !-------------------------------------------
  ! Sort particles between ilevel and ilevel+1
  !-------------------------------------------
  if(pic)then
     ! Remove particles to finer levels
     call kill_tree_fine(ilevel)
     ! Update boundary conditions for remaining particles
     call virtual_tree_fine(ilevel)
  end if

  !---------------
  ! Gravity update
  !---------------
  if(poisson)then

     ! Remove gravity source term with half time step and old force
     if(hydro)then
        call synchro_hydro_fine(ilevel,-0.5*dtnew(ilevel))
     endif

     ! Compute gravitational potential
     if(ilevel>levelmin)then
        if(ilevel .ge. cg_levelmin) then
           call phi_fine_cg(ilevel,icount)
        else
           call multigrid_fine(ilevel,icount)
        end if
     else
        call multigrid_fine(levelmin,icount)
     end if
     !when there is no old potential...
     if (nstep==0)call save_phi_old(ilevel)

     ! Compute gravitational acceleration
     call force_fine(ilevel,icount)

     ! Thermal feedback from stars
     if(hydro.and.star.and.eta_sn>0)call thermal_feedback(ilevel,icount)

     ! Synchronize remaining particles for gravity
     if(pic)then
        call synchro_fine(ilevel)
     end if

     if(hydro)then

        ! Compute Bondi-Hoyle accretion parameters
        if(sink.and.bondi)call bondi_hoyle(ilevel)

        ! Add gravity source term with half time step and new force
        call synchro_hydro_fine(ilevel,+0.5*dtnew(ilevel))

        ! Update boundaries
#ifdef SOLVERmhd
        do ivar=1,nvar+3
#else
        do ivar=1,nvar
#endif
           call make_virtual_fine_dp(uold(1,ivar),ilevel)
#ifdef SOLVERmhd
        end do
#else
        end do
#endif
        if(simple_boundary)call make_boundary_hydro(ilevel)
     end if
  end if

#ifdef RT
  ! Turn on RT in case of rt_stars and first stars just created:
  ! Update photon packages according to star particles
  if(rt .and. rt_star) call update_star_RT_feedback(ilevel)
#endif

  !----------------------
  ! Compute new time step
  !----------------------
  call newdt_fine(ilevel)
  if(ilevel>levelmin)then
     dtnew(ilevel)=MIN(dtnew(ilevel-1)/real(nsubcycle(ilevel-1)),dtnew(ilevel))
  end if

  ! Set unew equal to uold
  if(hydro)call set_unew(ilevel)

#ifdef RT
  ! Set rtunew equal to rtuold
  if(rt)call rt_set_unew(ilevel)
#endif

  !---------------------------
  ! Recursive call to amr_step
  !---------------------------
  if(ilevel<nlevelmax)then
     if(numbtot(1,ilevel+1)>0)then
        if(nsubcycle(ilevel)==2)then
           call amr_step(ilevel+1,1)
           call amr_step(ilevel+1,2)
        else
           call amr_step(ilevel+1,1)
        endif
     else
        ! Otherwise, update time and finer level time-step
        dtold(ilevel+1)=dtnew(ilevel)/dble(nsubcycle(ilevel))
        dtnew(ilevel+1)=dtnew(ilevel)/dble(nsubcycle(ilevel))
        call update_time(ilevel)
        if(sink)call update_sink(ilevel)
     end if
  else
     call update_time(ilevel)
     if(sink)call update_sink(ilevel)
  end if

#ifdef RT
  ! Add stellar radiation sources
  if(rt.and.rt_star) call star_RT_feedback(ilevel,dtnew(ilevel))
#endif

  !---------------
  ! Move particles
  !---------------
  if(pic)then
     call move_fine(ilevel) ! Only remaining particles
  end if

  !-----------
  ! Hydro step
  !-----------
  if(hydro)then

     ! Hyperbolic solver
     call godunov_fine(ilevel)

     ! Reverse update boundaries
#ifdef SOLVERmhd
     do ivar=1,nvar+3
#else
     do ivar=1,nvar
#endif
        call make_virtual_reverse_dp(unew(1,ivar),ilevel)
#ifdef SOLVERmhd
     end do
#else
     end do
#endif
     if(pressure_fix)then
        call make_virtual_reverse_dp(enew(1),ilevel)
        call make_virtual_reverse_dp(divu(1),ilevel)
     endif

     ! Set uold equal to unew
     call set_uold(ilevel)

     ! Density threshold or Bondi accretion onto sink particle
     if(sink)call grow_sink(ilevel)

     ! Add gravity source term with half time step and old force
     ! in order to complete the time step
     if(poisson)call synchro_hydro_fine(ilevel,+0.5*dtnew(ilevel))

     ! Restriction operator
     call upload_fine(ilevel)

  endif

#ifdef RT
  !---------------
  ! Radiation step
  !---------------
  if(rt)then
     ! Hyperbolic solver
     if(rt_advect) call rt_godunov_fine(ilevel,dtnew(ilevel))

     call add_rt_sources(ilevel,dtnew(ilevel))

     ! Reverse update boundaries
     do ivar=1,nrtvar
        call make_virtual_reverse_dp(rtunew(1,ivar),ilevel)
     end do

     ! Set rtuold equal to rtunew
     call rt_set_uold(ilevel)

     ! Restriction operator
     call rt_upload_fine(ilevel)
  endif
#endif

  !-------------------------------
  ! Source term in leaf cells only
  !-------------------------------
  if(neq_chem.or.cooling.or.T2_star>0.0)call cooling_fine(ilevel)

  !----------------------------------
  ! Star formation in leaf cells only
  !----------------------------------
  if(hydro.and.star)call star_formation(ilevel)

  !---------------------------------------
  ! Update physical and virtual boundaries
  !---------------------------------------
  if(hydro)then
#ifdef SOLVERmhd
     do ivar=1,nvar+3
#else
     do ivar=1,nvar
#endif
        call make_virtual_fine_dp(uold(1,ivar),ilevel)
#ifdef SOLVERmhd
     end do
#else
     end do
#endif
     if(simple_boundary)call make_boundary_hydro(ilevel)
  endif
#ifdef RT
  if(rt)then
     do ivar=1,nrtvar
        call make_virtual_fine_dp(rtuold(1,ivar),ilevel)
     end do
     if(simple_boundary)call rt_make_boundary_hydro(ilevel)
  end if
#endif

#ifdef SOLVERmhd
  ! Magnetic diffusion step
 if(hydro)then
     if(eta_mag>0d0.and.ilevel==levelmin)then
        call diffusion
     endif
  end if
#endif

  !-----------------------
  ! Compute refinement map
  !-----------------------
  if(.not.static) call flag_fine(ilevel,icount)

  !----------------------------
  ! Merge finer level particles
  !----------------------------
  if(pic)call merge_tree_fine(ilevel)

  !---------------
  ! Radiation step
  !---------------
#ifdef ATON
  if(aton.and.ilevel==levelmin)then
     call rad_step(dtnew(ilevel))
  endif
#endif

  if(sink)then
     !-------------------------------
     ! Update coarser level sink velocity
     !-------------------------------
     if(ilevel>levelmin)then
        vsold(1:nsink,1:ndim,ilevel-1)=vsnew(1:nsink,1:ndim,ilevel-1)
        if(nsubcycle(ilevel-1)==1)vsnew(1:nsink,1:ndim,ilevel-1)=vsnew(1:nsink,1:ndim,ilevel)
        if(icount==2)vsnew(1:nsink,1:ndim,ilevel-1)= &
             (vsold(1:nsink,1:ndim,ilevel)*dtold(ilevel)+vsnew(1:nsink,1:ndim,ilevel)*dtnew(ilevel))/ &
             (dtold(ilevel)+dtnew(ilevel))
     end if
     !---------------
     ! Sink production
     !---------------
     if(ilevel==levelmin)call create_sink
  end if

  !-------------------------------
  ! Update coarser level time-step
  !-------------------------------
  if(ilevel>levelmin)then
     if(nsubcycle(ilevel-1)==1)dtnew(ilevel-1)=dtnew(ilevel)
     if(icount==2)dtnew(ilevel-1)=dtold(ilevel)+dtnew(ilevel)
  end if

999 format(' Entering amr_step',i1,' for level',i2)

end subroutine amr_step


! <rdepo.f90 - A component of the City-scale
!                 Chemistry Transport Model EPISODE-CityChem>
!*****************************************************************************!
!*
!* EPISODE - An urban-scale air quality model
!* ==========================================
!* Copyright (C) 2018  NILU - Norwegian Institute for Air Research
!*                     Instituttveien 18
!*                     PO Box 100
!*                     NO-2027 Kjeller
!*                     Norway
!*
!*                     Contact persons: Gabriela Sousa Santos - gss@nilu.no
!*                                      Paul Hamer - pdh@nilu.no
!*
!* Unless explicitly acquired and licensed from Licensor under another license,
!* the contents of this file are subject to the Reciprocal Public License ("RPL")
!* Version 1.5, https://opensource.org/licenses/RPL-1.5 or subsequent versions as
!* allowed by the RPL, and You may not copy or use this file in either source code
!* or executable form, except in compliance with the terms and conditions of the RPL.
!*
!* All software distributed under the RPL is provided strictly on an "AS IS" basis,
!* WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, AND LICENSOR HEREBY
!* DISCLAIMS ALL SUCH WARRANTIES, INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF
!* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT, OR NON-INFRINGEMENT.
!* See the RPL for specific language governing rights and limitations under the RPL.
!*
!* ==========================================
!* The dispersion model EPISODE (Grønskei et. al., 1993; Larssen et al., 1994;
!* Walker et al., 1992, 1999; Slørdal et al., 2003, 2008) is an Eulerian grid model
!* with embedded subgrid models for calculations of pollutant concentrations resulting
!* from different types of sources (area-, line- and point sources). EPISODE solves the
!* time dependent advection/-diffusion equation on a 3 dimensional grid.
!* Finite difference numerical methods are applied to integrate the solution forward in time.
!* It also includes extensions as the implementation of a simplified EMEP photochemistry
!* scheme for urban areas (Walker et al. 2004) and a scheme for Secondary Organic Aerosol
!* implemented by Håvard Slørdal
!*
!* Grønskei, K.E., Walker, S.E., Gram, F. (1993) Evaluation of a model for hourly spatial
!*    concentrations distributions. Atmos. Environ., 27B, 105-120.
!* Larssen, S., Grønskei, K.E., Gram, F., Hagen, L.O., Walker, S.E. (1994) Verification of
!*    urban scale time-dependent dispersion model with sub-grid elements in Oslo, Norway.
!*    In: Air poll. modelling and its appl. X. New York, Plenum Press.
!* Slørdal, L.H., McInnes, H., Krognes, T. (2008): The Air Quality Information System AirQUIS.
!*    Info. Techn. Environ. Eng., 1, 40-47, 2008.
!* Slørdal, L.H., Walker, S.-E., Solberg, S. (2003) The Urban Air Dispersion Model EPISODE
!*    applied in AirQUIS. Technical Description. NILU TR 12/2003. ISBN 82-425-1522-0.
!* Walker, S.E., Grønskei, K.E. (1992) Spredningsberegninger for on-line overvåking i Grenland.
!*    Programbeskrivelse og brukerveiledning. Lillestrøm,
!*    Norwegian Institute for Air Research (NILU OR 55/92).
!* Walker, S.E., Slørdal, L.H., Guerreiro, C., Gram, F., Grønskei, K.E. (1999) Air pollution
!*    exposure monitoring and estimation. Part II. Model evaluation and population exposure.
!*    J. Environ. Monit, 1, 321-326.
!* Walker, S.-E., Solberg, S., Denby, B. (2003) Development and implementation of a
!*    simplified EMEP photochemistry scheme for urban areas in EPISODE. NILU TR 13/2013.
!*    ISBN 82-425-1524-7
!*****************************************************************************!

      subroutine rdepo

! *** The subroutine reads main depositions data from file.
! ----------------------------------------------------------------------------------
! Based on:
! Version Episode 5.5 (May29, 2012) prepared for BB-Stand-Alone
! Original source code of EPISODE by Sam-Erik Walker (NILU)
!
! Sam-Erik Walker
! Norwegian Institute for Air Research (NILU)
! Instituttveien 18 P.O. Box 100
! N-2027 Kjeller, NORWAY
! Tel: +47 63898000 Fax: +47 63898050
! E-mail: sam-erik.walker@nilu.no
!
! ----------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------
! REVISION HISTORY
!
!           2016  M. Karl: no output of wet deposition fields wanted for now
!
! ----------------------------------------------------------------------------------

      USE mod_util
      USE mod_main
      USE mod_site
      USE mod_conc
      USE mod_depo

! *** Local variables

      INTEGER I
      INTEGER IC
      CHARACTER(len=256) TXTSTR
      LOGICAL LEOF

! *** I      - Index
! *** IC     - Index of compound
! *** TXTSTR - Text string
! *** LEOF   - If end of file then true else false

!MSK      IF (.NOT. ALLOCATED(DDEPMFN)) ALLOCATE(DDEPMFN(NC))
!MSK      IF (.NOT. ALLOCATED(WDEPMFN)) ALLOCATE(WDEPMFN(NC))
      IF (.NOT. ALLOCATED(DDEPSFN)) ALLOCATE(DDEPSFN(NC))
!MSK      IF (.NOT. ALLOCATED(WDEPSFN)) ALLOCATE(WDEPSFN(NC))

!MSK      IF (.NOT. ALLOCATED(DDEPMUN)) ALLOCATE(DDEPMUN(NC))
!MSK      IF (.NOT. ALLOCATED(WDEPMUN)) ALLOCATE(WDEPMUN(NC))
      IF (.NOT. ALLOCATED(DDEPSUN)) ALLOCATE(DDEPSUN(NC))
!MSK      IF (.NOT. ALLOCATED(WDEPSUN)) ALLOCATE(WDEPSUN(NC))

!MSK      IF (.NOT. ALLOCATED(DDEPMFE)) ALLOCATE(DDEPMFE(NC))
!MSK      IF (.NOT. ALLOCATED(WDEPMFE)) ALLOCATE(WDEPMFE(NC))
      IF (.NOT. ALLOCATED(DDEPSFE)) ALLOCATE(DDEPSFE(NC))
!MSK      IF (.NOT. ALLOCATED(WDEPSFE)) ALLOCATE(WDEPSFE(NC))

!MSK      IF (.NOT. ALLOCATED(DDEPMFV)) ALLOCATE(DDEPMFV(NC))
!MSK      IF (.NOT. ALLOCATED(WDEPMFV)) ALLOCATE(WDEPMFV(NC))
      IF (.NOT. ALLOCATED(DDEPSFV)) ALLOCATE(DDEPSFV(NC))
!MSK      IF (.NOT. ALLOCATED(WDEPSFV)) ALLOCATE(WDEPSFV(NC))

!MSK      IF (.NOT. ALLOCATED(DDEPMFM)) ALLOCATE(DDEPMFM(NC))
!MSK      IF (.NOT. ALLOCATED(WDEPMFM)) ALLOCATE(WDEPMFM(NC))
      IF (.NOT. ALLOCATED(DDEPSFM)) ALLOCATE(DDEPSFM(NC))
!MSK      IF (.NOT. ALLOCATED(WDEPSFM)) ALLOCATE(WDEPSFM(NC))

      IF (.NOT. ALLOCATED(DDEPOI))  ALLOCATE(DDEPOI(NC))
      IF (.NOT. ALLOCATED(WDEPOI))  ALLOCATE(WDEPOI(NC))
      IF (.NOT. ALLOCATED(DDEPV))   ALLOCATE(DDEPV(NC))
      IF (.NOT. ALLOCATED(WDEPSR))  ALLOCATE(WDEPSR(NC))

      IF (.NOT. ALLOCATED(DDEPM))   ALLOCATE(DDEPM(NX,NY,NC))

      IF (NR .GT. 0) THEN
          IF (.NOT. ALLOCATED(DDEPR)) ALLOCATE(DDEPR(NC,NR))
      ENDIF

      IF (NLS .GT. 0) THEN
          IF (.NOT. ALLOCATED(DDEPS)) ALLOCATE(DDEPS(NC,NXS,NYS,NLS))
      ENDIF
      IF (.NOT. ALLOCATED(WDEPM)) ALLOCATE(WDEPM(NX,NY,NC))

      IF (NR .GT. 0) THEN
          IF (.NOT. ALLOCATED(WDEPR)) ALLOCATE(WDEPR(NC,NR))
      ENDIF

      IF (NLS .GT. 0) THEN
          IF (.NOT. ALLOCATED(WDEPS)) ALLOCATE(WDEPS(NC,NXS,NYS,NLS))
      ENDIF

! *** Read main grid Dry Deposition filenames:
!MSK      DO 100 IC = 1,NC
!MSK
!MSK      IF (MAINFE) THEN
!MSK          CALL GETDAT(MAINUN,TXTSTR,LEOF)
!MSK          IF (TXTSTR(1:1) .NE. '<') THEN
!MSK              READ (TXTSTR,1000) DDEPMFN(IC)
!MSK          ENDIF
!MSK          print *,'main grid drydep filename',DDEPMFN(IC)
!MSK      ELSE
!MSK          TXTSTR(1:1) = '<'
!MSK          CALL GETFNV(TXTSTR,DDEPMFN(IC),DDEPMFE(IC),1,1, &
!MSK                     DDEPMFV(IC))
!MSK      ENDIF
!MSK  100 CONTINUE

! *** Read main grid Wet Deposition filenames:
!MSK      DO 110 IC = 1,NC
!MSK
!MSK      IF (MAINFE) THEN
!MSK          CALL GETDAT(MAINUN,TXTSTR,LEOF)
!MSK          IF (TXTSTR(1:1) .NE. '<') THEN
!MSK              READ (TXTSTR,1000) WDEPMFN(IC)
!MSK          ENDIF
!MSK          print *,'main grid wetdep filename',WDEPMFN(IC)
!MSK      ELSE
!MSK          TXTSTR(1:1) = '<'
!MSK          CALL GETFNV(TXTSTR,WDEPMFN(IC),WDEPMFE(IC),1,1,  &
!MSK                     WDEPMFV(IC))
!MSK      ENDIF
!MSK
!MSK  110 CONTINUE

!MSK Commented the below files not found in main input
! *** Read  sub grid Dry Deposition filenames:
!      DO 120 IC = 1,NC
!
!      IF (MAINFE) THEN
!          CALL GETDAT(MAINUN,TXTSTR,LEOF)
!          IF (TXTSTR(1:1) .NE. '<') THEN
!              READ (TXTSTR,1000) DDEPSFN(IC)
!          ENDIF
!      ELSE
!          TXTSTR(1:1) = '<'
!          CALL GETFNV(TXTSTR,DDEPSFN(IC),DDEPSFE(IC),1,1,  &
!                     DDEPSFV(IC))
!      ENDIF
!!      IF (MESSFE) THEN
!!          WRITE (MESSUN,2100)
!!     &    (DDEPSFN(IC)(I:I),I=1,INDEX(DDEPSFN(IC),' ') - 1)
!!      ENDIF
!
!  120 CONTINUE

! *** Read  sub grid Wet Deposition filenames:
!      DO 130 IC = 1,NC
!
!      IF (MAINFE) THEN
!          CALL GETDAT(MAINUN,TXTSTR,LEOF)
!          IF (TXTSTR(1:1) .NE. '<') THEN
!              READ (TXTSTR,1000) WDEPSFN(IC)
!          ENDIF
!      ELSE
!          TXTSTR(1:1) = '<'
!          CALL GETFNV(TXTSTR,WDEPSFN(IC),WDEPSFE(IC),1,1,  &
!                     WDEPSFV(IC))
!      ENDIF
!!      IF (MESSFE) THEN
!!          WRITE (MESSUN,2110)
!!     &    (WDEPSFN(IC)(I:I),I=1,INDEX(WDEPSFN(IC),' ') - 1)
!!      ENDIF
!
!  130 CONTINUE

!! *** Read receptors Dry Deposition filename (Only one compund?):
      IF (MAINFE) THEN
          CALL GETDAT(MAINUN,TXTSTR,LEOF)
          IF (TXTSTR(1:1) .NE. '<') THEN
              READ (TXTSTR,1000) DDEPRFN
          ENDIF
          print *,'receptor point drydep filename',DDEPRFN
      ELSE
          TXTSTR(1:1) = '<'
          CALL GETFNV(TXTSTR,DDEPRFN,DDEPRFE,1,1,  &
                     DDEPRFV)
      ENDIF
!      IF (MESSFE) THEN
!          WRITE (MESSUN,2200)
!     &    (DDEPRFN(I:I),I=1,INDEX(DDEPRFN,' ') - 1)
!      ENDIF

! *** Read receptors Wet Deposition filename (Only one compund?):
      IF (MAINFE) THEN
          CALL GETDAT(MAINUN,TXTSTR,LEOF)
          IF (TXTSTR(1:1) .NE. '<') THEN
              READ (TXTSTR,1000) WDEPRFN
          ENDIF
          print *,'receptor point wetdep filename',WDEPRFN
      ELSE
          TXTSTR(1:1) = '<'
          CALL GETFNV(TXTSTR,WDEPRFN,WDEPRFE,1,1,  &
                     WDEPRFV)
      ENDIF
!      IF (MESSFE) THEN
!          WRITE (MESSUN,2210)
!     &    (WDEPRFN(I:I),I=1,INDEX(WDEPRFN,' ') - 1)
!      ENDIF

! *** Read line sources Dry Deposition filename (Only one compound?):
      IF (MAINFE) THEN
          CALL GETDAT(MAINUN,TXTSTR,LEOF)
          IF (TXTSTR(1:1) .NE. '<') THEN
              READ (TXTSTR,1000) DDEPLFN
          ENDIF
          print *,'line source drydep filename', DDEPLFN
      ELSE
          TXTSTR(1:1) = '<'
          CALL GETFNV(TXTSTR,DDEPLFN,DDEPLFE,1,1,  &
                     DDEPLFV)
      ENDIF
!      IF (MESSFE) THEN
!          WRITE (MESSUN,2300)
!     &    (DDEPLFN(I:I),I=1,INDEX(DDEPLFN,' ') - 1)
!      ENDIF

! *** Read line sources Wet Deposition filename (Only one compound?):
      IF (MAINFE) THEN
          CALL GETDAT(MAINUN,TXTSTR,LEOF)
          IF (TXTSTR(1:1) .NE. '<') THEN
              READ (TXTSTR,1000) WDEPLFN
          ENDIF
          print *,'line source wetdep filename', WDEPLFN
      ELSE
          TXTSTR(1:1) = '<'
          CALL GETFNV(TXTSTR,WDEPLFN,WDEPLFE,1,1,  &
                     WDEPLFV)
      ENDIF
!      IF (MESSFE) THEN
!          WRITE (MESSUN,2310)
!     &    (WDEPLFN(I:I),I=1,INDEX(WDEPLFN,' ') - 1)
!      ENDIF

      RETURN

 1000 format (A256)

 2000 format ('RDEPO: Main grid dry depositions file = ',256A1)
 2010 format ('RDEPO: Main grid wet depositions file = ',256A1)
 2100 format ('RDEPO: Sub  grid dry depositions file = ',256A1)
 2110 format ('RDEPO: Sub  grid wet depositions file = ',256A1)
 2200 format ('RDEPO: Receptors dry depositions file = ',256A1)
 2210 format ('RDEPO: Receptors wet depositions file = ',256A1)
 2300 format ('RDEPO: Line src. dry depositions file = ',256A1)
 2310 format ('RDEPO: Line src. wet depositions file = ',256A1)

! *** End of subroutine RDEPO

      end subroutine rdepo


C======================================================================
      SUBROUTINE PRINT
C
C parse PRINT qualifiers
      IMPLICIT NONE
C I/O
      INCLUDE 'cns.inc'
      INCLUDE 'comand.inc'
      INCLUDE 'coord.inc'
      INCLUDE 'cnst.inc'
      INCLUDE 'heap.inc'
      INCLUDE 'noe.inc'
C local
      CHARACTER*4 SOBJ
      DOUBLE PRECISION THRESH
C begin
      CALL NEXTA4('PRINT-object=',SOBJ)
      IF (SOBJ.EQ.'THRE') THEN
      CALL NEXTF('THREshold=',THRESH)
      CALL NEXTA4('PRINT-object=',SOBJ)
      ELSE
      THRESH=-0.0001D0
      END IF
C
      IF (SOBJ.EQ.'HELP') THEN
C
      CALL CNSHELP('cns-print')
C
      ELSE IF (SOBJ.EQ.'BOND') THEN
      CALL PRPICK('BOND',THRESH)
      ELSE IF (SOBJ.EQ.'ANGL') THEN
      CALL PRPICK('ANGL',THRESH)
      ELSE IF (SOBJ.EQ.'DIHE') THEN
      CALL PRPICK('DIHE',THRESH)
      ELSE IF (SOBJ.EQ.'IMPR') THEN
      CALL PRPICK('IMPR',THRESH)
      ELSE IF (SOBJ.EQ.'NOE ') THEN
      CALL NOEPRI(THRESH,0,.TRUE.,0)
      IF (NOEICV.GT.0) CALL NOEPRI(THRESH,1,.TRUE.,0)
      ELSE IF (SOBJ.EQ.'CDIH') THEN
      CALL CDIPRI(PUNIT,CNPHI,CNSCA,HEAP(ICIP),HEAP(ICJP),
     &        HEAP(ICKP),HEAP(ICLP),HEAP(ICICP),HEAP(ICCPD),
     &        HEAP(ICCPE),HEAP(ICCPB),HEAP(ICCPC),HEAP(ICCPO),
     &        THRESH,HEAP(HPDCV),0,DIHICV)
      IF (DIHICV.GT.0) THEN
      CALL CDIPRI(PUNIT,CNPHI,CNSCA,HEAP(ICIP),HEAP(ICJP),
     &            HEAP(ICKP),HEAP(ICLP),HEAP(ICICP),HEAP(ICCPD),
     &            HEAP(ICCPE),HEAP(ICCPB),HEAP(ICCPC),HEAP(ICCPO),
     &            THRESH,HEAP(HPDCV),1,DIHICV)
      END IF
      ELSE
      CALL DSPERR('PRINT','unknown value')
      END IF
      RETURN
      END
C======================================================================


*----------------------------------------------------------------------*
      subroutine expand_op_product(form_list,idx_res,
     &                             fac,nops,idx_op,
     &                             iblk_min_in, iblk_max_in,
     &                             connect,nconnect,force,
     &                             op_info)
*----------------------------------------------------------------------*
*     given a list of operator indices and a result operator generate
*     all contractions arising from
*
*        fac * <C_res|Op(1)Op(2) ....Op(n)|A_res>
*
*     idx_res: operator describing resulting "shape" of contraction
*     idx_op(nops): operators to be contracted
*     connect(2,nconnect): list of operator pairs that must be connected
*                          e.g. (1,3) if first and third operator should
*                          be connected.
*     force is set true if we want the connection of the first and last
*     vertices in a non-standard way. If this is so then the first
*     element of connect should be (1,nconnect).
*
*     andreas, june 2007
*
*----------------------------------------------------------------------*
      implicit none

      include 'stdunit.h'
      include 'opdim.h'
      include 'mdef_operator_info.h'
      include 'def_contraction.h'
      include 'def_formula_item.h'
      include 'ifc_operators.h'
      include 'ifc_baserout.h'

      integer, parameter ::
     &     ntest = 00

      type(formula_item), intent(inout), target ::
     &     form_list
      real(8), intent(in) ::
     &     fac
      integer, intent(in) ::
     &     nops, nconnect,
     &     idx_res, idx_op(nops), iblk_min_in(nops), iblk_max_in(nops),
     &     connect(2,nconnect)
      type(operator_info), intent(in) ::
     &     op_info
      logical, intent(in)::
     &     force

      type(formula_item), pointer ::
     &     form_pnt
      type(contraction) ::
     &     proto
      type(operator), pointer ::
     &     op_res, op
      logical ::
     &     fix_vtx(nops)
      logical ::
     &     ok
      integer ::
     &     nvtx, narc, iarc, iblk_res, iop, jop
      integer ::
     &     iblk_min(nops), iblk_max(nops), iblk_op(nops),
     &     occ_test(ngastp,2), occ_temp(ngastp,2),
     &     idx_op_vtx(nops+2), idx_sv_vtx(nops+2),
     &     iblk_min2(nops+2), iblk_max2(nops+2),
     &     connect2(2,nconnect)
      integer, pointer ::
     &     occ_vtx(:,:,:), neqv(:), idx_eqv(:,:), iop_typ(:)

      integer, external ::
     &     vtx_type

      ! passing arguments to expand_op_product2
      if (force) call quit(1,'obsolete "force" feature?')
      idx_op_vtx(2:nops+1) = idx_op(1:nops)
      idx_op_vtx(1) = idx_res
      idx_op_vtx(nops+2) = idx_res
      do iop = 1,nops+1
        idx_sv_vtx(iop) = iop
      end do
      idx_sv_vtx(nops+2) = 1
      iblk_min2(2:nops+1) = iblk_min_in(1:nops)
      iblk_max2(2:nops+1) = iblk_max_in(1:nops)
      if (iblk_min2(2).lt.0) then
        iblk_min2(1) = -1
      else
        iblk_min2(1) = 1
        iblk_min2(nops+2) = 1
      end if
      if (iblk_max2(2).lt.0) then
        iblk_max2(1) = -1
      else
        iblk_max2(1) = op_info%op_arr(idx_res)%op%n_occ_cls
        iblk_max2(nops+2) = op_info%op_arr(idx_res)%op%n_occ_cls
      end if
      connect2(1:2,1:nconnect) = connect(1:2,1:nconnect) + 1
      call expand_op_product2(form_list,idx_res,
     &       fac,nops+2,nops+1,
     &       idx_op_vtx,idx_sv_vtx,
     &       iblk_min2,iblk_max2,
     &       connect2,nconnect,
     &       0,0,
     &       0,0,
     &       .false.,op_info)

******OBSOLETE*********************************************************
*     obsolete part of subroutine
*     now deleted
***********************************************************************

      return
      end