!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!   mpgrafic - MPI version of N-body initial conditions grafic package   !
!   Copyright (C) 2008-2019 by Simon Prunet, Christophe Pichon et al     !
!   prunet iap.fr                                                        !
!                                                                        !
!   This program is free software; you can redistribute it and/or modify !
!   it under the terms of the GNU General Public License as published by !
!   the Free Software Foundation; either version 2 of the License, or    !
!   (at your option) any later version.                                  !
!                                                                        !
!   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, write to the                        !
!   Free Software Foundation, Inc.,                                      !
!     59 Temple Place - Suite 330, Boston, MA  02111-1307, USA           !
!   or see https://www.gnu.org/licenses/licenses.html#GPL .              !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
#include "../config.h"

program grafic1
  !  Generate initial conditions for cosmological N-body integration
  !  as a Gaussian random field.
  !  This version does not do constraints.  Instead, it produces output
  !  compatible with grafic2 for multiscale initial conditions.
  !  Disk use: lun=10 is output file, lun=11 is temp files.
  !
  use grafic_types
  use transform
  use grafic_io
  use normalize

  use iso_C_binding
  use wrap_rfftw3d_mod


  implicit none
#include "grafic1.inc"
#ifdef ADD1US
#define  rfftw3d_f77_create_plan  rfftw3d_f77_create_plan_
#define  rfftwnd_f77_destroy_plan rfftwnd_f77_destroy_plan_
#define  rfftwnd_f77_one_real_to_complex rfftwnd_f77_one_real_to_complex_
  /*
  mpgrafic-0.3.10 - shifted this routine to interface with iso_C_binding;
  #define  rfftw3d_f77_mpi_create_plan  rfftw3d_f77_mpi_create_plan_
  */
#define  rfftwnd_f77_mpi_destroy_plan rfftwnd_f77_mpi_destroy_plan_
#define  rfftwnd_f77_mpi rfftwnd_f77_mpi_
#define  rfftwnd_f77_mpi_local_sizes rfftwnd_f77_mpi_local_sizes_
#endif

  !c
  !c  Top grid size. This means the number of particles that
  !c  are to be placed at approximately regular intervals in the
  !c  1st, 2nd or 3rd orthogonal direction in the simulation box.
  !c  The total number of particles will be np1*np2*np3. Mpgrafic
  !c  normally outputs only the peculiar velocities of these particles;
  !c  the time evolution program should set particle positions
  !c  consistent with the Zel'dovich approximation.
  !c
  ! Can be overridden at ./configure stage, e.g.:
  ! CFLAGS="${CFLAGS} -DMPGRAFIC_NP_DEFAULT=1024" ./configure
#ifndef MPGRAFIC_NP_DEFAULT
#define MPGRAFIC_NP_DEFAULT 256
#endif

  integer :: np1 = MPGRAFIC_NP_DEFAULT
  integer :: np2 = MPGRAFIC_NP_DEFAULT
  integer :: np3 = MPGRAFIC_NP_DEFAULT
  integer io_status

#ifdef SING
  real(sp), dimension(:), allocatable :: f
#else
  real(dp), dimension(:), allocatable :: f
#endif
  real dx,x1o,x2o,x3o,xoff,fm
  integer irand,itide,m1s,m2s,m3s !,m1off,m2off,m3off
#ifdef HAVE_LIBGSL
  integer (c_int64_t) iseed
#else
  integer iseed
#endif
  integer m1t,m2t,m3t,m1offt,m2offt,m3offt
  !integer i1,i2,i3, l1,l2,l3, m1,m2,m3
  integer icomp,idim,nrefine
  integer ipad, nxs, nys, nzs
#ifdef HAVE_LIBGSL
  integer (c_int64_t) iseeds
#else
  integer iseeds
#endif
  !double precision lsigma
  double precision twopi,sigma,dsigma,rombin !,sigmadispl
  double precision dsigmadispl
  parameter (twopi=6.283185307179586d0)
  logical hanning

  ! The input parameter file can be named in the command line or piped from standard input.
#ifdef f2003
  use, intrinsic :: iso_fortran_env, only : input_unit
