!------------------------------------------------------------------------------
!P+
! NAME:
!       Aerosol_Rewrite
!
! PURPOSE:
!       Program to read the aerosol profile data file supplied by Clark Weaver
!       and output it in the CRTM common Aerosol format.
!
! CATEGORY:
!       CRTM : Atmosphere : I/O
!
! LANGUAGE:
!       Fortran-95
!
! MODULES:
!       Type_Kinds:                  Module containing definitions for kinds
!                                    of variable types.
!
!       Message_Handler:             Module to define simple error codes and
!                                    handle error conditions
!                                    USEs: FILE_UTILITY module
!
!       CRTM_Aerosol_Define:         Module defining the Aerosol data structure
!                                    and containing routines to manipulate it.
!                                    USEs: TYPE_KINDS module
!                                          ERROR_HANDLER module
!
!       CRTM_Aerosol_Binary_IO:      Module containing routines to read and write
!                                    Aerosol Binary format files.
!                                    USEs: TYPE_KINDS module
!                                          FILE_UTILITY module
!                                          ERROR_HANDLER module
!                                          BINARY_FILE_UTILITY module
!                                          CRTM_AEROSOL_DEFINE module
!
! CONTAINS:
!       None.
!
! INCLUDE FILES:
!       None.
!
! EXTERNALS:
!       None.
!
! COMMON BLOCKS:
!       None.
!
! FILES ACCESSED:
!       Input:  unformatted, sequential file provided by Clark
!
!       Output: Binary format Atmosphere file.
!
! SIDE EFFECTS:
!       If the output file already exists, it is overwritten.
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 17-Mar-2005
!                       paul.vandelst@ssec.wisc.edu
!
!  Copyright (C) 2005 Paul van Delst
!
!P-
!------------------------------------------------------------------------------

PROGRAM Aerosol_Rewrite

  ! ------------
  ! Module usage
  ! ------------

  USE Type_Kinds
  USE Message_Handler
  USE File_Utility

  USE CRTM_Aerosol_Define
  USE CRTM_Aerosol_Binary_IO

  ! ---------------------------
  ! Disable all implicit typing
  ! ---------------------------

  IMPLICIT NONE

  ! ----------
  ! Parameters
  ! ----------

  CHARACTER( * ),  PARAMETER :: PROGRAM_NAME   = 'Aerosol_Rewrite'
  CHARACTER( * ),  PARAMETER :: PROGRAM_RCS_ID = &
  CHARACTER( * ),  PARAMETER :: PROGRAM_HEADER = &
  '**********************************************************'

  ! -- Literal constants
  REAL( fp_kind ), PARAMETER :: ZERO = 0.0_fp_kind

  ! -- The data file names
  CHARACTER( * ), PARAMETER :: INPUT_FILENAME   = 'aerosol_profiles.dat.interpolated_and_layer_averaged'
  CHARACTER( * ), PARAMETER :: AEROSOL_FILENAME = 'Aerosol.bin'

  ! -- The number of profile layers
  INTEGER, PARAMETER :: N_LAYERS = 100

  ! -- The number of aerosol profiles
  INTEGER, PARAMETER :: N_AEROSOLS = 7

  ! -- The aerosol types
  INTEGER, PARAMETER, DIMENSION( N_AEROSOLS ) :: &
    AEROSOL_TYPE = (/ SULFATE_AEROSOL,            &
                      DUST_AEROSOL,               &
                      DRY_BLACK_CARBON_AEROSOL,   &
                      DRY_ORGANIC_CARBON_AEROSOL, &
                      WET_BLACK_CARBON_AEROSOL,   &
                      WET_ORGANIC_CARBON_AEROSOL, &
                      SEASALT_AEROSOL            /)

  ! -- The size modes for the aerosols
  INTEGER, PARAMETER, DIMENSION( N_AEROSOLS ) :: &
    N_MODES = (/ 1, &  ! Sulfate
                 4, &  ! Dust
                 1, &  ! Dry black carbon
                 1, &  ! Dry organic carbon
                 1, &  ! Wet black carbon
                 1, &  ! Wet organic carbon
                 4 /)  ! Sea salt
  INTEGER, PARAMETER :: MAX_N_MODES = 4

  ! -- The effective radii (um) for the aerosols
  REAL( fp_kind ), PARAMETER, DIMENSION( MAX_N_MODES, N_AEROSOLS ) :: EFFECTIVE_RADIUS = &
    RESHAPE( (/ 0.156_fp_kind, ZERO,         ZERO,         ZERO,         &    ! Sulfate
                0.73_fp_kind,  1.4_fp_kind,  2.4_fp_kind,  4.5_fp_kind,  &    ! Dust
                0.039_fp_kind, ZERO,         ZERO,         ZERO,         &    ! Dry black carbon
                0.087_fp_kind, ZERO,         ZERO,         ZERO,         &    ! Dry organic carbon
                0.039_fp_kind, ZERO,         ZERO,         ZERO,         &    ! Wet black carbon
                0.087_fp_kind, ZERO,         ZERO,         ZERO,         &    ! Wet organic carbon
                0.26_fp_kind,  1.19_fp_kind, 2.43_fp_kind, 7.57_fp_kind /), & ! Sea salt
             (/ MAX_N_MODES, N_AEROSOLS /) )

  ! -- The effective variance (um) of the size distribution for the aerosols
  REAL( fp_kind ), PARAMETER, DIMENSION( MAX_N_MODES, N_AEROSOLS ) :: EFFECTIVE_VARIANCE = &
    RESHAPE( (/ 2.03_fp_kind, ZERO,         ZERO,         ZERO,         &     ! Sulfate
                2.0_fp_kind,  2.0_fp_kind,  2.0_fp_kind,  2.0_fp_kind,  &     ! Dust
                2.0_fp_kind,  ZERO,         ZERO,         ZERO,         &     ! Dry black carbon
                2.2_fp_kind,  ZERO,         ZERO,         ZERO,         &     ! Dry organic carbon
                2.0_fp_kind,  ZERO,         ZERO,         ZERO,         &     ! Wet black carbon
                2.2_fp_kind,  ZERO,         ZERO,         ZERO,         &     ! Wet organic carbon
                2.03_fp_kind, 2.03_fp_kind, 2.03_fp_kind, 2.03_fp_kind /), &  ! Sea salt
             (/ MAX_N_MODES, N_AEROSOLS /) )

  ! -- Level temperature flag values
  INTEGER, PARAMETER :: NO  = 0
  INTEGER, PARAMETER :: YES = 1

  ! ---------
  ! Variables
  ! ---------

  CHARACTER( 256 ) :: Message

  INTEGER         :: pn_pos
  CHARACTER( 80 ) :: pn_fmt

  INTEGER :: Error_Status
  INTEGER :: IO_Status
  INTEGER :: FileID
  INTEGER :: m, n

  TYPE( CRTM_Aerosol_type ), DIMENSION( N_AEROSOLS ) :: Aerosol

  REAL( fp_kind ), DIMENSION( N_LAYERS ) :: Pressure

  !#----------------------------------------------------------------------------#
  !#                       -- OUTPUT DESCRIPTIVE HEADER --                      #
  !#----------------------------------------------------------------------------#

  pn_pos = ( LEN( PROGRAM_HEADER ) / 2 ) - &
           ( LEN( PROGRAM_NAME ) / 2 )
  pn_pos = MAX( pn_pos, 0 ) + 5
  WRITE( pn_fmt, '( "( ",i2,"x, a )" )' ) pn_pos

  WRITE( *, '(/5x, a)' ) PROGRAM_HEADER
  WRITE( *, FMT = TRIM( pn_fmt ) ) PROGRAM_NAME
  WRITE( *, '(/5x, " Program to read the aerosol profile data file supplied",&
             &/5x, "   by Clark Weaver and output it in the CRTM common",&
             &/5x, "   Aerosol format.")' )
  WRITE( *, '(/5x, " $Revision: 1.2 $")' )
  WRITE( *, '( 5x, a, /)' ) PROGRAM_HEADER

  !#----------------------------------------------------------------------------#
  !#                     -- ALLOCATE THE Aerosol STRUCTURES --                  #
  !#----------------------------------------------------------------------------#

  DO m = 1, N_AEROSOLS

    ! -------------------------------
    ! Allocate the Aerosol structures
    ! -------------------------------

    Error_Status = CRTM_Allocate_Aerosol( N_LAYERS, N_MODES( m ), &
                                          Aerosol( m ) )

    IF ( Error_Status /= SUCCESS ) THEN
      WRITE( Message, '( "Error allocating Aerosol structure array element ", i5 )' ) m
      CALL Display_Message( PROGRAM_NAME, &
                            TRIM( Message ), &
                            FAILURE )
      STOP
    END IF

    ! ------------------------------------------
    ! Fill the type, radius, and variance arrays
    ! ------------------------------------------

    Aerosol(m)%Type = AEROSOL_TYPE(m)

    DO n = 1, N_MODES(m)
      Aerosol(m)%Effective_Radius(:,n)   = EFFECTIVE_RADIUS(   n, AEROSOL_TYPE(m) )
      Aerosol(m)%Effective_Variance(:,n) = EFFECTIVE_VARIANCE( n, AEROSOL_TYPE(m) )
    END DO

  END DO

  !#----------------------------------------------------------------------------#
  !#                         -- READ THE DATA FILE  --                          #
  !#----------------------------------------------------------------------------#

  ! ------------------------
  ! Open the input data file
  ! ------------------------

  ! -- Get a logical unit number for input
  FileID = Get_Lun()
  IF ( FileID < 0 ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Error occurred obtaining file unit number.', &
                          FAILURE )
    STOP
  END IF

  ! -- Open the file
  OPEN( FileID, FILE   = INPUT_FILENAME, &
                STATUS = 'OLD', &
                FORM   = 'UNFORMATTED', &
                ACCESS = 'SEQUENTIAL', &
                ACTION = 'READ', &
                IOSTAT = IO_Status )

  IF ( IO_Status /= 0 ) THEN
    WRITE ( Message, '( "Error opening file ", a, ". IOSTAT = ", i5 )' ) INPUT_FILENAME, IO_Status
    CALL Display_Message( PROGRAM_NAME, &
                          TRIM( Message ), &
                          FAILURE )
    STOP
  END IF

  ! ----------------------
  ! Read the pressure data
  ! ----------------------

  READ( FileID, IOSTAT = IO_Status ) Pressure

  IF ( IO_Status /= 0 ) THEN
    WRITE ( Message, '( "Error reading pressure from ", a, ". IOSTAT = ", i5 )' ) INPUT_FILENAME, IO_Status
    CALL Display_Message( PROGRAM_NAME, &
                          TRIM( Message ), &
                          FAILURE )
    STOP
  END IF

  ! ---------------------
  ! Read the aerosol data
  ! ---------------------

  DO m = 1, N_AEROSOLS

    READ( FileID, IOSTAT = IO_Status ) Aerosol(m)%Concentration

    IF ( IO_Status /= 0 ) THEN
      WRITE( Message, '( "Error reading aerosol profile #", i5, " (", a, ") from ", a, ". IOSTAT = ", i5 )' ) &
                      m, AEROSOL_TYPE_NAME( AEROSOL_TYPE(m) ), INPUT_FILENAME, IO_Status
      CALL Display_Message( PROGRAM_NAME, &
                            TRIM( Message ), &
                            FAILURE )
      STOP
    END IF

  END DO

  !#----------------------------------------------------------------------------#
  !#                    -- WRITE THE Aerosol STRUCTURE FILE --                  #
  !#----------------------------------------------------------------------------#

  WRITE( *, '( /5x, "Writing the Aerosol data file ", a, "...." )' ) AEROSOL_FILENAME

  Error_Status = CRTM_Write_Aerosol_Binary( AEROSOL_FILENAME, &
                                            Aerosol )

  IF ( Error_Status /= SUCCESS ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Error writing Aerosol file '//AEROSOL_FILENAME, &
                          Error_Status )
    STOP
  END IF

  !#----------------------------------------------------------------------------#
  !#                -- TEST READ THE Atmosphere STRUCTURE FILE --               #
  !#----------------------------------------------------------------------------#

  ! -----------------------------------
  ! Destroy the Aerosol structure array
  ! -----------------------------------

  Error_Status = CRTM_Destroy_Aerosol( Aerosol )

  IF ( Error_Status /= SUCCESS ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Error destroying Aerosol structure array prior to test read.', &
                          Error_Status )
    STOP
  END IF

  ! -------------
  ! Read the file
  ! -------------

  WRITE( *, '( /5x, "Test reading the Aerosol data file...." )' )

  Error_Status = CRTM_Read_Aerosol_Binary( AEROSOL_FILENAME, &
                                           Aerosol )

  IF ( Error_Status /= SUCCESS ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Error test reading Aerosol file '//AEROSOL_FILENAME, &
                          Error_Status )
    STOP
  END IF

  !#----------------------------------------------------------------------------#
  !#                  -- DESTROY THE Aerosol STRUCTURE ARRAY --                 #
  !#----------------------------------------------------------------------------#

  Error_Status = CRTM_Destroy_Aerosol( Aerosol )

  IF ( Error_Status /= SUCCESS ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Error destroying Aerosol structure array.', &
                          Error_Status )
    STOP
  END IF

