PROGRAM obsope
!=======================================================================
!
! [PURPOSE:] Main program of observation operator
!
! [HISTORY:]
!   04/03/2013 Takemasa Miyoshi  created
!
!=======================================================================
  USE common
  USE common_mpi
  USE common_letkf
  USE common_speedy
  USE common_obs_speedy

  IMPLICIT NONE
! CHARACTER(9) :: obsinfile='obsin.dat'                  !IN
  CHARACTER(18) :: obsinfile='obs/yyyymmddhh.dat'        !IN
  CHARACTER(26) :: guesfile='gues/000000/yyyymmddhh.grd' !IN
  CHARACTER(15) :: obsoutfile='obs01000000.dat'          !OUT
  CHARACTER(15) :: cnffile='letkf.cnf000000'             !OUT
  REAL(r_size),ALLOCATABLE :: elem(:)
  REAL(r_size),ALLOCATABLE :: rlon(:)
  REAL(r_size),ALLOCATABLE :: rlat(:)
  REAL(r_size),ALLOCATABLE :: rlev(:)
  REAL(r_size),ALLOCATABLE :: odat(:)
  REAL(r_size),ALLOCATABLE :: oerr(:)
  REAL(r_size),ALLOCATABLE :: ohx(:)
  INTEGER,ALLOCATABLE :: oqc(:)
  REAL(r_size),ALLOCATABLE :: v3d(:,:,:,:)
  REAL(r_size),ALLOCATABLE :: v2d(:,:,:)
  REAL(r_size),ALLOCATABLE :: p_full(:,:,:)
  REAL(r_size),PARAMETER :: threshold_dz=1000.0d0
  REAL(r_size) :: dz,tg,qg
  INTEGER :: nobs
  REAL(r_size) :: ri,rj,rk
  INTEGER :: n
! INTEGER :: nbv                                          ! KK
  character(4) :: yyyy                                    ! KK
  character(2) :: mm, dd, hh                              ! KK
  INTEGER :: i, ista, iend                                ! KK
  INTEGER :: ierr
  namelist/letkf_param/ sigma_obs,nbv,pymdh,ymdh,logic_wout,logic_wsth,logic_wint,dastype,resample_m,type_pfmtx,type_relax,alph_relax,fgt_factor,gamma_gmpf

  CALL initialize_mpi
  CALL set_common_speedy
  if(myrank == 0) print '(A6, I6, A9, I10)', 'nbv = ', nbv, ', YMDH = ', ymdh

  open(1,file='letkf.cnf')
    read(1,nml=letkf_param)
  close(1)

! if(myrank == 0) then
!   namelist / MEMBER_INFO / &
!     nbv,  &
!     yyyy, &
!     mm,   &
!     dd,   &
!     hh
!   open(10, file='./MEMINFO', form='formatted', status='old')
!   read(10, nml=MEMBER_INFO)
!   close(10)
! end if
! CALL MPI_BCAST(nbv, 1, MPI_INTEGER,   0, MPI_COMM_WORLD, ierr)
! CALL MPI_BCAST(yyyy, 4, MPI_CHARACTER, 0, MPI_COMM_WORLD, ierr)
! CALL MPI_BCAST(mm,   2, MPI_CHARACTER, 0, MPI_COMM_WORLD, ierr)
! CALL MPI_BCAST(dd,   2, MPI_CHARACTER, 0, MPI_COMM_WORLD, ierr)
! CALL MPI_BCAST(hh,   2, MPI_CHARACTER, 0, MPI_COMM_WORLD, ierr)

  write(obsinfile(5:14), '(I10.10)') ymdh
  IF( myrank == 0) CALL get_nobs(obsinfile,6,nobs)
  CALL MPI_BCAST(nobs, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)

  ALLOCATE( elem(nobs) )
  ALLOCATE( rlon(nobs) )
  ALLOCATE( rlat(nobs) )
  ALLOCATE( rlev(nobs) )
  ALLOCATE( odat(nobs) )
  ALLOCATE( oerr(nobs) )
  ALLOCATE( ohx(nobs) )
  ALLOCATE( oqc(nobs) )

  CALL MPI_BARRIER(MPI_COMM_WORLD,ierr)

  CALL read_obs(obsinfile,nobs,elem,rlon,rlat,rlev,odat,oerr)