#else
#  define input_unit 5
#endif
  character(len=256) :: input_param_file
  integer :: input_param_file_id = 15
  integer :: infile_id = input_unit   ! By default, read from standard input.

  character(len=128) :: filename, small_file_name, small_kfile_name
  real astart,omegam,omegav,h0,dladt,fomega,vfact,pbar,pcdm
  real omegab,omegahdm,degen_hdm
  real asig,dxr,dpls,dplus,adp
  integer ierr, myid, status
  type(c_ptr) :: plan, iplan
  integer :: local_z_start,local_nz,local_y_start,local_ny
  integer :: nx, ny, nz
  integer :: total_local_size
  integer :: local_z_starts, local_nzs, local_y_starts, local_nys, total_local_sizes
  type(taille) :: headt, shtaille
  type(cosmo) :: headc, shcosmo
  character(len=128) :: outputfile

  character(len=256) :: command_line_arg1 ! so far very limited options
  character(len=256) :: command_line_arg2 ! so far very limited options
  logical :: help_only_arg = .false.

  common /cosmoparms/ omegam,omegav,h0
  common /cosmoparms2/ omegab,omegahdm,degen_hdm
  common /dsig/ asig,dxr
  external pbar,pcdm,dsigma,dsigmadispl,rombin,dplus,adp

  one_command_line_argument: if(command_argument_count() .gt. 0)then
     call get_command_argument(1,command_line_arg1)
     command_line_arg1 = trim(command_line_arg1)
     ! TODO: this is a minimal hack - consider the GNU argp library for more general options
     if(command_line_arg1 == '-V' .or. &
          command_line_arg1 == '--version')then
        help_only_arg = .true.
        write(*,'(a)')PACKAGE_STRING
        write(*,'(a)')'Written by Simon Prunet, Christophe Pichon et al.'
        write(*,'(a)')''
        write(*,'(a)')'Copyright (C) 2008-2019 Prunet, Pichon, Roukema.'
        write(*,'(a)')'This program is free software; you may redistribute it under the terms of'
        write(*,'(a)')'the GNU General Public License version 2 or later.  This program has'
        write(*,'(a)')'absolutely no warranty.'
     elseif(command_line_arg1 == '-h' .or. &
          command_line_arg1 == '-?' .or. &
          command_line_arg1 == '--help')then
        help_only_arg = .true.
        ! TODO: modularise this out to a documentation type file
        write(*,'(a)')'Usage: mpgrafic [OPTION...] [[<] INPUT_FILE] [> OUTPUT_FILE]'
        write(*,'(a)')''
        write(*,'(a)')'mpgrafic produces initial conditions files for N-body simulations of'
        write(*,'(a)')'cosmological large-scale structure formation. It is a free-licensed,'
        write(*,'(a)')"MPI-parallelised, rewritten version of Ed Bertschinger's grafic-1"
        write(*,'(a)')'program, producing output files in the grafic format. It includes'
        write(*,'(a)')'options for an Eisenstein and Hu baryonic wiggles power spectrum, for'
        write(*,'(a)')'using a low-resolution map for large-scale modes in the spirit of'
        write(*,'(a)')'grafic-2, and together with constrfield, can be used for generating'
        write(*,'(a)')'constrained initial conditions. Details are given in Prunet et al'
        write(*,'(a)')'(2008) http://cdsads.u-strasbg.fr/abs/2008ApJS..178..179P.'
        write(*,'(a)')''
        write(*,'(a)')'Most recent source code:'
        write(*,'(a)')'git clone https://broukema@bitbucket.org/broukema/mpgrafic.git'
        write(*,'(a)')''
        write(*,'(a)')' -?, --help        Give this help list'
        write(*,'(a)')'     --np=INTEGER  Number of particles per dimension (grid size will be INTEGER^3)'
        write(*,'(a)')'     --usage       Give a short usage message'
        write(*,'(a)')' -V, --version     Print program version'
     elseif(command_line_arg1 == '--usage')then
        help_only_arg = .true.
        write(*,'(a)')'Usage: mpgrafic [-?hV] [--np=INTEGER] [--help] [--usage]'
        write(*,'(a)')'            [--version] [[<] INPUT_FILE] [> OUTPUT_FILE]'
     elseif( command_line_arg1(1:5) == '--np=' .and. &
          len(command_line_arg1) .gt. 5 )then
        read(command_line_arg1(6:len(command_line_arg1)), &
             *,iostat=io_status) np1 ! allows 10^30-particle simulations...
        if(io_status.eq.0)then !override configured value
           np2 = np1
           np3 = np1
        else
           write(*,'(a)')'Warning: error reading option --np.'
        endif
     elseif( .not.(command_line_arg1(1:1) == '-') .and. &
          len(command_line_arg1) .gt. 0 )then
        ! assume that this is a filename
        input_param_file = trim(command_line_arg1)
        infile_id = input_param_file_id
     endif
     if(help_only_arg)then ! if valid command line argument found
        stop ! user only wants to know how to get started
     endif
  endif one_command_line_argument

  second_command_line_argument: if(command_argument_count() .gt. 1)then
     call get_command_argument(2,command_line_arg2)
     command_line_arg2 = trim(command_line_arg2)
     if( .not. (infile_id == input_param_file_id) .and. & ! if filename not yet found
          .not.(command_line_arg2(1:1) == '-') .and. & ! refuse filenames starting with '-'
          len(command_line_arg2) .gt. 0 )then ! refuse zero-length filenames
        ! assume that this is a filename
        input_param_file = trim(command_line_arg2)
        infile_id = input_param_file_id
     endif
  endif second_command_line_argument

  !
  call mpi_init(ierr)
  call mpi_comm_rank(mpi_comm_world,myid,ierr)
  if (myid==0) then
     print*
     print*,'Will generate initial conditions on grid of size ', &
          &     np1,np2,np3
     print*
  endif

  ! We follow grafic conventions: slowest varying index is nz
  ! The domain decomposition will be done in this direction
  nx=np1
  ny=np2
  nz=np3

  if (myid==0) then
     ! open file if stdin not used
     if(infile_id == input_param_file_id)then
        open(infile_id, file=input_param_file, access='sequential',&
             status='old', form='formatted')

     endif
  endif

  !
  !  Initialize power spectrum.
  call pini(infile_id)
  !  Initialize grid spacing.
  if (myid==0) then
     print*,'Enter dx (initial particle spacing in Mpc, not Mpc/h)'
     print*,'   or enter -boxlength in Mpc/h'
     print*,'   i.e. dx in Mpc if > 0, or -boxlength in Mpc/h if < 0'
     read(infile_id,*) dx
     write(*,'(f15.5)') dx
  endif
  call mpi_bcast(dx,1,mpi_real,0,mpi_comm_world,ierr)
  if (dx.lt.0.0) then
     dx=-dx*100./(h0*nx)
     if (myid==0) write(*,'(a,f15.5,a)') '  dx=',dx,' Mpc'
  end if

  !  Set astart based on smallest grid spacing.
  if (myid==0) then
     print*,'Enter 1 if these initial conditions will not be ', &
          &    'refined, otherwise'
     print*,'  enter the ultimate refinement factor for the ', &
          &    'smallest grid spacing'
     print*,'  (This is used only to set astart.)'
     read(infile_id,*) nrefine
     print*, nrefine
  endif
  call mpi_bcast(nrefine,1,mpi_integer,0,mpi_comm_world,ierr)
  if (nrefine.lt.1) then
     if (myid==0) print*,'Error! refinement factor must be >= 1'
     call mpi_finalize(ierr)
     stop
  end if
  if (nrefine.gt.1) then
     if (myid==0) print*,'nrefine>1 not implemented yet'
     call mpi_finalize(ierr)
     stop
  end if
  dxr=dx/nrefine
  asig=1.0d0
  sigma=2.0*twopi*rombin(dsigma,0.0d0,0.5d0*twopi/dxr,1.0d-7)
  !  This is sigma at a=1.
  sigma=sqrt(sigma)