END PROGRAM Aerosol_Rewrite

<<<<<<< variant A
>>>>>>> variant B
!-------------------------------------------------------------------------------
!                          -- MODIFICATION HISTORY --
!-------------------------------------------------------------------------------
!
!
! $Date: 2006/05/02 14:58:34 $
!
! $Revision: 1.2 $
!
! $Name:  $
!
! $State: Exp $
!
! $Log: Aerosol_Rewrite.f90,v $
! Revision 1.2  2006/05/02 14:58:34  dgroff
! - Replaced all references of Error_Handler with Message_Handler
!
! Revision 1.1  2005/03/28 16:20:20  paulv
! Initial checkin.
!
!
!
!
======= end


      subroutine wshrun
c
c     + + + PURPOSE + + +
c
c     SR WSHRUN routes the runoff from impoundments and
c     channels through the watershed.
c
c     Called from: SR WSHDRV
c     Author(s): Ascough II
c     Reference in User Guide:
c
c     Version:
c     Date recoded:
c     Recoded by:
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
      include 'pmxcsg.inc'
      include 'pmxelm.inc'
      include 'pmxhil.inc'
      include 'pmximp.inc'
      include 'pmxpln.inc'
      include 'pmxprt.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     + + + COMMON BLOCKS + + +
c
      include 'cdiss11.inc'
      include 'cirspri.inc'
      include 'coutchn.inc'
      include 'cstore1.inc'
      include 'cstruct.inc'

      include 'chydrol.inc'
      include 'cchpek.inc'
      include 'cstruc.inc'
c
c     + + + LOCAL VARIABLES + + +
c
c     + + + LOCAL DEFINITIONS + + +
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     wshpek
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c
c     calculate the average runoff on the watershed at the outlet
c     of the current channel element
c
      rofave(ielmt) = runvol(ielmt) / wsarea(ielmt)
c
c     save monthly, annual, and total runoff from each channel
c     element
c
      trunm(ielmt) = trunm(ielmt) + runvol(ielmt)
      truny(ielmt) = truny(ielmt) + runvol(ielmt)
      trunt(ielmt) = trunt(ielmt) + runvol(ielmt)
cd    Added by S. Dun, Dec 20, 2007
c     for more output of annual summary of the chnnel
      tronvy(ielmt) = tronvy(ielmt) + rvolon(ielmt)
      tronvt(ielmt) = tronvt(ielmt) + rvolon(ielmt)
      sbrvty(ielmt) = sbrvty(ielmt) + sbrunf(ielmt-nhill)
     1               * charea(ielmt-nhill)
      sbrvtt(ielmt) = sbrvtt(ielmt) + sbrunf(ielmt-nhill)
     1               * charea(ielmt-nhill)
c     End adding
c
c     the duration for the channel element is the maximum
c     duration of the watershed elements that may feed it
c
cd    Modified by S. Dun 1/08/2004
cd    This duration value has given in WSHCQI already.
cd    Only the dur for channel could be changed after WSHIRS.for
cd
cd      watdur(ielmt) = amax1(watdur(nhleft(ielmt)),
cd     1    watdur(nhrght(ielmt)),watdur(nhtop(ielmt)),
cd     1    watdur(ncleft(ielmt)),watdur(ncrght(ielmt)),
cd     1    watdur(nctop(ielmt)),watdur(nileft(ielmt)),
cd     1    watdur(nirght(ielmt)),watdur(nitop(ielmt)),dur,irdur)
      watdur(ielmt) = amax1(watdur(ielmt),dur)
cd    End modifying
c
c
c     calculate peak runoff using modified Rational method
c     (ipeak = 1) or modified CREAMS method (ipeak = 2)
c
      call wshpek
c
      return
      end


c $Id: urqmd.f,v 1.1 2012/11/29 21:00:09 jwebb Exp $
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      program UrQMD
c
c      Authors : The UrQMD collaboration
c                S.A. Bass, M. Belkacem, M. Bleicher, M. Brandstetter,
c                L. Bravina, C. Ernst, L. Gerland, M. Hofmann,
c                S. Hofmann, J. Konopka, G. Mao, L. Neise, S. Soff,
c                C. Spieles, H. Weber, L.A. Winckelmann, H. Stoecker
c                and W. Greiner
c
c     Revision: 1.2
c
cc    contact address:
cc
cc                     urqmd@th.physik.uni-frankfurt.de
cc
c
c This is the main module of {\tt urqmd}. It servers as a connection between
c the initialization, the propagation (including the real part of the
c optical potential) and the collision term (imaginary part of the optical
c potential).
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      implicit none
      include 'coms.f'
      include 'comres.f'
      include 'options.f'
      include 'colltab.f'
      include 'inputs.f'
      include 'newpart.f'
      include 'boxinc.f'
