subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:  read_goesglm                reads lightning obs from a BUFR file
!   prgmmr:      k apodaca <karina.apodaca@colostate.edu>
!      org:      CSU/CIRA, Data Assimilation Group
!     date:      2015-03-12
!
! abstract:  This routine reads lightning data (Earth-relative location, frequency) from
!            file and prepares it for assimiliation in the form of lightning flash rate
!            (#hits km-2 hr-1).
!
!            Note: when running GSI in regional mode, the code only
!            retains those observations that fall within the regional
!            domain
!
! program history log:
!   2015-06-12  zupanski  - include the convert_to_flash_rate subroutine to convert
!                           lightning strike observations into lightning flash rate
!                           (#hits km-2 hr-1).
!   2015-11-18  apodaca   - include the convert_time subroutine to deal with computer
!                           precision dependencies.
!   2018-02-07  apodaca   - add further documentation
!
!   input argument list:
!     infile   - unit from which to read BUFR data
!     obstype  - observation type to process
!     lunout   - unit to which to write data for further processing
!
!   output argument list:
!     nread    - number of type "obstype" observations read
!     nodata   - number of individual "obstype" observations read
!     ndata    - number of type "obstype" observations retained for further processing
!     twindin  - input group time window (hours)
!     sis      - satellite/instrument/sensor indicator
!
! attributes:
!   language: Fortran 90 and/or above
!   machine:
!
!$$$
  use kinds, only: r_single,r_kind,r_double,i_kind
  use constants, only: zero,one_tenth,one,deg2rad,&
      three,rad2deg,&
      r60inv,ten
  use gridmod, only: diagnostic_reg,wrf_mass_regional,regional,nlon,nlat,&
      tll2xy,txy2ll,&
      rlats,rlons
  use lightinfo, only: iuse_light,nlighttype
  use obsmod, only: iadate
  use obsmod, only: offtime_data
  use gsi_4dvar, only: l4dvar,l4densvar,time_4dvar,winlen

  implicit none

! Declare passed variables
  character(len=*)                      ,intent(in   ) :: infile,obstype
  character(len=*)                      ,intent(in   ) :: sis
  integer(i_kind)                       ,intent(in   ) :: lunout
  integer(i_kind)                       ,intent(inout) :: nread,ndata
  real(r_kind)                          ,intent(in   ) :: twindin
  integer(i_kind)                                      :: nodata

! Declare local parameters
  real(r_kind),parameter:: r6   = 6.0_r_kind
  real(r_kind),parameter:: r90  = 90.0_r_kind
  real(r_kind),parameter:: r180 = 180.0_r_kind
  real(r_kind),parameter:: r360 = 360.0_r_kind

!--- Declare local variables
  logical lob
  logical outside

  character(40) hdstr,oestr,qcstr
  character(10) date
  character(8)  subset
  character(1)  sidchr(8)

  integer(i_kind) ireadmg,ireadsb,icntpnt,icount
  integer(i_kind) lunin,i
  integer(i_kind) itx
  integer(i_kind) ihh,idd,idate,iret,im,iy,k
  integer(i_kind) nchanl,nreal,ilat,ilon
  integer(i_kind) lqm
  integer(i_kind) iout
  integer(i_kind) ntest,nvtest
  integer(i_kind) minobs,minan
  integer(i_kind) ntb
  integer(i_kind) nmsg                ! message index
  integer(i_kind),parameter :: maxobs=2000000
  integer(i_kind),dimension(5):: idate5
  integer(i_kind),allocatable,dimension(:):: isort,iloc

  real(r_kind) time
  real(r_kind) usage
  real(r_kind) loe,lmerr
  real(r_kind) time_correction
  real(r_kind) dlat,dlon,dlat_earth,dlon_earth
  real(r_kind) cdist,disterr,disterrmax,rlon00,rlat00
  real(r_kind) vdisterrmax
  real(r_kind) timex,timeobs,toff,t4dv,zeps
  real(r_kind),allocatable,dimension(:,:):: cdata_all,cdata_out
!--- flash rate
  real(r_kind),allocatable,dimension(:,:):: cdata_flash,cdata_flash_h
  integer(i_kind)                        :: ndata_flash,ndata_flash_h

  real(r_double) rstation_id

  real(r_double),dimension(3):: hdr
  real(r_double),dimension(1,1):: qcmark,obserr

!  equivalence to handle character names
  equivalence(rstation_id,sidchr)

!--- data statements
  data hdstr  /'XOB YOB DHR'/
  data oestr  /'LOE'/
  data qcstr  /'LQM'/

  data lunin / 13 /

  nreal=13
  lob = obstype == 'goes_glm'

!                .      .    .                                       .

! Open, then read date from BUFR file

  call closbf(lunin)
  open(lunin,file=infile,form='unformatted')
  call openbf(lunin,'IN',lunin)
  call datelen(10)

! Initialization

  ntb = 0
  nmsg = 0
  disterrmax=-9999.0_r_kind

  allocate(cdata_all(nreal,maxobs),isort(maxobs))
  isort = 0
  cdata_all=zero
  nread=0
  ntest=0
  nvtest=0
  nchanl=0
  ilon=2
  ilat=3
  icntpnt=0

!                .      .    .                                       .
! Big loop over glmbufr file : READING THE BUFR FILE

  loop_msg: do while (ireadmg(lunin,subset,idate)== 0)
     nmsg = nmsg+1
     write(*,'(3a,i10)') 'subset=',subset,' cycle time =',idate

     loop_readsb: do while(ireadsb(lunin) == 0)
!       use msg lookup table to decide which messages to skip
!       use report id lookup table to only process matching reports
        ntb = ntb+1

!       Extract location and date information
        call ufbint(lunin,hdr,3,1,iret,hdstr)

        if(abs(hdr(2))>r90 .or. abs(hdr(1))>r360) cycle loop_readsb
        if(hdr(1) > r180)hdr(1)=hdr(1)-r360
        if(hdr(1) < zero)hdr(1)=hdr(1)+r360
        dlon_earth=hdr(1)*deg2rad
        dlat_earth=hdr(2)*deg2rad

        if (regional) then

!-- WRF-ARW

           if (wrf_mass_regional) then

              call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside)    ! convert to rotated coordinates
              if(diagnostic_reg) then
                 call txy2ll(dlon,dlat,rlon00,rlat00)
                 ntest=ntest+1
                 cdist=sin(dlat_earth)*sin(rlat00)+cos(dlat_earth)*cos(rlat00)* &
                       (sin(dlon_earth)*sin(rlon00)+cos(dlon_earth)*cos(rlon00))
                 cdist=max(-one,min(cdist,one))
                 disterr=acos(cdist)*rad2deg
                 disterrmax=max(disterrmax,disterr)
              end if
              if(outside) cycle loop_readsb   ! check to see if outside regional domain

           endif ! wrf_mass_regional

        endif !if (regional) then

! Global

        if (.not. regional) then
            dlat = dlat_earth
            dlon = dlon_earth
            call grdcrd1(dlat,rlats,nlat,1)
            call grdcrd1(dlon,rlons,nlon,1)
        endif !  end global block

        if (offtime_data) then

!           in time correction for observations to account for analysis
!           time being different from obs file time.
            write(date,'( i10)') idate
            read (date,'(i4,3i2)') iy,im,idd,ihh
            idate5(1)=iy
            idate5(2)=im
            idate5(3)=idd
            idate5(4)=ihh
            idate5(5)=0
            call w3fs21(idate5,minobs)    !  obs ref time in seconds relative to historic date
            idate5(1)=iadate(1)
            idate5(2)=iadate(2)
            idate5(3)=iadate(3)
            idate5(4)=iadate(4)
            idate5(5)=0
            call w3fs21(idate5,minan)    !  analysis ref time in seconds relative to historic date

!           Add obs reference time, then subtract analysis time to get obs time relative to analysis
            time_correction=float(minobs-minan)*r60inv
        else
            time_correction=zero
        end if

        timeobs=real(real(hdr(3),r_single),r_double)
        t4dv=timeobs + toff
        zeps=1.0e-8_r_kind
        if (t4dv<zero  .and.t4dv>      -zeps) t4dv=zero
        if (t4dv>winlen.and.t4dv<winlen+zeps) t4dv=winlen
        t4dv=t4dv + time_correction
        time=timeobs + time_correction

        if (l4dvar.or.l4densvar) then
           if (t4dv<zero.or.t4dv>winlen) cycle loop_readsb ! outside time window
        else
           if((real(abs(time)) > real(twindin)))cycle loop_readsb ! outside time window
        endif

        timex=time

!       Note: An assessment of the GLM detection error is still a work in
!       progress and at present, there are no clear metrics to assign a
!       "quality mark" for an effective quality control procedure for
!       lightning observations from this sensor. Nonetheless, the infrastructure
!       for passing observations errors and quality control information to other
!       routines within the GSI source code has been left in place. In addition, a
!       temporarty undefined value (-.9999) has been assigned to the mnemonics
!       corresponding to these variables in the lightning BUFR file. Developments
!       for the calculation of observation errors and quality control (sanity checks) are
!       expected in future upgrades to the "GOES/GLM variational lightning
!       assimilation package."

!       Extract observation error informatiom
        call ufbint(lunin,obserr,1,1,iret,oestr)

        loe=obserr(1,1)
        lmerr=loe

!       Extract quality control information
        call ufbint(lunin,qcmark,1,1,iret,qcstr)

        lqm=qcmark(1,1)

!       Data counter

        nread=nread+1
        icntpnt=icntpnt+1

        ndata=ndata+1
        nodata=nodata+1
        iout=ndata
        isort(icntpnt)=iout

        if (ndata > maxobs) then
           write(6,*)'READ_GOESGLM:  ***WARNING*** ndata > maxobs for ',obstype
           ndata = maxobs
        end if

!       Set usage variable
        usage = zero

        if (iuse_light(nlighttype) <= 0)usage=100._r_kind
        if (lob) then
           cdata_all(1,iout) =loe                  ! lightning observation error
           cdata_all(2,iout) =dlon                 ! grid relative longitude
           cdata_all(3,iout) =dlat                 ! grid relative latitude
           cdata_all(4,iout) =iout                 ! lightning obs
           cdata_all(5,iout) =rstation_id          ! station id
           cdata_all(6,iout) =t4dv                 ! analysis time
           cdata_all(7,iout) =nlighttype           ! type
           cdata_all(8,iout) =lmerr                ! lightning max error
           cdata_all(9,iout) =lqm                  ! quality mark
           cdata_all(10,iout)=loe                  ! original lightning obs error loe
           cdata_all(11,iout)=usage                ! usage parameter
           cdata_all(12,iout)=dlon_earth*rad2deg   ! earth relative lon (degrees)
           cdata_all(13,iout)=dlat_earth*rad2deg   ! earth relative lat (degrees)
        end if

! end loop on read line BUFR

     end do loop_readsb

! end of BUFR read loop

  enddo loop_msg   !Uncomment if reading messeges in a loop

!                .      .    .                                       .

! Close unit to bufr file

  call closbf(lunin)

! Write header record and data to output file for further processing
  allocate(iloc(ndata))
  icount=0.
  do i=1,maxobs
     if(isort(i) > 0)then
       icount=icount+1
       iloc(icount)=isort(i)
     end if
  end do
  if(ndata /= icount)then
     write(6,*) ' READ_GOESGLM: mix up in read_goesglm ,ndata,icount ',ndata,icount
     call stop2(50)
  end if

  allocate(cdata_out(nreal,ndata))
  do i=1,ndata
     itx=iloc(i)
     do k=1,nreal
        cdata_out(k,i)=cdata_all(k,itx)
     end do
  end do

  deallocate(iloc,isort,cdata_all)

!                .      .    .                                       .

! Call to the subroutine that transforms lightning strikes into lightning flash rate

  if(ndata /= 0) then

      !! count flash rate data and alocate temporary domain
      !! begin with the current number of strikes as the theoretical upper limit

     ndata_flash_h=ndata

     allocate(cdata_flash_h(nreal,ndata_flash_h))

     call convert_to_flash_rate   &
              (nreal,ndata,cdata_out,ndata_flash_h,cdata_flash_h,ndata_flash)

     deallocate(cdata_out)
     ndata=ndata_flash
     allocate(cdata_flash(nreal,ndata))

     do i=1,ndata
        do k=1,nreal
           cdata_flash(k,i)=cdata_flash_h(k,i)
        end do
     end do

     deallocate(cdata_flash_h)

     write(lunout) obstype,sis,nreal,nchanl,ilat,ilon
     write(lunout) cdata_flash

!!!!!!!!!
!!! Write lat, lon, time, lightning flash rate "superobs" into a file:
!!! cdata_flash_h(2,iout),cdata_flash_h(3,iout),cdata_flash_h(4,iout), &
!!! cdata_flash_h(6,iout)cdata_flash(4,:)

     deallocate(cdata_flash)

  else  ! ndata=0

     write(lunout) obstype,sis,nreal,nchanl,ilat,ilon
     write(lunout) cdata_out
     deallocate(cdata_out)

  end if  !!  if(ndata =/ 0) then

900 continue
  if(diagnostic_reg .and. ntest>0) write(6,*)'READ_GOESGLM:  ',&
     'ntest,disterrmax=',ntest,disterrmax
  if(diagnostic_reg .and. nvtest>0) write(6,*)'READ_GOESGLM:  ',&
     'nvtest,vdisterrmax=',ntest,vdisterrmax

  if (ndata == 0) then
     call closbf(lunin)
     write(6,*)'READ_GOESGLM:  closbf(',lunin,')'
  endif

  close(lunin)

  close(55)

! End of routine
  return

end subroutine read_goesglm

!!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&

subroutine convert_to_flash_rate   &
   (nreal,ndata_strike,cdata_strike,ndata_flash_h,cdata_flash_h,ndata_flash)

!$$$  documentation block
!                .      .    .                                       .
! subroutine:  convert_to_flash_rate      converts geo-located lightning strikes into
!                                         lightning flash rate (#hits km-2 hr-1)

!   prgmmr: zupanski <milija.zupanski@colostate.edu>
!      org: CSU/CIRA, Data Assimilation group
!     date: 2015-06-12
!
! abstract:  This subroutine does the following:
!----
!- 1- counts the number of hits surrounding a GSI analysis grid point
!- 2- calculates the flash rate averaged over time and area (hr*km**2)
!- 3- finds the center of mass in terms of lon,lat and glon,glat
!- 4- assigns a center of mass to be the flash rate observation point
!----
!
! program history log:
!   2015-07-01  apodaca  - several updates in the calculation of lightning flashrate

  use kinds, only: r_single,r_kind,r_double,i_kind
  use constants, only: zero,one_tenth,one,deg2rad,&
      three,half,zero,&
      r10,r100,ten, r1000, rearth
  use gridmod, only: wrf_mass_regional,regional,nlon,nlat,&
      tll2xy,txy2ll
  use gridmod, only: lat2, lon2
  use wrf_mass_guess_mod, only: ges_xlon, ges_xlat
  use gsi_4dvar, only: nhr_assimilation

  implicit none

  integer(i_kind),intent(in   )               :: nreal,ndata_strike,ndata_flash_h
  integer(i_kind),intent(inout)               :: ndata_flash
  real(r_kind),intent(inout),dimension(nreal,ndata_strike)  :: cdata_strike
  real(r_kind),intent(inout),dimension(nreal,ndata_flash_h) :: cdata_flash_h

  real(r_kind),allocatable,dimension(:) :: gtim_central
  real(r_kind),allocatable,dimension(:) :: glon_central
  real(r_kind),allocatable,dimension(:) :: glat_central
  real(r_kind),allocatable,dimension(:) ::  lon_central
  real(r_kind),allocatable,dimension(:) ::  lat_central
  integer(i_kind),allocatable,dimension(:) ::  ind_min
  integer(i_kind),allocatable,dimension(:) ::  lcount

  real(r_kind)      :: rearth2
  real(r_kind)      :: dtime,darea,cosine
  real(r_kind)      :: darea_sum
  real(r_kind)      :: delta_lon,delta_lat
  real(r_kind)      :: lat_ref
  real(r_kind)      :: xx,yy
  real(r_kind)      :: dist2,dist_min
  integer(i_kind)   :: ii0,jj0
  integer(i_kind)   :: ngridh
  integer(i_kind)   :: index
  integer(i_kind)   :: iobs,usage
  logical           :: xflag,yflag

  real(r_kind)      :: xbound,ybound
  integer(i_kind)   :: nxdim,nydim
  integer(i_kind)   :: icount

  !  Output files
!----

!- unit grid lat-lon distances (Earth difference divided by grid difference)
!- calculated from all averaged grid areas
!!- note: this can be relaxed if the unit grid area (km) is known (i.e. darea)
!! darea = (r*cos(lat)*dlon)*(dlat)

  rearth2=(rearth/r1000)**2  !! squared earth radius in km (need for darea calculation)

  if (ndata_strike>0) then

     darea_sum=0._r_kind
     do iobs=1,ndata_strike

        ii0=INT(cdata_strike(2,iobs))
        jj0=INT(cdata_strike(3,iobs))

        delta_lon=ges_xlon(jj0,ii0+1,1)-ges_xlon(jj0,ii0,1)
        delta_lat=ges_xlat(jj0+1,ii0,1)-ges_xlat(jj0,ii0,1)

        lat_ref  =half*(cdata_strike(13,iobs)+cdata_strike(13,iobs-1))

        cosine=cos(lat_ref*deg2rad)

        darea_sum=darea_sum+rearth2*cos(lat_ref*deg2rad)*(abs(delta_lon)*deg2rad)*&
                  (abs(delta_lat)*deg2rad)

     end do  !! do iobs=2,ndata_strike

     darea=darea_sum/float(ndata_strike)
  else   !! ndata_strike=0
     darea=zero

  end if  !! if(ndata_strike>0) then

  dtime=float(nhr_assimilation)

  ! Regional

  if (regional) then

!-- WRF-ARW

     if (wrf_mass_regional) then

        nxdim=lon2
        nydim=lat2

     endif ! wrf_mass_regional

  endif !if (regional) then

! Global

  if (.not. regional) then

     nxdim=nlon
     nydim=nlat

  endif !  end global block

!!! Allocate new var for flash rate here (nxdim,nydim)
! asign zero to all points
! update the relevant points in the loop

  ngridh=nxdim*nydim

  allocate(gtim_central(1:ngridh))
  allocate(glon_central(1:ngridh))
  allocate(glat_central(1:ngridh))
  allocate( lon_central(1:ngridh))
  allocate( lat_central(1:ngridh))
  allocate(      lcount(1:ngridh))

  lcount(:)=0
  glon_central(:)=zero
  glat_central(:)=zero
  lon_central(:) =zero
  lat_central(:) =zero
  gtim_central(:)=zero

  do iobs=1,ndata_strike

     xx=cdata_strike(2,iobs)   !! glon
     yy=cdata_strike(3,iobs)   !! glat
     ii0=INT(cdata_strike(2,iobs))
     jj0=INT(cdata_strike(3,iobs))

!!   find lightning strikes near the (ii0,jj0) point

     xbound=float(ii0)
     ybound=float(jj0)

     xflag=(xx>xbound) .AND. (xx<xbound+1.)
     yflag=(yy>ybound) .AND. (yy<ybound+1.)

     if (xflag .AND. yflag ) then

        index=(jj0-1)*nxdim+ii0
        lcount(index)=lcount(index)+1

        glon_central(index)=glon_central(index)+cdata_strike(2,iobs)
        glat_central(index)=glat_central(index)+cdata_strike(3,iobs)
        lon_central(index)= lon_central(index)+cdata_strike(12,iobs)
        lat_central(index)= lat_central(index)+cdata_strike(13,iobs)

        if (lcount(index)<2) then
            gtim_central(index)=cdata_strike(6,iobs)
        else
            call convert_time (gtim_central(index),cdata_strike(6,iobs),lcount(index))
        end if

     end if  !! if(xflag .AND. yflag )

  enddo !! do iobs=1,ndata_strike

!-- find the center of mass

  do index=1,ngridh
     if (lcount(index)>0) then
        glon_central(index)=glon_central(index)/float(lcount(index))
        glat_central(index)=glat_central(index)/float(lcount(index))
        lon_central(index)= lon_central(index)/float(lcount(index))
        lat_central(index)= lat_central(index)/float(lcount(index))
     endif  !! if(lcount(index)>0) then
  enddo  !! do index=1,ngridh

!-- find the original index of the nearest strike (need for transfer of input obs)

  allocate(ind_min(1:ngridh))
  ind_min(:)=-99

  dist_min=1.e10_r_kind
  do iobs=1,ndata_strike

     xx=cdata_strike(2,iobs)   !! glon
     yy=cdata_strike(3,iobs)   !! glat
     ii0=INT(cdata_strike(2,iobs))
     jj0=INT(cdata_strike(3,iobs))
     index=(jj0-1)*nxdim+ii0

     if (lcount(index)>0) then
        dist2=(xx-glon_central(index))**2+(yy-glat_central(index))**2
        if (dist2<dist_min) then
           dist_min=dist2
           ind_min(index)=iobs
        end if
     end if  !! if(lcount(index)>0) then

  enddo  !! do iobs=1,ndata_strike

!----
!---- Output
!----

!-- count the non-zero flash rates and assign a temporary domain cdata_flash_h
!-- Note: it is assumed that only non-zero flash rates are true observations

  icount=0
  do index=1,ngridh
     if (lcount(index)>0) then
        icount=icount+1
        cdata_flash_h( 1,icount)=cdata_strike( 1,ind_min(index))
        cdata_flash_h( 2,icount)=glon_central(index)
        cdata_flash_h( 3,icount)=glat_central(index)

        if (darea>0._r_kind) then
           cdata_flash_h( 4,icount)=float(lcount(index))/(darea*dtime)
        else
           cdata_flash_h( 4,icount)=0.
        end if

        cdata_flash_h( 5,icount)=cdata_strike( 5,ind_min(index))
        cdata_flash_h( 6,icount)=gtim_central(index)
        cdata_flash_h( 7,icount)=cdata_strike( 7,ind_min(index))
        cdata_flash_h( 8,icount)=cdata_strike( 8,ind_min(index))
        cdata_flash_h( 9,icount)=cdata_strike( 9,ind_min(index))
        cdata_flash_h(10,icount)=cdata_strike(10,ind_min(index))
        cdata_flash_h(11,icount)=usage
        cdata_flash_h(12,icount)=lon_central(index)
        cdata_flash_h(13,icount)=lat_central(index)

     endif  !! if(lcount(index)>0) then

  enddo  !! do index=1,ngridh

  ndata_flash=icount

  deallocate(ind_min)
  deallocate(lcount)
  deallocate(gtim_central)
  deallocate(glon_central)
  deallocate(glat_central)
  deallocate(lon_central)
  deallocate(lat_central)

!-----
! End of routine
  return

end subroutine convert_to_flash_rate

!-----
subroutine convert_time (date_old,date_new,nmax)

!$$$  documentation block
!                .      .    .                                       .
! subroutine:  convert_time
! prgmmr: k apodaca               date: 2015-11-18
!
! abstract:  This subroutine performs a date conversion to deal with
!            computer precission dependencies associated with a 10-digit
!            float for the analysis date/time.
!--
  use kinds, only: r_kind,i_kind

  implicit none

  integer(i_kind), intent(in) :: nmax
  real(r_kind), intent(inout) :: date_old
  real(r_kind), intent(in)  :: date_new
  integer(i_kind) :: i,sumidd
  integer(i_kind) :: idd,jdd,kdd
  real(r_kind), allocatable :: xdate(:)
  real(r_kind) :: dd,hh,ysumidd,xsumidd
  real(r_kind) :: xdd,xhh,ydate
  real(r_kind) :: xccyy

  allocate(xdate(1:nmax))

  xdate(1:nmax-1) = date_old
  xdate(nmax) = date_new

  sumidd=0._r_kind
  do i=1,nmax
     xccyy = INT(1.0e-8_r_kind*xdate(i))*1.0e8_r_kind
     xdate(i) = INT(xdate(i))-xccyy

     jdd=INT(0.0001_r_kind*xdate(i))
     idd=INT(xdate(i))-jdd*10000

     ysumidd=float(idd)
     dd=float(INT(0.01_r_kind*ysumidd))
     hh=ysumidd-dd*100._r_kind

     sumidd=sumidd+dd*24._r_kind+hh

  enddo  !! do i=1,nmax

  xsumidd=float(sumidd)/nmax
  ysumidd=float(INT(xsumidd))

  kdd=INT(xsumidd/24._r_kind)
  xdd=float(kdd)
  xhh=ysumidd-float(kdd)*24._r_kind

  ydate=float(jdd)*10000._r_kind+xdd*100._r_kind+xhh+xccyy

  date_old=ydate

  deallocate(xdate)

end subroutine convert_time


!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

!    Date:       1 Oct 1992
!    Time:       12:03
!    Program:    SIMPLE.FOR
!    Version:    6.00.00
!    Programmer: Nicolaas M de Rooij
!
      subroutine simple(inflag, mx, nn, nct, a, iro, jc, b, c, ko, zb,
     1 p, jh, x, y, pe, e)
!               4-69
!        automatic simplex       redundant equations cause infeasibility
!               zb(j) replaces kb(j) of earlier versions.  the index for
!              position in basis is a floating point number.
!               simple uses subprogram
!                  find
!               simple uses double precision version of
!                  abs, amax1
      implicit real*8 (a-h,o-z)
      equivalence (xx,ll)
      dimension b(1), c(1), p(1), x(1), y(1), pe(1), e(1)
      dimension zb(1)
!        real aa,aijt,bb,cost,dt,rcost,texp,tpiv,ty,xold,xx,xy,yi,ymax
      integer inflag, mx, nn, ko(6), jh(1)
      integer i, ia, invc, ir, iter, j, jt, k, kbj, l, ll, m, m2, mm, n
      integer ncut, numvr, nver, numpv
      logical feas, trig, ver, kq
!        matrix is single dimensioned, with row and column numbers
!        in separate arrays
      real*8 a(1)
      integer iro(1), jc(1)
!        set initial values, set constant values
      iter = 0
      numvr = 0
      numpv = 0
      m = mx
      n = nn
      texp = .5**16
      nver = m/2 + 5
      ncut = 4*m + 10
      m2 = m**2
      feas = .false.
      if (inflag.ne.0) go to 30
!        *          start  phase one with singleton basis
      j = 0
      ko(1) = 0
      do 20 ii=1,nct
         jj = jc(ii)
         if (jj.eq.j) go to 10
         if (ko(1).eq.1 .and. ko(2).eq.0) zb(j) = 1.0
         j = jj
         zb(j) = 0.0
         ko(1) = 0
         ko(2) = 0
   10    if (a(ii).gt.0.0) ko(1) = ko(1) + 1
         if (a(ii).lt.0.0) ko(2) = 1
   20 continue
      if (ko(1).eq.1 .and. ko(2).eq.0) zb(j) = 1.0
   30 do 40 i=1,m
         jh(i) = -1
   40 continue
!        create inverse from 'zb' and 'jh'     (step 7)
   50 ver = .true.
      invc = 0
      numvr = numvr + 1
      trig = .false.
      do 60 i=1,m2
         e(i) = 0.0
   60 continue
      mm = 1
      do 70 i=1,m
         e(mm) = 1.0
         pe(i) = 0.0
         x(i) = b(i)
         if (jh(i).ne.0) jh(i) = -1
         mm = mm + m + 1
   70 continue
      jt = 1
   80 if (zb(jt).eq.0.0) go to 130
      go to 290
!        get column(jt)
   90 ty = tpiv
      ir = 0
      do 100 i=1,m
         absyi = dabs(y(i))
         if (jh(i).ne.(-1) .or. x(i).ne.0.0 .or. absyi.le.ty) go to 100
         ty = absyi
         ir = i
  100 continue
      if (ir.ne.0) go to 120
      ty = 0.
      do 110 i=1,m
         absyi = dabs(y(i))
         absxi = dabs(x(i))
         if (jh(i).ne.(-1) .or. x(i).eq.0.0 .or. absyi.le.tpiv) go to
     1    110
         if (absyi.le.ty*absxi) go to 110
         ty = absyi/absxi
         ir = i
  110 continue
  120 zb(jt) = 0.0
      if (ir.eq.0) go to 130
      go to 400
!        pivot(ir,jt)
  130 jt = jt + 1
      if (jt.le.n) go to 80
      do 140 i=1,m
         if (jh(i).eq.(-1)) jh(i) = 0
         if (jh(i).eq.0) feas = .false.
  140 continue
!        *          determine feasibility                 (step 1)
  150 ver = .false.
      if (feas) go to 170
      do 160 i=1,m
         if (x(i).lt.0.0 .or. jh(i).eq.0) go to 190
  160 continue
      feas = .true.
!        *          get applicable prices                 (step 2)
  170 do 180 i=1,m
         p(i) = pe(i)
         if (x(i).lt.0.) x(i) = 0.
  180 continue
      kq = .false.
      go to 250
  190 feas = .false.
      do 200 j=1,m
         p(j) = 0.
  200 continue
      kq = .true.
      do 240 i=1,m
         mm = i
         if (x(i).ge.0.0) go to 220
         kq = .false.
         do 210 j=1,m
            p(j) = p(j) + e(mm)
            mm = mm + m
  210    continue
         go to 240
  220    if (jh(i).ne.0) go to 240
         kq = kq .and. x(i).eq.0.
         do 230 j=1,m
            p(j) = p(j) - e(mm)
            mm = mm + m
  230    continue
  240 continue
!        *          find minimum reduced cost             (step 3)
  250 jt = 0
      bb = 0.0
      jj = 0
      do 280 ii=1,nct
         j = jc(ii)
         if (j.eq.jj) go to 260
         if (zb(j).ne.0.0) go to 280
         jj = j
         dt = 0.0
  260    i = iro(ii)
         dt = dt + p(i)*a(ii)
         if (ii.eq.nct) go to 270
         if (jc(ii+1).eq.jj) go to 280
  270    if (feas) dt = dt + c(j)
         if (kq) dt = -dabs(dt)
         if (dt.ge.bb) go to 280
         bb = dt
         jt = j
  280 continue
      if (jt.le.0) go to 470
      if (iter.ge.ncut) go to 460
      iter = iter + 1
!        *          multiply inverse times a(.,jt)        (step 4)
!             begin subroutine get column(jt)
  290 do 300 i=1,m
         y(i) = 0.0
  300 continue
      ll = 0
      cost = c(jt)
      do 330 i=1,m
         call find(i, jt, ii, iflag)
         if (iflag.ne.0) go to 320
         aijt = a(ii)
         cost = cost + aijt*pe(i)
         do 310 j=1,m
            ll = ll + 1
            y(j) = y(j) + aijt*e(ll)
  310    continue
         go to 330
  320    ll = ll + m
  330 continue
      ymax = 0.0
      do 340 i=1,m
         ymax = dmax1(dabs(y(i)),ymax)
  340 continue
      tpiv = ymax*texp
!        end of get column
      if (ver) go to 90
      rcost = ymax/bb
      if (trig .and. bb.ge.(-tpiv)) go to 470
      trig = bb.ge.(-tpiv)
!        *          select pivot row                      (step 5)
      aa = tpiv
      ir = 0
      if (feas) go to 360
      do 350 i=1,m
         absyi = dabs(y(i))
         if (jh(i).ne.0 .or. x(i).ne.0.0 .or. absyi.le.aa) go to 350
         aa = absyi
         ir = i
  350 continue
      if (ir.ne.0) go to 390
  360 do 370 i=1,m
         if (x(i).ne.0. .or. y(i).le.aa) go to 370
         aa = y(i)
         ir = i
  370 continue
      if (ir.ne.0) go to 390
      aa = 0.
      do 380 i=1,m
         if (x(i).eq.0. .or. dabs(y(i)).le.tpiv) go to 380
         if (y(i)/x(i).le.aa) go to 380
         aa = y(i)/x(i)
         ir = i
  380 continue
      if (ir.eq.0) go to 450
!        *          pivot on (ir,jt)                      (step 6)
  390 ia = jh(ir)
      if (ia.gt.0) zb(ia) = 0.0
!        begin subroutine pivot(ir,jt)
  400 numpv = numpv + 1
      jh(ir) = jt
      zb(jt) = ir
      yi = -y(ir)
      y(ir) = -1.0
      ll = 0
      do 430 j=1,m
         l = ll + ir
         if (e(l).ne.0.0) go to 410
         ll = ll + m
         go to 430
  410    xy = e(l)/yi
         pe(j) = pe(j) + cost*xy
         e(l) = 0.0
         do 420 i=1,m
            ll = ll + 1
            e(ll) = e(ll) + xy*y(i)
  420    continue
  430 continue
      xy = x(ir)/yi
      do 440 i=1,m
         xold = x(i)
         x(i) = xold + xy*y(i)
         if (.not.ver .and. x(i).lt.0. .and. xold.ge.0.) x(i) = 0.
  440 continue
      y(ir) = -yi
      x(ir) = -xy
!        end of pivot
      if (ver) go to 130
!        to step 1 if not inverting, to step 7 if inverting
      if (numpv.le.m) go to 150
      invc = invc + 1
      if (invc.eq.nver) go to 50
      go to 150
!        *  end of algorithm, set exit values            ***
  450 if (.not.feas .or. rcost.le.(-1000.0)) go to 470
!        infinite solution
      k = 2
      go to 480
!        problem is cycling perhaps
  460 k = 4
      go to 480
!        feasible or infeasible solution
  470 k = 0
  480 if (.not.feas) k = k + 1
      do 490 j=1,n
         kbj = zb(j)
!        store final solution values in zb
         if (kbj.eq.0) zb(j) = 0.0
         if (kbj.ne.0) zb(j) = x(kbj)
  490 continue
      ko(1) = k
      ko(2) = iter
      ko(3) = invc
      ko(4) = numvr
      ko(5) = numpv
      ko(6) = jt
      return
      end


!=======================================================================
! This is part of the 2DECOMP&FFT library
!
! 2DECOMP&FFT is a software framework for general-purpose 2D (pencil)
! decomposition. It also implements a highly scalable distributed
! three-dimensional Fast Fourier Transform (FFT).
!
! Copyright (C) 2009-2012 Ning Li, the Numerical Algorithms Group (NAG)
!
!=======================================================================

! This is the main 2D pencil decomposition module

module decomp_2d

  use MPI

  implicit none

  private        ! Make everything private unless declared public

#ifdef DOUBLE_PREC
  integer, parameter, public :: mytype = KIND(0.0D0)
  integer, parameter, public :: real_type = MPI_DOUBLE_PRECISION
  integer, parameter, public :: real2_type = MPI_2DOUBLE_PRECISION
  integer, parameter, public :: complex_type = MPI_DOUBLE_COMPLEX
#ifdef SAVE_SINGLE
  integer, parameter, public :: mytype_single = KIND(0.0)
  integer, parameter, public :: real_type_single = MPI_REAL
#else
  integer, parameter, public :: mytype_single = KIND(0.0D0)
  integer, parameter, public :: real_type_single = MPI_DOUBLE_PRECISION
#endif
#else
  integer, parameter, public :: mytype = KIND(0.0)
  integer, parameter, public :: real_type = MPI_REAL
  integer, parameter, public :: real2_type = MPI_2REAL
  integer, parameter, public :: complex_type = MPI_COMPLEX
  integer, parameter, public :: mytype_single = KIND(0.0)
  integer, parameter, public :: real_type_single = MPI_REAL
#endif

  integer, save, public :: mytype_bytes

  ! some key global variables
  integer, save, public :: nx_global, ny_global, nz_global  ! global size

  integer, save, public :: nrank  ! local MPI rank
  integer, save, public :: nproc  ! total number of processors

  ! parameters for 2D Cartesian topology
  integer, save, dimension(2) :: dims, coord
  logical, save, dimension(2) :: periodic
  integer, save, public :: DECOMP_2D_COMM_CART_X, &
       DECOMP_2D_COMM_CART_Y, DECOMP_2D_COMM_CART_Z
  integer, save :: DECOMP_2D_COMM_ROW, DECOMP_2D_COMM_COL

  ! define neighboring blocks (to be used in halo-cell support)
  !  first dimension 1=X-pencil, 2=Y-pencil, 3=Z-pencil
  ! second dimension 1=east, 2=west, 3=north, 4=south, 5=top, 6=bottom
  integer, save, dimension(3,6) :: neighbour

  ! flags for periodic condition in three dimensions
  logical, save :: periodic_x, periodic_y, periodic_z

#ifdef SHM
  ! derived type to store shared-memory info
  TYPE, public :: SMP_INFO
     integer MPI_COMM          ! SMP associated with this communicator
     integer NODE_ME           ! rank in this communicator
     integer NCPU              ! size of this communicator
     integer SMP_COMM          ! communicator for SMP-node masters
     integer CORE_COMM         ! communicator for cores on SMP-node
     integer SMP_ME            ! SMP-node id starting from 1 ... NSMP
     integer NSMP              ! number of SMP-nodes in this communicator
     integer CORE_ME           ! core id starting from 1 ... NCORE
     integer NCORE             ! number of cores on this SMP-node
     integer MAXCORE           ! maximum no. cores on any SMP-node
     integer N_SND             ! size of SMP shared memory buffer
     integer N_RCV             ! size of SMP shared memory buffer
     integer(8) SND_P          ! SNDBUF address (cray pointer), for real
     integer(8) RCV_P          ! RCVBUF address (cray pointer), for real
     integer(8) SND_P_c        ! for complex
     integer(8) RCV_P_c        ! for complex
  END TYPE SMP_INFO
#endif

  ! derived type to store decomposition info for a given global data size
  TYPE, public :: DECOMP_INFO
     ! staring/ending index and size of data held by current processor
     integer, dimension(3) :: xst, xen, xsz  ! x-pencil
     integer, dimension(3) :: yst, yen, ysz  ! y-pencil
     integer, dimension(3) :: zst, zen, zsz  ! z-pencil

     ! in addition to local information, processors also need to know
     ! some global information for global communications to work

     ! how each dimension is distributed along pencils
     integer, allocatable, dimension(:) :: &
          x1dist, y1dist, y2dist, z2dist

     ! send/receive buffer counts and displacements for MPI_ALLTOALLV
     integer, allocatable, dimension(:) :: &
          x1cnts, y1cnts, y2cnts, z2cnts
     integer, allocatable, dimension(:) :: &
          x1disp, y1disp, y2disp, z2disp

     ! buffer counts for MPI_ALLTOALL: either for evenly distributed data
     ! or for padded-alltoall
     integer :: x1count, y1count, y2count, z2count

     ! evenly distributed data
     logical :: even

#ifdef SHM
     ! For shared-memory implementation

     ! one instance of this derived type for each communicator
     ! shared moemory info, such as which MPI rank belongs to which node
     TYPE(SMP_INFO) :: ROW_INFO, COL_INFO

     ! shared send/recv buffers for ALLTOALLV
     integer, allocatable, dimension(:) :: x1cnts_s, y1cnts_s, &
          y2cnts_s, z2cnts_s
     integer, allocatable, dimension(:) :: x1disp_s, y1disp_s, &
          y2disp_s, z2disp_s
     ! A copy of original buffer displacement (will be overwriten)
     integer, allocatable, dimension(:) :: x1disp_o, y1disp_o, &
          y2disp_o, z2disp_o
#endif
  END TYPE DECOMP_INFO

  ! main (default) decomposition information for global size nx*ny*nz
  TYPE(DECOMP_INFO), save :: decomp_main
  TYPE(DECOMP_INFO), save, public :: phG,ph1,ph2,ph3,ph4

  ! staring/ending index and size of data held by current processor
  ! duplicate 'decomp_main', needed by apps to define data structure
  integer, save, dimension(3), public :: xstart, xend, xsize  ! x-pencil
  integer, save, dimension(3), public :: ystart, yend, ysize  ! y-pencil
  integer, save, dimension(3), public :: zstart, zend, zsize  ! z-pencil

  ! These are the buffers used by MPI_ALLTOALL(V) calls
  integer, save :: decomp_buf_size = 0
  real(mytype),    allocatable, dimension(:) :: work1_r, work2_r
  complex(mytype), allocatable, dimension(:) :: work1_c, work2_c

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! To define smaller arrays using every several mesh points
  integer, save, dimension(3), public :: xszS,yszS,zszS,xstS,ystS,zstS,xenS,yenS,zenS
  integer, save, dimension(3), public :: xszV,yszV,zszV,xstV,ystV,zstV,xenV,yenV,zenV
  integer, save, dimension(3), public :: xszP,yszP,zszP,xstP,ystP,zstP,xenP,yenP,zenP
  logical, save :: coarse_mesh_starts_from_1
  integer, save :: iskipS, jskipS, kskipS
  integer, save :: iskipV, jskipV, kskipV
  integer, save :: iskipP, jskipP, kskipP

  ! public user routines
  public :: decomp_2d_init, decomp_2d_finalize, &
       transpose_x_to_y, transpose_y_to_z, &
       transpose_z_to_y, transpose_y_to_x, &
#ifdef OCC
       transpose_x_to_y_start, transpose_y_to_z_start, &
       transpose_z_to_y_start, transpose_y_to_x_start, &
       transpose_x_to_y_wait, transpose_y_to_z_wait, &
       transpose_z_to_y_wait, transpose_y_to_x_wait, &
       transpose_test, &
#endif
       decomp_info_init, decomp_info_finalize, partition, &
       init_coarser_mesh_statS,fine_to_coarseS,&
       init_coarser_mesh_statV,fine_to_coarseV,&
       init_coarser_mesh_statP,fine_to_coarseP,&
       alloc_x, alloc_y, alloc_z, &
       update_halo, decomp_2d_abort, &
       get_decomp_info

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! These are routines to perform global data transpositions
  !
  !   Four combinations are available, enough to cover all situations
  !    - transpose_x_to_y (X-pencil --> Y-pencil)
  !    - transpose_y_to_z (Y-pencil --> Z-pencil)
  !    - transpose_z_to_y (Z-pencil --> Y-pencil)
  !    - transpose_y_to_x (Y-pencil --> X-pencil)
  !
  !   Generic interface provided here to support multiple data types
  !    - real and complex types supported through generic interface
  !    - single/double precision supported through pre-processing
  !       * see 'mytype' variable at the beginning
  !    - an optional argument can be supplied to transpose data whose
  !      global size is not the default nx*ny*nz
  !       * as the case in fft r2c/c2r interface
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  interface transpose_x_to_y
     module procedure transpose_x_to_y_real
     module procedure transpose_x_to_y_complex
  end interface transpose_x_to_y

  interface transpose_y_to_z
     module procedure transpose_y_to_z_real
     module procedure transpose_y_to_z_complex
  end interface transpose_y_to_z

  interface transpose_z_to_y
     module procedure transpose_z_to_y_real
     module procedure transpose_z_to_y_complex
  end interface transpose_z_to_y

  interface transpose_y_to_x
     module procedure transpose_y_to_x_real
     module procedure transpose_y_to_x_complex
  end interface transpose_y_to_x

#ifdef OCC
  interface transpose_x_to_y_start
     module procedure transpose_x_to_y_real_start
     module procedure transpose_x_to_y_complex_start
  end interface transpose_x_to_y_start

  interface transpose_y_to_z_start
     module procedure transpose_y_to_z_real_start
     module procedure transpose_y_to_z_complex_start
  end interface transpose_y_to_z_start

  interface transpose_z_to_y_start
     module procedure transpose_z_to_y_real_start
     module procedure transpose_z_to_y_complex_start
  end interface transpose_z_to_y_start

  interface transpose_y_to_x_start
     module procedure transpose_y_to_x_real_start
     module procedure transpose_y_to_x_complex_start
  end interface transpose_y_to_x_start

  interface transpose_x_to_y_wait
     module procedure transpose_x_to_y_real_wait
     module procedure transpose_x_to_y_complex_wait
  end interface transpose_x_to_y_wait

  interface transpose_y_to_z_wait
     module procedure transpose_y_to_z_real_wait
     module procedure transpose_y_to_z_complex_wait
  end interface transpose_y_to_z_wait

  interface transpose_z_to_y_wait
     module procedure transpose_z_to_y_real_wait
     module procedure transpose_z_to_y_complex_wait
  end interface transpose_z_to_y_wait

  interface transpose_y_to_x_wait
     module procedure transpose_y_to_x_real_wait
     module procedure transpose_y_to_x_complex_wait
  end interface transpose_y_to_x_wait
#endif

  interface update_halo
     module procedure update_halo_real
     module procedure update_halo_complex
  end interface update_halo

  interface alloc_x
     module procedure alloc_x_real
     module procedure alloc_x_complex
  end interface alloc_x

  interface alloc_y
     module procedure alloc_y_real
     module procedure alloc_y_complex
  end interface alloc_y

  interface alloc_z
     module procedure alloc_z_real
     module procedure alloc_z_complex
  end interface alloc_z

contains

#ifdef SHM_DEBUG
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! For debugging, print the shared-memory structure
  subroutine print_smp_info(s)
    TYPE(SMP_INFO) :: s
    write(10,*) 'size of current communicator:', s%NCPU
    write(10,*) 'rank in current communicator:', s%NODE_ME
    write(10,*) 'number of SMP-nodes in this communicator:', s%NSMP
    write(10,*) 'SMP-node id (1 ~ NSMP):', s%SMP_ME
    write(10,*) 'NCORE - number of cores on this SMP-node', s%NCORE
    write(10,*) 'core id (1 ~ NCORE):', s%CORE_ME
    write(10,*) 'maximum no. cores on any SMP-node:', s%MAXCORE
    write(10,*) 'size of SMP shared memory SND buffer:', s%N_SND
    write(10,*) 'size of SMP shared memory RCV buffer:', s%N_RCV
  end subroutine print_smp_info
#endif

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Routine to be called by applications to initialise this library
  !   INPUT:
  !     nx, ny, nz   - global data dimension
  !     p_row, p_col - 2D processor grid
  !   OUTPUT:
  !     all internal data structures initialised properly
  !     library ready to use
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine decomp_2d_init(nx,ny,nz,p_row,p_col,periodic_bc)

    implicit none

    integer, intent(IN) :: nx,ny,nz,p_row,p_col
    logical, dimension(3), intent(IN), optional :: periodic_bc

    integer :: errorcode, ierror, row, col

#ifdef SHM_DEBUG
    character(len=80) fname
#endif

    nx_global = nx
    ny_global = ny
    nz_global = nz

    if (present(periodic_bc)) then
       periodic_x = periodic_bc(1)
       periodic_y = periodic_bc(2)
       periodic_z = periodic_bc(3)
    else
       periodic_x = .false.
       periodic_y = .false.
       periodic_z = .false.
    end if

    if (p_row==0 .and. p_col==0) then
       ! determine the best 2D processor grid
       call best_2d_grid(nproc, row, col)
    else
       if (nproc /= p_row*p_col) then
          errorcode = 1
          call decomp_2d_abort(errorcode, &
               'Invalid 2D processor grid - nproc /= p_row*p_col')
       else
          row = p_row
          col = p_col
       end if
    end if

    ! Create 2D Catersian topology
    ! Note that in order to support periodic B.C. in the halo-cell code,
    ! need to create multiple topology objects: DECOMP_2D_COMM_CART_?,
    ! corresponding to three pencil orientations. They contain almost
    ! identical topological information but allow different combinations
    ! of periodic conditions.
    dims(1) = row
    dims(2) = col
    periodic(1) = periodic_y
    periodic(2) = periodic_z
    call MPI_CART_CREATE(MPI_COMM_WORLD,2,dims,periodic, &
         .false., &  ! do not reorder rank
         DECOMP_2D_COMM_CART_X, ierror)
    periodic(1) = periodic_x
    periodic(2) = periodic_z
    call MPI_CART_CREATE(MPI_COMM_WORLD,2,dims,periodic, &
         .false., DECOMP_2D_COMM_CART_Y, ierror)
    periodic(1) = periodic_x
    periodic(2) = periodic_y
    call MPI_CART_CREATE(MPI_COMM_WORLD,2,dims,periodic, &
         .false., DECOMP_2D_COMM_CART_Z, ierror)

    call MPI_CART_COORDS(DECOMP_2D_COMM_CART_X,nrank,2,coord,ierror)

    ! derive communicators defining sub-groups for ALLTOALL(V)
    call MPI_CART_SUB(DECOMP_2D_COMM_CART_X,(/.true.,.false./), &
         DECOMP_2D_COMM_COL,ierror)
    call MPI_CART_SUB(DECOMP_2D_COMM_CART_X,(/.false.,.true./), &
         DECOMP_2D_COMM_ROW,ierror)

    ! gather information for halo-cell support code
    call init_neighbour

    ! actually generate all 2D decomposition information
    call decomp_info_init(nx,ny,nz,decomp_main)

    ! make a copy of the decomposition information associated with the
    ! default global size in these global variables so applications can
    ! use them to create data structures
    xstart = decomp_main%xst
    ystart = decomp_main%yst
    zstart = decomp_main%zst
    xend   = decomp_main%xen
    yend   = decomp_main%yen
    zend   = decomp_main%zen
    xsize  = decomp_main%xsz
    ysize  = decomp_main%ysz
    zsize  = decomp_main%zsz

#ifdef SHM_DEBUG
    ! print out shared-memory information
    write(fname,99) nrank
99  format('log',I2.2)
    open(10,file=fname)
    write(10,*)'I am mpi rank ', nrank, 'Total ranks ', nproc
    write(10,*)' '
    write(10,*)'Global data size:'
    write(10,*)'nx*ny*nz', nx,ny,nz
    write(10,*)' '
    write(10,*)'2D processor grid:'
    write(10,*)'p_row*p_col:', dims(1), dims(2)
    write(10,*)' '
    write(10,*)'Portion of global data held locally:'
    write(10,*)'xsize:',xsize
    write(10,*)'ysize:',ysize
    write(10,*)'zsize:',zsize
    write(10,*)' '
    write(10,*)'How pensils are to be divided and sent in alltoallv:'
    write(10,*)'x1dist:',decomp_main%x1dist
    write(10,*)'y1dist:',decomp_main%y1dist
    write(10,*)'y2dist:',decomp_main%y2dist
    write(10,*)'z2dist:',decomp_main%z2dist
    write(10,*)' '
    write(10,*)'######Shared buffer set up after this point######'
    write(10,*)' '
    write(10,*) 'col communicator detais:'
    call print_smp_info(decomp_main%COL_INFO)
    write(10,*)' '
    write(10,*) 'row communicator detais:'
    call print_smp_info(decomp_main%ROW_INFO)
    write(10,*)' '
    write(10,*)'Buffer count and displacement of per-core buffers'
    write(10,*)'x1cnts:',decomp_main%x1cnts
    write(10,*)'y1cnts:',decomp_main%y1cnts
    write(10,*)'y2cnts:',decomp_main%y2cnts
    write(10,*)'z2cnts:',decomp_main%z2cnts
    write(10,*)'x1disp:',decomp_main%x1disp
    write(10,*)'y1disp:',decomp_main%y1disp
    write(10,*)'y2disp:',decomp_main%y2disp
    write(10,*)'z2disp:',decomp_main%z2disp
    write(10,*)' '
    write(10,*)'Buffer count and displacement of shared buffers'
    write(10,*)'x1cnts:',decomp_main%x1cnts_s
    write(10,*)'y1cnts:',decomp_main%y1cnts_s
    write(10,*)'y2cnts:',decomp_main%y2cnts_s
    write(10,*)'z2cnts:',decomp_main%z2cnts_s
    write(10,*)'x1disp:',decomp_main%x1disp_s
    write(10,*)'y1disp:',decomp_main%y1disp_s
    write(10,*)'y2disp:',decomp_main%y2disp_s
    write(10,*)'z2disp:',decomp_main%z2disp_s
    write(10,*)' '
    close(10)
#endif

    ! determine the number of bytes per float number
    ! do not use 'mytype' which is compiler dependent
    ! also possible to use inquire(iolength=...)
    call MPI_TYPE_SIZE(real_type,mytype_bytes,ierror)

#ifdef EVEN
    if (nrank==0) write(*,*) 'Padded ALLTOALL optimisation on'
#endif

    return
  end subroutine decomp_2d_init

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Routine to be called by applications to clean things up
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine decomp_2d_finalize

    implicit none

    call decomp_info_finalize(decomp_main)

    decomp_buf_size = 0
    deallocate(work1_r, work2_r, work1_c, work2_c)

    return
  end subroutine decomp_2d_finalize

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Return the default decomposition object
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine get_decomp_info(decomp)

    implicit none

    TYPE(DECOMP_INFO), intent(OUT) :: decomp

    decomp = decomp_main

    return
  end subroutine get_decomp_info

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Advanced Interface allowing applications to define globle domain of
  ! any size, distribute it, and then transpose data among pencils.
  !  - generate 2D decomposition details as defined in DECOMP_INFO
  !  - the default global data size is nx*ny*nz
  !  - a different global size nx/2+1,ny,nz is used in FFT r2c/c2r
  !  - multiple global sizes can co-exist in one application, each
  !    using its own DECOMP_INFO object
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine decomp_info_init(nx,ny,nz,decomp)

    implicit none

    integer, intent(IN) :: nx,ny,nz
    TYPE(DECOMP_INFO), intent(INOUT) :: decomp

    integer :: buf_size, status, errorcode

    ! verify the global size can actually be distributed as pencils
    if (nx<dims(1) .or. ny<dims(1) .or. ny<dims(2) .or. nz<dims(2)) then
       errorcode = 6
       call decomp_2d_abort(errorcode, &
            'Invalid 2D processor grid. ' // &
            'Make sure that min(nx,ny) >= p_row and ' // &
            'min(ny,nz) >= p_col')
    end if

    if (mod(nx,dims(1))==0 .and. mod(ny,dims(1))==0 .and. &
         mod(ny,dims(2))==0 .and. mod(nz,dims(2))==0) then
       decomp%even = .true.
    else
       decomp%even = .false.
    end if

    ! distribute mesh points
    allocate(decomp%x1dist(0:dims(1)-1),decomp%y1dist(0:dims(1)-1), &
         decomp%y2dist(0:dims(2)-1),decomp%z2dist(0:dims(2)-1))
    call get_dist(nx,ny,nz,decomp)

    ! generate partition information - starting/ending index etc.
    call partition(nx, ny, nz, (/ 1,2,3 /), &
         decomp%xst, decomp%xen, decomp%xsz)
    call partition(nx, ny, nz, (/ 2,1,3 /), &
         decomp%yst, decomp%yen, decomp%ysz)
    call partition(nx, ny, nz, (/ 2,3,1 /), &
         decomp%zst, decomp%zen, decomp%zsz)

    ! prepare send/receive buffer displacement and count for ALLTOALL(V)
    allocate(decomp%x1cnts(0:dims(1)-1),decomp%y1cnts(0:dims(1)-1), &
         decomp%y2cnts(0:dims(2)-1),decomp%z2cnts(0:dims(2)-1))
    allocate(decomp%x1disp(0:dims(1)-1),decomp%y1disp(0:dims(1)-1), &
         decomp%y2disp(0:dims(2)-1),decomp%z2disp(0:dims(2)-1))
    call prepare_buffer(decomp)

#ifdef SHM
    ! prepare shared-memory information if required
    call decomp_info_init_shm(decomp)
#endif

    ! allocate memory for the MPI_ALLTOALL(V) buffers
    ! define the buffers globally for performance reason

    buf_size = max(decomp%xsz(1)*decomp%xsz(2)*decomp%xsz(3), &
         max(decomp%ysz(1)*decomp%ysz(2)*decomp%ysz(3), &
         decomp%zsz(1)*decomp%zsz(2)*decomp%zsz(3)) )
#ifdef EVEN
    ! padded alltoall optimisation may need larger buffer space
    buf_size = max(buf_size, &
         max(decomp%x1count*dims(1),decomp%y2count*dims(2)) )
#endif

    ! check if additional memory is required
    ! *** TODO: consider how to share the real/complex buffers
    if (buf_size > decomp_buf_size) then
       decomp_buf_size = buf_size
       if (allocated(work1_r)) deallocate(work1_r)
       if (allocated(work2_r)) deallocate(work2_r)
       if (allocated(work1_c)) deallocate(work1_c)
       if (allocated(work2_c)) deallocate(work2_c)
       allocate(work1_r(buf_size), STAT=status)
       allocate(work2_r(buf_size), STAT=status)
       allocate(work1_c(buf_size), STAT=status)
       allocate(work2_c(buf_size), STAT=status)
       if (status /= 0) then
          errorcode = 2
          call decomp_2d_abort(errorcode, &
               'Out of memory when allocating 2DECOMP workspace')
       end if
    end if

    return
  end subroutine decomp_info_init

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Release memory associated with a DECOMP_INFO object
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine decomp_info_finalize(decomp)

    implicit none

    TYPE(DECOMP_INFO), intent(INOUT) :: decomp

    deallocate(decomp%x1dist,decomp%y1dist,decomp%y2dist,decomp%z2dist)
    deallocate(decomp%x1cnts,decomp%y1cnts,decomp%y2cnts,decomp%z2cnts)
    deallocate(decomp%x1disp,decomp%y1disp,decomp%y2disp,decomp%z2disp)

#ifdef SHM
    deallocate(decomp%x1disp_o,decomp%y1disp_o,decomp%y2disp_o, &
         decomp%z2disp_o)
    deallocate(decomp%x1cnts_s,decomp%y1cnts_s,decomp%y2cnts_s, &
         decomp%z2cnts_s)
    deallocate(decomp%x1disp_s,decomp%y1disp_s,decomp%y2disp_s, &
         decomp%z2disp_s)
#endif

    return
  end subroutine decomp_info_finalize

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Coarser mesh support for statistic
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine init_coarser_mesh_statS(i_skip,j_skip,k_skip,from1)

    implicit none

    integer, intent(IN) :: i_skip,j_skip,k_skip
    logical, intent(IN) :: from1  ! .true.  - save 1,n+1,2n+1...
    ! .false. - save n,2n,3n...

    integer, dimension(3) :: skip
    integer :: i

    coarse_mesh_starts_from_1 = from1
    iskipS = i_skip
    jskipS = j_skip
    kskipS = k_skip

    skip(1)=iskipS
    skip(2)=jskipS
    skip(3)=kskipS

    do i=1,3
       if (from1) then
          xstS(i) = (xstart(i)+skip(i)-1)/skip(i)
          if (mod(xstart(i)+skip(i)-1,skip(i))/=0) xstS(i)=xstS(i)+1
          xenS(i) = (xend(i)+skip(i)-1)/skip(i)
       else
          xstS(i) = xstart(i)/skip(i)
          if (mod(xstart(i),skip(i))/=0) xstS(i)=xstS(i)+1
          xenS(i) = xend(i)/skip(i)
       end if
       xszS(i) = xenS(i)-xstS(i)+1
    end do

    do i=1,3
       if (from1) then
          ystS(i) = (ystart(i)+skip(i)-1)/skip(i)
          if (mod(ystart(i)+skip(i)-1,skip(i))/=0) ystS(i)=ystS(i)+1
          yenS(i) = (yend(i)+skip(i)-1)/skip(i)
       else
          ystS(i) = ystart(i)/skip(i)
          if (mod(ystart(i),skip(i))/=0) ystS(i)=ystS(i)+1
          yenS(i) = yend(i)/skip(i)
       end if
       yszS(i) = yenS(i)-ystS(i)+1
    end do

    do i=1,3
       if (from1) then
          zstS(i) = (zstart(i)+skip(i)-1)/skip(i)
          if (mod(zstart(i)+skip(i)-1,skip(i))/=0) zstS(i)=zstS(i)+1
          zenS(i) = (zend(i)+skip(i)-1)/skip(i)
       else
          zstS(i) = zstart(i)/skip(i)
          if (mod(zstart(i),skip(i))/=0) zstS(i)=zstS(i)+1
          zenS(i) = zend(i)/skip(i)
       end if
       zszS(i) = zenS(i)-zstS(i)+1
    end do

    return
  end subroutine init_coarser_mesh_statS

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Coarser mesh support for visualization
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine init_coarser_mesh_statV(i_skip,j_skip,k_skip,from1)

    implicit none

    integer, intent(IN) :: i_skip,j_skip,k_skip
    logical, intent(IN) :: from1  ! .true.  - save 1,n+1,2n+1...
    ! .false. - save n,2n,3n...

    integer, dimension(3) :: skip
    integer :: i

    coarse_mesh_starts_from_1 = from1
    iskipV = i_skip
    jskipV = j_skip
    kskipV = k_skip

    skip(1)=iskipV
    skip(2)=jskipV
    skip(3)=kskipV

    do i=1,3
       if (from1) then
          xstV(i) = (xstart(i)+skip(i)-1)/skip(i)
          if (mod(xstart(i)+skip(i)-1,skip(i))/=0) xstV(i)=xstV(i)+1
          xenV(i) = (xend(i)+skip(i)-1)/skip(i)
       else
          xstV(i) = xstart(i)/skip(i)
          if (mod(xstart(i),skip(i))/=0) xstV(i)=xstV(i)+1
          xenV(i) = xend(i)/skip(i)
       end if
       xszV(i) = xenV(i)-xstV(i)+1
    end do

    do i=1,3
       if (from1) then
          ystV(i) = (ystart(i)+skip(i)-1)/skip(i)
          if (mod(ystart(i)+skip(i)-1,skip(i))/=0) ystV(i)=ystV(i)+1
          yenV(i) = (yend(i)+skip(i)-1)/skip(i)
       else
          ystV(i) = ystart(i)/skip(i)
          if (mod(ystart(i),skip(i))/=0) ystV(i)=ystV(i)+1
          yenV(i) = yend(i)/skip(i)
       end if
       yszV(i) = yenV(i)-ystV(i)+1
    end do

    do i=1,3
       if (from1) then
          zstV(i) = (zstart(i)+skip(i)-1)/skip(i)
          if (mod(zstart(i)+skip(i)-1,skip(i))/=0) zstV(i)=zstV(i)+1
          zenV(i) = (zend(i)+skip(i)-1)/skip(i)
       else
          zstV(i) = zstart(i)/skip(i)
          if (mod(zstart(i),skip(i))/=0) zstV(i)=zstV(i)+1
          zenV(i) = zend(i)/skip(i)
       end if
       zszV(i) = zenV(i)-zstV(i)+1
    end do

    return
  end subroutine init_coarser_mesh_statV

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Coarser mesh support for probe
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine init_coarser_mesh_statP(i_skip,j_skip,k_skip,from1)

    implicit none

    integer, intent(IN) :: i_skip,j_skip,k_skip
    logical, intent(IN) :: from1  ! .true.  - save 1,n+1,2n+1...
    ! .false. - save n,2n,3n...

    integer, dimension(3) :: skip
    integer :: i

    coarse_mesh_starts_from_1 = from1
    iskipP = i_skip
    jskipP = j_skip
    kskipP = k_skip

    skip(1)=iskipP
    skip(2)=jskipP
    skip(3)=kskipP

    do i=1,3
       if (from1) then
          xstP(i) = (xstart(i)+skip(i)-1)/skip(i)
          if (mod(xstart(i)+skip(i)-1,skip(i))/=0) xstP(i)=xstP(i)+1
          xenP(i) = (xend(i)+skip(i)-1)/skip(i)
       else
          xstP(i) = xstart(i)/skip(i)
          if (mod(xstart(i),skip(i))/=0) xstP(i)=xstP(i)+1
          xenP(i) = xend(i)/skip(i)
       end if
       xszP(i) = xenP(i)-xstP(i)+1
    end do

    do i=1,3
       if (from1) then
          ystP(i) = (ystart(i)+skip(i)-1)/skip(i)
          if (mod(ystart(i)+skip(i)-1,skip(i))/=0) ystP(i)=ystP(i)+1
          yenP(i) = (yend(i)+skip(i)-1)/skip(i)
       else
          ystP(i) = ystart(i)/skip(i)
          if (mod(ystart(i),skip(i))/=0) ystP(i)=ystP(i)+1
          yenP(i) = yend(i)/skip(i)
       end if
       yszP(i) = yenP(i)-ystP(i)+1
    end do

    do i=1,3
       if (from1) then
          zstP(i) = (zstart(i)+skip(i)-1)/skip(i)
          if (mod(zstart(i)+skip(i)-1,skip(i))/=0) zstP(i)=zstP(i)+1
          zenP(i) = (zend(i)+skip(i)-1)/skip(i)
       else
          zstP(i) = zstart(i)/skip(i)
          if (mod(zstart(i),skip(i))/=0) zstP(i)=zstP(i)+1
          zenP(i) = zend(i)/skip(i)
       end if
       zszP(i) = zenP(i)-zstP(i)+1
    end do

    return
  end subroutine init_coarser_mesh_statP

  ! Copy data from a fine-resolution array to a coarse one for statistic
  subroutine fine_to_coarseS(ipencil,var_fine,var_coarse)

    implicit none

    real(mytype), dimension(:,:,:) :: var_fine
    real(mytype), dimension(:,:,:) :: var_coarse
    integer, intent(IN) :: ipencil

    real(mytype), allocatable, dimension(:,:,:) :: wk, wk2
    integer :: i,j,k

    if (ipencil==1) then
       allocate(wk(xstS(1):xenS(1),xstS(2):xenS(2),xstS(3):xenS(3)))
       allocate(wk2(xstart(1):xend(1),xstart(2):xend(2),xstart(3):xend(3)))
       wk2=var_fine
       if (coarse_mesh_starts_from_1) then
          do k=xstS(3),xenS(3)
             do j=xstS(2),xenS(2)
                do i=xstS(1),xenS(1)
                   wk(i,j,k) = wk2((i-1)*iskipS+1,(j-1)*jskipS+1,(k-1)*kskipS+1)
                end do
             end do
          end do
       else
          do k=xstS(3),xenS(3)
             do j=xstS(2),xenS(2)
                do i=xstS(1),xenS(1)
                   wk(i,j,k) = wk2(i*iskipS,j*jskipS,k*kskipS)
                end do
             end do
          end do
       end if
       var_coarse=wk
    else if (ipencil==2) then
       allocate(wk(ystS(1):yenS(1),ystS(2):yenS(2),ystS(3):yenS(3)))
       allocate(wk2(ystart(1):yend(1),ystart(2):yend(2),ystart(3):yend(3)))
       wk2=var_fine
       if (coarse_mesh_starts_from_1) then
          do k=ystS(3),yenS(3)
             do j=ystS(2),yenS(2)
                do i=ystS(1),yenS(1)
                   wk(i,j,k) = wk2((i-1)*iskipS+1,(j-1)*jskipS+1,(k-1)*kskipS+1)
                end do
             end do
          end do
       else
          do k=ystS(3),yenS(3)
             do j=ystS(2),yenS(2)
                do i=ystS(1),yenS(1)
                   wk(i,j,k) = wk2(i*iskipS,j*jskipS,k*kskipS)
                end do
             end do
          end do
       end if
       var_coarse=wk
    else if (ipencil==3) then
       allocate(wk(zstS(1):zenS(1),zstS(2):zenS(2),zstS(3):zenS(3)))
       allocate(wk2(zstart(1):zend(1),zstart(2):zend(2),zstart(3):zend(3)))
       wk2=var_fine
       if (coarse_mesh_starts_from_1) then
          do k=zstS(3),zenS(3)
             do j=zstS(2),zenS(2)
                do i=zstS(1),zenS(1)
                   wk(i,j,k) = wk2((i-1)*iskipS+1,(j-1)*jskipS+1,(k-1)*kskipS+1)
                end do
             end do
          end do
       else
          do k=zstS(3),zenS(3)
             do j=zstS(2),zenS(2)
                do i=zstS(1),zenS(1)
                   wk(i,j,k) = wk2(i*iskipS,j*jskipS,k*kskipS)
                end do
             end do
          end do
       end if
       var_coarse=wk
    end if

    deallocate(wk,wk2)

    return
  end subroutine fine_to_coarseS

  ! Copy data from a fine-resolution array to a coarse one for visualization
  subroutine fine_to_coarseV(ipencil,var_fine,var_coarse)

    implicit none

    real(mytype), dimension(:,:,:) :: var_fine
    real(mytype), dimension(:,:,:) :: var_coarse
    integer, intent(IN) :: ipencil

    real(mytype), allocatable, dimension(:,:,:) :: wk, wk2
    integer :: i,j,k

    if (ipencil==1) then
       allocate(wk(xstV(1):xenV(1),xstV(2):xenV(2),xstV(3):xenV(3)))
       allocate(wk2(xstart(1):xend(1),xstart(2):xend(2),xstart(3):xend(3)))
       wk2=var_fine
       if (coarse_mesh_starts_from_1) then
          do k=xstV(3),xenV(3)
             do j=xstV(2),xenV(2)
                do i=xstV(1),xenV(1)
                   wk(i,j,k) = wk2((i-1)*iskipV+1,(j-1)*jskipV+1,(k-1)*kskipV+1)
                end do
             end do
          end do
       else
          do k=xstV(3),xenV(3)
             do j=xstV(2),xenV(2)
                do i=xstV(1),xenV(1)
                   wk(i,j,k) = wk2(i*iskipV,j*jskipV,k*kskipV)
                end do
             end do
          end do
       end if
       var_coarse=wk
    else if (ipencil==2) then
       allocate(wk(ystV(1):yenV(1),ystV(2):yenV(2),ystV(3):yenV(3)))
       allocate(wk2(ystart(1):yend(1),ystart(2):yend(2),ystart(3):yend(3)))
       wk2=var_fine
       if (coarse_mesh_starts_from_1) then
          do k=ystV(3),yenV(3)
             do j=ystV(2),yenV(2)
                do i=ystV(1),yenV(1)
                   wk(i,j,k) = wk2((i-1)*iskipV+1,(j-1)*jskipV+1,(k-1)*kskipV+1)
                end do
             end do
          end do
       else
          do k=ystV(3),yenV(3)
             do j=ystV(2),yenV(2)
                do i=ystV(1),yenV(1)
                   wk(i,j,k) = wk2(i*iskipV,j*jskipV,k*kskipV)
                end do
             end do
          end do
       end if
       var_coarse=wk
    else if (ipencil==3) then
       allocate(wk(zstV(1):zenV(1),zstV(2):zenV(2),zstV(3):zenV(3)))
       allocate(wk2(zstart(1):zend(1),zstart(2):zend(2),zstart(3):zend(3)))
       wk2=var_fine
       if (coarse_mesh_starts_from_1) then
          do k=zstV(3),zenV(3)
             do j=zstV(2),zenV(2)
                do i=zstV(1),zenV(1)
                   wk(i,j,k) = wk2((i-1)*iskipV+1,(j-1)*jskipV+1,(k-1)*kskipV+1)
                end do
             end do
          end do
       else
          do k=zstV(3),zenV(3)
             do j=zstV(2),zenV(2)
                do i=zstV(1),zenV(1)
                   wk(i,j,k) = wk2(i*iskipV,j*jskipV,k*kskipV)
                end do
             end do
          end do
       end if
       var_coarse=wk
    end if

    deallocate(wk,wk2)

    return
  end subroutine fine_to_coarseV

  ! Copy data from a fine-resolution array to a coarse one for probe
  subroutine fine_to_coarseP(ipencil,var_fine,var_coarse)

    implicit none

    real(mytype), dimension(:,:,:) :: var_fine
    real(mytype), dimension(:,:,:) :: var_coarse
    integer, intent(IN) :: ipencil

    real(mytype), allocatable, dimension(:,:,:) :: wk, wk2
    integer :: i,j,k

    if (ipencil==1) then
       allocate(wk(xstP(1):xenP(1),xstP(2):xenP(2),xstP(3):xenP(3)))
       allocate(wk2(xstart(1):xend(1),xstart(2):xend(2),xstart(3):xend(3)))
       wk2=var_fine
       if (coarse_mesh_starts_from_1) then
          do k=xstP(3),xenP(3)
             do j=xstP(2),xenP(2)
                do i=xstP(1),xenP(1)
                   wk(i,j,k) = wk2((i-1)*iskipP+1,(j-1)*jskipP+1,(k-1)*kskipP+1)
                end do
             end do
          end do
       else
          do k=xstP(3),xenP(3)
             do j=xstP(2),xenP(2)
                do i=xstP(1),xenP(1)
                   wk(i,j,k) = wk2(i*iskipP,j*jskipP,k*kskipP)
                end do
             end do
          end do
       end if
       var_coarse=wk
    else if (ipencil==2) then
       allocate(wk(ystP(1):yenP(1),ystP(2):yenP(2),ystP(3):yenP(3)))
       allocate(wk2(ystart(1):yend(1),ystart(2):yend(2),ystart(3):yend(3)))
       wk2=var_fine
       if (coarse_mesh_starts_from_1) then
          do k=ystP(3),yenP(3)
             do j=ystP(2),yenP(2)
                do i=ystP(1),yenP(1)
                   wk(i,j,k) = wk2((i-1)*iskipP+1,(j-1)*jskipP+1,(k-1)*kskipP+1)
                end do
             end do
          end do
       else
          do k=ystP(3),yenP(3)
             do j=ystP(2),yenP(2)
                do i=ystP(1),yenP(1)
                   wk(i,j,k) = wk2(i*iskipP,j*jskipP,k*kskipP)
                end do
             end do
          end do
       end if
       var_coarse=wk
    else if (ipencil==3) then
       allocate(wk(zstP(1):zenP(1),zstP(2):zenP(2),zstP(3):zenP(3)))
       allocate(wk2(zstart(1):zend(1),zstart(2):zend(2),zstart(3):zend(3)))
       wk2=var_fine
       if (coarse_mesh_starts_from_1) then
          do k=zstP(3),zenP(3)
             do j=zstP(2),zenP(2)
                do i=zstP(1),zenP(1)
                   wk(i,j,k) = wk2((i-1)*iskipP+1,(j-1)*jskipP+1,(k-1)*kskipP+1)
                end do
             end do
          end do
       else
          do k=zstP(3),zenP(3)
             do j=zstP(2),zenP(2)
                do i=zstP(1),zenP(1)
                   wk(i,j,k) = wk2(i*iskipP,j*jskipP,k*kskipP)
                end do
             end do
          end do
       end if
       var_coarse=wk
    end if

    deallocate(wk,wk2)

    return
  end subroutine fine_to_coarseP

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Find sub-domain information held by current processor
  !   INPUT:
  !     nx, ny, nz - global data dimension
  !     pdim(3)    - number of processor grid in each dimension,
  !                  valid values: 1 - distibute locally;
  !                                2 - distribute across p_row;
  !                                3 - distribute across p_col
  !   OUTPUT:
  !     lstart(3)  - starting index
  !     lend(3)    - ending index
  !     lsize(3)   - size of the sub-block (redundant)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine partition(nx, ny, nz, pdim, lstart, lend, lsize)

    implicit none

    integer, intent(IN) :: nx, ny, nz
    integer, dimension(3), intent(IN) :: pdim
    integer, dimension(3), intent(OUT) :: lstart, lend, lsize

    integer, allocatable, dimension(:) :: st,en,sz
    integer :: i, gsize

    do i = 1, 3

       if (i==1) then
          gsize = nx
       else if (i==2) then
          gsize = ny
       else if (i==3) then
          gsize = nz
       end if

       if (pdim(i) == 1) then        ! all local
          lstart(i) = 1
          lend(i)   = gsize
          lsize(i)  = gsize
       elseif (pdim(i) == 2) then    ! distribute across dims(1)
          allocate(st(0:dims(1)-1))
          allocate(en(0:dims(1)-1))
          allocate(sz(0:dims(1)-1))
          call distribute(gsize,dims(1),st,en,sz)
          lstart(i) = st(coord(1))
          lend(i)   = en(coord(1))
          lsize(i)  = sz(coord(1))
          deallocate(st,en,sz)
       elseif (pdim(i) == 3) then    ! distribute across dims(2)
          allocate(st(0:dims(2)-1))
          allocate(en(0:dims(2)-1))
          allocate(sz(0:dims(2)-1))
          call distribute(gsize,dims(2),st,en,sz)
          lstart(i) = st(coord(2))
          lend(i)   = en(coord(2))
          lsize(i)  = sz(coord(2))
          deallocate(st,en,sz)
       end if

    end do
    return

  end subroutine partition

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !   - distibutes grid points in one dimension
  !   - handles uneven distribution properly
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine distribute(data1,proc,st,en,sz)

    implicit none
    ! data1 -- data size in any dimension to be partitioned
    ! proc  -- number of processors in that dimension
    ! st    -- array of starting index
    ! en    -- array of ending index
    ! sz    -- array of local size  (redundent)
    integer data1,proc,st(0:proc-1),en(0:proc-1),sz(0:proc-1)
    integer i,size1,nl,nu

    size1=data1/proc
    nu = data1 - size1 * proc
    nl = proc - nu
    st(0) = 1
    sz(0) = size1
    en(0) = size1
    do i=1,nl-1
       st(i) = st(i-1) + size1
       sz(i) = size1
       en(i) = en(i-1) + size1
    end do
    size1 = size1 + 1
    do i=nl,proc-1
       st(i) = en(i-1) + 1
       sz(i) = size1
       en(i) = en(i-1) + size1
    end do
    en(proc-1)= data1
    sz(proc-1)= data1-st(proc-1)+1

    return
  end subroutine distribute

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  Define how each dimension is distributed across processors
  !    e.g. 17 meshes across 4 processor would be distibuted as (4,4,4,5)
  !    such global information is required locally at MPI_ALLTOALLV time
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine get_dist(nx,ny,nz,decomp)

    integer, intent(IN) :: nx, ny, nz
    TYPE(DECOMP_INFO), intent(INOUT) :: decomp
    integer, allocatable, dimension(:) :: st,en

    allocate(st(0:dims(1)-1))
    allocate(en(0:dims(1)-1))
    call distribute(nx,dims(1),st,en,decomp%x1dist)
    call distribute(ny,dims(1),st,en,decomp%y1dist)
    deallocate(st,en)

    allocate(st(0:dims(2)-1))
    allocate(en(0:dims(2)-1))
    call distribute(ny,dims(2),st,en,decomp%y2dist)
    call distribute(nz,dims(2),st,en,decomp%z2dist)
    deallocate(st,en)

    return
  end subroutine get_dist

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Prepare the send / receive buffers for MPI_ALLTOALLV communications
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine prepare_buffer(decomp)

    implicit none

    TYPE(DECOMP_INFO), intent(INOUT) :: decomp

    integer :: i

    ! MPI_ALLTOALLV buffer information

    do i=0, dims(1)-1
       decomp%x1cnts(i) = decomp%x1dist(i)*decomp%xsz(2)*decomp%xsz(3)
       decomp%y1cnts(i) = decomp%ysz(1)*decomp%y1dist(i)*decomp%ysz(3)
       if (i==0) then
          decomp%x1disp(i) = 0  ! displacement is 0-based index
          decomp%y1disp(i) = 0
       else
          decomp%x1disp(i) = decomp%x1disp(i-1) + decomp%x1cnts(i-1)
          decomp%y1disp(i) = decomp%y1disp(i-1) + decomp%y1cnts(i-1)
       end if
    end do

    do i=0, dims(2)-1
       decomp%y2cnts(i) = decomp%ysz(1)*decomp%y2dist(i)*decomp%ysz(3)
       decomp%z2cnts(i) = decomp%zsz(1)*decomp%zsz(2)*decomp%z2dist(i)
       if (i==0) then
          decomp%y2disp(i) = 0  ! displacement is 0-based index
          decomp%z2disp(i) = 0
       else
          decomp%y2disp(i) = decomp%y2disp(i-1) + decomp%y2cnts(i-1)
          decomp%z2disp(i) = decomp%z2disp(i-1) + decomp%z2cnts(i-1)
       end if
    end do

    ! MPI_ALLTOALL buffer information

    ! For evenly distributed data, following is an easier implementation.
    ! But it should be covered by the more general formulation below.
    !decomp%x1count = decomp%xsz(1)*decomp%xsz(2)*decomp%xsz(3)/dims(1)
    !decomp%y1count = decomp%ysz(1)*decomp%ysz(2)*decomp%ysz(3)/dims(1)
    !decomp%y2count = decomp%ysz(1)*decomp%ysz(2)*decomp%ysz(3)/dims(2)
    !decomp%z2count = decomp%zsz(1)*decomp%zsz(2)*decomp%zsz(3)/dims(2)

    ! For unevenly distributed data, pad smaller messages. Note the
    ! last blocks along pencils always get assigned more mesh points
    ! for X <=> Y transposes
    decomp%x1count = decomp%x1dist(dims(1)-1) * &
         decomp%y1dist(dims(1)-1) * decomp%xsz(3)
    decomp%y1count = decomp%x1count
    ! for Y <=> Z transposes
    decomp%y2count = decomp%y2dist(dims(2)-1) * &
         decomp%z2dist(dims(2)-1) * decomp%zsz(1)
    decomp%z2count = decomp%y2count

    return
  end subroutine prepare_buffer

#ifdef SHM

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  Generate shared-memory information
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine decomp_info_init_shm(decomp)

    implicit none

    TYPE(DECOMP_INFO), intent(INOUT) :: decomp

    ! a copy of old displacement array (will be overwritten by shm code)
    allocate(decomp%x1disp_o(0:dims(1)-1),decomp%y1disp_o(0:dims(1)-1), &
         decomp%y2disp_o(0:dims(2)-1),decomp%z2disp_o(0:dims(2)-1))
    decomp%x1disp_o = decomp%x1disp
    decomp%y1disp_o = decomp%y1disp
    decomp%y2disp_o = decomp%y2disp
    decomp%z2disp_o = decomp%z2disp

    call prepare_shared_buffer(decomp%ROW_INFO,DECOMP_2D_COMM_ROW,decomp)
    call prepare_shared_buffer(decomp%COL_INFO,DECOMP_2D_COMM_COL,decomp)

    return
  end subroutine decomp_info_init_shm

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! For shared-memory implementation, prepare send/recv shared buffer
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine prepare_shared_buffer(C,MPI_COMM,decomp)

    implicit none

    TYPE(SMP_INFO) :: C
    INTEGER :: MPI_COMM
    TYPE(DECOMP_INFO) :: decomp

    INTEGER, ALLOCATABLE :: KTBL(:,:),NARY(:,:),KTBLALL(:,:)
    INTEGER MYSMP, MYCORE, COLOR

    integer :: ierror

    C%MPI_COMM = MPI_COMM
    CALL MPI_COMM_SIZE(MPI_COMM,C%NCPU,ierror)
    CALL MPI_COMM_RANK(MPI_COMM,C%NODE_ME,ierror)
    C%SMP_COMM  = MPI_COMM_NULL
    C%CORE_COMM = MPI_COMM_NULL
    C%SMP_ME= 0
    C%NCORE = 0
    C%CORE_ME = 0
    C%MAXCORE = 0
    C%NSMP  = 0
    C%N_SND = 0
    C%N_RCV = 0
    C%SND_P = 0
    C%RCV_P = 0
    C%SND_P_c = 0
    C%RCV_P_c = 0

    ! get smp-node map for this communicator and set up smp communicators
    CALL GET_SMP_MAP(C%MPI_COMM, C%NSMP, MYSMP, &
         C%NCORE, MYCORE, C%MAXCORE)
    C%SMP_ME = MYSMP + 1
    C%CORE_ME = MYCORE + 1
    ! - set up inter/intra smp-node communicators
    COLOR = MYCORE
    IF (COLOR.GT.0) COLOR = MPI_UNDEFINED
    CALL MPI_Comm_split(C%MPI_COMM, COLOR, MYSMP, C%SMP_COMM, ierror)
    CALL MPI_Comm_split(C%MPI_COMM, MYSMP, MYCORE, C%CORE_COMM, ierror)
    ! - allocate work space
    ALLOCATE(KTBL(C%MAXCORE,C%NSMP),NARY(C%NCPU,C%NCORE))
    ALLOCATE(KTBLALL(C%MAXCORE,C%NSMP))
    ! - set up smp-node/core to node_me lookup table
    KTBL = 0
    KTBL(C%CORE_ME,C%SMP_ME) = C%NODE_ME + 1
    CALL MPI_ALLREDUCE(KTBL,KTBLALL,C%NSMP*C%MAXCORE,MPI_INTEGER, &
         MPI_SUM,MPI_COMM,ierror)
    KTBL=KTBLALL
    !  IF (SUM(KTBL) /= C%NCPU*(C%NCPU+1)/2) &
    !       CALL MPI_ABORT(...

    ! compute offsets in shared SNDBUF and RCVBUF
    CALL MAPSET_SMPSHM(C, KTBL, NARY, decomp)

    DEALLOCATE(KTBL,NARY)

    return
  end subroutine prepare_shared_buffer

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Use Ian Bush's FreeIPC to generate shared-memory information
  !  - system independent solution
  !  - replacing David Tanqueray's implementation in alloc_shm.c
  !    (old C code renamed to get_smp_map2)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine get_smp_map(comm, nnodes, my_node, ncores, my_core, maxcor)

    use FIPC_module

    implicit none

    integer, intent(IN) :: comm
    integer, intent(OUT) :: nnodes, my_node, ncores, my_core, maxcor

    integer :: intra_comm, extra_comm
    integer :: ierror

    call FIPC_init(comm, ierror)

    ! intra_comm: communicator for processes on this shared memory node
    ! extra_comm: communicator for all rank 0 on each shared memory node
    call FIPC_ctxt_intra_comm(FIPC_ctxt_world, intra_comm, ierror)
    call FIPC_ctxt_extra_comm(FIPC_ctxt_world, extra_comm, ierror)

    call MPI_COMM_SIZE(intra_comm,  ncores, ierror)
    call MPI_COMM_RANK(intra_comm, my_core, ierror)

    ! only rank 0 on each shared memory node member of extra_comm
    ! for others extra_comm = MPI_COMM_NULL
    if (extra_comm /= MPI_COMM_NULL) then
       call MPI_COMM_SIZE(extra_comm,  nnodes, ierror)
       call MPI_COMM_RANK(extra_comm, my_node, ierror)
    end if

    ! other ranks share the same information as their leaders
    call MPI_BCAST( nnodes, 1, MPI_INTEGER, 0, intra_comm, ierror)
    call MPI_BCAST(my_node, 1, MPI_INTEGER, 0, intra_comm, ierror)

    ! maxcor
    call MPI_ALLREDUCE(ncores, maxcor, 1, MPI_INTEGER, MPI_MAX, &
         MPI_COMM_WORLD, ierror)

    call FIPC_finalize(ierror)

    return

  end subroutine get_smp_map

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Set up smp-node based shared memory maps
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  SUBROUTINE MAPSET_SMPSHM(C, KTBL, NARY, decomp)

    IMPLICIT NONE

    TYPE (SMP_INFO) C
    INTEGER KTBL(C%MAXCORE,C%NSMP)
    INTEGER NARY(C%NCPU,C%NCORE)
    TYPE (DECOMP_INFO) :: decomp

    INTEGER i, j, k, l, N, PTR, BSIZ, ierror, status, seed
    character*16 s

    BSIZ = C%N_SND

    ! a - SNDBUF
    IF (C%MPI_COMM==DECOMP_2D_COMM_COL) THEN
       ALLOCATE(decomp%x1cnts_s(C%NSMP),decomp%x1disp_s(C%NSMP+1), &
            stat=status)
       CALL MPI_Allgather(decomp%x1cnts, C%NCPU, MPI_INTEGER, &
            NARY, C%NCPU, MPI_INTEGER, C%CORE_COMM, ierror)
       PTR = 0
       DO i=1,C%NSMP
          decomp%x1disp_s(i) = PTR
          N = 0
          DO j=1,C%MAXCORE
             k = KTBL(j,i)
             IF (k > 0) then
                DO l=1,C%NCORE
                   IF (l == C%CORE_ME) decomp%x1disp_o(k-1) = PTR
                   N = N + NARY(k,l)
                   PTR = PTR + NARY(k,l)
                END DO
             END IF
          END DO
          decomp%x1cnts_s(i) = N
       END DO
       decomp%x1disp_s(C%NSMP+1) = PTR
       IF (PTR > BSIZ) BSIZ = PTR

    ELSE IF (C%MPI_COMM==DECOMP_2D_COMM_ROW) THEN
       ALLOCATE(decomp%y2cnts_s(C%NSMP),decomp%y2disp_s(C%NSMP+1), &
            stat=status)
       CALL MPI_Allgather(decomp%y2cnts, C%NCPU, MPI_INTEGER, &
            NARY, C%NCPU, MPI_INTEGER, C%CORE_COMM, ierror)
       PTR = 0
       DO i=1,C%NSMP
          decomp%y2disp_s(i) = PTR
          N = 0
          DO j=1,C%MAXCORE
             k = KTBL(j,i)
             IF (k > 0) then
                DO l=1,C%NCORE
                   IF (l == C%CORE_ME) decomp%y2disp_o(k-1) = PTR
                   N = N + NARY(k,l)
                   PTR = PTR + NARY(k,l)
                END DO
             END IF
          END DO
          decomp%y2cnts_s(i) = N
       END DO
       decomp%y2disp_s(C%NSMP+1) = PTR
       IF (PTR > BSIZ) BSIZ = PTR
    END IF

    ! b - RCVBUF

    IF (C%MPI_COMM==DECOMP_2D_COMM_COL) THEN
       ALLOCATE(decomp%y1cnts_s(C%NSMP),decomp%y1disp_s(C%NSMP+1), &
            stat=status)
       CALL MPI_Allgather(decomp%y1cnts, C%NCPU, MPI_INTEGER, &
            NARY, C%NCPU, MPI_INTEGER, C%CORE_COMM, ierror)
       PTR = 0
       DO i=1,C%NSMP
          decomp%y1disp_s(i) = PTR
          N=0
          DO j=1,C%NCORE
             DO l=1,C%MAXCORE
                k = KTBL(l,i)
                IF (k > 0) then
                   IF (j == C%CORE_ME) decomp%y1disp_o(k-1) = PTR
                   N = N + NARY(k,j)
                   PTR = PTR + NARY(k,j)
                END IF
             END DO
          END DO
          decomp%y1cnts_s(i) = N
       END DO
       decomp%y1disp_s(C%NSMP+1) = PTR
       IF (PTR > BSIZ) BSIZ = PTR

    ELSE IF (C%MPI_COMM==DECOMP_2D_COMM_ROW) THEN
       ALLOCATE(decomp%z2cnts_s(C%NSMP),decomp%z2disp_s(C%NSMP+1), &
            stat=status)
       CALL MPI_Allgather(decomp%z2cnts, C%NCPU, MPI_INTEGER, &
            NARY, C%NCPU, MPI_INTEGER, C%CORE_COMM, ierror)
       PTR = 0
       DO i=1,C%NSMP
          decomp%z2disp_s(i) = PTR
          N=0
          DO j=1,C%NCORE
             DO l=1,C%MAXCORE
                k = KTBL(l,i)
                IF (k > 0) then
                   IF (j == C%CORE_ME) decomp%z2disp_o(k-1) = PTR
                   N = N + NARY(k,j)
                   PTR = PTR + NARY(k,j)
                END IF
             END DO
          END DO
          decomp%z2cnts_s(i) = N
       END DO
       decomp%z2disp_s(C%NSMP+1) = PTR
       IF (PTR > BSIZ) BSIZ = PTR

    END IF

    ! check buffer size and (re)-allocate buffer space if necessary
    IF (BSIZ > C%N_SND) then
       IF (C%SND_P /= 0) CALL DEALLOC_SHM(C%SND_P, C%CORE_COMM)
       ! make sure each rank has unique keys to get shared memory
       !IF (C%MPI_COMM==DECOMP_2D_COMM_COL) THEN
       !   seed = nrank+nproc*0+1 ! has to be non-zero
       !ELSE IF (C%MPI_COMM==DECOMP_2D_COMM_ROW) THEN
       !   seed = nrank+nproc*1+1
       !END IF
       status = 1
       !CALL ALLOC_SHM(C%SND_P, BSIZ, real_type, C%CORE_COMM, status, &
       !     seed)
       CALL ALLOC_SHM(C%SND_P, BSIZ, real_type, C%CORE_COMM, status)
       C%N_SND = BSIZ

       IF (C%RCV_P /= 0) CALL DEALLOC_SHM(C%RCV_P, C%CORE_COMM)
       status = 1
       CALL ALLOC_SHM(C%RCV_P, BSIZ, real_type, C%CORE_COMM, status)
       C%N_RCV = BSIZ

       IF (C%SND_P_c /= 0) CALL DEALLOC_SHM(C%SND_P_c, C%CORE_COMM)
       status = 1
       CALL ALLOC_SHM(C%SND_P_c, BSIZ, complex_type, C%CORE_COMM, status)
       C%N_SND = BSIZ

       IF (C%RCV_P_c /= 0) CALL DEALLOC_SHM(C%RCV_P_c, C%CORE_COMM)
       status = 1
       CALL ALLOC_SHM(C%RCV_P_c, BSIZ, complex_type, C%CORE_COMM, status)
       C%N_RCV = BSIZ

    END IF

    RETURN
  END SUBROUTINE MAPSET_SMPSHM

#endif

#ifdef OCC
  ! For non-blocking communication code, progress the comminication stack
  subroutine transpose_test(handle)

    implicit none

    integer :: handle, ierror

    call NBC_TEST(handle,ierror)

    return
  end subroutine transpose_test
#endif

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Transposition routines
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
#include "transpose_x_to_y.inc"
#include "transpose_y_to_z.inc"
#include "transpose_z_to_y.inc"
#include "transpose_y_to_x.inc"

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Auto-tuning algorithm to select the best 2D processor grid
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine best_2d_grid(iproc, best_p_row, best_p_col)

    implicit none

    integer, intent(IN) :: iproc
    integer, intent(OUT) :: best_p_row, best_p_col

    integer, allocatable, dimension(:) :: factors
    double precision :: t1, t2, best_time
    integer :: nfact, i, row, col, ierror, errorcode

    real(mytype), allocatable, dimension(:,:,:) :: u1, u2, u3

    TYPE(DECOMP_INFO) :: decomp

    if (nrank==0) write(*,*) 'In auto-tuning mode......'

    best_time = huge(t1)
    best_p_row = -1
    best_p_col = -1

    i = int(sqrt(real(iproc))) + 10  ! enough space to save all factors
    allocate(factors(i))
    call findfactor(iproc, factors, nfact)
    if (nrank==0) write(*,*) 'factors: ', (factors(i), i=1,nfact)

    do i=1, nfact

       row = factors(i)
       col = iproc / row

       ! enforce the limitation of 2D decomposition
       if (min(nx_global,ny_global)>=row .and. &
            min(ny_global,nz_global)>=col) then

          ! 2D Catersian topology
          dims(1) = row
          dims(2) = col
          periodic(1) = .false.
          periodic(2) = .false.
          call MPI_CART_CREATE(MPI_COMM_WORLD,2,dims,periodic, &
               .false.,DECOMP_2D_COMM_CART_X, ierror)
          call MPI_CART_COORDS(DECOMP_2D_COMM_CART_X,nrank,2,coord,ierror)

          ! communicators defining sub-groups for ALLTOALL(V)
          call MPI_CART_SUB(DECOMP_2D_COMM_CART_X,(/.true.,.false./), &
               DECOMP_2D_COMM_COL,ierror)
          call MPI_CART_SUB(DECOMP_2D_COMM_CART_X,(/.false.,.true./), &
               DECOMP_2D_COMM_ROW,ierror)

          ! generate 2D decomposition information for this row*col
          call decomp_info_init(nx_global,ny_global,nz_global,decomp)

          ! arrays for X,Y and Z-pencils
          allocate(u1(decomp%xsz(1),decomp%xsz(2),decomp%xsz(3)))
          allocate(u2(decomp%ysz(1),decomp%ysz(2),decomp%ysz(3)))
          allocate(u3(decomp%zsz(1),decomp%zsz(2),decomp%zsz(3)))

          ! timing the transposition routines
          t1 = MPI_WTIME()
          call transpose_x_to_y(u1,u2,decomp)
          call transpose_y_to_z(u2,u3,decomp)
          call transpose_z_to_y(u3,u2,decomp)
          call transpose_y_to_x(u2,u1,decomp)
          t2 = MPI_WTIME() - t1

          deallocate(u1,u2,u3)
          call decomp_info_finalize(decomp)

          call MPI_ALLREDUCE(t2,t1,1,MPI_DOUBLE_PRECISION,MPI_SUM, &
               MPI_COMM_WORLD,ierror)
          t1 = t1 / dble(nproc)

          if (nrank==0) then
             write(*,*) 'processor grid', row, ' by ', col, ' time=', t1
          end if

          if (best_time > t1) then
             best_time = t1
             best_p_row = row
             best_p_col = col
          end if

       end if

    end do ! loop through processer grid

    deallocate(factors)

    if (best_p_row/=-1) then
       if (nrank==0) then
          write(*,*) 'the best processor grid is probably ', &
               best_p_row, ' by ', best_p_col
       end if
    else
       errorcode = 9
       call decomp_2d_abort(errorcode, &
            'The processor-grid auto-tuning code failed. ' // &
            'The number of processes requested is probably too large.')
    end if

    return
  end subroutine best_2d_grid

#include "factor.inc"

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Halo cell support
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
#include "halo.inc"

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Error handling
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine decomp_2d_abort(errorcode, msg)

    implicit none

    integer, intent(IN) :: errorcode
    character(len=*), intent(IN) :: msg

    integer :: ierror

    if (nrank==0) then
       write(*,*) '2DECOMP&FFT ERROR - errorcode: ', errorcode
       write(*,*) 'ERROR MESSAGE: ' // msg
    end if
    call MPI_ABORT(MPI_COMM_WORLD,errorcode,ierror)

    return
  end subroutine decomp_2d_abort

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Utility routines to help allocate 3D arrays
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
#include "alloc.inc"

end module decomp_2d


!==============================================================================!
  subroutine Read_Control_Numerical(flow, turb, mult)
!------------------------------------------------------------------------------!
!   Reads details about numerical models from control file.                    !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Field_Mod,      only: Field_Type, heat_transfer
  use Var_Mod,        only: Var_Type
  use Turb_Mod,       only: Turb_Type
  use Multiphase_Mod, only: Multiphase_Type, multiphase_model,   &
                            VOLUME_OF_FLUID
  use Control_Mod
  use Numerics_Mod
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Field_Type),      target :: flow
  type(Turb_Type),       target :: turb
  type(Multiphase_Type), target :: mult
!----------------------------------[Locals]------------------------------------!
  type(Var_Type),   pointer :: tq, ui, phi
  character(len=80)         :: name
  integer                   :: i, sc
!==============================================================================!

  !-------------------------!
  !   Related to momentum   !
  !-------------------------!
  do i = 1, 3
    if(i .eq. 1) ui => flow % u
    if(i .eq. 2) ui => flow % v
    if(i .eq. 3) ui => flow % w
    ui % urf   = 0.8
    ui % niter = 5
    call Control_Mod_Advection_Scheme_For_Momentum            (name)
    ui % adv_scheme = Numerics_Mod_Advection_Scheme_Code      (name)
    call Control_Mod_Time_Integration_Scheme                  (name)
    ui % td_scheme = Numerics_Mod_Time_Integration_Scheme_Code(name)
    call Control_Mod_Blending_Coefficient_For_Momentum        (ui % blend)
    call Control_Mod_Simple_Underrelaxation_For_Momentum      (ui % urf)
    call Control_Mod_Tolerance_For_Momentum_Solver            (ui % tol)
    call Control_Mod_Preconditioner_For_System_Matrix         (ui % precond)
    call Control_Mod_Max_Iterations_For_Momentum_Solver       (ui % niter)
  end do

  !-------------------------!
  !   Related to pressure   !
  !-------------------------!
  flow % pp % niter = 40
  call Control_Mod_Tolerance_For_Pressure_Solver      (flow % pp % tol)
  call Control_Mod_Preconditioner_For_System_Matrix   (flow % pp % precond)
  call Control_Mod_Max_Iterations_For_Pressure_Solver (flow % pp % niter)
  call Control_Mod_Simple_Underrelaxation_For_Pressure(flow % pp % urf)

  !------------------------------!
  !   Related to heat transfer   !
  !------------------------------!
  if(heat_transfer) then
    flow % t % urf   = 0.7
    flow % t % niter = 5
    call Control_Mod_Advection_Scheme_For_Energy                    (name)
    flow % t % adv_scheme = Numerics_Mod_Advection_Scheme_Code      (name)
    call Control_Mod_Time_Integration_Scheme                        (name)
    flow % t % td_scheme = Numerics_Mod_Time_Integration_Scheme_Code(name)
    call Control_Mod_Blending_Coefficient_For_Energy  (flow % t % blend)
    call Control_Mod_Simple_Underrelaxation_For_Energy(flow % t % urf)
    call Control_Mod_Tolerance_For_Energy_Solver      (flow % t % tol)
    call Control_Mod_Preconditioner_For_System_Matrix (flow % t % precond)
    call Control_Mod_Max_Iterations_For_Energy_Solver (flow % t % niter)
  end if

  !--------------------------------!
  !   Related to multiphase flow   !
  !--------------------------------!
  if(multiphase_model .eq. VOLUME_OF_FLUID) then
    mult % vof % urf   = 0.7
    mult % vof % niter = 5
    call Control_Mod_Advection_Scheme_For_Multiphase                  (name)
    mult % vof % adv_scheme = Numerics_Mod_Advection_Scheme_Code      (name)
    call Control_Mod_Time_Integration_Scheme                          (name)
    mult % vof % td_scheme = Numerics_Mod_Time_Integration_Scheme_Code(name)
    call Control_Mod_Blending_Coefficient_For_Multiphase  (mult % vof % blend)
    call Control_Mod_Simple_Underrelaxation_For_Multiphase(mult % vof % urf)
    call Control_Mod_Tolerance_For_Multiphase_Solver      (mult % vof % tol)
    call Control_Mod_Preconditioner_For_System_Matrix     (mult % vof % precond)
    call Control_Mod_Max_Iterations_For_Multiphase_Solver (mult % vof % niter)
    ! Max Courant number and Max substep cycles
    call Control_Mod_Max_Courant_Vof(mult % courant_max_param)
    call Control_Mod_Max_Substep_Cycles_Vof(mult % n_sub_param)
    ! Max correction cycles for beta
    call Control_Mod_Max_Correction_Cycles_Beta_Vof(mult % corr_num_max)
    ! Max number convolution/smoothing steps for curvature and normal
    call Control_Mod_Max_Smoothing_Cycles_Curvature_Vof(mult % n_conv_curv)
    call Control_Mod_Max_Smoothing_Cycles_Normal_Vof(mult % n_conv_norm)
    ! Parameters for distance function
    call Control_Mod_Factor_Fictitious_Time_Vof(mult % c_tau)
    call Control_Mod_Factor_Number_Cells_Distance_Function_Vof(mult % c_eps)
    call Control_Mod_Distance_Function_Time_Integration_Scheme(name)
    mult % t_dist_scheme = Numerics_Mod_Time_Integration_Scheme_Code(name)
  end if

  !--------------------------------!
  !   Related to passive scalars   !
  !--------------------------------!
  do sc = 1, flow % n_scalars
    phi => flow % scalar(sc)
    phi % urf   = 0.7
    phi % niter = 5
    call Control_Mod_Advection_Scheme_For_Scalars              (name)
    phi % adv_scheme = Numerics_Mod_Advection_Scheme_Code      (name)
    call Control_Mod_Time_Integration_Scheme                   (name)
    phi % td_scheme = Numerics_Mod_Time_Integration_Scheme_Code(name)
    call Control_Mod_Blending_Coefficient_For_Scalars          (phi % blend)
    call Control_Mod_Simple_Underrelaxation_For_Scalars        (phi % urf)
    call Control_Mod_Tolerance_For_Scalars_Solver              (phi % tol)
    call Control_Mod_Preconditioner_For_System_Matrix          (phi % precond)
    call Control_Mod_Max_Iterations_For_Scalars_Solver         (phi % niter)
  end do

  !------------------------------!
  !   All turbuelnt quantities   !
  !------------------------------!
  do i = 1, 12
    if(i .eq.  1) tq => turb % kin
    if(i .eq.  2) tq => turb % eps
    if(i .eq.  3) tq => turb % zeta
    if(i .eq.  4) tq => turb % f22
    if(i .eq.  5) tq => turb % vis
    if(i .eq.  6) tq => turb % t2
    if(i .eq.  7) tq => turb % uu
    if(i .eq.  8) tq => turb % vv
    if(i .eq.  9) tq => turb % ww
    if(i .eq. 10) tq => turb % uv
    if(i .eq. 11) tq => turb % uw
    if(i .eq. 12) tq => turb % vw
    tq % urf   = 1.0
    tq % niter = 6
    call Control_Mod_Advection_Scheme_For_Turbulence          (name)
    tq % adv_scheme = Numerics_Mod_Advection_Scheme_Code      (name)
    call Control_Mod_Time_Integration_Scheme                  (name)
    tq % td_scheme = Numerics_Mod_Time_Integration_Scheme_Code(name)
    call Control_Mod_Blending_Coefficient_For_Turbulence      (tq % blend)
    call Control_Mod_Simple_Underrelaxation_For_Turbulence    (tq % urf)
    call Control_Mod_Tolerance_For_Turbulence_Solver          (tq % tol)
    call Control_Mod_Preconditioner_For_System_Matrix         (tq % precond)
    call Control_Mod_Max_Iterations_For_Turbulence_Solver     (tq % niter)
  end do

  end subroutine