!!!!!!!! ALL following !!$ are to remove R. Teyssier's astart and
!!!!!!!! sigma computations....

!!$  sigmadispl=2.0*twopi* &
!!$       &     rombin(dsigmadispl,twopi/dxr/np1,0.5d0*twopi/dxr,1.0d-7)
  !  This is sigma at a=1.
!!$  sigmadispl=sqrt(sigmadispl)
!!$  sigma=MAX(sigma,sigmadispl/dxr)
  !  Normalize so that rms density flutuation=sigstart at starting
  !  redshift scaling back the fluctuations as if they grew like cdm.
  dpls=sigstart/sigma*dplus(1.0,omegam,omegav)
  astart=adp(dpls,omegam,omegav)
  asig=astart
  sigma=2.0*twopi*rombin(dsigma,0.0d0,0.5d0*twopi/dxr,1.0d-7)
!!$  sigma=2.0*twopi*rombin(dsigma,twopi/dxr/np1,0.5d0*twopi/ &
!!$       &                         dxr,1.0d-7)
  sigma=sqrt(sigma)
  if (myid==0) then
     write(*,'(a,es15.5)') 'Scaling initial conditions to starting a=',astart
     write(*,'(a,es15.5)') '  when sigma(delta) at ultimate refinement scale=' &
          &  ,real(sigma)
  endif
  !sigmadispl=2.0*twopi*rombin(dsigmadispl,0.0d0,0.5d0*twopi/dxr,1.0d-7)