c
      integer i,j,k,steps,ii,ocharge,ncharge, mc, mp, noc, it1,it2
      real*8 sqrts,otime,xdummy,st
      logical isstable
      integer stidx,CTOsave
      real*8 Ekinbar, Ekinmes, ESky2, ESky3, EYuk, ECb, EPau
      common /energies/ Ekinbar, Ekinmes, ESky2, ESky3, EYuk, ECb, EPau
      integer cti1sav,cti2sav
chp hydro variables
      real*8 thydro_start,thydro,nucrad
      logical lhydro

c
c     numerical/technical initialisation
c
      call uinit(0)
      call osc_header
      call osc99_header
c
c  Main program
c

      mc=0
      mp=0
      noc=0
c
c loop over all events
c
      do 10 event=1,nevents

c     start event here
c

c     time is the system time at the BEGINNING of every timestep
      time = 0.0
chp hydro flag, hydro should be called only once
      lhydro=.true.

c     initialize random number generator
c     call auto-seed generator only for first event and if no seed was fixed
      if(.not.firstseed.and.(.not.fixedseed)) then
         ranseed=-(1*abs(ranseed))
         call sseed(ranseed)
      else
         firstseed=.false.
      endif

      write(6,*)'event# ',event,ranseed

c
c     initialisation of physics quantities
c
      call init

chp hydro switch
      if (CToption(45).eq.1)then
chp hydro start time (nuclei have passed each other)
chp ebeam is only the kinetic energy
chp CTParam(65) is useful for the variation of the start time
chp default value is one
       thydro_start=CTParam(65)*2.d0*nucrad(Ap)*sqrt(2.d0*emnuc/ebeam)
       write(*,*) 'thydro_start is:', thydro_start
chp lower limit for hydro start time
       if(thydro_start.lt.CTParam(63)) then
        thydro_start=CTParam(63)
        write(6,*) 'thydro_start is set to:',CTParam(63)
       end if
      end if

c old time if an old fort.14 is used
      if(CTOption(40).eq.1)time=acttime

c output preparation

c write headers to file
      call output(13)
      call output(14)
      call output(15)
      call output(16)
      if(event.eq.1)call output(17)
      call osc99_event(-1)

c for CTOption(4)=1 : output of initialization configuration
      if(CTOption(4).eq.1)call file14out(0)

c     participant/spectator model:
      if(CTOption(28).ne.0) call rmspec(0.5d0*bimp,-(0.5d0*bimp))

c     compute time of output
      otime = outsteps*dtimestep

c reset time step counter
      steps = 0

c  loop over all timesteps

      do 20  steps=1,nsteps

c store coordinates in arrays with *_t
c this is needed for MD type propagation
         if (eos.ne.0) then
            do 23 j=1,npart
               r0_t(j) = r0(j)
               rx_t(j) = rx(j)
               ry_t(j) = ry(j)
               rz_t(j) = rz(j)
 23         continue
         end if

c we are at the beginning of the timestep, set current time (acttime)
         acttime = time
c  option for MD without collision term
         if(CTOption(16).ne.0) goto 103

c  Load collision table with next collisions in current timestep
         call colload
c     check for collisions in time-step, nct = # of collisions in table
         if (nct.gt.0) then

c     entry-point for collision loop in case of full colload after every coll.
 101        continue
            k = 0
c     normal entry-point for collision loop
 100        continue
c     get next collision
            call getnext(k)

c     exit collision loop if no collisions are left
            if (k.eq.0) goto 102
chp call hydro if start time is reached
            if(CTOption(45).eq.1)then

             if(cttime(k).gt.thydro_start.and.lhydro)then
              st=thydro_start-acttime
              call cascstep(acttime,st)
chp all particle arrays will be modified by hydro
              call hydro(thydro_start,thydro)
              acttime=thydro_start
              lhydro=.false.
              if(thydro.gt.1.d-8.or.CTOption(48).eq.1)then
chp full update of collision table
              call colload

              go to 101
              end if
             end if
            end if

c  propagate all particles to next collision time
c  store actual time in acttime, propagation time st=cttime(k)-acttime
	    st=cttime(k)-acttime
            call cascstep(acttime,st)
c  new actual time (for upcoming collision)
            acttime = cttime(k)

c  perform collision

            if(cti2(k).gt.0.and.
     .           abs(sqrts(cti1(k),cti2(k))-ctsqrts(k)).gt.1d-3)then
               write(6,*)' ***(E) wrong collision update (col) ***'
               write(6,*)cti1(k),cti2(k),
     .              ctsqrts(k),sqrts(cti1(k),cti2(k))
            else if(cti2(k).eq.0.and.
     .              abs(fmass(cti1(k))-ctsqrts(k)).gt.1d-3) then
               write(6,*)' *** main(W) wrong collision update (decay)'
               write(6,*)ctag,cti1(k),ityp(cti1(k)),dectime(cti1(k)),
     .              fmass(cti1(k)),ctsqrts(k)
            endif

            ocharge=charge(cti1(k))
            if(cti2(k).gt.0) ocharge=ocharge+charge(cti2(k))

c     store quantities in local variables for charge conservation check
            it1= ityp(cti1(k))
            if(cti2(k).gt.0)it2= ityp(cti2(k))

c increment "dirty" collision counter
            if(cti2(k).gt.0)then !scatter
               mc=mc+1
            endif
c     perform scattering/decay
            cti1sav = cti1(k)
            cti2sav = cti2(k)
            call scatter(cti1(k),cti2(k),ctsigtot(k),ctsqrts(k),
     &                   ctcolfluc(k))

c
c  update collision table
c
c     normal update mode
            if(CTOption(17).eq.0) then
               if(nexit.eq.0) then
c     new collision partners for pauli-blocked states (nexit=0)
                  if (cti1(k).ne.cti1sav.or.cti2(k).ne.cti2sav) then
                   cti1(k) = cti1sav
                   cti2(k) = cti2sav
                  endif
                  call collupd(cti1(k),1)
                  if(cti2(k).gt.0) call collupd(cti2(k),1)
               else
                  ncharge=0
c     new collision partners for scattered/produced particles (nexit><0)
                  do 30 i=1,nexit
c     ncharge is used for charge conservation check
                     ncharge=ncharge+charge(inew(i))
                     call collupd(inew(i),1)
 30               continue

c     charge conservation check
                  if(ocharge.ne.ncharge) then
                     write(6,*)'ch-conservation error coll/dec ',ctag
                     write(6,*)'   it1:',it1,'   it2:',it2
                     write(6,*)'   ch:',ocharge,ncharge
                     write(6,*)'cti1(k),cti2(k),ctsigtot(k),ctsqrts(k)'
                     write(6,*)cti1(k),cti2(k),ctsigtot(k),ctsqrts(k)
                  endif
               endif

c     update collisions for partners of annihilated particles
               do 55 ii=1,nsav
                  call collupd(ctsav(ii),1)
 55            continue
               nsav=0

            else ! (CTOption(17).ne.0)
c     full collision load
               call colload
            endif

            if (CTOption(17).eq.0) goto 100
            goto 101

c     this is the point to jump to after all collisions in the timestep
c     have been taken care of
 102        continue

         endif ! (nct.gt.0)

c  After all collisions in the timestep are done, propagate to end of
c  the timestep.

c     point to jump to in case of MD without collision term
 103     continue

c     increment timestep
         time = time+dtimestep

c  After all collisions in the timestep are done, propagate to end of
c  the timestep.
         call cascstep(acttime,time-acttime)

c     in case of potential interaction, do MD propagation step
         if (eos.ne.0) then

c set initial conditions for MD propagation-step
            do 24 j=1,npart
               r0(j) = r0_t(j)
               rx(j) = rx_t(j)
               ry(j) = ry_t(j)
               rz(j) = rz_t(j)
 24         continue

c now molecular dynamics trajectories
            call proprk(time,dtimestep)

         end if ! (eos.ne.0)

c     perform output if desired
         if(mod(steps,outsteps).eq.0.and.steps.lt.nsteps)then
            if(CTOption(28).eq.2)call spectrans(otime)
            call file14out(steps)
         endif ! output handling

 20   continue ! time step loop

ce
	acttime=time
c optional decay of all unstable particles before final output
c DANGER: pauli-blocked decays are not performed !!!
         if(CTOption(18).eq.0) then
c no do-loop is used because npart changes in loop-structure
            i=0
            nct=0
            actcol=0
c disable Pauli-Blocker for final decays
	    CTOsave=CTOption(10)
            CTOption(10)=1
c decay loop structure starts here
 40         continue
            i=i+1

c is particle unstable
            if(dectime(i).lt.1.d30) then
 41            continue
               isstable = .false.
               do 44 stidx=1,nstable
                  if (ityp(i).eq.stabvec(stidx)) then
c                     write (6,*) 'no decay of particle ',ityp(i)
                     isstable = .true.
                  endif
 44            enddo
               if (.not.isstable) then