! IF( myrank == 0 ) CALL read_obs(obsinfile,nobs,elem,rlon,rlat,rlev,odat,oerr)
! CALL MPI_BCAST(elem, nobs, MPI_REAL8, 0, MPI_COMM_WORLD, ierr)
! CALL MPI_BCAST(rlon, nobs, MPI_REAL8, 0, MPI_COMM_WORLD, ierr)
! CALL MPI_BCAST(rlat, nobs, MPI_REAL8, 0, MPI_COMM_WORLD, ierr)
! CALL MPI_BCAST(rlev, nobs, MPI_REAL8, 0, MPI_COMM_WORLD, ierr)
! CALL MPI_BCAST(odat, nobs, MPI_REAL8, 0, MPI_COMM_WORLD, ierr)
! CALL MPI_BCAST(oerr, nobs, MPI_REAL8, 0, MPI_COMM_WORLD, ierr)
! CALL MPI_BCAST(ohx , nobs, MPI_REAL8, 0, MPI_COMM_WORLD, ierr)
! CALL MPI_BCAST(oqc , nobs, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
! print *, myrank, elem(obs-1), elem(10)
! print *, myrank, rlon(nobs-1), rlon(10)
! print *, myrank, rlat(nobs-1), rlat(10)
! print *, myrank, rlev(nobs-1), rlev(10)
! print *, myrank, odat(nobs-1), odat(10)
! print *, myrank, oerr(nobs-1), oerr(10)
! print *, myrank, ohx(nobs-1), ohx(10)
! print *, myrank, oqc(nobs-1), oqc(10)
  ALLOCATE( v3d(nlon,nlat,nlev,nv3d) )
  ALLOCATE( v2d(nlon,nlat,nv2d) )
  ALLOCATE( p_full(nlon,nlat,nlev) )

  ista = myrank+1                                                           ! KK
  iend = nbv                                                                ! KK
  do i = ista, iend, nprocs                                                 ! KK

!   write(guesfile(6:11), '(I6.6)') myrank+nbv                              ! KK
    write(guesfile(6:11), '(I6.6)') i                                       ! KK
    write(guesfile(13:22), '(I10.10)') ymdh                                 ! KK
    CALL read_grd(guesfile,v3d,v2d)

    p_full(:,:,:) = 0.d0                                                    ! KK
    CALL calc_pfull(nlon,nlat,v2d(:,:,iv2d_ps),p_full)

    ohx=0.0d0
    oqc=0
    DO n=1,nobs
      CALL phys2ijk(p_full,elem(n),rlon(n),rlat(n),rlev(n),ri,rj,rk)
      IF(CEILING(ri) < 2 .OR. nlon+1 < CEILING(ri)) THEN
 !      WRITE(6,'(A)') '* X-coordinate out of range'
 !      WRITE(6,'(A,F6.2,A,F6.2)') '*   ri=',ri,', rlon=',rlon(n)
        CYCLE
      END IF
      IF(CEILING(rj) < 2 .OR. nlat < CEILING(rj)) THEN
 !      WRITE(6,'(A)') '* Y-coordinate out of range'
 !      WRITE(6,'(A,F6.2,A,F6.2)') '*   rj=',rj,', rlat=',rlat(n)
        CYCLE
      END IF
      IF(CEILING(rk) > nlev) THEN
        CALL itpl_2d(phi0,ri,rj,dz)
 !      WRITE(6,'(A)') '* Z-coordinate out of range'
 !      WRITE(6,'(A,F6.2,A,F10.2,A,F6.2,A,F6.2,A,F10.2)') &
 !       & '*   rk=',rk,', rlev=',rlev(n),&
 !       & ', (lon,lat)=(',rlon(n),',',rlat(n),'), phi0=',dz
        CYCLE
      END IF
      IF(CEILING(rk) < 2 .AND. NINT(elem(n)) /= id_ps_obs) THEN
        IF(NINT(elem(n)) == id_u_obs .OR. NINT(elem(n)) == id_v_obs) THEN
          rk = 1.00001d0
        ELSE
          CALL itpl_2d(phi0,ri,rj,dz)
 !        WRITE(6,'(A)') '* Z-coordinate out of range'
 !        WRITE(6,'(A,F6.2,A,F10.2,A,F6.2,A,F6.2,A,F10.2)') &
 !         & '*   rk=',rk,', rlev=',rlev(n),&
 !         & ', (lon,lat)=(',rlon(n),',',rlat(n),'), phi0=',dz
          CYCLE
        END IF
      END IF
      IF(NINT(elem(n)) == id_ps_obs .AND. odat(n) < -100.0d0) THEN
        CYCLE
      END IF
!     IF(NINT(tmpelm(nn+n)) == id_ps_obs) THEN
!       CALL itpl_2d(phi0,ri,rj,dz)
!       dz = dz - tmplev(nn+n)
!       IF(ABS(dz) < threshold_dz) THEN ! pressure adjustment threshold
!         CALL itpl_2d(t(:,:,1),ri,rj,tg)
!         CALL itpl_2d(q(:,:,1),ri,rj,qg)
!         CALL prsadj(tmpdat(nn+n),dz,tg,qg)
!       ELSE
!         PRINT '(A)','PS obs vertical adjustment beyond threshold'
!         PRINT '(A,F10.2,A,F6.2,A,F6.2,A)',&
!           & '  dz=',dz,', (lon,lat)=(',tmplon(nn+n),',',tmplat(nn+n),')'
!         CYCLE
!       END IF
!     END IF
      !
      ! observational operator
      !
      CALL Trans_XtoY(elem(n),ri,rj,rk,v3d,v2d,p_full,ohx(n))
      oqc(n) = 1
    END DO

!   write(obsoutfile(6:11), '(I6.6)') myrank+nbv                            ! KK
    write(obsoutfile(6:11), '(I6.6)') i                                     ! KK
    CALL write_obs2(obsoutfile,nobs,elem,rlon,rlat,rlev,odat,oerr,ohx,oqc)
  end do                                                                    ! KK

  DEALLOCATE( elem,rlon,rlat,rlev,odat,oerr,ohx,oqc,v3d,v2d,p_full )

  CALL MPI_BARRIER(MPI_COMM_WORLD,ierr)

!=== make information file ===!
  ! fort.2 for SPEEDY model
! open(9, file='fort.2', form='formatted')
! write(9, *) "1111"
! write(9, *) yyyy
! write(9, *) mm
! write(9, *) dd
! write(9, *) hh
! close(9)

  ! ymhd.txt
! open(11, file='ymdh.txt', form='formatted')
! write(11, '(A10)') tymdh
! close(11)

  CALL MPI_BARRIER(MPI_COMM_WORLD,ierr)
  CALL finalize_mpi

  stop

END PROGRAM obsope


      SUBROUTINE DIVSET(ALG, IV, LIV, LV, V)
C
C  ***  SUPPLY ***SOL (VERSION 2.3) DEFAULT VALUES TO IV AND V  ***
C
C  ***  ALG = 1 MEANS REGRESSION CONSTANTS.
C  ***  ALG = 2 MEANS GENERAL UNCONSTRAINED OPTIMIZATION CONSTANTS.
C
      INTEGER LIV, LV
      INTEGER ALG, IV(LIV)
      DOUBLE PRECISION V(LV)
C
      INTEGER I7MDCN
      EXTERNAL I7MDCN,DV7DFL
C I7MDCN... RETURNS MACHINE-DEPENDENT INTEGER CONSTANTS.
C DV7DFL.... PROVIDES DEFAULT VALUES TO V.
C
      INTEGER ALG1, MIV, MV
      INTEGER MINIV(4), MINV(4)
C
C  ***  SUBSCRIPTS FOR IV  ***
C
      INTEGER ALGSAV, COVPRT, COVREQ, DRADPR, DTYPE, HC, IERR, INITH,
     1        INITS, IPIVOT, IVNEED, LASTIV, LASTV, LMAT, MXFCAL,
     2        MXITER, NFCOV, NGCOV, NVDFLT, NVSAVE, OUTLEV, PARPRT,
     3        PARSAV, PERM, PRUNIT, QRTYP, RDREQ, RMAT, SOLPRT, STATPR,
     4        VNEED, VSAVE, X0PRT
C
C  ***  IV SUBSCRIPT VALUES  ***
C
      PARAMETER (ALGSAV=51, COVPRT=14, COVREQ=15, DRADPR=101, DTYPE=16,
     1           HC=71, IERR=75, INITH=25, INITS=25, IPIVOT=76,
     2           IVNEED=3, LASTIV=44, LASTV=45, LMAT=42, MXFCAL=17,
     3           MXITER=18, NFCOV=52, NGCOV=53, NVDFLT=50, NVSAVE=9,
     4           OUTLEV=19, PARPRT=20, PARSAV=49, PERM=58, PRUNIT=21,
     5           QRTYP=80, RDREQ=57, RMAT=78, SOLPRT=22, STATPR=23,
     6           VNEED=4, VSAVE=60, X0PRT=24)
      DATA MINIV(1)/82/, MINIV(2)/59/, MINIV(3)/103/, MINIV(4)/103/,
     1     MINV(1)/98/, MINV(2)/71/, MINV(3)/101/, MINV(4)/85/
C
C-------------------------------  BODY  --------------------------------
C
      IF (PRUNIT .LE. LIV) IV(PRUNIT) = I7MDCN(1)
      IF (ALGSAV .LE. LIV) IV(ALGSAV) = ALG
      IF (ALG .LT. 1 .OR. ALG .GT. 4) GO TO 40
      MIV = MINIV(ALG)
      IF (LIV .LT. MIV) GO TO 20
      MV = MINV(ALG)
      IF (LV .LT. MV) GO TO 30
      ALG1 = MOD(ALG-1,2) + 1
      CALL DV7DFL(ALG1, LV, V)
      IV(1) = 12
      IF (ALG .GT. 2) IV(DRADPR) = 1
      IV(IVNEED) = 0
      IV(LASTIV) = MIV
      IV(LASTV) = MV
      IV(LMAT) = MV + 1
      IV(MXFCAL) = 200
      IV(MXITER) = 150
      IV(OUTLEV) = 1
      IV(PARPRT) = 1
      IV(PERM) = MIV + 1
      IV(SOLPRT) = 1
      IV(STATPR) = 1
      IV(VNEED) = 0
      IV(X0PRT) = 1
C
      IF (ALG1 .GE. 2) GO TO 10
C
C  ***  REGRESSION  VALUES
C
      IV(COVPRT) = 3
      IV(COVREQ) = 1
      IV(DTYPE) = 1
      IV(HC) = 0
      IV(IERR) = 0
      IV(INITS) = 0
      IV(IPIVOT) = 0
      IV(NVDFLT) = 32
      IV(VSAVE) = 58
      IF (ALG .GT. 2) IV(VSAVE) = IV(VSAVE) + 3
      IV(PARSAV) = IV(VSAVE) + NVSAVE
      IV(QRTYP) = 1
      IV(RDREQ) = 3
      IV(RMAT) = 0
      GO TO 999
C
C  ***  GENERAL OPTIMIZATION VALUES
C
 10   IV(DTYPE) = 0
      IV(INITH) = 1
      IV(NFCOV) = 0
      IV(NGCOV) = 0
      IV(NVDFLT) = 25
      IV(PARSAV) = 47
      IF (ALG .GT. 2) IV(PARSAV) = 61
      GO TO 999
C
 20   IV(1) = 15
      GO TO 999
C
 30   IV(1) = 16
      GO TO 999
C
 40   IV(1) = 67
C
 999  RETURN
C  ***  LAST LINE OF DIVSET FOLLOWS  ***
      END


! KGEN-generated Fortran source file
!
! Filename    : rrlw_kg09.f90
! Generated at: 2015-07-06 23:28:45
! KGEN version: 0.4.13

    MODULE rrlw_kg09
        USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check
        USE shr_kind_mod, ONLY: r8 => shr_kind_r8
        !      use parkind ,only : jpim, jprb
        IMPLICIT NONE
        !-----------------------------------------------------------------
        ! rrtmg_lw ORIGINAL abs. coefficients for interval 9
        ! band 9:  1180-1390 cm-1 (low - h2o,ch4; high - ch4)
        !
        ! Initial version:  JJMorcrette, ECMWF, jul1998
        ! Revised: MJIacono, AER, jun2006
        !-----------------------------------------------------------------
        !
        !  name     type     purpose
        !  ----   : ----   : ---------------------------------------------
        !fracrefao: real
        !fracrefbo: real
        ! kao     : real
        ! kbo     : real
        ! kao_mn2o: real
        ! kbo_mn2o: real
        ! selfrefo: real
        ! forrefo : real
        !-----------------------------------------------------------------
        !-----------------------------------------------------------------
        ! rrtmg_lw COMBINED abs. coefficients for interval 9
        ! band 9:  1180-1390 cm-1 (low - h2o,ch4; high - ch4)
        !
        ! Initial version:  JJMorcrette, ECMWF, jul1998
        ! Revised: MJIacono, AER, jun2006
        !-----------------------------------------------------------------
        !
        !  name     type     purpose
        !  ----   : ----   : ---------------------------------------------
        !fracrefa : real
        !fracrefb : real
        ! ka      : real
        ! kb      : real
        ! ka_mn2o : real
        ! kb_mn2o : real
        ! selfref : real
        ! forref  : real
        !
        ! absa    : real
        ! absb    : real
        !-----------------------------------------------------------------
        INTEGER, parameter :: ng9  = 12
        REAL(KIND=r8), dimension(ng9) :: fracrefb
        REAL(KIND=r8) :: fracrefa(ng9,9)
        REAL(KIND=r8) :: absa(585,ng9)
        REAL(KIND=r8) :: absb(235,ng9)
        REAL(KIND=r8) :: ka_mn2o(9,19,ng9)
        REAL(KIND=r8) :: kb_mn2o(19,ng9)
        REAL(KIND=r8) :: selfref(10,ng9)
        REAL(KIND=r8) :: forref(4,ng9)
        PUBLIC kgen_read_externs_rrlw_kg09
    CONTAINS

    ! write subroutines

    ! module extern variables

    SUBROUTINE kgen_read_externs_rrlw_kg09(kgen_unit)
        INTEGER, INTENT(IN) :: kgen_unit
        READ(UNIT=kgen_unit) fracrefb
        READ(UNIT=kgen_unit) fracrefa
        READ(UNIT=kgen_unit) absa
        READ(UNIT=kgen_unit) absb
        READ(UNIT=kgen_unit) ka_mn2o
        READ(UNIT=kgen_unit) kb_mn2o
        READ(UNIT=kgen_unit) selfref
        READ(UNIT=kgen_unit) forref
    END SUBROUTINE kgen_read_externs_rrlw_kg09

    END MODULE rrlw_kg09


c 07.06.2006 Link routines between QGSJet-II-03 and EPOS.
c author T. Pierog

c-----------------------------------------------------------------------
      subroutine IniQGSJETII
c-----------------------------------------------------------------------
c Primary initialization for QGSJET-II
c-----------------------------------------------------------------------
      parameter(iapmax=208)
      include 'epos.inc'
      integer debug
      common /qgdebug/ debug
      common /qgarr43/ moniou
      double precision bqgs2,bmaxqgs,bmaxnex,bminnex,xan,xbn
      common /qgsIInex1/xan(iapmax,3),xbn(iapmax,3)
     *,bqgs2,bmaxqgs,bmaxnex,bminnex
      CHARACTER DATDIR*(132)

      call utpri('iniqgsII',ish,ishini,6)
      write(ifmt,'(a,i6)')'initialize QGSJET-II ...'

      debug=0
      if(ish.ge.3)debug=ish-2
      moniou=ifch

c model parameter setting
      call qgset
c common initialization procedure
      DATDIR="qgsjetII"
      call qgaini(DATDIR)
      BMAXNEX=dble(bmaxim)
      BMINNEX=dble(bminim)
      egymin=0.1
      egymax=egymax
      irescl=0

      call utprix('iniqgsII',ish,ishini,6)
      end

c-----------------------------------------------------------------------
      subroutine IniEvtQGSII
c-----------------------------------------------------------------------
c Initialization for each type of event (for given proj, targ and egy)
c-----------------------------------------------------------------------
      parameter(iapmax=208)
      include 'epos.inc'
      common/geom/rmproj,rmtarg,bmax,bkmx
c QGSJET-II Common
      double precision bqgs,bmaxqgs,bmaxnex,bminnex,xa,xb,e0
      common /qgsIInex1/xa(iapmax,3),xb(iapmax,3)
     *,bqgs,bmaxqgs,bmaxnex,bminnex

      if(matarg.gt.iapmax.or.maproj.gt.iapmax)
     &  call utstop('Nucleus too big for QGSJET-II (Mmax=208) !&')
      call iclass(idproj,iclpro)
      call iclass(idtarg,icltar)
      icp=idtrafo('nxs','qgs',idproj)
      if(icp.eq.0)icp=1-2*int(rangen()+0.5)       !pi0=pi+ or p-
      if(abs(icp).gt.5)
     &  call utstop('Projectile not allowed in QGSJET-II !&')
      e0=dble(elab)
      call qgini(e0,icp,maproj,matarg)
      call qgini(e0,icp,maproj,matarg)        !again to set bm properly
      bmax=BMAXQGS
      qgsIIincs=qgsIIcrse(ekin,maproj,matarg,idtarg)
      if(engy.lt.egymin)qgsIIincs=0.          !below egymin, no interaction
      call xsigma                             !change bm in qgfz
      bkmx=sqrt(sigine/10./pi)        !10= fm^2 -> mb
      if(ish.ge.2)write(ifch,*)
     &  'QGSJET-II used with (E,proj,maproj,matarg,bmax)',e0,icp
     &  ,maproj,matarg,bmax

      return
      end

c-----------------------------------------------------------------------
      subroutine emsqgsII(iret)
c-----------------------------------------------------------------------
c  call qgsjet-II to simulate interaction
c-----------------------------------------------------------------------
      parameter(iapmax=208,nptmax=95000)
      include 'epos.inc'
      include 'epos.incems'
      common/geom/rmproj,rmtarg,bmax,bkmx
      double precision bqgs,bmaxqgs,bmaxnex,bminnex,xa,xb,esp
      common /qgsIInex1/xa(iapmax,3),xb(iapmax,3)
     *,bqgs,bmaxqgs,bmaxnex,bminnex
      common/nucl3/phi,bimp
      common /qgarr12/ nsp
      common /qgarr14/ esp(4,nptmax),ich(nptmax)
c nsf - number of secondary fragments;
c iaf(i) - mass of the i-th fragment
      common /qgarr13/ nsf,iaf(iapmax)
      common /qgarr55/ nwt,nwp

      iret=0
      b1=bminim
      b2=min(bmax,bmaxim)
      a=pi*(b2**2-b1**2)

      if(a.gt.0..and.rangen().gt.qgsIIincs/10./a)goto 1001   !no interaction
      if(ish.ge.3)call alist('Determine QGSJET-II Production&',0,0)

      nptl=0
      nsp=0
      call qgconf

      nevt=1
      kolevt=-1
      koievt=-1
      kohevt=-1
      npjevt=maproj
      ntgevt=matarg
      pmxevt=pnll
      egyevt=engy
      if(BQGS.ge.0.d0)then
        bimevt=real(BQGS)
        bimp=real(BQGS)
        phi=2.*pi*rangen()
        phievt=phi
      else
        bimevt=0.
        bimp=0.
        phievt=0.
        phi=0.
      endif
      anintine=anintine+1.

      call conre
      call conwr
      call conqgsII

c keep the projectile spectators as fragments
      npns=0
      npps=0
      ns=0
      if(infragm.eq.2)then

        if(NSF.gt.0)then
          do is=1,NSF           !count the number of spectators
          if(ish.ge.7)write(ifch,'(a,i5,a,i5)')
     $       ' Projecticle Fragment ',is,' Mass :',IAF(is)
            nptl=nptl+1
            istptl(nptl)=0
            if(IAF(is).eq.1)then
              id=idptl(is)
              pptl(3,nptl)=pptl(3,is)
              pptl(4,nptl)=pptl(4,is)
              pptl(5,nptl)=pptl(5,is)
              if(id.eq.1120)npps=npps+1
              if(id.eq.1220)npns=npns+1
            else
              if(IAF(is).eq.2)then
                id=17
                npps=npps+1
                npns=npns+1
              elseif(IAF(is).eq.3)then
                id=18
                npps=npps+1
                npns=npns+2
              elseif(IAF(is).eq.4)then
                id=19
                npps=npps+2
                npns=npns+2
              else
                inucl=IAF(is)
                iprot= int(dble(inucl) / 2.15d0 + 0.7d0)
                id=1000000000+iprot*10000+inucl*10 !code for nuclei
                npps=npps+iprot
                npns=npns+inucl-iprot
              endif
              call idmass(id,am)
              pptl(4,nptl)=dble(IAF(is))*pptl(4,is)      !Etot
              pptl(5,nptl)=am                             !mass
              pz2tmp=(pptl(4,nptl)+am)*(pptl(4,nptl)-am)
              if(pz2tmp.gt.0.d0)then
                pptl(3,nptl)=sqrt(pz2tmp)                 !Pz
              else
                write(*,*)'Warning in emsqgsII !'
                write(*,*)'energy of fragment too small :',IAF(is),am
     &                     ,pptl(4,nptl)
                pptl(3,nptl)=pptl(4,nptl)
              endif
            endif
            pptl(1,nptl)=0.d0 !P_x
            pptl(2,nptl)=0.d0 !P_y
            ityptl(nptl)=0
            iorptl(nptl)=1
            jorptl(nptl)=maproj+matarg
            ifrptl(1,nptl)=0
            ifrptl(2,nptl)=0
            xorptl(1,nptl)=0.d0
            xorptl(2,nptl)=0.d0
            xorptl(3,nptl)=0.d0
            xorptl(4,nptl)=0.d0
            tivptl(1,nptl)=0.d0
            tivptl(2,nptl)=0.d0
            idptl(nptl)=id
            if(ish.ge.5)write(ifch,'(a,i5,a,i5,a,4(e10.4,1x),f6.3)')
     $       ' Fragment from qgsjetII ',nptl,' id :',idptl(nptl)
     $  , ' momentum :',(pptl(k,nptl),k=1,5)

          enddo
        endif

c make the projectile spectators as free nucleons

      else
        ns=0
        if(NSF.gt.0)then
          do is=1,NSF           !count the number of spectators
            ns=ns+IAF(is)
          enddo
          if(infragm.eq.1)then
c  remaining nucleus is one fragment
            nptl=nptl+1
            istptl(nptl)=0
            pptl(1,nptl)=0.d0
            pptl(2,nptl)=0.d0
            pptl(4,nptl)=0.d0
            inucl=0
            do is=1,ns
              inucl=inucl+1
              pptl(4,nptl)=pptl(4,nptl)+pptl(4,is)
            enddo
            iprot= int(dble(inucl) / 2.15d0 + 0.7d0)
            idnucl=1000000000+iprot*10000+inucl*10 !code for nuclei
            npps=npps+iprot
            npns=npns+inucl-iprot
            call idmass(idnucl,am)
            pptl(5,nptl)=am  !mass
            ptot=(pptl(4,nptl)+am)*(pptl(4,nptl)-am)
            pptl(3,nptl)=sqrt(ptot)
            ityptl(nptl)=0
            istptl(nptl)=0
            iorptl(nptl)=1
            jorptl(nptl)=maproj
            ifrptl(1,nptl)=0
            ifrptl(2,nptl)=0
            xorptl(1,nptl)=xorptl(1,1)
            xorptl(2,nptl)=xorptl(2,1)
            xorptl(3,nptl)=xorptl(3,1)
            xorptl(4,nptl)=xorptl(4,1)
            tivptl(1,nptl)=tivptl(1,1)
            tivptl(2,nptl)=tivptl(2,1)
            idptl(nptl)=idnucl
          else
            do is=maproj-ns+1,maproj          !make the ns last projectile nucleon final
              if(idptl(is).eq.1120)npps=npps+1
              if(idptl(is).eq.1220)npns=npns+1
            enddo
          endif
        endif
      endif

c number of participants
      if(laproj.gt.1)then
        npjevt=maproj-npps-npns
        npppar=max(0,laproj-npps)
        npnpar=npjevt-npppar
c set participant projectile as non spectators
        do i=1,maproj
          if(idptl(i).eq.1120)then
            if(npppar.gt.0)then
              npppar=npppar-1
            else                !restore spectators
              iorptl(i)=0
              if(infragm.eq.0)istptl(i)=0
            endif
          endif
          if(idptl(i).eq.1220)then
            if(npnpar.gt.0)then
              npnpar=npnpar-1
            else                !restore spectators
              iorptl(i)=0
              if(infragm.eq.0)istptl(i)=0
            endif
          endif
        enddo
      endif

c restore target spectators
      ns=0
      if(NWT.lt.matarg)then
c number of participants
        ntgevt=NWT
        do is=ntgevt+1,matarg         !make the last target nucleon final
          iorptl(maproj+is)=0
          istptl(maproj+is)=0
        enddo
      endif

      do is=1,nsp

c ich is the type of secondary hadron, esp - its transverse momentum,
c and its energy
c the following notations for the particles types are used: 0 - pi0, 1 -
c pi+,
c -1 - pi-, 2 - p, -2 - p, 3 - n, -3 - n, 4 - k+, -4 - k-, 5 - k0s, -5 -
c k0l
          ic=ich(is)
          if(ish.ge.7)write(ifch,'(a,i5,a,i5,2a,4(e10.4,1x))')
     $       ' qgsjet particle ',is,' id :',ic,' before conversion'
     $     , ' momentum :',(esp(k,is),k=1,4)

            nptl=nptl+1
            if(nptl.gt.mxptl)call utstop('qgsjet: mxptl too small&')
            id=idtrafo('qgs','nxs',ic)
            if(ish.ge.7)write(ifch,'(a,i5,a,i5,a)')
     $       ' epos particle ',nptl,' id :',id,' after conversion'
            call idmass(id,am)

            pptl(1,nptl)=real(esp(3,is)) !P_x
            pptl(2,nptl)=real(esp(4,is)) !P_y
            pptl(3,nptl)=real(esp(2,is)) !P_z
            pptl(4,nptl)=real(esp(1,is)) !E
            pptl(5,nptl)=am              !mass
            istptl(nptl)=0
            ityptl(nptl)=0
            iorptl(nptl)=1
            jorptl(nptl)=maproj+matarg
            ifrptl(1,nptl)=0
            ifrptl(2,nptl)=0
            xorptl(1,nptl)=0.
            xorptl(2,nptl)=0.
            xorptl(3,nptl)=0.
            xorptl(4,nptl)=0.
            tivptl(1,nptl)=0.
            tivptl(2,nptl)=0.
            idptl(nptl)=id

c boost in CMS frame
            call utlob5(yhaha, pptl(1,nptl), pptl(2,nptl)
     .        , pptl(3,nptl), pptl(4,nptl), pptl(5,nptl))

            if(ish.ge.5)write(ifch,'(a,i5,a,i5,a,4(e10.4,1x),f6.3)')
     $       ' particle from qgsjet ',nptl,' id :',idptl(nptl)
     $  , ' momentum :',(pptl(k,nptl),k=1,5)

      enddo

1000  return

1001  iret=-1
      goto 1000

      end

c-----------------------------------------------------------------------
      subroutine conqgsII
c-----------------------------------------------------------------------
c  determines interaction configuration
c-----------------------------------------------------------------------

      include 'epos.inc'
      include 'epos.incems'
      common/geom/rmproj,rmtarg,bmax,bkmx
      common/nucl3/phi,bimp
      common /cncl/xproj(mamx),yproj(mamx),zproj(mamx)
     *            ,xtarg(mamx),ytarg(mamx),ztarg(mamx)
      common/cncl2/diffbpr(mamx,mamx),diffbtg(mamx,mamx)
      common/cncl3/iactpr(mamx),iacttg(mamx)
      common/cfacmss/facmss

      call utpri('cqgsII ',ish,ishini,4)

      iret=0

c     initialisations
c     ---------------

      vel=tanh(ypjtl-yhaha)+tanh(yhaha)

c     determine phi, bimp, coll, iproj, itarg, x/y/zproj, x/y/ztarg
c     ---------------------------------------------------------------

      if(maproj.eq.1.and.matarg.eq.1)then

      koll=1
      do n=1,4
        coord(n,1)=0.
      enddo
      bk(1)=bimp
      iproj(1)=1
      itarg(1)=1
      phi=phievt
      xproj(1)=bimp*cos(phi)
      yproj(1)=bimp*sin(phi)
      zproj(1)=0
      xtarg(1)=0
      ytarg(1)=0
      ztarg(1)=0
      lproj(1)=1
      ltarg(1)=1
      lproj3(1)=1
      ltarg3(1)=1
      kproj(1,1)=1
      ktarg(1,1)=1

           else

      bx=0
      by=0
      if(maproj.gt.0)then
        phi=phievt
        bimp=bimevt
        bx=cos(phi)*bimp
        by=sin(phi)*bimp
      endif
      if(maproj.eq.0)goto 1000
      koll=0
      do i=1,maproj
      lproj(i)=0
      enddo
      do j=1,matarg
      ltarg(j)=0
      enddo
      do 12 i=1,maproj
      do 11 j=1,matarg
      bij=sqrt((xproj(i)+bx-xtarg(j))**2+(yproj(i)+by-ytarg(j))**2)
      if(ish.ge.7)write(ifch,*)'i_p:',i,' i_t:',j,' b_ij:',bij
      if(bij.gt.bkmx)goto 11

      if(koll.ge.kollmx)goto 1000
      koll=koll+1

      bk(koll)=bij
      bkx(koll)=xproj(i)+bx-xtarg(j)
      bky(koll)=yproj(i)+by-ytarg(j)
      iproj(koll)=i
      itarg(koll)=j
      lproj(i)=lproj(i)+1
      ltarg(j)=ltarg(j)+1
      kproj(i,lproj(i))=koll
      ktarg(j,ltarg(j))=koll

11    continue
12    continue

      do k=1,koll
        do n=1,4
          coord(n,k)=0.
        enddo
      enddo

          endif

      if(ish.ge.3)write(ifch,*)'koll=',koll
      if(koll.eq.0)goto 1000

c     determine coord
c     ---------------
      do kl=1,koll
      i=iproj(kl)
      j=itarg(kl)
      dist=ztarg(j)-zproj(i)
      coord(1,kl)=(xproj(i)+xtarg(j))*0.5
      coord(2,kl)=(yproj(i)+ytarg(j))*0.5
      coord(3,kl)=(zproj(i)+ztarg(j))*0.5
      coord(4,kl)=dist/vel
      enddo

c     determine number of collisions according glauber model
c     ------------
      nglevt=koll

c     exit
c     ----
1000  continue
      if(ish.ge.5)then
      write(ifch,*)'ia,x/y/zproj:'
      do mm=1,maproj
      write(ifch,*)mm,iactpr(mm),xproj(mm),yproj(mm),zproj(mm)
      enddo
      write(ifch,*)'ia,x/y/ztarg:'
      do mm=1,matarg
      write(ifch,*)mm,iacttg(mm),xtarg(mm),ytarg(mm),ztarg(mm)
      enddo
      write(ifch,*)'iret',iret
      endif
      call utprix('cqgsII ',ish,ishini,4)
      return

      end

c------------------------------------------------------------------------------
      function qgsIIcrse(egy,mapro,matar,id)
c------------------------------------------------------------------------------
c inelastic cross section of qgsjet-II
c (id=0 corresponds to air)
c egy - kinetic energy
c maproj - projec mass number     (1<maproj<64)
c matarg - target mass number     (1<matarg<64)
c------------------------------------------------------------------------------
      include 'epos.inc'
      double precision egyl,qgsect

      qgsIIcrse=0.
      call iclass(idproj,icpro)
      call idmass(1120,amt1)
      call idmass(1220,amt2)
      amtar=0.5*(amt1+amt2)
      if(matar.eq.1)amtar=amt1
      if(mapro.eq.1)then
        call idmass(idproj,ampro)
      else
        ampro=mapro*amtar
      endif
      egyl=dble(egy+ampro)

      if(id.eq.0)then
        do k=1,3
          mt=int(airanxs(k))
          qgsIIcrse=qgsIIcrse+airwnxs(k)*qgsect(egyl,icpro,mapro,mt)
        enddo
      else
        qgsIIcrse=qgsect(egyl,icpro,mapro,matar)
      endif

      return
      end

c--------------------------------------------------------------------
      double precision function qgran(b10)
c--------------------------------------------------------------------
c Random number generator
c--------------------------------------------------------------------
      include 'epos.inc'
      double precision b10,drangen
      qgran=drangen(b10)
      if(irandm.eq.1)write(ifch,*)'qgran()= ',qgran

      return
      end


    !Do Metropolis-Hastings and slice sampling algorithms
    !Also directional gridding method for fast-slow parameters
    !Provisional implementation of Wang-Landau and Multicanonical methods

    module MonteCarlo
    use CalcLike
    use RandUtils
    use propose
    use ParamPointSet
    implicit none
    private

    real(mcp), parameter :: eps_1 = 1.00001

    Type, extends(TConfigClass) :: TSampleCollector
    contains
    procedure :: AddNewPoint => TSampleCollector_AddNewPoint
    procedure :: AddNewWeightedPoint => TSampleCollector_AddNewWeightedPoint
    procedure :: ReadCheckpoint => TSampleCollector_ReadCheckpoint
    end Type

    Type, extends(TLikelihoodUser) :: TSamplingAlgorithm
        integer :: num_sample = 0
        real(mcp) :: MaxLike = LogZero
        real(mcp) :: MaxLikeParams(max_num_params)
        class(TSampleCollector), pointer :: SampleCollector => null()
    contains
    procedure :: Init => TSamplingAlgorithm_Init
    procedure :: LogLike => TSamplingAlgorithm_LogLike
    procedure :: SaveState => TSamplingAlgorithm_SaveState
    procedure :: LoadState => TSamplingAlgorithm_LoadState
    end Type TSamplingAlgorithm

    Type, extends(TSamplingAlgorithm) :: TChainSampler
        integer :: oversample_fast =1
        integer :: output_thin =1
        integer :: num_accept = 0
        real(mcp) :: propose_scale = 2.4_mcp
        integer :: burn_in = 2
        class(BlockedProposer), pointer :: Proposer => null()
    contains
    procedure :: MetropolisAccept => TChainSampler_MetropolisAccept
    procedure :: MoveDone => TChainSampler_MoveDone
    procedure :: SampleFrom =>  TChainSampler_SampleFrom
    procedure :: GetNewSample =>  TChainSampler_GetNewSample
    procedure :: SetCovariance => TChainSampler_SetCovariance
    procedure :: SaveState => TChainSampler_SaveState
    procedure :: LoadState => TChainSampler_LoadState
    procedure :: ReadParams => TChainSampler_ReadParams
    procedure :: Init => TChainSampler_Init
    procedure :: InitWithPropose=> TChainSampler_InitWithPropose
    end Type

    Type, extends(TChainSampler) :: TMetropolisSampler
        integer :: num_metropolis_accept=0, num_metropolis=0, last_num=0
    contains
    procedure :: GetNewSample => TMetropolisSampler_GetNewSample
    procedure :: GetNewMetropolisSample => TMetropolisSampler_GetNewSample
    procedure :: FastParameterSample => TMetropolisSampler_FastParameterSample
    end Type

    Type, extends(TMetropolisSampler) :: TFastDraggingSampler
        integer :: num_fast_calls = 0, num_slow_calls = 0, drag_accpt=0
        integer :: num_drag=0
    contains
    procedure :: GetNewSample => TFastDraggingSampler_GetNewSample
    procedure :: ReadParams => TFastDraggingSampler_ReadParams
    end Type

    public TSampleCollector, TSamplingAlgorithm, TChainSampler, TMetropolisSampler, TFastDraggingSampler
    contains

    subroutine TSamplingAlgorithm_Init(this, LikeCalculator, SampleCollector)
    class(TSamplingAlgorithm) :: this
    class(TLikeCalculator), target:: LikeCalculator
    class(TSampleCollector), target, optional :: SampleCollector

    if (present(SampleCollector)) then
        this%SampleCollector => SampleCollector
    else
        this%SampleCollector => null()
    end if
    this%LikeCalculator => LikeCalculator
    this%num_sample = 0
    this%MaxLike = LogZero

    end subroutine TSamplingAlgorithm_Init

    function TSamplingAlgorithm_LogLike(this, Params) result(logLike)
    class(TSamplingAlgorithm) :: this
    class(ParamSet) Params
    real(mcp) :: logLike

    logLike = this%LikeCalculator%GetLogLike(Params)

    end function TSamplingAlgorithm_LogLike

    subroutine TSamplingAlgorithm_LoadState(this,F)
    class(TSamplingAlgorithm) :: this
    class(TFileStream) :: F

    call F%Read(this%num_sample, this%MaxLike)
    call F%Read(this%MaxLikeParams)

    end subroutine TSamplingAlgorithm_LoadState

    subroutine TSamplingAlgorithm_SaveState(this,F)
    class(TSamplingAlgorithm) :: this
    class(TFileStream) :: F

    call F%Write(this%num_sample, this%MaxLike)
    call F%Write(this%MaxLikeParams)

    end subroutine TSamplingAlgorithm_SaveState

    !!!TChainSampler

    function TChainSampler_MetropolisAccept(this, Like, CurLike) result(MetropolisAccept)
    class(TChainSampler) :: this
    real(mcp) Like, CurLike
    logical MetropolisAccept

    if (Like /=LogZero) then
        MetropolisAccept = CurLike > Like
        if (.not. MetropolisAccept) MetropolisAccept = randexp1() > Like - CurLike
    else
        MetropolisAccept = .false.
    end if

    end function TChainSampler_MetropolisAccept

    subroutine TChainSampler_SampleFrom(this,CurParams, CurLike, samples_to_get)
    class(TChainSampler) :: this
    Type(ParamSet) CurParams
    integer samples_to_get
    real(mcp)  CurLike
    real(mcp) :: mult

    mult= 0

    do while (this%num_sample <= samples_to_get*this%Oversample_fast)
        call this%GetNewSample(CurParams, CurLike, mult)

        if (CurLike /= logZero) then
            if (associated(this%SampleCollector) .and. mod(this%num_sample, this%output_thin)==0 .and. mult>0) then
                call this%SampleCollector%AddNewPoint(CurParams%P, CurLike)
                if (mod(this%num_sample,100*this%Oversample_fast)==0) call CheckParamChange
            end if
        else
            if (this%num_sample > 1000) then
                call DoAbort('MCMC.f90: Couldn''t start after 1000 tries - check starting ranges')
            end if
        end if
    end do

    if (Feedback > 0) then
        write(*,*) MPIRank, 'Stopping as have ',samples_to_get ,' samples. '
        call this%LikeCalculator%WritePerformanceStats(stdout)
    end if

    end subroutine TChainSampler_SampleFrom

    subroutine TChainSampler_MoveDone(this,accpt, CurParams, CurLike, mult, thin_fac)
    class(TChainSampler) :: this
    logical, intent(in) :: accpt
    class(TCalculationAtParamPoint), intent(in) :: CurParams
    real(mcp) CurLike
    real(mcp), intent(inout):: mult
    integer, intent(in), optional :: thin_fac

    this%num_sample = this%num_sample + 1
    if (accpt) then
        if (mult>0) then
            if (associated(this%SampleCollector) .and. CurLike /= LogZero .and. this%num_accept> this%burn_in) &
            & call this%SampleCollector%AddNewWeightedPoint(CurParams, CurLike, mult, thin_fac)
            this%num_accept = this%num_accept + 1
        end if
        mult=1
        if (CurLike < this%MaxLike) then
            this%MaxLike = CurLike
            this%MaxLikeParams = CurParams%P
        end if
    else
        mult = mult + 1
    end if

    end subroutine TChainSampler_MoveDone

    subroutine TChainSampler_GetNewSample(this, CurParams, CurLike, mult)
    class(TChainSampler) :: this
    Type(ParamSet) CurParams
    real(mcp) CurLike, mult
    end subroutine TChainSampler_GetNewSample

    subroutine TChainSampler_LoadState(this,F)
    class(TChainSampler) :: this
    class(TFileStream) F

    call this%TSamplingAlgorithm%LoadState(F)
    call F%Read(this%num_accept)
    call this%Proposer%LoadState(F)

    end subroutine TChainSampler_LoadState

    subroutine TChainSampler_SaveState(this,F)
    class(TChainSampler) :: this
    class(TFileStream) F

    call this%TSamplingAlgorithm%SaveState(F)
    call F%Write(this%num_accept)
    call this%Proposer%SaveState(F)

    end subroutine TChainSampler_SaveState

    subroutine TChainSampler_SetCovariance(this, cov)
    class(TChainSampler) :: this
    real(mcp) :: cov(:,:)

    call this%Proposer%SetCovariance(cov)

    end subroutine TChainSampler_SetCovariance

    subroutine TChainSampler_ReadParams(this, Ini)
    class(TChainSampler) :: this
    class(TSettingIni) :: Ini

    if (use_fast_slow) then
        this%oversample_fast = Ini%Read_Int('oversample_fast',1, min=1)
        this%output_thin =  this%oversample_fast
    end if
    call Ini%Read('propose_scale',this%propose_scale, min=0.d0)
    call Ini%Read('burn_in',this%burn_in)

    end subroutine TChainSampler_ReadParams

    subroutine TChainSampler_Init(this, LikeCalculator, SampleCollector)
    class(TChainSampler) :: this
    class(TLikeCalculator), target:: LikeCalculator
    class(TSampleCollector), target, optional :: SampleCollector

    call this%InitWithPropose(LikeCalculator, SampleCollector)

    end subroutine TChainSampler_Init

    subroutine TChainSampler_InitWithPropose(this,LikeCalculator, SampleCollector, propose_scale)
    class(TChainSampler) :: this
    class(TLikeCalculator), target:: LikeCalculator
    class(TSampleCollector), target, optional :: SampleCollector
    real(mcp), intent(in), optional :: propose_scale

    if (present(propose_scale)) this%propose_scale = propose_scale

    call this%TSamplingAlgorithm%Init(LikeCalculator,SampleCollector)
    allocate(BlockedProposer::this%Proposer)
    call this%Proposer%Init(BaseParams%param_blocks, slow_block_max= slow_tp_max, &
    oversample_fast=this%oversample_fast, propose_scale=this%propose_scale)
    this%num_accept=0

    end subroutine TChainSampler_InitWithPropose

    !!! TMetropolisSampler

    subroutine TMetropolisSampler_GetNewSample(this, CurParams, CurLike, mult)
    !Standard metropolis hastings
    class(TMetropolisSampler) :: this
    Type(ParamSet) CurParams, Trial
    real(mcp) CurLike, mult, Like
    logical :: accpt

    Trial = CurParams
    call this%Proposer%GetProposal(Trial%P)

    Like = this%LogLike(Trial)
    if (Feedback > 1) write (*,*) instance, 'Likelihood: ', real(Like), 'Current Like:', real(CurLike)

    if (Like /= logZero) then
        accpt = this%MetropolisAccept(Like, CurLike)
    else
        accpt = .false.
    end if

    this%num_metropolis = this%num_metropolis + 1

    call this%MoveDone(accpt, CurParams, CurLike, mult, this%Oversample_fast)
    call CurParams%AcceptReject(Trial, accpt)

    if (accpt) then
        CurParams = Trial
        CurLike = Like
        this%num_metropolis_accept = this%num_metropolis_accept + 1
        if (Feedback > 1) write (*,*) this%num_metropolis, ' metropolis accept. ratio:', &
        & real(this%num_metropolis_accept)/this%num_metropolis
        if (LogFile%Opened() .and. mod(this%num_metropolis_accept,50*this%Oversample_fast) ==0) then
            write (LogFile%unit,*) 'metropolis rat:',real(this%num_metropolis_accept)/this%num_metropolis,  &
            & ' in ',this%num_metropolis, ', best: ',real(this%MaxLike)
            write (LogFile%unit,*) 'local acceptance ratio:', 50./(this%num_metropolis - this%last_num)
            this%last_num = this%num_metropolis
        end if
    end if

    end subroutine TMetropolisSampler_GetNewSample

    subroutine TMetropolisSampler_FastParameterSample(this, CurParams, CurLike, mult)
    !Metropolis hastings on fast parameters
    class(TMetropolisSampler) :: this
    Type(ParamSet) CurParams, Trial
    real(mcp) CurLike, Like
    real(mcp) mult
    logical :: accpt

    Trial = CurParams
    call this%Proposer%GetProposalFast(Trial%P)

    Like = this%LogLike(Trial)
    if (Like /= logZero) then
        accpt = this%MetropolisAccept(Like, CurLike)
    else
        accpt = .false.
    end if

    call this%MoveDone(accpt, CurParams, CurLike, mult)
    call CurParams%AcceptReject(Trial,accpt)

    if (accpt) then
        CurParams = Trial
        CurLike = Like
    end if

    end subroutine TMetropolisSampler_FastParameterSample

    subroutine TFastDraggingSampler_GetNewSample(this,CurParams, CurLike, mult)
    !Make proposals in fast-marginalized slow parameters
    !'drag' fast parameters using method of Neal
    class(TFastDraggingSampler) :: this
    Type(ParamSet) TrialEnd, TrialStart, CurParams, CurEndParams, CurStartParams
    real(mcp) CurLike, mult
    integer numaccpt
    real(mcp) CurIntLike, IntLike, CurEndLike, CurStartLike, EndLike, StartLike
    real(mcp) CurDragLike, DragLike
    logical :: accpt
    real(mcp)  :: likes_start_sum, likes_end_sum
    integer interp_step, interp_steps
    real(mcp) frac, delta(num_params)

    if (CurLike == LogZero .or. BaseParams%num_fast==0 .or. BaseParams%num_slow ==0) then
        call this%GetNewMetropolisSample(CurParams, CurLike, mult)
        return
    end if

    this%num_drag=this%num_drag+1
    if (mod(this%num_drag, this%oversample_fast)/=0) then
        call this%TMetropolisSampler%FastParameterSample(CurParams, CurLike, mult)
        return
    end if

    if (Feedback > 1) write (*,*) instance, 'Fast dragging, Like: ', CurLike

    call Timer()
    TrialEnd = CurParams
    call this%Proposer%GetProposalSlow(TrialEnd%P)

    CurEndLike = this%LogLike(TrialEnd)
    if (CurEndLike==logZero) then
        call TrialEnd%Clear(keep=CurParams)
        mult = mult + 1
        return
    end if
    CurStartLike = CurLike
    if (Feedback > 1) call Timer('Dragging Slow time')

    this%num_slow_calls = this%num_slow_calls + 1

    likes_end_sum = CurEndLike
    likes_start_sum = CurStartLike

    CurStartParams = CurParams
    CurEndParams = TrialEnd

    interp_steps = max(2,nint(dragging_steps * BaseParams%num_fast) + 1)

    numaccpt = 0
    do interp_step = 1, interp_steps-1
        call this%Proposer%GetProposalFastDelta(delta)
        TrialEnd = CurEndParams
        TrialEnd%P(1:num_params) = TrialEnd%P(1:num_params) + delta
        EndLike = this%LogLike(TrialEnd)
        accpt = EndLike /= logZero

        if (accpt) then
            this%num_fast_calls = this%num_fast_calls + 1
            TrialStart = CurStartParams
            TrialStart%P(1:num_params) = TrialStart%P(1:num_params)  + delta
            StartLike = this%LogLike(TrialStart)
            accpt = StartLike/=logZero

            if (accpt) then
                this%num_fast_calls = this%num_fast_calls + 1
                if (Feedback > 2) print *,'End,start drag: ', interp_step, EndLike, StartLike

                frac = real(interp_step, mcp)/interp_steps
                CurIntLike = CurStartLike*(1-frac) + frac*CurEndLike
                IntLike = StartLike*(1-frac) + frac*EndLike
                accpt = this%MetropolisAccept(IntLike, CurIntLike)
            end if
        end if

        call CurEndParams%AcceptReject(TrialEnd, accpt)
        call CurStartParams%AcceptReject(TrialStart, accpt)

        if (accpt) then
            CurEndParams = TrialEnd
            CurStartParams = TrialStart
            CurEndLike = EndLike
            CurStartLike = StartLike
            CurIntLike = IntLike
            numaccpt = numaccpt + 1
        end if

        likes_start_sum = likes_start_sum + CurStartLike
        likes_end_sum = likes_end_sum + CurEndLike
    end do

    if (Feedback > 1) call Timer('Dragging time')

    if (Feedback > 1) print *,'drag steps accept ratio:', real(numaccpt)/(interp_steps)

    CurDragLike = likes_start_sum/interp_steps !old slow
    DragLike = likes_end_sum/interp_steps !proposed new slow
    if (Feedback > 2) print *,'CurDragLike, DragLike: ', CurDragLike, DragLike

    accpt = this%MetropolisAccept(DragLike, CurDragLike)

    call this%MoveDone(accpt, CurParams, CurLike, mult)
    call CurParams%AcceptReject(CurEndParams, accpt)

    if (accpt) then
        CurParams = CurEndParams
        CurLike = CurEndLike
        this%drag_accpt=this%drag_accpt+1
        if (Feedback > 0 .and. mod(this%drag_accpt,30)==0 .or. Feedback>1) &
        write (*,*) trim(concat('Chain:',MpiRank,' drag accpt:')), real(this%drag_accpt)/(this%num_drag/this%oversample_fast), &
        'fast/slow',real(this%num_fast_calls)/this%num_slow_calls, 'slow:', this%num_slow_calls
    end if

    end subroutine TFastDraggingSampler_GetNewSample

    subroutine TFastDraggingSampler_ReadParams(this, Ini)
    class(TFastDraggingSampler) :: this
    class(TSettingIni) :: Ini

    call this%TMetropolisSampler%ReadParams(Ini)
    this%output_thin = 1

    end subroutine TFastDraggingSampler_ReadParams

    subroutine TSampleCollector_AddNewPoint(this,P,like)
    class(TSampleCollector) :: this
    real(mcp), intent(in) ::like
    real(mcp) P(:)
    !Add each point (duplicated if chain does not move)
    end subroutine TSampleCollector_AddNewPoint

    subroutine TSampleCollector_AddNewWeightedPoint(this, CurParams, CurLike, mult, thin_fac)
    class(TSampleCollector) :: this
    class(TCalculationAtParamPoint), intent(in) :: CurParams
    real(mcp) CurLike
    real(mcp), intent(in):: mult !tbe weight, usually integer for standard chains
    integer, intent(in), optional :: thin_fac
    !Add samples accumulated into weighted sample
    end subroutine TSampleCollector_AddNewWeightedPoint

    subroutine TSampleCollector_ReadCheckpoint(this)
    class(TSampleCollector) :: this
    end subroutine TSampleCollector_ReadCheckpoint

    end module MonteCarlo


!##############################################################################
!# ****************************************************************************
!# <name> boundarycondition </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module defines the analytical representation of boundary conditions.
!# In detainl, the following types of boundary conditions are supported:
!# - Neumann boundary conditions
!# - Dirichlet boundary conditions
!# - Pressure drop boundary conditions
!# The structure here only describe the boundary conditions. There are no
!# routines in this module to impose them into a solution/defect vector.
!# For imposing boundary conditions into vectors, the boundary conditions
!# first have to be 'discretised' using the module 'DiscreteBC'!
!#
!# IMPORTANT NOTE:
!# THIS MODULE IS OUTDATED AND NOT USED ANYMORE! IT IS STILL CONTENT OF THE
!# FEAT2 LIBRARY TO ALLOW A USER TO DEFINE ANALYTIC BONUDARY CONDITIONS ON
!# APPLICATION LEVEL. THE KERNEL ROUTINES HOWEVER DO NOT USE ANALYTICAL
!# BOUNDARY CONDITIONS ANYMORE: BOUNDARY CONDITIONS ARE ALWAYS DIRECTLY
!# ASSEMBLED INTO THEIR DISCRETE COUNTERPART SUCH THAT THEY CAN BE IMPLEMENTED
!# INTO MATRICES/VECTORS!
!#
!# Neumann boundary conditions are usually imposed as 'do nothing' boundary
!# conditions and therefore not realised in a special structure. This
!# means, the module here realises all 'other' types of boundary conditions
!# not being Neumann. Neumann is standard, and all other types of BC`s
!# must be imposed.
!#
!# Method description \\
!# ------------------ \\
!# The t_boundaryConditions structure collects all boundary conditions to a
!# domain. It contains three lists of 'boundary condition regions'
!# (structure t_bcRegion), for
!# - boundary conditions bound to segments on the real boundary
!# - boundary conditions anywhere on the real boundary
!# - boundary conditions, imposed by fictitious boundary objects.
!#
!# A 'boundary condition region' object t_bcRegion realises a boundary
!# condition. It contains information about the type of the boundary conditions
!# and where they are, on the real boundary as well as on fictitious boundary
!# objects. Furthermore, it contains information about the solution component
!# the boundary condition refers to (e.g. X-velocity, Y-velocity,...)
!#
!# A boundary condition can be deactivated by setting the cbcRegionType flag
!# in the boundary region to BC_DONOTHING.
!#
!# BC`s on real boundary components in 2D \\
!# -------------------------------------- \\
!# Boundary conditions on real boundary components are described via a boundary
!# region struture as defined in boundary.f90. This contains basically a minimum
!# and maximum parameter value on the boundary as well as s number of a
!# boundary component. Optionally, the boundary region may be specified to
!# be attached to a real boundary segment, e.g. a full circle or a line on
!# the boundary.
!#
!# BC`s on fictitious boundary components \\
!# -------------------------------------- \\
!# The concept of (analytic) fictitious boundary components is somehow
!# different to the concept of standard boundary conditions.
!# An analytic fictitious boundary component is a 'virtual object' in the
!# domain that is associated to a special boundary condition. Each FB-object
!# therefore covers a 'group of cells' inside the domain.
!# Two basic principles drive this idea:\\
!#
!# a) The fictitious boundary object is not necessarily one single object like
!#    a circle or a square. It can even be a group of objects, all sharing
!#    the same boundary condition (e.g. 10000 flying balls, all described
!#    by a Dirichlet-type fictitious boundary object).\\
!#
!# b) All objects are described in 'analytical fashion' without any grid in the
!#    background. During the discretisation, the 'boundary conditions' that are
!#    associated to a fictitious boundary object (group) are 'discretised'
!#    to get a discrete, mesh- and solution dependent representation.
!#    By using filter techniques, this data can be imposed to the PDE, e.g.
!#    into the right hand side, the solution or into the matrix.\\
!#
!# Fictitious boundary objects are identified to the application by
!# t_fictBoundaryRegion structures. The content of the structure is more or less
!# application specific; it simply contains a couple of information that allow
!# the evaluation routines to identify a fictitious boundary object.
!#
!#
!# Linear and nonlinear boundary conditions
!# ----------------------------------------
!# There are two types of boundary conditions: Linear (like Dirichlet) and
!# nonlinear ones (like Slip boundary conditions). Linear boundary conditions
!# are standard boundary conditions that are realised by discretising and
!# implementing them into solution/rhs/defect vectors during the linear
!# iteration. Nonlinear boundary conditions are implemented usually in a
!# nonlinear loop and need a special implementation there, which might
!# be different from when a linear system is solved.
!#
!#
!# The following routines can be found here:\\
!#
!# 1.) bcond_initBC
!#     -> Initialises a boundary condition structure
!#
!# 2.) bcond_doneBC
!#     -> Cleans up a boundary condition structure, releases memory
!#
!# 3.) bcond_newBC
!#     -> Adds a general boundary condition for the real boundary to a
!#        boundary-condition object; normally used only internally.
!#
!# 4.) bcond_getBCRegion
!#     -> Finds the index of the first boundary condition region containing a point.
!#
!# 5.) bcond_newDirichletBConRealBD
!#     -> Adds a Dirichlet boundary condition the real boundary to a
!#        boundary-condition object
!#
!# 6.) bcond_newPressureDropBConRealBD
!#     -> Adds a pressure-drop boundary condition the real boundary to a
!#        boundary-condition object
!#
!# 7.) bcond_newSlipBConRealBD
!#     -> Adds (nonlinear) slip boundary conditions on the real boundary
!#        to a boundary-condition object
!#
!# 8.) bcond_newFeastMirrorBConRealBD
!#     -> Adds a Dirichlet boundary condition the real boundary to a
!#        boundary-condition object
!#
!# </purpose>
!##############################################################################

module boundarycondition

!$ use omp_lib
  use fsystem
  use boundary
  use fictitiousboundary

  implicit none

  private
  public :: t_bcRegion
  public :: t_boundaryConditions
  public :: bcond_initBC
  public :: bcond_doneBC
  public :: bcond_newBC
  public :: bcond_getBCRegion
  public :: bcond_newDirichletBConRealBD
  public :: bcond_newFeastMirrorBConRealBD
  public :: bcond_newPressureDropBConRealBD
  public :: bcond_newSlipBConRealBD
  public :: bcond_newDirichletBConFictBD

!<constants>

!<constantblock description="The type identifier for (linear) boundary conditions">

  ! Do-nothing boundary conditions (Neumann)
  integer, parameter, public :: BC_DONOTHING      = 0

  ! Dirichlet boundary conditions.
  ! Dirichlet boundary conditions are always specified for exactly one
  ! equation. t_bcRegion\%nequations is set =1 and t_bcRegion\%Iequations(1)
  ! identifies the number of the equation, the boundary conditions refer to.
  integer, parameter, public :: BC_DIRICHLET      = 1

  ! Robin boundary conditions
  integer, parameter, public :: BC_ROBIN          = 2

  ! Pressure-drop boundary conditions
  integer, parameter, public :: BC_PRESSUREDROP   = 3

  ! Flux boundary conditions
  integer, parameter, public :: BC_FLUX           = 4

  ! FEAST mirror boundary for domain decomposition
  integer, parameter, public :: BC_FEASTMIRROR    = 5

!</constantblock>

!<constantblock description="The type identifier for nonlinar boundary conditions">

  ! Slip boundary condition
  integer, parameter, public :: BC_SLIP           = 100

!</constantblock>

!<constantblock description="The type identifier for boundary regions">

  ! The boundary segment is unspecified.
  integer, parameter, public :: BC_RTYPE_UNDEFINED = 0

  ! The boundary dition region corresponds to a specific region on
  ! the real boundary.
  integer, parameter, public :: BC_RTYPE_REAL      = 1

  ! The boundary condition region 'lives' on the real boundary
  ! but does not correspond to a specific segment ('free' real
  ! boundar condition).
  integer, parameter, public :: BC_RTYPE_FREE      = 2

  ! The boundary condition region corresponds to a fictitious boundary
  ! object.
  integer, parameter, public :: BC_RTYPE_FBCOBJECT = 3

!</constantblock>

!<constantblock>

  ! Default blocksize for allocating new structures in the
  ! p_RregionsSpecific / p_RregionsFree list - if the list is full.
  integer, parameter, public :: BC_LISTBLOCKSIZE = 10

  ! Maximum number of equations that are supported simultaneously by
  ! boundary conditions.
  integer, parameter, public :: BC_MAXEQUATIONS = 16

!</constantblock>

!</constants>

!<types>
!<typeblock>

  ! The following structure realises a 'region' on the boundary where
  ! boundary conditions are defined. This is realised using the
  ! 'boundary region' structure from the 'boundary' module.
  ! The structure contains  user defined integer, double precision and
  ! string tag, which can be set by the application to arbitrary,
  ! problem dependent values (e.g. identifier tags for callback routines).

  type t_bcRegion

    ! Type of BC region, this structure defines. One of the BC_RTYPE_xxxx
    ! constants.
    integer :: cbcRegionType = BC_RTYPE_UNDEFINED

    ! Type of boundary conditions, this structure describes.
    ! One of the BC_xxxx constants.
    integer :: ctype = BC_DONOTHING

    ! Number of equations, this BC refers to. This is usually =1 but can be
    ! higher if the BC couples multiple equations (like <tex>$u_x + u_y = c$</tex> or so).
    ! Normally, this is the length of the Iequations list below, but the
    ! meaning might be different for special type BC`s.
    integer :: nequations = 0

    ! A list of up to BC_MAXEQUATIONS numbers identifying the equations,
    ! a boundary condition refers to. The use of this is defined
    ! as follows:
    !
    ! a) A simple Dirichlet-boundary condition for the X-velocity on real
    !   boundary is identified by "nequations=1" + "Iequations=[1]".
    !
    ! b) A simple Dirichlet-boundary condition for the Y-velocity on real
    !   boundary is identified by "nequations=1" + "Iequations=[2]".
    !
    ! c) "Pressure drop" boundary conditions on real boundary that must
    !   modify two "velocity" components 1(=x), 2(=y) are identified by
    !   "nequations=2" + "Iequations=[1 2]".
    !
    ! d) A simple Dirichlet boundary conditions for X- and Y-velocity
    !   for a fictitious boundary region is identified by "nequations=2"
    !   + "Iequations=[1 2]" (1=x, 2=y component)
    !
    ! e) A boundary condition like "u_x + u_y = const" on real boundary
    !   may be identified by "nequations=2" + "Iequations=[1 2]"
    !   (let us see if that is really the case if such a thing is implemented...)
    !
    ! Basically, this is a list of the blocks in a block solution vector
    ! that are affected by a boundary condition. The list here is actually
    ! bounadry-condition specific, i.e. another BC than Dirichlet can use
    ! the list in a different way to remember which equations take part
    ! on a special BC.
    integer, dimension(BC_MAXEQUATIONS) :: Iequations = 0

    ! Whether or not this boundary region is a 'static' region.
    ! If TRUE, the discretisation routine will discretise this boundary
    !  region only once and then never touch it anymore when called again.
    ! If FALSE, the discretisation routine assumes that the boundary
    !  region might have changed from one call to the other (e.g. in a
    !  time dependent simulation, the position or values might have changed)
    !  and will therefore always rebuild the information for this boundary
    !  region when being called again.
    logical :: bisStatic = .false.

    ! User defined tag to identify what to evaluate on the boundary.
    ! =0: undefined.
    ! This tag can be e.g. an identifier that tells the application whether
    ! to evaluate a constant, a parabolic profile or an expression
    ! on the boundary. Not used by the framework internally.
    integer      :: ibdrexprtype = 0

    ! user defined integer tag
    integer(I32) :: itag = 0

    ! User defined double precision tag
    real(DP) :: dtag = 0.0_DP

    ! User defined string tag; usually set to the name of an expression to
    ! evaluate in this boundary condition region.
    character(LEN=SYS_STRLEN) :: stag = ''

    ! Definition of a region on the boundary where the boundary conditions
    ! 'live'. This can be either a 'specific' region (i.e. a region
    ! connected with a boundary segment) in case the boundary region
    ! corresponds to a boundary segment, or it can be a 'free' boundary
    ! region not corresponding to any special segment on the boundary.
    ! For boundary conditions of fictitious boundary objects,
    ! this structure is undefined!
    type (t_boundaryRegion) :: rboundaryRegion

    ! Definition of a fictitious boundary region. If boundary conditions
    ! in a fictitious boundary region are discretised, this structure
    ! allows the application to identify the boundary region.
    ! For boundary conditions on the real boundary, this structure
    ! is undefined.
    type (t_fictBoundaryRegion) :: rfictBoundaryRegion

  end type

!</typeblock>

!<typeblock>

  ! Definition of a boundary condition. The structure basically contains
  ! a type-identifier specifying the type of boundary conditions
  ! the structure describes as well as a list of 'boundary region'
  ! segments that describe the position of the boundary condition
  ! on tghe boundary.

  type t_boundaryConditions

    ! Pointer to the domain that is connected with this boundary
    ! condition
    type(t_boundary), pointer :: p_rboundary => null()

    ! Number of regions in the list of boundary condition regions,
    ! corresponding to boundary regions.
    ! On each region, the boundary condition of type ctype
    ! is specified.
    integer :: iregionCount = 0

    ! A list of t_BCregion structures that define the position
    ! of boundary condition ctype on the boundary.
    ! The first iregionCount elements in the array are valid,
    ! the rest may be undefined.
    type(t_bcRegion), dimension(:), pointer :: p_Rregions => null()

    ! Number of regions in the list of boundary condition regions,
    ! not corresponding to specific boundary regions.
    ! On each region, the boundary condition of type ctype
    ! is specified.
    !INTEGER :: iregionCountFree = 0

    ! A list of t_BCregion structures that define the position
    ! of boundary condition ctype on the boundary.
    ! The first iregionCountFree elements in the array are valid,
    ! the rest may be undefined.
    !TYPE(t_bcRegion), DIMENSION(:), POINTER :: p_RregionsFree => NULL()

    ! Number of regions in the list of boundary condition regions,
    ! corresponding to fictitious boundary objects.
    ! On each region, the boundary condition of type ctype
    ! is specified.
    integer :: iregionCountFBC = 0

    ! A list of t_BCregion structures that define the position
    ! of boundary condition ctype on the boundary.
    ! The first iregionCountFBC elements in the array are valid,
    ! the rest may be undefined.
    type(t_bcRegion), dimension(:), pointer :: p_RregionsFBC => null()

  end type

!</typeblock>

!</types>

contains

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

!<subroutine>

  subroutine bcond_initBC (p_rboundaryConditions,rboundary,ibcRegionsCount)

!<description>
  ! This routine initialises a boundary condition structure.
  ! If p_rboundaryConditions is NULL(), a new structure will be created.
  ! Otherwise, the existing structure is recreated/updated.
!</description>

!<input>
  ! The domain which is to be connected to the boundary conditions.
  type(t_boundary), intent(in), target :: rboundary

  ! OPTIONAL: The initial size of the lists saving boundary conditions.
  ! When adding boundary conditions to the rboundaryConditions structure,
  ! if there is not enough space, the lists saving the boundary conditions
  ! are dynamically increased (in terms of BC_LISTBLOCKSIZE).
  integer, intent(in), optional :: ibcRegionsCount
!</input>

!<output>
  ! The structure to be initialised.
  type(t_boundaryConditions), pointer :: p_rboundaryConditions
!</output>

!</subroutine>

  ! local variables
  integer ibcCount

  ! Do we have a structure?
  if (.not. associated(p_rboundaryConditions)) then
    allocate(p_rboundaryConditions)
  else
    ! Release the old structure without removing it from the heap.
    call bcond_doneBC(p_rboundaryConditions,.true.)
  end if

  ! The 'default constructor' does most of the necessary work, as
  ! rboundaryConditions is assumed as 'intent=out'. We only have to make
  ! the connection to the domain.

  p_rboundaryConditions%p_rboundary => rboundary

  ! Allocate memory for boundary condition lists
  ibcCount = BC_LISTBLOCKSIZE
  if (present(ibcRegionsCount)) ibcCount = max(1,ibcRegionsCount)

  allocate(p_rboundaryConditions%p_Rregions(ibcCount))
  !ALLOCATE(p_rboundaryConditions%p_RregionsFree(ibcCount))
  allocate(p_rboundaryConditions%p_RregionsFBC(ibcCount))

  end subroutine

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

!<subroutine>

  subroutine bcond_doneBC (p_rboundaryConditions,bkeepStructure)

!<description>
  ! This routine cleans up a boundary condition structure. All reserved
  ! memory is released.
!</description>

!<input>
  ! OPTIONAL: If set to TRUE, the structure p_rboundaryConditions itself is not
  ! released from memory. If set to FALSE or not existent (the usual setting),
  ! the structure p_rboundaryConditions will also be removed from the heap after
  ! cleaning up.
  logical, intent(in), optional :: bkeepStructure
!</input>

!<inputoutput>
  ! The structure to be cleaned up..
  type(t_boundaryConditions), pointer :: p_rboundaryConditions
!</inputoutput>

!</subroutine>

  if (.not. associated(p_rboundaryConditions)) return

  ! Clean up
  deallocate(p_rboundaryConditions%p_RregionsFBC)
  !DEALLOCATE(p_rboundaryConditions%p_RregionsFree)
  deallocate(p_rboundaryConditions%p_Rregions)
  p_rboundaryConditions%iregionCountFBC = 0
  !p_rboundaryConditions%iregionCountFree = 0
  p_rboundaryConditions%iregionCount = 0
  p_rboundaryConditions%p_rboundary => null()

  ! Deallocate the structure (if we are allowed to), finish.
  if (.not. present(bkeepStructure)) then
    deallocate(p_rboundaryConditions)
  else
    if (.not. bkeepStructure) deallocate(p_rboundaryConditions)
  end if

  end subroutine

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

!<subroutine>

  subroutine bcond_newBC (ctype,cbdtype,rboundaryConditions,&
                          p_rbcRegion, rboundaryRegion, rfictBoundaryRegion)

!<description>
  ! Adds a general boundary condition region to the boundary condition structure..
  ! A pointer to the region is returned
  ! in p_rbcRegion, the caller can add some user-defined information there
  ! if necessary (e.g. the name, a tag or something else).
  ! The boundary conditions are assumed to be on the 'real' boundary -
  ! fictitious-boundary boundary conditions are supported by another routine.
!</description>

!<input>
  ! The type of boundary conditions.
  ! This is a BC_xxxx flag.
  integer, intent(in) :: ctype

  ! Specifies the type of the boundary where to add boundary conditions.
  ! This is a BC_RTYPE_xxxx flag.
  integer, intent(in) :: cbdtype

  ! OPTIONAL: A boundary-region object, describing the position
  ! on the boundary where boundary conditions should be imposed.
  ! A copy of this is added to the rboundaryConditions structure.
  ! This parameter must be present for boundary conditions on the real
  ! boundary but can be omitted when adding a fictitious boundary condition.
  type(t_boundaryRegion), intent(in), optional :: rboundaryRegion

  ! OPTIONAL: A fictitious-boundary-region object, describing the
  ! fictitious boundary region.
  ! A copy of this is added to the rboundaryConditions structure.
  ! This parameter must be present for boundary conditions on the fictitious
  ! boundary but can be omitted when adding boundary condition on the real
  ! boundary.
  type(t_fictBoundaryRegion), intent(in), optional :: rfictBoundaryRegion
!</input>

!<inputoutput>
  ! The structure where the boundary condition region is to be added.
  type(t_boundaryConditions), intent(inout), target :: rboundaryConditions
!</inputoutput>

!<output>
  ! OPTIONAL: A pointer to the added boundary region. The caller can make more specific
  ! modifications to this.
  type(t_bcRegion), optional, pointer :: p_rbcRegion
!</output>

!</subroutine>

  ! local variables
  type(t_bcRegion), dimension(:), pointer :: p_Rregion,p_temp
  type(t_bcRegion), pointer :: p_rbcRegionLocal
  integer, pointer :: ifull

  ! Select the type of boundary where to add:
  select case (cbdtype)
  case (BC_RTYPE_REAL,BC_RTYPE_FREE)
    p_Rregion => rboundaryConditions%p_Rregions
    ifull => rboundaryConditions%iregionCount
  !CASE (BC_RTYPE_FREE)
  !  p_Rregion => rboundaryConditions%p_RregionsFree
  !  ifull => rboundaryConditions%iregionCountFree
  case (BC_RTYPE_FBCOBJECT)
    p_Rregion => rboundaryConditions%p_RregionsFBC
    ifull => rboundaryConditions%iregionCountFBC
  case default
    print *,'Not implemented boundary condition.'
    call sys_halt()
  end select

  ! Space left, or do we have to reallocate?
  if (ifull .ge. size(p_Rregion)) then
    allocate(p_temp(ifull+BC_LISTBLOCKSIZE))
    p_temp(1:size(p_Rregion)) = p_Rregion(:)
    deallocate(p_Rregion)
    p_Rregion => p_temp

    select case (cbdtype)
    case (BC_RTYPE_REAL,BC_RTYPE_FREE)
      rboundaryConditions%p_Rregions => p_Rregion
    !CASE (BC_RTYPE_FREE)
    !  rboundaryConditions%p_RregionsFree => p_Rregion
    case (BC_RTYPE_FBCOBJECT)
      rboundaryConditions%p_RregionsFBC => p_Rregion
    end select
  end if

  ! Add the region
  ifull = ifull + 1
  p_rbcRegionLocal => p_Rregion(ifull)

  ! Initialise the structure
  p_rbcRegionLocal%cbcRegionType = cbdtype
  p_rbcRegionLocal%ctype = ctype

  if (present(rboundaryRegion)) then
    p_rbcRegionLocal%rboundaryRegion = rboundaryRegion
  else
    if (cbdtype .ne. BC_RTYPE_FBCOBJECT) then
      print *,'bcond_newBC: Boundary not specified'
    end if
  end if

  if (present(rfictBoundaryRegion)) then
    p_rbcRegionLocal%rfictBoundaryRegion = rfictBoundaryRegion
  else
    if (cbdtype .eq. BC_RTYPE_FBCOBJECT) then
      print *,'bcond_newBC: Fictitious Boundary not specified'
    end if
  end if

  ! If p_rbcRegion is given, return the pointer
  if (present(p_rbcRegion)) then
    p_rbcRegion => p_rbcRegionLocal
  end if

  end subroutine

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

!<function>

  integer function bcond_getBCRegion (rboundaryConditions,&
                                      iboundCompIdx,dparam,cparType,istartIndex)

!<description>
  ! The tupel (iboundCompIdx,dparam) specifies a point on the real 2D boundary.
  ! The routine tries to find the index of the first boundary condition region
  ! that contains this point. This index is returned in iindex.
  ! Afterwards, the caller can access that boundary condition region
  ! using rboundaryConditions%p_Rregions(iindexBC).
!</description>

!<input>
  ! A structure containing all boundary condition regions on the real boundary.
  type(t_boundaryConditions), intent(inout), target :: rboundaryConditions

  ! The number of the boundary component of the point.
  integer, intent(in) :: iboundCompIdx

  ! The parameter value of the point to be checked.
  real(DP), intent(in) :: dparam

  ! OPTIONAL: Type of parametrisation to use.
  ! One of the BDR_PAR_xxxx constants. If not given, BDR_PAR_01 is assumed.
  integer, intent(in), optional :: cparType

  ! OPTIONAL: Start index in rboundaryConditions%p_Rregions(:) where to start
  ! the search for the point identified by (iboundCompIndex,dparam).
  ! If not specified, 1 is assumed, thus the routine will return the first
  ! boundary condition region that contains the point.
  ! If specified, the routine will search for the point in the boundary
  ! condition regions rboundaryConditions%p_Rregions(istartIndex:).
  ! This allows to skip some regions: E.g. if the caller assumes a point
  ! to be in multiple regions and one region is found, the caller can
  ! specify the number of the next region here where to continue the search.
  integer, intent(in), optional :: istartIndex
!</input>

!<result>
  ! Number of the boundary region in rboundaryConditions%p_Rregions(:) that
  ! contains the point.
  ! =0 if no boundary condition region containing the point was found.
!</result>

!</function>

    real(DP) :: dparValue
    integer :: cactParType, iindexBC

    cactParType = BDR_PAR_01
    if (present(cparType)) then
      cactParType = cparType
    end if

    ! Initialise iindexBC by istartIndex and use it as a counter.
    iindexBC = 1
    if (present(istartIndex)) then
      if (istartIndex .gt. 0) then
        iindexBC = istartIndex
      end if
    end if

    ! Loop through the boundary condition regions
    do while (iindexBC .le. rboundaryConditions%iregionCount)

      ! Convert the parameter value to the correct parametrisation if necessary
      dparValue = boundary_convertParameter(rboundaryConditions%p_rboundary, &
          iboundCompIdx, dparam, &
          rboundaryConditions%p_Rregions(iindexBC)%rboundaryRegion%cparType, &
          cactParType)

      ! Check if it is inside of the region
      select case (rboundaryConditions%p_Rregions(iindexBC)%cbcRegionType)
      case (BC_RTYPE_REAL,BC_RTYPE_FREE)

        if (boundary_isInRegion ( &
            rboundaryConditions%p_Rregions(iindexBC)%rboundaryRegion,&
            iboundCompIdx,dparValue)) then
          ! Leave the subroutine. iindexBC has the index the caller is searching for.
          bcond_getBCRegion = iindexBC
          return
        end if

      end select

      iindexBC = iindexBC+1

    end do

    ! No region was found. Return 0.
    bcond_getBCRegion = 0

  end function

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

!<subroutine>

  subroutine bcond_newDirichletBConRealBD (rboundaryConditions,iequation,&
                                           rboundaryRegion,p_rbcRegion)

!<description>
  ! Adds a Dirichlet boundary condition region to the boundary condition
  ! structure. A pointer to the region is returned in p_rbcRegion, the caller
  ! can add some user-defined information there if necessary
  ! (e.g. the name, a tag or something else).
  ! The boundary conditions are assumed to be on the 'real' boundary -
  ! fictitious-boundary boundary conditions are supported by another routine.
!</description>

!<input>
  ! An identifier for the equation, this boundary condition refers to.
  ! >= 1. 1=first equation (e.g. X-velocity), 2=2nd equation (e.g.
  ! Y-velocity), etc.
  integer, intent(in) :: iequation

  ! A boundary-condition-region object, describing the position on the
  ! boundary where boundary conditions should be imposed.
  ! A copy of this is added to the rboundaryConditions structure.
  type(t_boundaryRegion), intent(in) :: rboundaryRegion
!</input>

!<inputoutput>
  ! The structure where the boundary condition region is to be added.
  type(t_boundaryConditions), intent(inout), target :: rboundaryConditions
!</inputoutput>

!<output>
  ! OPTIONAL: A pointer to the added boundary region. The caller can make
  ! more specific modifications to this if necessary.
  type(t_bcRegion), optional, pointer :: p_rbcRegion
!</output>

!</subroutine>

  ! local variables
  type(t_bcRegion), pointer :: p_rbcReg

  ! Add a general boundary condition region.
  ! Add a 'real' boundary condition region if rboundaryRegion%iboundSegIdx
  ! identifies that the boundary region belongs to a real boundary segment.
  ! Add a 'free' boundary condition region if the rboundaryRegion does not belong
  ! to any real segment (rboundaryRegion%iboundSegIdx=0).
  if (rboundaryRegion%iboundSegIdx .ne. 0) then
    call bcond_newBC (BC_DIRICHLET,BC_RTYPE_REAL,rboundaryConditions,&
                      p_rbcReg,rboundaryRegion)
  else
    call bcond_newBC (BC_DIRICHLET,BC_RTYPE_FREE,rboundaryConditions,&
                      p_rbcReg,rboundaryRegion)
  end if

  ! Modify the structure, impose additionally needed information
  ! for Dirichlet boundary - in detail, set the equation where the BC
  ! applies to.
  p_rbcReg%nequations = 1
  p_rbcReg%Iequations(1) = iequation

  ! Eventually, return the pointer
  if (present(p_rbcRegion)) p_rbcRegion => p_rbcReg

  end subroutine

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

!<subroutine>

  subroutine bcond_newFeastMirrorBConRealBD (rboundaryConditions,iequation,&
                                             rboundaryRegion,p_rbcRegion)

!<description>
  ! Adds a FEAST mirror boundary condition region to the boundary condition
  ! structure. A pointer to the region is returned in p_rbcRegion, the caller
  ! can add some user-defined information there if necessary
  ! (e.g. the name, a tag or something else).
  ! The boundary conditions are assumed to be on the 'real' boundary -
  ! fictitious-boundary boundary conditions are supported by another routine.
!</description>

!<input>
  ! An identifier for the equation, this boundary condition refers to.
  ! >= 1. 1=first equation (e.g. X-velocity), 2=2nd equation (e.g.
  ! Y-velocity), etc.
  integer, intent(in) :: iequation

  ! A boundary-condition-region object, describing the position on the
  ! boundary where boundary conditions should be imposed.
  ! A copy of this is added to the rboundaryConditions structure.
  type(t_boundaryRegion), intent(in) :: rboundaryRegion
!</input>

!<inputoutput>
  ! The structure where the boundary condition region is to be added.
  type(t_boundaryConditions), intent(inout), target :: rboundaryConditions
!</inputoutput>

!<output>
  ! OPTIONAL: A pointer to the added boundary region. The caller can make
  ! more specific modifications to this if necessary.
  type(t_bcRegion), optional, pointer :: p_rbcRegion
!</output>

!</subroutine>

  ! local variables
  type(t_bcRegion), pointer :: p_rbcReg

  ! Add a general boundary condition region.
  ! Add a 'real' boundary condition region if rboundaryRegion%iboundSegIdx
  ! identifies that the boundary region belongs to a real boundary segment.
  ! Add a 'free' boundary condition region if the rboundaryRegion does not belong
  ! to any real segment (rboundaryRegion%iboundSegIdx=0).
  if (rboundaryRegion%iboundSegIdx .ne. 0) then
    call bcond_newBC (BC_FEASTMIRROR,BC_RTYPE_REAL,rboundaryConditions,&
                      p_rbcReg,rboundaryRegion)
  else
    call bcond_newBC (BC_FEASTMIRROR,BC_RTYPE_FREE,rboundaryConditions,&
                      p_rbcReg,rboundaryRegion)
  end if

  ! Modify the structure, impose additionally needed information
  ! for Dirichlet boundary - in detail, set the equation where the BC
  ! applies to.
  p_rbcReg%nequations = 1
  p_rbcReg%Iequations(1) = iequation

  ! Eventually, return the pointer
  if (present(p_rbcRegion)) p_rbcRegion => p_rbcReg

  end subroutine

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

!<subroutine>

  subroutine bcond_newPressureDropBConRealBD (rboundaryConditions,IvelEqns,&
                                              rboundaryRegion,p_rbcRegion)

!<description>
  ! Adds a Pressure-Drop boundary condition region to the boundary condition
  ! structure. A pointer to the region is returned in p_rbcRegion, the caller
  ! can add some user-defined information there if necessary
  ! (e.g. the name, a tag or something else).
!</description>

!<input>
  ! A list of identifiers for the velocity equations, this boundary condition
  ! modifies. Usually (1,2) for X- and Y-velocity.
  integer, dimension(:), intent(in) :: IvelEqns

  ! A boundary-region object, describing the position on the
  ! boundary where boundary conditions should be imposed.
  ! A copy of this is added to the rboundaryConditions structure.
  type(t_boundaryRegion), intent(in) :: rboundaryRegion
!</input>

!<inputoutput>
  ! The structure where the boundary condition region is to be added.
  type(t_boundaryConditions), intent(inout), target :: rboundaryConditions
!</inputoutput>

!<output>
  ! OPTIONAL: A pointer to the added boundary region. The caller can make more specific
  ! modifications to this.
  type(t_bcRegion), optional, pointer :: p_rbcRegion
!</output>

!</subroutine>

  ! local variables
  type(t_bcRegion), pointer :: p_rbcReg

  ! Add a general boundary condition region.
  ! Add a 'real' boundary condition region if rboundaryRegion%iboundSegIdx
  ! identifies that the boundary region belongs to a real boundary segment.
  ! Add a 'free' boundary condition region if the rboundaryRegion does not belong
  ! to any real segment (rboundaryRegion%iboundSegIdx=0).
  if (rboundaryRegion%iboundSegIdx .ne. 0) then
    call bcond_newBC (BC_PRESSUREDROP,BC_RTYPE_REAL,rboundaryConditions,&
                      p_rbcReg,rboundaryRegion)
  else
    call bcond_newBC (BC_PRESSUREDROP,BC_RTYPE_FREE,rboundaryConditions,&
                      p_rbcReg,rboundaryRegion)
  end if

  ! Modify the structure, impose additionally needed information
  ! for Dirichlet boundary - in detail, set the equation where the BC
  ! applies to.
  p_rbcReg%nequations = size(IvelEqns)
  p_rbcReg%Iequations(1:size(IvelEqns)) = IvelEqns

  ! Eventually, return the pointer
  if (present(p_rbcRegion)) p_rbcRegion => p_rbcReg

  end subroutine

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

!<subroutine>

  subroutine bcond_newSlipBConRealBD (rboundaryConditions,IvelEqns,&
                                      rboundaryRegion,p_rbcRegion)

!<description>
  ! Adds a nonlinear Slip boundary condition region to the boundary condition
  ! structure. A pointer to the region is returned in p_rbcRegion, the caller
  ! can add some user-defined information there if necessary
  ! (e.g. the name, a tag or something else).
!</description>

!<input>
  ! A list of identifiers for the velocity equations, this boundary condition
  ! modifies. Usually (1,2) for X- and Y-velocity.
  integer, dimension(:), intent(in) :: IvelEqns

  ! A boundary-region object, describing the position on the
  ! boundary where boundary conditions should be imposed.
  ! A copy of this is added to the rboundaryConditions structure.
  type(t_boundaryRegion), intent(in) :: rboundaryRegion
!</input>

!<inputoutput>
  ! The structure where the boundary condition region is to be added.
  type(t_boundaryConditions), intent(inout), target :: rboundaryConditions
!</inputoutput>

!<output>
  ! OPTIONAL: A pointer to the added boundary region. The caller can make more specific
  ! modifications to this.
  type(t_bcRegion), optional, pointer :: p_rbcRegion
!</output>

!</subroutine>

  ! local variables
  type(t_bcRegion), pointer :: p_rbcReg

  ! Add a general boundary condition region.
  ! Add a 'real' boundary condition region if rboundaryRegion%iboundSegIdx
  ! identifies that the boundary region belongs to a real boundary segment.
  ! Add a 'free' boundary condition region if the rboundaryRegion does not belong
  ! to any real segment (rboundaryRegion%iboundSegIdx=0).
  if (rboundaryRegion%iboundSegIdx .ne. 0) then
    call bcond_newBC (BC_SLIP,BC_RTYPE_REAL,rboundaryConditions,&
                      p_rbcReg,rboundaryRegion)
  else
    call bcond_newBC (BC_SLIP,BC_RTYPE_FREE,rboundaryConditions,&
                      p_rbcReg,rboundaryRegion)
  end if

  ! Modify the structure, impose additionally needed information
  ! for Dirichlet boundary - in detail, set the equation where the BC
  ! applies to.
  p_rbcReg%nequations = size(IvelEqns)
  p_rbcReg%Iequations(1:size(IvelEqns)) = IvelEqns

  ! Eventually, return the pointer
  if (present(p_rbcRegion)) p_rbcRegion => p_rbcReg

  end subroutine

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

!<subroutine>

  subroutine bcond_newDirichletBConFictBD (rboundaryConditions,Iequations,&
                                           rboundaryRegion,p_rbcRegion)

!<description>
  ! Adds a Dirichlet boundary condition region for a fictitious boundary
  ! component to the boundary condition structure.
  ! A pointer to the region is returned in p_rfbcRegion, the caller
  ! can add some user-defined information there if necessary
  ! (e.g. the name, a tag or something else).
!</description>

!<input>
  ! An array of identifiers for the equations, this boundary condition
  ! refers to. Example: Iequations = [1 2] for X-velocity-component (1) and
  ! Y-velocity component (2).
  integer, dimension(:), intent(in) :: Iequations

  ! A fictitious-boundary-region object, describing the position on the
  ! boundary where boundary conditions should be imposed.
  ! A copy of this is added to the rboundaryConditions structure.
  type(t_fictBoundaryRegion), intent(in) :: rboundaryRegion
!</input>

!<inputoutput>
  ! The structure where the boundary condition region is to be added.
  type(t_boundaryConditions), intent(inout), target :: rboundaryConditions
!</inputoutput>

!<output>
  ! OPTIONAL: A pointer to the added boundary condition region. The caller can
  ! make more specific modifications to this if necessary.
  type(t_bcRegion), optional, pointer :: p_rbcRegion
!</output>

!</subroutine>

  ! local variables
  type(t_bcRegion), pointer :: p_rbcReg

  ! Add a general boundary condition region for a fictitiouos boundary object.
  call bcond_newBC (BC_DIRICHLET,BC_RTYPE_FBCOBJECT,rboundaryConditions,&
                    p_rbcReg,rfictBoundaryRegion=rboundaryRegion)

  ! Modify the structure, impose additionally needed information
  ! for Dirichlet boundary - in detail, set the equation where the BC
  ! applies to.
  p_rbcReg%nequations = size(Iequations)
  p_rbcReg%Iequations(1:size(Iequations)) = Iequations

  ! Eventually, return the pointer
  if (present(p_rbcRegion)) p_rbcRegion => p_rbcReg

  end subroutine

end module