!!$  sigmadispl=2.0*twopi* &
!!$       &   rombin(dsigmadispl,twopi/dxr/np1,0.5d0*twopi/dxr,1.0d-7)
!!$  sigmadispl=sqrt(sigmadispl)
!!$  if (myid==0) then
!!$     print*,'  when sigma(displ) at ultimate refinement scale=', &
!!$          &    real(sigmadispl),' Mpc '
!!$     print*,'                                                 ', &
!!$          &    real(sigmadispl)/dxr,' dx'
!!$     print*
!!$  endif

!!!!!!!! END OF astart/sigma modifications. Code should be back to
!!!!!!!! original grafic1 starting conditions....


  !  velocity (proper km/s) =  Displacement (comoving Mpc at astart) * vfact.
  !  vfact = dln(D+)/dtau where tau=conformal time.
  vfact=fomega(astart,omegam,omegav) &
       &       *h0*dladt(astart,omegam,omegav)/astart
  if (myid==0) write(*,'(a,es15.5)') 'vfact=',vfact
  !
  !  Now set output parameters.  There are two cases:
  !  hanning=T: no further refinement.
  !  hanning=F: prepare for further refinement.
  !
  if (myid==0) then
     print*,'Enter 0 for final output or 1 for further refinement'
     read(infile_id,*) irand
     print*, irand
  endif
  call mpi_barrier(mpi_comm_world,ierr)
  call mpi_bcast(irand,1,mpi_integer,0,mpi_comm_world,ierr)

  if (irand.eq.1) then
     if (myid==0) print*,'Further refinement (input to grafic2) not implemented yet'
     call mpi_finalize(ierr)
     stop
  endif