c     perform decay
                  call scatter(i,0,0.d0,fmass(i),xdummy)
c     backtracing if decay-product is unstable itself
                  if(dectime(i).lt.1.d30) goto 41
               endif
            endif
c     check next particle
            if(i.lt.npart) goto 40
         endif ! final decay
         CTOption(10)=CTOsave
c final output

	   if(CTOption(28).eq.2)call spectrans(otime)

         call file13out(nsteps)
         if(CTOption(50).eq.0)then
          call file14out(nsteps)
         end if
         call file16out
         if(CTOption(50).eq.0)then
          call osc_event
         end if
         call osc99_event(1)
         call osc99_eoe

         mp=mp+npart
         if(ctag.eq.0)then
           write(*,*)'(W) No collision in event ',event
           noc=noc+1
         endif

c     end of event loop
 10   continue

      write(6,*)'no. of collisions = ',mc/dble(nevents), ' (per event)'
      write(6,*)'final particles   = ',mp/dble(nevents), ' (per event)'
      write(6,*)'empty events      : ', noc, ' = ',
     +      noc*1d2/dble(nevents), '%'
      end


!----------------------------------------------------------------------------- best with 100 columns

!> environment for the pressure-based coupled solver
module modPbc
  use modPolyFvGrid
  use modCondition
  use modUDF
  use modSUNDIALS
  use modSparse
  use iso_c_binding

  public

  integer,parameter::DIMS=3 !< three dimensions

  integer,parameter::MAXIT_PBC=20 !< max number of momentum and pressure equation iterations
  integer,parameter::MAXL_PBC=20 !< max dimensions of PBC Krylov subspace
  integer,parameter::MAXIT_ENERGY=50 !< max number of energy equation iterations
  integer,parameter::MAXIT_OUTER=20 !< max number of outer iterations
  integer,parameter::MAXIT_FULL=50 !< max number of full NS equation iterations
  integer,parameter::PBC_PREC_FILL=50 !< filling parameter of PBC ILU preconditioner

  integer,parameter::BC_WALL_TEMP=1 !< wall boundary with prescribed temperature
  integer,parameter::BC_WALL_TEMP_UDF=101 !< wall boundary with prescribed temperature by UDF
  integer,parameter::BC_WALL_SLIP=2 !< adiabatic slip wall
  integer,parameter::BC_IN_STATIC=10 !< inflow boundary with static properties
  integer,parameter::BC_IN_STATIC_UDF=110 !< inflow boundary with static properties by UDF
  integer,parameter::BC_IN_TOTAL=11 !< inflow boundary with total properties
  integer,parameter::BC_IN_TOTAL_UDF=111 !< inflow boundary with total properties by UDF
  integer,parameter::BC_OUT=20 !< outflow boundary
  integer,parameter::BC_OUT_UDF=120 !< outflow boundary by UDF
  integer,parameter::BC_FAR=30 !< far-field boundary
  integer,parameter::BC_FAR_UDF=130 !< far-field boundary by UDF

  type(polyFvGrid)::grid !< computational grid
  type(condTab)::bc !< boundary conditions
  type(UDFTab)::udf !< UDF

  integer,allocatable::iBC(:) !< indexes boundary conditions

  double precision::t !< time
  double precision::tFinal !< final time
  double precision::dt !< time step size [s]
  double precision::tInt !< time interval of output
  double precision::tNext !< time for next output
  integer::iOut !< index of output
  integer::nRetry !< number of retry for the current time step
  logical::needRetry !< if retry of the current time step is needed

  double precision::Rgas !< specific gas constant [J/kg/K]
  double precision::gamm !< gamma of gas

  double precision,allocatable::rho(:) !< density [kg/m^3]
  double precision,allocatable::rhou(:,:) !< momentum [kg/s/m^2]
  double precision,allocatable::rhoE(:) !< total energy [J/m^3]
  double precision,allocatable::p(:) !< pressure [Pa]
  double precision,allocatable::u(:,:) !< velocity [m/s]
  double precision,allocatable::temp(:) !< temperature [K]
  double precision,allocatable::massFrac(:,:) !< mass fraction of species

  ! state at the beginning of a time step
  double precision,allocatable::rho0(:),rhou0(:,:),rhoE0(:),p0(:),u0(:,:),temp0(:),massFrac0(:,:)

  ! state at the beginning of an outer iteration
  double precision,allocatable::rho1(:),p1(:)

  double precision,allocatable::visc(:) !< viscosity [Pa*s]
  double precision,allocatable::cond(:) !< thermal conductivity [W/m/K]
  double precision,allocatable::flowRho(:) !< mass flow through pair [kg/s]
  double precision,allocatable::flowRhou(:,:) !< momentum flow through pair [kg*m/s^2]
  double precision,allocatable::flowRhoH(:) !< enthalpy flow through pair [W]
  double precision,allocatable::advRho(:) !< mass advection into cell [kg/s]
  double precision,allocatable::advRhou(:,:) !< momentum advection into cell [kg*m/s^2]
  double precision,allocatable::advRhoH(:) !< enthalpy advection into cell [W]
  double precision,allocatable::gradU(:,:,:) !< gradient of velocity [1/s]
  double precision,allocatable::gradP(:,:) !< gradient of pressure [Pa/m]
  double precision,allocatable::gradTemp(:,:) !< gradient of temp [K/m]
  double precision,allocatable::viscF(:,:) !< viscous force applied on cell [N]
  double precision,allocatable::presF(:,:) !< pressure force applied on cell [N]
  double precision,allocatable::condQ(:) !< heat conduction into cell [W]
  double precision,allocatable::H(:) !< mass-specific enthalpy [J/kg]

  double precision,allocatable::massFlowSensU(:,:,:) !< sensitivity of mass flow rate on velocity
  double precision,allocatable::massFlowSensP(:,:) !< sensitivity of mass flow rate on pressure
  integer,allocatable::pbcPrecI(:),pbcPrecJ(:) !< PBC preconditioner COO index
  double precision,allocatable::pbcPrecVal(:) !< PBC preconditioner COO value

  ! scales and scaling factors
  double precision,allocatable::rhoScale !< density scale [kg/m^3]
  double precision,allocatable::rhouScale !< momentum scale [kg/s/m^2]
  double precision,allocatable::rhoEScale !< total energy scale [J/m^3]
  double precision,allocatable::pScale !< pressure scale [Pa]
  double precision,allocatable::uScale !< velocity scale [m/s]
  double precision,allocatable::tempScale !< temperature scale [K]
  double precision,allocatable::pbcXFact(:) !< pbc solution scaling factor vector
  double precision,allocatable::pbcRFact(:) !< pbc residual scaling factor vector
  double precision,allocatable::fullXFact(:) !< full system solution scaling factor vector
  double precision,allocatable::fullRFact(:) !< full system residual scaling factor vector

  ! data for algebraic solver
  type(NewtonKrylov)::pbcEq !< momentum and pressure equations (isothermal) solved by Newton-GMRES
  type(ILU)::pbcPrec !< PBC preconditioner
  type(fixPt)::energyEq !< energy equation as a fix point problem
  type(NewtonKrylov)::fullEq !< full NS equations solved by Newton-GMRES
  integer::nItPBC,nItEnergy,nItOuter,nItFull !< number of iterations