!!$  if (irand.eq.1) then
!!$     hanning=.false.
!!$     if (myid==0) print*,'Enter size (n1c,n2c,n3c) of the level-1 subgrid ', &
!!$          &      'to be extracted.'
!!$     if (myid==0) print*,'  Sizes must be even numbers and be no larger than ', &
!!$          &      int(0.5*np1),int(0.5*np2),int(0.5*np3)
!!$     read(*,*) m1s,m2s,m3s
!!$     if (mod(m1s,2).ne.0.or.mod(m2s,2).ne.0.or.mod(m3s,2).ne.0) then
!!$        if (myid==0) print*,'Error! Sizes must be even numbers!'
!!$        call mpi_finalize(ierr)
!!$        stop
!!$     end if
!!$     if (2*m1s.gt.np1.or.2*m2s.gt.np2.or.2*m3s.gt.np3) then
!!$        if (myid==0) print*,'Error!  Subgrid is too large'
!!$        call mpi_finalize(ierr)
!!$        stop
!!$     end if
!!$     if (myid==0) then
!!$        print*,'Enter offset of level-1 subgrid (m1off,m2off,m3off).'
!!$        print*,'  Offsets are relative to level-0 grid corner.'
!!$        print*,'  Offsets may be positive or negative, with absolute ', &
!!$             & ' values no larger than',int(0.5*np1),int(0.5*np2),int(0.5*np3)
!!$     endif
!!$     read(*,*) m1off,m2off,m3off
!!$     !  Now get coordinates for tidal volume.
!!$     if (myid==0) print*,'Enter size (m1t,m2t,m3t) of the final subvolume, ', &
!!$          &      'in units of top grid spacing'
!!$     read(*,*) m1t,m2t,m3t
!!$     if (m1t.gt.m1s.or.m2t.gt.m2s.or.m3t.gt.m3s) then
!!$        if (myid==0) print*,'Error! Final subvolume cannot be larger than ', &
!!$             &        'level-1 subgrid'
!!$        call mpi_finalize(ierr)
!!$        stop
!!$     end if
!!$     if (myid==0) then
!!$        print*,'Enter offset of final subvolume (m1offt,m2off2,m3offt).'
!!$        print*,'  Offsets are relative to level-0 grid corner.'
!!$        print*,'  Final subvolume must lie within level-1 subgrid'
!!$     endif
!!$     read(*,*) m1offt,m2offt,m3offt
!!$     if (m1offt.lt.m1off.or.m1offt+m1t.gt.m1off+m1s.or. &
!!$          &        m2offt.lt.m2off.or.m2offt+m2t.gt.m2off+m2s.or. &
!!$          &        m3offt.lt.m3off.or.m3offt+m3t.gt.m3off+m3s) then
!!$        if (myid==0) print*,'Error! Final subvolume isn''t contained within ', &
!!$             &             'level-1 subgrid'
!!$        call mpi_finalize(ierr)
!!$        stop
!!$     end if
!!$     !  Coordinates of the subgrid corner.
!!$     x1o=m1off*dx
!!$     x2o=m2off*dx
!!$     x3o=m3off*dx
!!$     if (myid==0) then
!!$        print*,'Grafic1 will output level-1 subgrid as follows:'
!!$        print*,'  xmin, xmax = ',x1o,x1o+m1s*dx
!!$        print*,'  ymin, ymax = ',x2o,x2o+m2s*dx
!!$        print*,'  zmin, zmax = ',x3o,x3o+m3s*dx
!!$        print*,'Grafic1 will compute tides assuming final subvolume:'
!!$        print*,'  xmin, xmax = ',m1offt*dx,(m1offt+m1t)*dx
!!$        print*,'  ymin, ymax = ',m2offt*dx,(m2offt+m2t)*dx
!!$        print*,'  zmin, zmax = ',m3offt*dx,(m3offt+m3t)*dx
!!$     endif
!!$     !  Open output file and write header.
!!$     open(10,file='grafic2.top',form='unformatted',status='unknown')
!!$     rewind 10
!!$     write(10)  2*m1s,2*m2s,2*m3s,dx,x1o,x2o,x3o,m1t,m2t,m3t, &
!!$          &      m1offt-m1off,m2offt-m2off,m3offt-m3off,hanning,astart, &
!!$          &      omegam,omegav,h0
!!$     if (myid==0) print*,'Output file is grafic2.top; use as input to subsequent', &
!!$          &           ' run of grafic2'
!!$  else
  hanning=.false.
  m1s=np1 !Unused here...
  m2s=np2 !Unused here...
  m3s=np3 !Unused here...
  x1o=0.0
  x2o=0.0
  x3o=0.0
  if (myid==0) then
     print*,'Setting output grid to ',m1s,m2s,m3s
     print*,'Enter <RETURN> to skip output grid size'
     read(infile_id,*)
     print*,'Enter <RETURN> to skip output grid offset'
     read(infile_id,*)
     print*,'Enter <RETURN> to skip final grid size'
     read(infile_id,*)
     print*,'Enter <RETURN> to skip final grid offset'
     read(infile_id,*)
     print*,'Will produce output files ic_deltab, ic_velb[xyz],', &
          &           ' ic_velc[xyz]'
  endif
!!$end if
  call mpi_barrier(mpi_comm_world,ierr)
  !  Set parameters for subgrid noise.
  if (myid==0) then
     print*
     print*,'Subgrid white noise:'
     print*,'  Choose irand (1 or 2) from the following list:'
     !  print*,'    irand=0 to generate new noise and don''t save it'
     print*,'    irand=1 to generate new noise and save to file'
     print*,'    irand=2 to read noise from existing file'
     print*,'Enter irand'
     read(infile_id,*) irand
     print*, irand
  endif
  call mpi_barrier(mpi_comm_world,ierr)
  call mpi_bcast(irand,1,mpi_integer,0,mpi_comm_world,ierr)
  if (irand.lt.0.or.irand.gt.2) then
     if (myid==0) print*,'Illegal value of irand'
     call mpi_finalize(ierr)
     stop
  end if

  if (myid==0) then
     print*,'  Enter random number seed (9-digit integer, ignored ', &
          &    'if irand=2)'
     read(infile_id,*) iseed
     write(*,'(i12)') iseed
  endif
  call mpi_barrier(mpi_comm_world,ierr)