contains

  !> initialize the simulation
  subroutine init()
    use modFileIO
    integer,parameter::FID=10
    double precision::pInit,uInit(DIMS),TInit,pE(DIMS),tmpD
    double precision,allocatable::massFracInit(:)
    integer::udfIc,udfBc,iUdf(5)

    ! read inputs
    open(FID,file='grid.msh',action='read')
      call readGMSH(FID,grid)
    close(FID)
    call grid%up()
    open(FID,file='bc',action='read')
      call readCondTab(FID,bc)
    close(FID)
    call mapCondTab(grid,bc,iBC)
    if(any(bc%t(:)==BC_WALL_TEMP_UDF).or.&
    &  any(bc%t(:)==BC_IN_STATIC_UDF).or.&
    &  any(bc%t(:)==BC_IN_TOTAL_UDF).or.&
    &  any(bc%t(:)==BC_OUT_UDF).or.&
    &  any(bc%t(:)==BC_FAR_UDF))then
      udfBc=1
    else
      udfBc=0
    end if
    open(FID,file='ic',action='read')
      read(FID,*)udfIC
      if(udfIc==0)then
        read(FID,*)pInit
        read(FID,*)TInit
        read(FID,*)uInit(1)
        read(FID,*)uInit(2)
        read(FID,*)uInit(3)
      else
        read(FID,*)tmpD
        iUdf(1)=int(tmpD)
        read(FID,*)tmpD
        iUdf(2)=int(tmpD)
        read(FID,*)tmpD
        iUdf(3)=int(tmpD)
        read(FID,*)tmpD
        iUdf(4)=int(tmpD)
        read(FID,*)tmpD
        iUdf(5)=int(tmpD)
      end if
    close(FID)
    open(FID,file='sim',action='read')
      read(FID,*)tFinal
      read(FID,*)dt
      read(FID,*)tInt
    close(FID)
    open(FID,file='fl',action='read')
      read(FID,*)Rgas
      read(FID,*)gamm
    close(FID)
    if(udfIc/=0.or.udfBc/=0)then
      open(FID,file='udf',action='read')
        call readUDFTab(FID,udf)
      close(FID)
    end if
    ! initialize algebraic solver
    call pbcEq%init(grid%nC*(DIMS+1),pbcRHS,maxl=MAXL_PBC,pset=pbcPSet,psol=pbcPSol)
    call pbcEq%setMaxIt(MAXIT_PBC)
    call pbcPrec%init(grid%nC*(DIMS+1),(size(grid%neib,1)+1)*(DIMS+1)*grid%nC,PBC_PREC_FILL)
    call energyEq%init(grid%nC,energyRHS,maa=MAXIT_ENERGY)
    call energyEq%setMaxIt(MAXIT_ENERGY)
    call fullEq%init(grid%nC*(DIMS+2),fullRHS,maxl=MAXIT_FULL,pset=fullPSet,psol=fullPSol)
    call fullEq%setMaxIt(MAXIT_FULL)
    ! work space and initial state
    allocate(rho(grid%nE))
    allocate(rho0(grid%nE))
    allocate(rho1(grid%nE))
    allocate(rhou(DIMS,grid%nE))
    allocate(rhou0(DIMS,grid%nE))
    allocate(rhoE(grid%nE))
    allocate(rhoE0(grid%nE))
    allocate(p(grid%nE))
    allocate(p0(grid%nE))
    allocate(p1(grid%nE))
    allocate(u(DIMS,grid%nE))
    allocate(u0(DIMS,grid%nE))
    allocate(temp(grid%nE))
    allocate(temp0(grid%nE))
    allocate(massFrac(1,grid%nE))! FIXME fix nSp
    allocate(massFrac0(1,grid%nE))! FIXME fix nSp
    allocate(massFracInit(1))! FIXME fix nSp
    allocate(visc(grid%nE))
    allocate(cond(grid%nE))
    allocate(flowRho(grid%nP))
    allocate(flowRhou(DIMS,grid%nP))
    allocate(flowRhoH(grid%nP))
    allocate(advRho(grid%nC))
    allocate(advRhou(DIMS,grid%nC))
    allocate(advRhoH(grid%nC))
    allocate(gradU(DIMS,DIMS,grid%nC))
    allocate(gradP(DIMS,grid%nC))
    allocate(gradTemp(DIMS,grid%nC))
    allocate(viscF(DIMS,grid%nC))
    allocate(presF(DIMS,grid%nC))
    allocate(condQ(grid%nC))
    allocate(H(grid%nC))
    allocate(massFlowSensU(DIMS,2,grid%nP))
    allocate(massFlowSensP(2,grid%nP))
    allocate(pbcPrecI((size(grid%neib,1)+1)*(DIMS+1)*grid%nC))
    allocate(pbcPrecJ((size(grid%neib,1)+1)*(DIMS+1)*grid%nC))
    allocate(pbcPrecVal((size(grid%neib,1)+1)*(DIMS+1)*grid%nC))
    allocate(pbcXFact((DIMS+1)*grid%nC))
    allocate(pbcRFact((DIMS+1)*grid%nC))
    allocate(fullXFact((DIMS+2)*grid%nC))
    allocate(fullRFact((DIMS+2)*grid%nC))
    do i=1,grid%nE
      if(udfIc/=0)then
        pE(:)=grid%p(:,i)
        pInit=udf%eval(iUdf(1),pE,0d0)
        TInit=udf%eval(iUdf(2),pE,0d0)
        uInit(1)=udf%eval(iUdf(3),pE,0d0)
        uInit(2)=udf%eval(iUdf(4),pE,0d0)
        uInit(3)=udf%eval(iUdf(5),pE,0d0)
      end if
      ! FIXME remove below
      massFracInit=[1d0]
      ! FIXME remove above
      p(i)=pInit
      u(:,i)=uInit(:)
      temp(i)=TInit
      massFrac(:,i)=massFracInit(:)
    end do
    call recoverState(p,u,temp,massFrac,rho,rhou,rhoE)
    t=0d0
    tNext=tInt
    iOut=0
    deallocate(massFracInit)
  end subroutine

  !> clear the simulation environment
  subroutine clear()
    call grid%clear()
  end subroutine

  !> record {rho,rhoU,rhoE,p,u,temp,massFrac} in {rho0,rhoU0,rhoE0,p0,u0,temp0,massFrac0}
  subroutine recordState0()
    rho0(:)=rho(:)
    rhou0(:,:)=rhou(:,:)
    rhoE0(:)=rhoE(:)
    p0(:)=p(:)
    u0(:,:)=u(:,:)
    temp0(:)=temp(:)
    massFrac0(:,:)=massFrac(:,:)
  end subroutine

  !> load {rho,rhoU,rhoE,p,u,temp,massFrac} from {rho0,rhoU0,rhoE0,p0,u0,temp0,massFrac0}
  subroutine loadState0()
    rho(:)=rho0(:)
    rhou(:,:)=rhou0(:,:)
    rhoE(:)=rhoE0(:)
    p(:)=p0(:)
    u(:,:)=u0(:,:)
    temp(:)=temp0(:)
    massFrac(:,:)=massFrac0(:,:)
  end subroutine

  !> derive primitive state {p,u,T} from conserved state {rho,rhou,rhoE}
  subroutine deriveState(rhoi,rhoui,rhoEi,massFraci,po,uo,tempo)
    double precision,intent(in)::rhoi(:) !< density
    double precision,intent(in)::rhoui(:,:) !< momentum
    double precision,intent(in)::rhoEi(:) !< total energy
    double precision,intent(in)::massFraci(:,:) !< mass fraction of species
    double precision,intent(inout)::po(:) !< pressure
    double precision,intent(inout)::uo(:,:) !< velocity
    double precision,intent(inout)::tempo(:) !< temperature

    !$omp parallel do default(shared)
    do i=1,grid%nE
      uo(:,i)=rhoui(:,i)/rhoi(i)
      ! FIXME calculation of p, T based on cantera
      po(i)=(gamm-1d0)*(rhoEi(i)-0.5d0*dot_product(rhoui(:,i),rhoui(:,i))/rhoi(i))
      tempo(i)=po(i)/rhoi(i)/Rgas
    end do
    !$omp end parallel do
  end subroutine

  !> recover conserved state {rho,rhou,rhoE} from primitive state {p,u,T}
  subroutine recoverState(pi,ui,tempi,massFraci,rhoo,rhouo,rhoEo)
    double precision,intent(in)::pi(:) !< pressure
    double precision,intent(in)::ui(:,:) !< velocity
    double precision,intent(in)::tempi(:) !< temperature
    double precision,intent(in)::massFraci(:,:) !< mass fraction of species
    double precision,intent(inout)::rhoo(:) !< density
    double precision,intent(inout)::rhouo(:,:) !< momentum
    double precision,intent(inout)::rhoEo(:) !< total energy

    !$omp parallel do default(shared)
    do i=1,grid%nE
      ! FIXME calculation of rho, rhoE based on cantera
      rhoo(i)=pi(i)/Rgas/tempi(i)
      rhouo(:,i)=rhoo(i)*ui(:,i)
      rhoEo(i)=rhoo(i)*(1d0/(gamm-1d0)*Rgas*tempi(i)+0.5d0*dot_product(ui(:,i),ui(:,i)))
    end do
    !$omp end parallel do
  end subroutine

  !> write the state to post-processing file
  subroutine writeState(fName)
    use modFileIO
    character(*),intent(in)::fName
    integer,parameter::FID=10
    double precision::eps
    double precision,save,allocatable::tmp1(:),tmp2(:,:)

    if(.not.allocated(tmp1))then
      allocate(tmp1(grid%nE))
      allocate(tmp2(DIMS,grid%nE))
    end if
    open(FID,file=trim(fName),action='write')
    call writeVTK(FID,grid)
    call writeVTK(FID,grid,E_DATA)
    tmp1=dble(grid%gid)
    call writeVTK(FID,'geoID',tmp1)
    forall(i=1:grid%nE)
      tmp1(i)=merge(0d0,1d0,i<=grid%nC)
    end forall
    call writeVTK(FID,'geoType',tmp1)
    if(iOut==0)then
      call writeVTK(FID,'density',rho)
      call writeVTK(FID,'velocity',u)
      call writeVTK(FID,'pressure',p)
      call writeVTK(FID,'temperature',temp)
    else
      eps=(t-tNext)/dt
      tmp1=eps*rho0+(1d0-eps)*rho
      call writeVTK(FID,'density',tmp1)
      tmp2=eps*u0+(1d0-eps)*u
      call writeVTK(FID,'velocity',tmp2)
      tmp1=eps*p0+(1d0-eps)*p
      call writeVTK(FID,'pressure',tmp1)
      tmp1=eps*temp0+(1d0-eps)*temp
      call writeVTK(FID,'temperature',tmp1)
    end if
    close(FID)
  end subroutine

  !> calculate time step size, scaling vectors and initial solution vector
  subroutine preSolve()
    double precision,parameter::CFL_ACCOUSTIC=50d0
    double precision,parameter::CFL_FLOW=0.5d0
    double precision,parameter::CFL_DIFFUSION=0.5d0

    ! TODO calculate dt, cantera sound speed
    dt=min(dt,minval(CFL_ACCOUSTIC*grid%v(:)**(1d0/3d0)&
    &                     /sqrt(gamm*p(1:grid%nC)/rho(1:grid%nC))))
    dt=min(dt,minval(CFL_FLOW*grid%v(:)**(1d0/3d0)&
    &                /norm2(u(:,1:grid%nC),1)))
    dt=min(dt,minval(CFL_DIFFUSION*grid%v(:)**(2d0/3d0)&
    &                /(visc(1:grid%nC)/rho(1:grid%nC))))
    if(nRetry>0)then
      dt=dt/2d0**nRetry
      write(*,'(a,i2,a,g12.6)')'[i] starting retry No. ',nRetry,' at t: ',t
    end if

    ! solution and residual scales
    pScale=max(maxval(p),maxval(0.5d0*rho*norm2(u,1)**2))
    uScale=max(maxval(norm2(u,1)),sqrt(2d0*(maxval(p)-minval(p))/minval(rho)),0.01d0)
    tempScale=maxval(temp)
    rhoScale=maxval(rho)
    rhouScale=rhoScale*uScale
    rhoEScale=max(rhoScale*Rgas*tempScale,0.5d0*rhoScale*uScale**2)
    forall(i=1:grid%nC)
      pbcXFact((DIMS+1)*(i-1)+1:(DIMS+1)*(i-1)+DIMS)=1d0/uScale
      pbcXFact((DIMS+1)*(i-1)+(DIMS+1))=1d0/pScale
      pbcRFact((DIMS+1)*(i-1)+1:(DIMS+1)*(i-1)+DIMS)=1d0/rhouScale
      pbcRFact((DIMS+1)*(i-1)+(DIMS+1))=1d0/rhoScale
      fullXFact((DIMS+2)*(i-1)+1:(DIMS+2)*(i-1)+DIMS)=1d0/uScale
      fullXFact((DIMS+2)*(i-1)+(DIMS+1))=1d0/pScale
      fullXFact((DIMS+2)*(i-1)+(DIMS+2))=1d0/tempScale
      fullRFact((DIMS+2)*(i-1)+1:(DIMS+2)*(i-1)+DIMS)=1d0/rhouScale
      fullRFact((DIMS+2)*(i-1)+(DIMS+1))=1d0/rhoScale
      fullRFact((DIMS+2)*(i-1)+(DIMS+2))=1d0/rhoEScale
    end forall
    call pbcEq%setScale(pbcXFact,pbcRFact)
    call fullEq%setScale(fullXFact,fullRfact)

    nItPBC=0
    nItEnergy=0
    nItFull=0

    write(*,'(a,g12.6,a,g12.6)')'[i] starting step, t: ',t,' dt: ',dt
  end subroutine

  !> guess next time step size, etc.
  subroutine postSolve()
    double precision,parameter::MIN_EFFORT=0.3d0 !< increase dt if "effort" lower than lower limit
    double precision,parameter::MAX_EFFORT=0.5d0 !< reduce dt if "effort" higher than higher limit
    double precision,parameter::MAX_GROWTH=1.2d0 !< new dt is no more than 120% of the current dt
    double precision::effort !< the "effort"

    ! adjust time step size to maintain effort
    effort=maxval(dble([nItPBC,nItEnergy,nItOuter])/dble([MAXIT_PBC,MAXIT_ENERGY,MAXIT_OUTER]))
    if(effort<MIN_EFFORT)then
      dt=dt*min(MIN_EFFORT/effort,MAX_GROWTH)
    else if(effort>MAX_EFFORT)then
      dt=dt*MAX_EFFORT/effort
    end if
    write(*,'(a,i2,a,i2,a,i2,a,i2,a)')'[i] finished step, nIt[PBC,Energy,Outer]: [',&
    &                                 nItPBC,',',nItEnergy,',',nItOuter,']'
  end subroutine

  !> set the boundary conditions
  subroutine setBC()
    double precision::pGst,TGst,uGst(DIMS),rhoGst,rhouGst(DIMS),rhoEGst,Mach,pP(DIMS),Tt,pt,&
    &                 un(DIMS),ut(DIMS),ui(DIMS),charI,charO

    do i=grid%nPi+1,grid%nPi+grid%nPb
      m=grid%iEP(1,i)
      n=grid%iEP(2,i)
      ! default adiabatic wall boundary
      pGst=p(m)
      uGst(:)=-u(:,m)
      TGst=temp(m)
      rhoGst=rho(m)
      rhouGst=-rhou(:,m)
      rhoEGst=rhoE(m)
      if(iBC(n)>0)then
        select case(bc%t(iBC(n)))
        case(BC_WALL_TEMP,BC_WALL_TEMP_UDF) ! wall temperature boundary
          ! TODO implement this
        case(BC_WALL_SLIP) ! adiabatic slip wall boundary
          pGst=p(m)
          TGst=temp(m)
          uGst(:)=u(:,m)-2d0*grid%normP(:,i)*dot_product(grid%normP(:,i),u(:,m))
        case(BC_IN_STATIC,BC_IN_STATIC_UDF) ! inflow boundary with static properties
          if(bc%t(iBC(n))==BC_IN_STATIC)then
            pGst=bc%p(1,iBC(n))
            TGst=bc%p(2,iBC(n))
            uGst(:)=bc%p(3:5,iBC(n))
          else
            pP(:)=grid%pP(:,i)
            pGst=udf%eval(int(bc%p(1,iBC(n))),pP,t)
            TGst=udf%eval(int(bc%p(2,iBC(n))),pP,t)
            uGst(1)=udf%eval(int(bc%p(3,iBC(n))),pP,t)
            uGst(2)=udf%eval(int(bc%p(4,iBC(n))),pP,t)
            uGst(3)=udf%eval(int(bc%p(5,iBC(n))),pP,t)
          end if
          Mach=norm2(uGst)/sqrt(gamm*Rgas*TGst)
          if(Mach<1d0)then
            if(dot_product(uGst,uGst)>0d0)then
              uGst(:)=dot_product(u(:,m),uGst(:))*uGst/dot_product(uGst,uGst)
            else
              uGst(:)=u(:,m)
            end if
          end if
        case(BC_IN_TOTAL,BC_IN_TOTAL_UDF) ! inflow boundary with total properties
          if(bc%t(iBC(n))==BC_IN_TOTAL)then
            pt=bc%p(1,iBC(n))
            Tt=bc%p(2,iBC(n))
            uGst=bc%p(3:5,iBC(n))
          else
            pP(:)=grid%pP(:,i)
            pt=udf%eval(int(bc%p(1,iBC(n))),pP,t)
            Tt=udf%eval(int(bc%p(2,iBC(n))),pP,t)
            uGst(1)=udf%eval(int(bc%p(3,iBC(n))),pP,t)
            uGst(2)=udf%eval(int(bc%p(4,iBC(n))),pP,t)
            uGst(3)=udf%eval(int(bc%p(5,iBC(n))),pP,t)
          end if
          TGst=Tt-0.5d0*(gamm-1d0)/gamm/Rgas*dot_product(uGst,uGst)
          Mach=norm2(uGst)/sqrt(gamm*Rgas*TGst)
          if(Mach<1d0)then
            if(dot_product(uGst,uGst)>0d0)then
              uGst(:)=dot_product(u(:,m),uGst(:))*uGst/dot_product(uGst,uGst)
            else
              uGst(:)=u(:,m)
            end if
            TGst=Tt-0.5d0*(gamm-1d0)/gamm/Rgas*dot_product(uGst,uGst)
            Mach=norm2(uGst)/sqrt(gamm*Rgas*TGst)
          end if
          pGst=pt*(1d0+0.5d0*(gamm-1d0)*Mach**2)**(-gamm/(gamm-1d0))
        case(BC_OUT,BC_OUT_UDF) ! outflow boundary
          if(bc%t(iBC(n))==BC_OUT)then
            pGst=bc%p(1,iBC(n))
          else
            pP(:)=grid%pP(:,i)
            pGst=udf%eval(int(bc%p(1,iBC(n))),pP,t)
          end if
          uGst(:)=u(:,m)
          TGst=temp(m)
        case(BC_FAR,BC_FAR_UDF) ! far-field boundary
          if(bc%t(iBC(n))==BC_FAR)then
            pGst=bc%p(1,iBC(n))
            TGst=bc%p(2,iBC(n))
            uGst(:)=bc%p(3:5,iBC(n))
          else
            pP(:)=grid%pP(:,i)
            pGst=udf%eval(int(bc%p(1,iBC(n))),pP,t)
            TGst=udf%eval(int(bc%p(2,iBC(n))),pP,t)
            uGst(1)=udf%eval(int(bc%p(3,iBC(n))),pP,t)
            uGst(2)=udf%eval(int(bc%p(4,iBC(n))),pP,t)
            uGst(3)=udf%eval(int(bc%p(5,iBC(n))),pP,t)
          end if
          charO=dot_product(uGst,grid%normP(:,i))-2d0*sqrt(gamm*Rgas*TGst)/(gamm-1d0)
          ui(:)=u(:,m)
          charI=dot_product(ui,grid%normP(:,i))+2d0*sqrt(gamm*Rgas*temp(m))/(gamm-1d0)
          un(:)=0.5d0*grid%normP(:,i)*(charI+charO)
          if(dot_product(un(:),grid%normP(:,i))>0d0)then
            ut(:)=ui(:)-grid%normP(:,i)*dot_product(grid%normP(:,i),ui(:))
          else
            ut(:)=uGst(:)-un
          end if
          uGst(:)=un(:)+ut(:)
        case default
        end select
        rhoGst=pGst/Rgas/TGst
        rhouGst(:)=rhoGst*uGst(:)
        rhoEGst=rhoGst*(1d0/(gamm-1d0)*Rgas*TGst+0.5d0*dot_product(uGst,uGst))
      end if
      ! apply ghost values
      p(n)=pGst
      u(:,n)=uGst(:)
      temp(n)=TGst
      rho(n)=rhoGst
      rhou(:,n)=rhouGst(:)
      rhoE(n)=rhoEGst
    end do
  end subroutine

  !> solve the coupled momentum and pressure equations while keeping isentropic
  subroutine solvePBC()
    use modGradient
    double precision,allocatable,save::x(:)
    integer::info

    if(.not.allocated(x))then
      allocate(x((DIMS+1)*grid%nC))
    else if(size(x)/=(DIMS+1)*grid%nC)then
      deallocate(x)
      allocate(x((DIMS+1)*grid%nC))
    end if
    forall(i=1:grid%nC)
      x((DIMS+1)*(i-1)+1:(DIMS+1)*(i-1)+DIMS)=u(:,i)
      x((DIMS+1)*(i-1)+(DIMS+1))=p(i)
    end forall
    call setBC()
    call findGrad(grid,p,gradP)
    call findGrad(grid,u,gradU)
    call pbcEq%solve(x,info=info)
    needRetry=info<0
    call pbcEq%getNIt(n)
    nItPBC=max(nItPBC,n)
    forall(i=1:grid%nC)
      u(:,i)=x((DIMS+1)*(i-1)+1:(DIMS+1)*(i-1)+DIMS)
      p(i)=x((DIMS+1)*(i-1)+(DIMS+1))
    end forall
  end subroutine

  !> residual function of the momentum and pressure equations
  function pbcRHS(oldVector,newVector,dat)
    use iso_c_binding
    use ieee_arithmetic
    use modSUNDIALS
    use modAdvection
    use modDiffusion
    use modPressure
    use modNewtonian
    type(C_PTR),value::oldVector !< old N_Vector
    type(C_PTR),value::newVector !< new N_Vector
    type(C_PTR),value::dat !< optional user data object
    integer(C_INT)::pbcRHS !< error code
    double precision,pointer::x(:) !< fortran pointer associated with oldVector
    double precision,pointer::y(:) !< fortran pointer associated with newVector

    call associateVector(oldVector,x)
    call associateVector(newVector,y)

    !$omp parallel workshare
    forall(i=1:grid%nC)
      u(:,i)=x((DIMS+1)*(i-1)+1:(DIMS+1)*(i-1)+DIMS)
      p(i)=x((DIMS+1)*(i-1)+(DIMS+1))
      rho(i)=p1(i)/Rgas/temp(i)*(p(i)/p1(i))**(1d0/gamm)
      rhou(:,i)=rho(i)*u(:,i)
    end forall
    !$omp end parallel workshare
    call setBC()
    call findPresForce(grid,p,gradP,presF)
    call findViscForce(grid,u,gradU,visc,viscF)
    call findMassFlow(grid,rho,u,p,presF,dt,flowRho)
    call findVarFlow(grid,u,flowRho,flowRhou)
    call findAdv(grid,flowRho,advRho)
    call findAdv(grid,flowRhou,advRhou)
    !$omp parallel workshare
    forall(i=1:grid%nC)
      y((DIMS+1)*(i-1)+1:(DIMS+1)*(i-1)+DIMS)=& ! momentum equation residual
      &  rhou(:,i)-rhou0(:,i)-dt/grid%v(i)*(advRhou(:,i)+presF(:,i)+viscF(:,i))
      y((DIMS+1)*(i-1)+(DIMS+1))=& ! pressure equation residual
      &  rho(i)-rho0(i)-dt/grid%v(i)*advRho(i)
    end forall
    !$omp end parallel workshare
    pbcRHS=merge(1,0,any(ieee_is_nan(y).or.(.not.ieee_is_finite(y))))
    if(c_associated(dat))then
    end if
  end function

  !> momentum and pressure preconditioning matrix setup/factor
  function pbcPSet(c_x,c_xScale,c_f,c_fScale,dat)
    use iso_c_binding
    use modSUNDIALS
    use modAdvection
    use modPressure
    type(C_PTR),value::c_x,c_xScale,c_f,c_fScale,dat
    integer(C_INT)::pbcPSet
    double precision,pointer::x(:),xScale(:),f(:),fScale(:)
    type(C_PTR)::foo
    double precision,parameter::PBC_PREC_DROPTOL=1e-6

    call associateVector(c_x,x)
    call associateVector(c_xScale,xScale)
    call associateVector(c_f,f)
    call associateVector(c_fScale,fScale)

    ! construct preconditioning matrix
    !$omp parallel workshare
    forall(i=1:grid%nC)
      u(:,i)=x((DIMS+1)*(i-1)+1:(DIMS+1)*(i-1)+DIMS)
      p(i)=x((DIMS+1)*(i-1)+(DIMS+1))
      rho(i)=p1(i)/Rgas/temp(i)*(p(i)/p1(i))**(1d0/gamm)
      rhou(:,i)=rho(i)*u(:,i)
    end forall
    !$omp end parallel workshare
    call setBC()
    call findPresForce(grid,p,gradP,presF)
    call findMassFlow(grid,rho,u,p,presF,dt,flowRho,sensU=massFlowSensU,sensP=massFlowSensP)
    !$omp parallel workshare
    forall(i=1:grid%nC)
      forall(j=1:DIMS+1)
        pbcPrecI((DIMS+1)*(i-1)+j)=(DIMS+1)*(i-1)+j
        pbcPrecJ((DIMS+1)*(i-1)+j)=(DIMS+1)*(i-1)+j
      end forall
      pbcPrecVal((DIMS+1)*(i-1)+1:(DIMS+1)*(i-1)+DIMS)=1d0
      pbcPrecVal((DIMS+1)*(i-1)+(DIMS+1))=1d0
    end forall
    !$omp end parallel workshare
    l=grid%nC*(DIMS+1)
    do i=1,grid%nP
      m=grid%iEP(1,i)
      n=grid%iEP(2,i)
      if(n<=grid%nC)then
        !pPrecVal(m)=pPrecVal(m)-dt/grid%v(m)*massFlowSensP(1,i)
        !pPrecVal(n)=pPrecVal(n)+dt/grid%v(n)*massFlowSensP(2,i)
        !l=l+1
        !pPrecI(l)=m
        !pPrecJ(l)=n
        !pPrecVal(l)=-dt/grid%v(m)*massFlowSensP(2,i)
        !l=l+1
        !pPrecI(l)=n
        !pPrecJ(l)=m
        !pPrecVal(l)=dt/grid%v(n)*massFlowSensP(1,i)
      else
        !pPrecVal(m)=pPrecVal(m)-dt/grid%v(m)*massFlowSensP(1,i)
      end if
    end do
    ! factorize preconditioning matrix
    call pbcPrec%setCOO(pbcPrecI,pbcPrecJ,pbcPrecVal,l)
    call pbcPrec%fact(PBC_PREC_DROPTOL)
    pbcPSet=0
    foo=dat
  end function

  !> momentum and pressure preconditioning problem solving
  function pbcPSol(c_x,c_xScale,c_f,c_fScale,c_v,dat)
    type(C_PTR),value::c_x,c_xScale,c_f,c_fScale,c_v,dat
    integer(C_INT)::pbcPSol
    double precision,pointer::x(:),xScale(:),f(:),v(:),fScale(:)
    double precision,allocatable,save::pbcRst(:),pbcRHS(:)
    type(C_PTR)::foo

    call associateVector(c_x,x)
    call associateVector(c_xScale,xScale)
    call associateVector(c_f,f)
    call associateVector(c_fScale,fScale)
    call associateVector(c_v,v)

    if(.not.allocated(pbcRst))then
      allocate(pbcRst(grid%nC*(DIMS+1)))
      allocate(pbcRHS(grid%nC*(DIMS+1)))
    end if

    ! find x increment from f increment v and save back to v
    pbcRHS(1:grid%nC*(DIMS+1))=v(1:grid%nC*(DIMS+1))
    call pbcPrec%solve(pbcRHS,pbcRst)
    v(1:grid%nC*(DIMS+1))=pbcRst(1:grid%nC*(DIMS+1))
    pbcPsol=0
    foo=dat
  end function

  !> solve the energy equation
  subroutine solveEnergy()
    use modGradient
    double precision,allocatable,save::x(:)
    integer::info

    if(.not.allocated(x))then
      allocate(x(grid%nC))
    else if(size(x)/=grid%nC)then
      deallocate(x)
      allocate(x(grid%nC))
    end if
    x(1:grid%nC)=rhoE(1:grid%nC)
    call setBC()
    call findGrad(grid,temp,gradTemp)
    call energyEq%solve(x,info=info)
    needRetry=info<0
    call energyEq%getNIt(n)
    nItEnergy=max(nItEnergy,n)
    forall(i=1:grid%nC)
      rhoE(i)=x(i)
      temp(i)=(rhoE(i)/rho(i)-0.5d0*dot_product(u(:,i),u(:,i)))/(1d0/(gamm-1d0))/Rgas
    end forall
  end subroutine

  !> RHS of the energy equation in the form of a fix point problem
  function energyRHS(oldVector,newVector,dat)
    use iso_c_binding
    use ieee_arithmetic
    use modSUNDIALS
    use modAdvection
    use modDiffusion
    type(C_PTR),value::oldVector !< old N_Vector
    type(C_PTR),value::newVector !< new N_Vector
    type(C_PTR),value::dat !< optional user data object
    integer(C_INT)::energyRHS !< error code
    double precision,pointer::x(:) !< fortran pointer associated with oldVector
    double precision,pointer::y(:) !< fortran pointer associated with newVector

    call associateVector(oldVector,x)
    call associateVector(newVector,y)

    rhoE(1:grid%nC)=x(1:grid%nC)
    !$omp parallel workshare
    forall(i=1:grid%nC)
      temp(i)=(rhoE(i)/rho(i)-0.5d0*dot_product(u(:,i),u(:,i)))/(1d0/(gamm-1d0))/Rgas
    end forall
    !$omp end parallel workshare
    call setBC()
    H=(rhoE+p)/rho
    call findVarFlow(grid,H,flowRho,flowRhoH)
    call findAdv(grid,flowRhoH,advRhoH)
    call findDiff(grid,temp,gradTemp,cond,condQ)
    !$omp parallel workshare
    forall(i=1:grid%nC)
      y(i)=rhoE0(i)+dt/grid%v(i)*(advRhoH(i)+condQ(i)) ! TODO add viscous heating
    end forall
    !$omp end parallel workshare
    energyRHS=merge(1,0,any(ieee_is_nan(y).or.(.not.ieee_is_finite(y))))
    if(c_associated(dat))then
    end if
  end function

  !> solve the full NS equations
  subroutine solveFull()
    double precision,allocatable,save::x(:)
    integer::info

    if(.not.allocated(x))then
      allocate(x((DIMS+2)*grid%nC))
    else if(size(x)/=(DIMS+2)*grid%nC)then
      deallocate(x)
      allocate(x((DIMS+2)*grid%nC))
    end if
    forall(i=1:grid%nC)
      x((DIMS+2)*(i-1)+1:(DIMS+2)*(i-1)+DIMS)=u(:,i)
      x((DIMS+2)*(i-1)+(DIMS+1))=p(i)
      x((DIMS+2)*(i-1)+(DIMS+2))=temp(i)
    end forall
    call setBC()
    call fullEq%solve(x,info=info)
    needRetry=info<0
    call fullEq%getNIt(nItFull)
    forall(i=1:grid%nC)
      u(:,i)=x((DIMS+2)*(i-1)+1:(DIMS+2)*(i-1)+DIMS)
      p(i)=x((DIMS+2)*(i-1)+(DIMS+1))
      temp(i)=x((DIMS+2)*(i-1)+(DIMS+2))
    end forall
  end subroutine

  !> residual function of the full NS equations
  function fullRHS(oldVector,newVector,dat)
    use iso_c_binding
    use ieee_arithmetic
    use modSUNDIALS
    use modGradient
    use modAdvection
    use modDiffusion
    use modPressure
    use modNewtonian
    type(C_PTR),value::oldVector !< old N_Vector
    type(C_PTR),value::newVector !< new N_Vector
    type(C_PTR),value::dat !< optional user data object
    integer(C_INT)::fullRHS !< error code
    double precision,pointer::x(:) !< fortran pointer associated with oldVector
    double precision,pointer::y(:) !< fortran pointer associated with newVector

    call associateVector(oldVector,x)
    call associateVector(newVector,y)

    !$omp parallel workshare
    forall(i=1:grid%nC)
      u(:,i)=x((DIMS+2)*(i-1)+1:(DIMS+2)*(i-1)+DIMS)
      p(i)=x((DIMS+2)*(i-1)+(DIMS+1))
      temp(i)=x((DIMS+2)*(i-1)+(DIMS+2))
    end forall
    !$omp end parallel workshare
    call recoverState(p,u,temp,massFrac,rho,rhou,rhoE)
    call setBC()
    H=(rhoE+p)/rho
    call findGrad(grid,p,gradP)
    call findGrad(grid,u,gradU)
    call findPresForce(grid,p,gradP,presF)
    call findViscForce(grid,u,gradU,visc,viscF)
    call findMassFlow(grid,rho,u,p,presF,dt,flowRho)
    call findVarFlow(grid,u,flowRho,flowRhou)
    call findVarFlow(grid,H,flowRho,flowRhoH)
    call findAdv(grid,flowRho,advRho)
    call findAdv(grid,flowRhou,advRhou)
    call findAdv(grid,flowRhoH,advRhoH)
    call findDiff(grid,temp,gradTemp,cond,condQ)
    !$omp parallel workshare
    forall(i=1:grid%nC)
      y((DIMS+2)*(i-1)+1:(DIMS+2)*(i-1)+DIMS)=& ! momentum equation residual
      &  rhou(:,i)-rhou0(:,i)-dt/grid%v(i)*(advRhou(:,i)+presF(:,i)+viscF(:,i))
      y((DIMS+2)*(i-1)+(DIMS+1))=& ! pressure equation residual
      &  rho(i)-rho0(i)-dt/grid%v(i)*advRho(i)
      y((DIMS+2)*(i-1)+(DIMS+2))=& ! energy equation residual
      &  rhoE(i)-rhoE0(i)-dt/grid%v(i)*(advRhoH(i)+condQ(i))
    end forall
    !$omp end parallel workshare
    fullRHS=merge(1,0,any(ieee_is_nan(y).or.(.not.ieee_is_finite(y))))
    if(c_associated(dat))then
    end if
  end function

   !> full NS equations preconditioning matrix setup/factor
  function fullPSet(c_x,c_xScale,c_f,c_fScale,dat)
    type(C_PTR),value::c_x,c_xScale,c_f,c_fScale,dat
    integer(C_INT)::fullPSet
    double precision,pointer::x(:),xScale(:),f(:),fScale(:)
    type(C_PTR)::foo

    call associateVector(c_x,x)
    call associateVector(c_xScale,xScale)
    call associateVector(c_f,f)
    call associateVector(c_fScale,fScale)

    ! construct preconditioning matrix
    ! factor preconditioning matrix
    fullPSet=0
    foo=dat
  end function

  !> full NS equations preconditioning problem solving
  function fullPSol(c_x,c_xScale,c_f,c_fScale,c_v,dat)
    type(C_PTR),value::c_x,c_xScale,c_f,c_fScale,c_v,dat
    integer(C_INT)::fullPSol
    double precision,pointer::x(:),xScale(:),f(:),v(:),fScale(:)
    type(C_PTR)::foo

    call associateVector(c_x,x)
    call associateVector(c_xScale,xScale)
    call associateVector(c_f,f)
    call associateVector(c_fScale,fScale)
    call associateVector(c_v,v)

    ! find x increment from f increment v and save back to v
    !$omp parallel do
    do i=1,grid%nC ! TODO: need to figure out why cannot use forall with omp workshare here
      v((DIMS+2)*(i-1)+1:(DIMS+2)*(i-1)+DIMS)=v((DIMS+2)*(i-1)+1:(DIMS+2)*(i-1)+DIMS)/rho(i)
      v((DIMS+2)*(i-1)+(DIMS+1))=v((DIMS+2)*(i-1)+(DIMS+1))
      v((DIMS+2)*(i-1)+(DIMS+2))=v((DIMS+2)*(i-1)+(DIMS+2))/rho(i)/(Rgas/(gamm-1d0))
    end do
    !$omp end parallel do
    fullPsol=0
    foo=dat
  end function

end module