#ifdef HAVE_LIBGSL
  call mpi_bcast(iseed,1,mpi_integer8,0,mpi_comm_world,ierr)
#else
  call mpi_bcast(iseed,1,mpi_integer,0,mpi_comm_world,ierr)
#endif
  filename=''
  if (myid==0) then
     print*,'  Enter filename of white noise file (or <RETURN> ', &
          &    'if irand=0)'
     read(infile_id,'(a)') filename
     print*,filename
  endif
  call mpi_barrier(mpi_comm_world,ierr)
  ! filename='white.dat'
  ! filename is needed by other cpus (to read or write)
  call mpi_bcast(filename,128,mpi_character,0,mpi_comm_world,ierr)
  ! print*,'in mpgrafic, filename is ','***'//trim(filename)//'***'

  ! Ask if padding of small k modes is required
  if (myid==0) then
     print*,' Enter 1 if padding of large scales is required, 0 otherwise'
     read(infile_id,*) ipad
     print*, ipad
  endif
  call mpi_barrier(mpi_comm_world,ierr)
  call mpi_bcast(ipad,1,mpi_integer,0,mpi_comm_world,ierr)
  small_file_name=''
  if (myid==0) then
     print*,' Enter padding file name (white noise format, ignored if ipad=0)'
     read(infile_id,'(a)') small_file_name
     print*, small_file_name

     ! close file if stdin not used
     if(infile_id == input_param_file_id)then
        close(infile_id)
     endif
  endif
  call mpi_barrier(mpi_comm_world,ierr)
  call mpi_bcast(small_file_name,128,mpi_character,0,mpi_comm_world,ierr)

  ! Compute small k modes from small file and store them, if needed
  small_kfile_name='ksmall'
  if (ipad==1) then
     if (myid==0) then
        print*,' Will compute the large scales from file ', trim(small_file_name)
        print*,' Beware that the large scales are assumed to be prewhitened, '
        print*,' and that the constraints are assumed to be imposed with the same '
        print*,' power spectrum: cosmologies of small and large k modes need to be '
        print*,' consistent...'
     endif
!!$     call grafic_read_header(small_file_name,shtaille,shcosmo)
!!$     nxs=shtaille%nx
!!$     nys=shtaille%ny
!!$     nzs=shtaille%nz
     call grafic_read_header_white(small_file_name,nxs,nys,nzs,iseeds)
     call rfftw3d_f77_mpi_create_plan_c_wrap(plan,mpi_comm_world,nxs,nys,nzs, &
          & fftw_real_to_complex,fftw_estimate)
     call rfftwnd_f77_mpi_local_sizes(plan,local_nzs,local_z_starts, &
          & local_nys, local_y_starts, total_local_sizes)
     allocate(f(total_local_sizes))
     call grafic_read(f,local_nzs,local_z_starts,nys,nxs,small_file_name,white_in=.true.)
     ! Make sure avg is 0 and rms is 1
#ifndef NO_NORM_WHITE
     call mpnorm(local_nzs,nzs,nys,nxs,total_local_sizes,f)
#endif
     ! Normalise a la Bertschinger
     f = f/sqrt(real(nxs*nys,dp)*nzs)
     call fft_mpi(plan,f,total_local_sizes)
     ! Scale small grid power to large grid
     ! f = f*real(np1*np2,dp)*np3/real(nxs*nys*nzs,dp)
     call rfftwnd_f77_mpi_destroy_plan(plan)
     shtaille%nx=nxs
     shtaille%ny=nys
     shtaille%nz=nzs
     if (myid==0) call grafic_write_header(small_kfile_name,shtaille, &
          & shcosmo)
     call mpi_barrier(mpi_comm_world,ierr)
     call grafic_write(f,local_nzs,local_z_starts,nys,nxs,small_kfile_name, &
          & padding_in=.true.)
     deallocate(f)
  endif

  ! Compute local buffer size from total grid size, and prepare fftw
  ! plans. Beware that domain decomposition is done along nx...
  ! (Slowest varying dimension in the array)

  call rfftw3d_f77_mpi_create_plan_c_wrap(plan,mpi_comm_world,nx,ny,nz, &
       fftw_real_to_complex, fftw_estimate)
  call rfftw3d_f77_mpi_create_plan_c_wrap(iplan,mpi_comm_world,nx,ny,nz, &
       fftw_complex_to_real, fftw_estimate)
  call rfftwnd_f77_mpi_local_sizes(plan,local_nz,local_z_start,local_ny, &
       local_y_start,total_local_size)

  if (total_local_size <= 0) then
        if (myid==0) then
          print*,'Beware: size of local buffers does not fit in 4 bits !'
          print*,'Use with a bigger number of processes ...'
          print*,'Aborting'
        endif
     call mpi_finalize(ierr)
     stop

  endif
!
  !  Outer loop over components to be refined.
  !
  do icomp=0,12
     !  0: baryon density.
     !  1,2: inner,outer baryon x-velocity.
     !  3,4: inner,outer baryon y-velocity.
     !  5,6: inner,outer baryon z-velocity.
     !  7,8: inner,outer CDM x-velocity.
     !  9,10: inner,outer CDM y-velocity.
     !  11,12: inner,outer CDM z-velocity.
     !
     !  If not generating grafic2.dat for further refinement, and
     !    if icomp=odd, then skip.
     if (mod(icomp,2).eq.1) cycle
     !
     !  Optional half-grid offset to velocity fields.
     if (icomp.gt.0.and.icomp.le.6) then
        xoff=0.5*dx*offvelb
     else if (icomp.gt.6) then
        xoff=0.5*dx*offvelc
     else
        xoff=0.0
     end if
     !  Don't need to recompute random numbers.
     if (icomp.gt.0.and.irand.eq.1) irand=2
     !
     !  Generate random fields.  idim=0,1,2,3 for density, displacement.
     itide=0
     if (mod(icomp,2).eq.0) then
        idim=icomp/2
        !  Outer case.
        ! if (.not.hanning.and.idim.gt.0) itide=1
     else
        !  Inner case.
        idim=(icomp+1)/2
        ! if (.not.hanning.and.idim.gt.0) itide=-1
     end if
     allocate(f(total_local_size),stat=status)
     if (status /= 0) then
        print*,'Could not allocate array, aborting'
        call mpi_finalize(ierr)
        stop
     endif
     ! First Feed the headers...
     headt%nx=np1
     headt%ny=np2
     headt%nz=np3
     headt%dx=dx
     headt%lx=x1o+xoff
     headt%ly=x2o+xoff
     headt%lz=x3o+xoff
     headc%astart=astart
     headc%omegam=omegam
     headc%omegav=omegav
     headc%h0=h0

     if (idim.le.3) then
        call mpic4(idim,irand,iseed,itide,m1t,m2t,m3t,m1offt,m2offt, &
             &     m3offt,hanning,filename,astart,pbar,dx,xoff,f,fm, &
             &     plan,iplan,local_nz,local_z_start,total_local_size, &
             &     headt,headc,small_kfile_name,ipad, &
             &     np1,np2,np3)
     else
        idim=idim-3
        call mpic4(idim,irand,iseed,itide,m1t,m2t,m3t,m1offt,m2offt, &
             &     m3offt,hanning,filename,astart,pcdm,dx,xoff,f,fm, &
             &     plan,iplan,local_nz,local_z_start,total_local_size, &
             &     headt,headc,small_kfile_name,ipad, &
             &     np1,np2,np3)
     end if

     !
     !  Prepare data for output.
     !
     if (.true.) then
        ! For a version of RAMSES much older than 2013, you may have
        ! to comment out the following line; however, using such an
        ! out-of-date version of RAMSES would be unwise.
        if (idim > 0) f = f*vfact
        ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

        !  Output files.
        if (icomp.eq.0) then
           outputfile='ic_deltab'
        else if (icomp.eq.2) then
           outputfile='ic_velbx'
        else if (icomp.eq.4) then
           outputfile='ic_velby'
        else if (icomp.eq.6) then
           outputfile='ic_velbz'
        else if (icomp.eq.8) then
           outputfile='ic_velcx'
        else if (icomp.eq.10) then
           outputfile='ic_velcy'
        else if (icomp.eq.12) then
           outputfile='ic_velcz'
        end if
        if (myid==0) then
           headt%nx=np1
           headt%ny=np2
           headt%nz=np3
           headt%dx=dx
           headt%lx=x1o+xoff
           headt%ly=x2o+xoff
           headt%lz=x3o+xoff
           headc%astart=astart
           headc%omegam=omegam
           headc%omegav=omegav
           headc%h0=h0
           call grafic_write_header(outputfile,headt,headc)
        endif
        call mpi_barrier(mpi_comm_world,ierr)
        call grafic_write(f,local_nz,local_z_start,ny,nx,outputfile)
     endif ! subgrid is not implemented...

!!$  else
!!$     !  hanning=F, extract next-level subgrid and append to grafic2.dat.
!!$     !  First surround subvolume with 1/2-size buffer and wrap periodically.
!!$     sigma=0.0
!!$     do m3=1,2*m3s
!!$        i3=m3+m3off
!!$        !  Periodic boundary conditions on top grid.
!!$        if (i3.lt.1) i3=i3+np3
!!$        if (i3.gt.np3) i3=i3-np3
!!$        l3=i3
!!$        if (m3.gt.1.5*m3s) l3=l3-2*m3s
!!$        if (l3.lt.1) l3=l3+np3
!!$        do m2=1,2*m2s
!!$           i2=m2+m2off
!!$           if (i2.lt.1) i2=i2+np2
!!$           if (i2.gt.np2) i2=i2-np2
!!$           l2=i2
!!$           if (m2.gt.1.5*m2s) l2=l2-2*m2s
!!$           if (l2.lt.1) l2=l2+np2
!!$           do m1=1,2*m1s
!!$              i1=m1+m1off
!!$              if (i1.lt.1) i1=i1+np1
!!$              if (i1.gt.np1) i1=i1-np1
!!$              l1=i1
!!$              if (m1.gt.1.5*m1s) l1=l1-2*m1s
!!$              if (l1.lt.1) l1=l1+np1
!!$              slice(m1,m2)=f(l1,l2,l3)
!!$              sigma=sigma+f(l1,l2,l3)**2
!!$           end do
!!$        end do
!!$        write(10) ((slice(m1,m2),m1=1,2*m1s),m2=1,2*m2s)
!!$     end do
!!$     sigma=sqrt(sigma/(8*m1s*m2s*m3s))
!!$     if (myid==0) print*,'After extraction, component ',icomp, &
!!$          &      ' has subvolume RMS=',real(sigma)
!!$  end if
     !  End loop over icomp.
     deallocate(f)
  enddo
  !
!!$if (.not.hanning) close(10)
  call mpi_finalize(ierr)
  stop
end program grafic1

  !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
function dsigma(ak)
  !  This function calculates the variance of density with a Hanning
  !  filter at the grid Nyquist frequency.
  !
  implicit none
  double precision dsigma,ak
  real asig,dx,p
  common /dsig/ asig,dx
  external p
  !
  if (ak.le.0.0d0.or.ak.gt.3.1415926535898d0/dx) then
     dsigma=0.0d0
     return
  end if
  !  Hanning filter.
  dsigma=ak*ak*p(real(ak),asig)*cos(0.5*ak*dx)
  !
  return
end function dsigma

  !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
function dsigmadispl(ak)
  !  This function calculates the variance of displacement with a Hanning
  !  filter at the grid Nyquist frequency.
  !
  implicit none
  double precision dsigmadispl,ak
  real asig,dx,p
  common /dsig/ asig,dx
  external p
  !
  if (ak.le.0.0d0.or.ak.gt.3.1415926535898d0/dx) then
     dsigmadispl=0.0d0
     return
  end if
  !  Hanning filter.
  dsigmadispl=ak*ak*p(real(ak),asig)/ak/ak/3.*cos(0.5*ak*dx)
  !
  return
end function dsigmadispl
