module test

  contains

    INTEGER::current_size=0
    TYPE(fft_type_descriptor),INTENT(in)::desc
    INTEGER,OPTIONAL,INTENT(IN)::howmany
    INTEGER::howmany_
    INTEGER::info
    CHARACTER(LEN=*),INTENT(IN)::calling_routine,message
    INTEGER,INTENT(IN)::ierr
    CHARACTER(LEN=6)::cerr
    INTEGER::info
    TYPE(fft_type_descriptor),INTENT(IN)::dfft
    CHARACTER(LEN=*),INTENT(IN)::fft_kind
    INTEGER,OPTIONAL,INTENT(IN)::howmany
    INTEGER::howmany_=1
    CHARACTER(LEN=12)::clock_label
    TYPE(fft_type_descriptor),INTENT(IN)::dfft
    CHARACTER(LEN=*),INTENT(IN)::fft_kind
    INTEGER,OPTIONAL,INTENT(IN)::howmany
    INTEGER::howmany_=1
    CHARACTER(LEN=12)::clock_label
    TYPE(fft_box_descriptor),INTENT(IN)::dfft
    INTEGER,INTENT(IN)::ia
    TYPE(fft_type_descriptor),INTENT(IN)::dfft
    CHARACTER(LEN=*),INTENT(IN)::fft_kind
    INTEGER,OPTIONAL,INTENT(IN)::howmany
    INTEGER(kind=cuda_stream_kind),OPTIONAL,INTENT(IN)::stream
    INTEGER::howmany_=1
    INTEGER(kind=cuda_stream_kind)::stream_=0
    CHARACTER(LEN=12)::clock_label
    TYPE(fft_type_descriptor),INTENT(IN)::dfft
    CHARACTER(LEN=*),INTENT(IN)::fft_kind
    INTEGER,OPTIONAL,INTENT(IN)::howmany
    INTEGER(kind=cuda_stream_kind),OPTIONAL,INTENT(IN)::stream
    INTEGER::howmany_=1
    INTEGER(kind=cuda_stream_kind)::stream_=0
    CHARACTER(LEN=12)::clock_label
    TYPE(fft_type_descriptor),INTENT(inout)::dfft
    INTEGER::ng,n1,n2,n3
    TYPE(fft_type_descriptor),INTENT(in)::desc
    INTEGER,INTENT(IN)::ispin
    LOGICAL,INTENT(IN)::noncolin,domag
    INTEGER::ierr,ioff,idx,ir3,ir,ipol,ioff_tg,nxyp,npol_
    TYPE(fft_type_descriptor),INTENT(in)::desc
    INTEGER,INTENT(IN)::ispin
    INTEGER::ierr,ioff,idx,ir3,nxyp,ioff_tg
    TYPE(fft_type_descriptor),INTENT(in)::desc
    INTEGER::ierr,from,ir3,ioff,nxyp,ioff_tg
    TYPE(fft_type_descriptor),INTENT(in)::desc
    INTEGER::ierr,from,ir3,ioff,nxyp,ioff_tg
    TYPE(fft_type_descriptor),INTENT(in)::desc
    INTEGER::ierr,from,ir3,ioff,nxyp,ioff_tg
    TYPE(fft_type_descriptor),INTENT(in)::desc
    INTEGER,INTENT(OUT)::right_nnr
    TYPE(fft_type_descriptor),INTENT(in)::desc
    INTEGER,INTENT(OUT)::val
    TYPE(fft_type_descriptor),INTENT(in)::desc
    INTEGER,INTENT(OUT)::val
    TYPE(fft_type_descriptor),INTENT(in)::desc
    INTEGER,INTENT(OUT)::val
    INTEGER::fftx_ntgrp
    TYPE(fft_type_descriptor),INTENT(in)::desc
    INTEGER::fftx_tgpe
    TYPE(fft_type_descriptor),INTENT(in)::desc
    INTEGER::fftx_tgcomm
    TYPE(fft_type_descriptor),INTENT(in)::desc
    TYPE(fft_type_descriptor),INTENT(in)::desc
    INTEGER::nspin,ir
    TYPE(fft_type_descriptor),INTENT(in)::desc
    integer::ig
    TYPE(fft_type_descriptor),INTENT(in)::desc
    integer::ig
    TYPE(fft_type_descriptor),INTENT(in)::desc
    integer::ig
    TYPE(fft_type_descriptor),INTENT(in)::desc
    COMPLEX(DP)::fp,fm
    INTEGER::ig
    TYPE(fft_type_descriptor),INTENT(in)::desc
    COMPLEX(DP)::fp,fm
    INTEGER::ig
    TYPE(fft_type_descriptor),INTENT(in)::desc
    COMPLEX(DP)::fp,fm
    INTEGER::ig
    TYPE(fft_type_descriptor),INTENT(in)::desc
    INTEGER,INTENT(IN)::i,nbsp_bgrp
    INTEGER::eig_offset,eig_index,right_nnr
    INTEGER,INTENT(IN)::unit
    TYPE(fft_type_descriptor),INTENT(in)::desc
    INTEGER::i,j,nr3l
    CHARACTER(LEN=*),INTENT(IN)::fft_kind
    TYPE(fft_type_descriptor),INTENT(IN)::dfft
    INTEGER,OPTIONAL,INTENT(IN)::howmany
    INTEGER,INTENT(IN)::ia
    TYPE(fft_box_descriptor),INTENT(IN)::dfft
    CHARACTER(LEN=*),INTENT(IN)::grid_type
    TYPE(fft_type_descriptor),INTENT(IN)::dfft
    INTEGER,OPTIONAL,INTENT(IN)::howmany
    INTEGER(kind=cuda_stream_kind),OPTIONAL,INTENT(IN)::stream
    CHARACTER(LEN=*),INTENT(IN)::fft_kind
    TYPE(fft_type_descriptor),INTENT(IN)::dfft
    INTEGER,OPTIONAL,INTENT(IN)::howmany
    CHARACTER(LEN=*),INTENT(IN)::grid_type
    TYPE(fft_type_descriptor),INTENT(IN)::dfft
    INTEGER,OPTIONAL,INTENT(IN)::howmany
    INTEGER(kind=cuda_stream_kind),OPTIONAL,INTENT(IN)::stream
    TYPE(fft_type_descriptor),INTENT(IN)::dfft_in,dfft_out
    TYPE(fft_type_descriptor),INTENT(IN)::dfft_in,dfft_out
    TYPE(fft_type_descriptor),INTENT(IN)::dfft_in,dfft_out
    INTEGER::ngm
    TYPE(fft_type_descriptor),INTENT(IN)::dfft_in,dfft_out
    INTEGER::ngm
    TYPE(fft_type_descriptor),INTENT(in)::dfft
    INTEGER,INTENT(in)::isgn
    INTEGER::n1,n2,n3,nx1,nx2,nx3
    INTEGER::nnr_
    INTEGER::nsticks_x,nsticks_y,nsticks_z
    INTEGER::i
    TYPE(fft_type_descriptor),INTENT(in)::dfft
    INTEGER,INTENT(in)::isgn
    INTEGER::n1,n2,n3,nx1,nx2,nx3
    INTEGER::nnr_
    INTEGER::nsticks_x,nsticks_y,nsticks_z
    INTEGER::ierr,i
    INTEGER(kind=cuda_stream_kind)::stream=0
    TYPE(fft_type_descriptor),INTENT(in)::dfft
    INTEGER,INTENT(in)::isgn
    INTEGER,INTENT(in)::howmany
    INTEGER::n1,n2,n3,nx1,nx2,nx3
    INTEGER::nnr_
    INTEGER::nsticks_x,nsticks_y,nsticks_z
    INTEGER::nsticks_zx
    INTEGER::ierr,i,j
    INTEGER::nstreams
    INTEGER(kind=cuda_stream_kind)::stream=0
    TYPE(fft_type_descriptor),INTENT(IN)::dfft
    INTEGER,INTENT(IN)::i,j,k
    INTEGER::kk,ii,jj,ip,ierr
    COMPLEX(DP)::f_aux
    TYPE(fft_type_descriptor),INTENT(IN)::dfft
    INTEGER,INTENT(IN)::i,j,k
    COMPLEX(DP),INTENT(IN)::f_in
    INTEGER::kk,ii,jj,ip,ierr
    INTEGER,INTENT(IN)::i,j,k
    TYPE(fft_type_descriptor),INTENT(IN)::dfft
    INTEGER::ii,jj,ip,ierr
    COMPLEX(DP)::f_aux
    COMPLEX(DP),INTENT(IN)::f_in
    INTEGER,INTENT(IN)::i,j,k
    TYPE(fft_type_descriptor),INTENT(IN)::dfft
    INTEGER::ii,jj
    TYPE(fft_type_descriptor),INTENT(in)::dfft
    INTEGER,INTENT(in)::isgn
    INTEGER::me_p
    INTEGER::n1,n2,n3,nx1,nx2,nx3
    INTEGER,INTENT(in)::iopt
    INTEGER,INTENT(in)::iopt
    TYPE(fft_type_descriptor),INTENT(in)::dfft
    INTEGER,INTENT(in)::isgn
    INTEGER::me_p,istat
    INTEGER::n1,n2,n3,nx1,nx2,nx3
    INTEGER(kind=cuda_stream_kind)::stream=0
    INTEGER,INTENT(in)::iopt
    INTEGER,INTENT(in)::iopt
    TYPE(fft_type_descriptor),INTENT(in)::dfft
    INTEGER,INTENT(in)::isgn
    INTEGER,INTENT(in)::batchsize
    INTEGER::me_p,istat,i,j,currsize
    INTEGER::n1,n2,n3,nx1,nx2,nx3,ncpx,nppx,proc
    INTEGER(kind=cuda_stream_kind)::stream=0
    INTEGER,PARAMETER::MPI_COMM_NULL=0
    INTEGER,PARAMETER::ndims=10
    INTEGER,PARAMETER::nfftx=2049
    INTEGER,PARAMETER::stdout=6
    REAL(DP),PARAMETER::eps8=1.0E-8_DP
    INTEGER,INTENT(IN)::isign
    INTEGER,INTENT(IN)::nsl,nz,ldz
    REAL(DP)::tscale
    INTEGER::i,err,idir,ip,void
    INTEGER,SAVE::icurrent=1
    LOGICAL::found
    INTEGER::tid
    INTEGER::offset,ldz_t
    INTEGER::omp_get_max_threads
    INTEGER,PARAMETER::ltabl=3*nfftx+100
    INTEGER::INFO
    INTEGER,INTENT(IN)::isign,ldx,ldy,nx,ny,nzl
    INTEGER::i,k,j,err,idir,ip,kk,void
    REAL(DP)::tscale
    INTEGER,SAVE::icurrent=1
    INTEGER,PARAMETER::stdout=6
    INTEGER::offset
    INTEGER::nx_t,ny_t,nzl_t,ldx_t,ldy_t
    INTEGER::itid,mytid,ntids
    INTEGER::omp_get_thread_num,omp_get_num_threads,omp_get_max_threads
    INTEGER,PARAMETER::ltabl=3*nfftx+100
    INTEGER::INFO
    INTEGER,INTENT(IN)::nx,ny,nz,ldx,ldy,ldz,howmany,isign
    INTEGER::i,k,j,err,idir,ip
    REAL(DP)::tscale
    INTEGER,SAVE::icurrent=1
    INTEGER,PARAMETER::ltabl=4*nfftx+300
    INTEGER::INFO
    integer::nx,ny,nz,ldx,ldy,ldz,howmany,isign
    integer::m,incx1,incx2
    INTEGER::i,k,j,err,idir,ip,ii,jj
    REAL(DP)::tscale
    INTEGER,SAVE::icurrent=1
    INTEGER,PARAMETER::ltabl=3*nfftx+100
    INTEGER::INFO
    TYPE(DFTI_DESCRIPTOR),POINTER::desc
    INTEGER,INTENT(IN)::isign
    INTEGER,INTENT(IN)::nsl,nz,ldz
    REAL(DP)::tscale
    INTEGER::i,err,idir,ip,void
    INTEGER,SAVE::icurrent=1
    LOGICAL::found
    INTEGER::tid
    INTEGER::offset,ldz_t
    INTEGER::omp_get_max_threads
    LOGICAL,SAVE::dfti_first=.TRUE.
    INTEGER::dfti_status=0
    INTEGER,INTENT(IN)::isign,ldx,ldy,nx,ny,nzl
    INTEGER::i,k,j,err,idir,ip,kk,void
    REAL(DP)::tscale
    INTEGER,SAVE::icurrent=1
    INTEGER,PARAMETER::stdout=6
    INTEGER::offset
    INTEGER::nx_t,ny_t,nzl_t,ldx_t,ldy_t
    INTEGER::itid,mytid,ntids
    INTEGER::omp_get_thread_num,omp_get_num_threads,omp_get_max_threads
    LOGICAL,SAVE::dfti_first=.TRUE.
    INTEGER::dfti_status=0
    INTEGER,INTENT(IN)::nx,ny,nz,ldx,ldy,ldz,howmany,isign
    INTEGER::i,k,j,err,idir,ip
    REAL(DP)::tscale
    INTEGER,SAVE::icurrent=1
    LOGICAL,SAVE::dfti_first=.TRUE.
    INTEGER::dfti_status=0
    integer::nx,ny,nz,ldx,ldy,ldz,isign,howmany
    INTEGER,INTENT(IN)::isign
    INTEGER,INTENT(IN)::nsl,nz,ldz
    REAL(DP)::tscale
    INTEGER::i,err,idir,ip,void
    INTEGER,SAVE::icurrent=1
    LOGICAL::done
    INTEGER::tid
    INTEGER::offset,ldz_t
    INTEGER::omp_get_max_threads
    INTEGER,PARAMETER::ltabl=20000+3*nfftx
    INTEGER,INTENT(IN)::isign,ldx,ldy,nx,ny,nzl
    INTEGER::i,k,j,err,idir,ip,kk,void
    REAL(DP)::tscale
    INTEGER,SAVE::icurrent=1
    INTEGER,PARAMETER::stdout=6
    INTEGER::offset
    INTEGER::nx_t,ny_t,nzl_t,ldx_t,ldy_t
    INTEGER::itid,mytid,ntids
    INTEGER::omp_get_thread_num,omp_get_num_threads,omp_get_max_threads
    INTEGER,PARAMETER::ltabl=20000+3*nfftx
    INTEGER,INTENT(IN)::nx,ny,nz,ldx,ldy,ldz,howmany,isign
    INTEGER::i,k,j,err,idir,ip
    REAL(DP)::tscale
    INTEGER,SAVE::icurrent=1
    integer::nx,ny,nz,ldx,ldy,ldz,howmany,isign
    integer::m,incx1,incx2
    INTEGER::i,k,j,err,idir,ip,ii,jj
    REAL(DP)::tscale
    INTEGER,SAVE::icurrent=1
    INTEGER,PARAMETER::ltabl=20000+3*nfftx
    INTEGER,INTENT(IN)::isign
    INTEGER,INTENT(IN)::nsl,nz,ldz
    REAL(DP)::tscale
    INTEGER::i,err,idir,ip,void
    INTEGER,SAVE::icurrent=1
    LOGICAL::found
    INTEGER::tid
    INTEGER::offset,ldz_t
    INTEGER::omp_get_max_threads
    INTEGER,INTENT(IN)::isign,ldx,ldy,nx,ny,nzl
    INTEGER::i,k,j,err,idir,ip,kk,void
    REAL(DP)::tscale
    INTEGER,SAVE::icurrent=1
    INTEGER,PARAMETER::stdout=6
    INTEGER::offset
    INTEGER::nx_t,ny_t,nzl_t,ldx_t,ldy_t
    INTEGER::itid,mytid,ntids
    INTEGER::omp_get_thread_num,omp_get_num_threads,omp_get_max_threads
    INTEGER,INTENT(IN)::nx,ny,nz,ldx,ldy,ldz,howmany,isign
    INTEGER::i,k,j,err,idir,ip
    REAL(DP)::tscale
    INTEGER,SAVE::icurrent=1
    integer::nx,ny,nz,ldx,ldy,ldz,howmany,isign
    integer::m,incx1,incx2
    INTEGER::i,k,j,err,idir,ip,ii,jj,h,ldh
    REAL(DP)::tscale
    INTEGER,SAVE::icurrent=1
    INTEGER,INTENT(IN)::isign
    INTEGER,INTENT(IN)::nsl,nz,ldz
    REAL(DP)::tscale
    INTEGER::i,err,idir,ip,void
    INTEGER,SAVE::icurrent=1
    LOGICAL::done
    INTEGER::tid
    INTEGER::offset,ldz_t
    INTEGER::omp_get_max_threads
    INTEGER,INTENT(IN)::isign,ldx,ldy,nx,ny,nzl
    INTEGER::i,k,j,err,idir,ip,kk,void
    REAL(DP)::tscale
    INTEGER,SAVE::icurrent=1
    INTEGER,PARAMETER::stdout=6
    INTEGER::offset
    INTEGER::nx_t,ny_t,nzl_t,ldx_t,ldy_t
    INTEGER::itid,mytid,ntids
    INTEGER::omp_get_thread_num,omp_get_num_threads,omp_get_max_threads
    INTEGER,INTENT(IN)::nx,ny,nz,ldx,ldy,ldz,howmany,isign
    INTEGER::i,k,j,err,idir,ip
    REAL(DP)::tscale
    INTEGER,SAVE::icurrent=1
    INTEGER,PARAMETER::stdout=6
    integer::nx,ny,nz,ldx,ldy,ldz,howmany,isign
    integer::m,incx1,incx2
    INTEGER::i,k,j,err,idir,ip,ii,jj
    REAL(DP)::tscale
    INTEGER,SAVE::icurrent=1
    INTEGER,INTENT(IN)::isign
    INTEGER,INTENT(IN)::nsl,nz,ldz
    REAL(DP)::tscale
    INTEGER::i,err,idir,ip,void
    INTEGER,SAVE::icurrent=1
    LOGICAL::done
    INTEGER::tid
    INTEGER::offset,ldz_t
    INTEGER::omp_get_max_threads
    INTEGER,PARAMETER::ltabl=2*nfftx+64
    COMPLEX(DP)::DUMMY
    INTEGER,SAVE::isys=1
    INTEGER,INTENT(IN)::isign,ldx,ldy,nx,ny,nzl
    INTEGER::i,k,j,err,idir,ip,kk,void
    REAL(DP)::tscale
    INTEGER,SAVE::icurrent=1
    INTEGER,PARAMETER::stdout=6
    INTEGER::offset
    INTEGER::nx_t,ny_t,nzl_t,ldx_t,ldy_t
    INTEGER::itid,mytid,ntids
    INTEGER::omp_get_thread_num,omp_get_num_threads,omp_get_max_threads
    INTEGER,PARAMETER::ltabl=2*nfftx+64
    COMPLEX(DP)::DUMMY
    INTEGER,SAVE::isys=1
    INTEGER,INTENT(IN)::nx,ny,nz,ldx,ldy,ldz,howmany,isign
    INTEGER::i,k,j,err,idir,ip
    REAL(DP)::tscale
    INTEGER,SAVE::icurrent=1
    INTEGER,PARAMETER::ltabl=60
    INTEGER,PARAMETER::lwork=195+6*nfftx
    INTEGER::k_off,kj_offset
    COMPLEX(DP),DIMENSION(:),ALLOCATABLE::cw2
    INTEGER::nbtasks
    integer::nx,ny,nz,ldx,ldy,ldz,howmany,isign
    integer::m,incx1,incx2
    INTEGER::i,k,j,err,idir,ip,ii,jj
    REAL(DP)::tscale
    INTEGER,SAVE::icurrent=1
    INTEGER,INTENT(IN)::isign
    INTEGER,INTENT(IN)::nsl,nz,ldz
    INTEGER(kind=cuda_stream_kind)::stream
    LOGICAL,INTENT(IN),optional::in_place
    REAL(DP)::tscale
    INTEGER::i,err,idir,ip,void,istat
    INTEGER,SAVE::icurrent=1
    LOGICAL::found
    LOGICAL::is_inplace
    INTEGER::tid
    INTEGER,PARAMETER::RANK=1
    INTEGER::STRIDE,DIST,BATCH
    INTEGER,INTENT(IN)::isign,ldx,ldy,nx,ny,nzl
    INTEGER(kind=cuda_stream_kind)::stream
    INTEGER::i,k,j,err,idir,ip,kk,void,istat
    REAL(DP)::tscale
    INTEGER,SAVE::icurrent=1
    INTEGER,PARAMETER::stdout=6
    INTEGER::batch_1,batch_2
    INTEGER,PARAMETER::RANK=2
    INTEGER::STRIDE,DIST,BATCH
    INTEGER,PARAMETER::RANK=1
    INTEGER::STRIDE_X,STRIDE_Y,DIST_X,DIST_Y,BATCH_X,BATCH_Y1,BATCH_Y2
    INTEGER,INTENT(IN)::nx,ny,nz,ldx,ldy,ldz,howmany,isign
    INTEGER(kind=cuda_stream_kind)::stream
    INTEGER::i,k,j,err,idir,ip,istat
    REAL(DP)::tscale
    INTEGER,SAVE::icurrent=1
    INTEGER,PARAMETER::RANK=3
    INTEGER::STRIDE,DIST,BATCH
    INTEGER,PARAMETER::stdout=6
    integer::nx,ny,nz,ldx,ldy,ldz,howmany,isign
    integer(kind=cuda_stream_kind)::stream
    integer::m,incx1,incx2
    INTEGER::i,k,j,err,idir,ip,ii,jj,istat
    REAL(DP)::tscale
    INTEGER,SAVE::icurrent=1
    INTEGER,PARAMETER::RANK=3
    INTEGER::i
    INTEGER,PARAMETER::ndims=3
    TYPE(C_PTR)::cft_b_bw_planz=C_NULL_PTR
    TYPE(C_PTR)::cft_b_bw_planx=C_NULL_PTR
    TYPE(C_PTR)::cft_b_bw_plany=C_NULL_PTR
    real(DP)::tscale
    integer::ip,i,first_index,how_many_y
    integer,save::icurrent=1
    integer,INTENT(IN)::nx,ny,nz
    integer,INTENT(IN)::nx,ny,nz,ldx,ldy,ldz,imin2,imax2,imin3,imax3,sgn
    INTEGER,SAVE::k,first_index,how_many_y
    INTEGER::stdout=6
    INTEGER::nr1=0!
    INTEGER::nr2=0
    INTEGER::nr3=0!
    INTEGER::nr1x=0
    INTEGER::nr2x=0
    INTEGER::nr3x=0
    INTEGER::nnr=0
    INTEGER::mype=0
    INTEGER::comm=0
    INTEGER::nproc=1
    INTEGER::root=0
    TYPE(fft_box_descriptor)::desc
    INTEGER,INTENT(in)::nat,nproc,mype,root,comm
    TYPE(fft_box_descriptor)::desc
    TYPE(fft_box_descriptor),INTENT(INOUT)::desc
    INTEGER,INTENT(in)::nat
    TYPE(fft_type_descriptor),INTENT(IN)::dfftp
    INTEGER::nr1b,nr2b,nr3b,nr1bx,nr2bx,nr3bx
    INTEGER::isa
    INTEGER::ir2,ibig2,irb2,imin2,imax2,nr2
    INTEGER::ir3,ibig3,irb3,imin3,imax3,nr3
    INTEGER::n,nx
    REAL(DP)::log2n
    integer::nr
    logical::allowed
    integer::mr,i,fac,p,maxpwr
    INTEGER,INTENT(IN)::nr
    INTEGER,OPTIONAL,INTENT(IN)::np
    INTEGER::new
    INTEGER::nr1=0!
    INTEGER::nr2=0
    INTEGER::nr3=0!
    INTEGER::nr1x=0
    INTEGER::nr2x=0
    INTEGER::nr3x=0
    LOGICAL::lpara=.FALSE.
    LOGICAL::lgamma=.FALSE.
    INTEGER::root=0
    INTEGER::comm=MPI_COMM_NULL
    INTEGER::comm2=MPI_COMM_NULL
    INTEGER::comm3=MPI_COMM_NULL
    INTEGER::nproc=1
    INTEGER::nproc2=1
    INTEGER::nproc3=1
    INTEGER::mype=0
    INTEGER::mype2=0
    INTEGER::mype3=0
    INTEGER::my_nr3p=0
    INTEGER::my_nr2p=0
    INTEGER::my_i0r3p=0
    INTEGER::my_i0r2p=0
    INTEGER::nr1w_tg
    INTEGER::nst
    INTEGER::ngm
    INTEGER::ngw
    INTEGER::nnp=0
    INTEGER::nnr=0
    INTEGER::nnr_tg=0
    LOGICAL::has_task_groups=.FALSE.
    LOGICAL::use_pencil_decomposition=.FALSE.
    CHARACTER(len=12)::rho_clock_label=''
    CHARACTER(len=12)::wave_clock_label=''
    INTEGER::grid_id
    INTEGER(kind=cuda_stream_kind),allocatable,dimension(:)::stream_scatter_yz
    INTEGER(kind=cuda_stream_kind),allocatable,dimension(:)::stream_many
    INTEGER::nstream_many=16
    INTEGER(kind=cuda_stream_kind)::a2a_comp
    INTEGER(kind=cuda_stream_kind),allocatable,dimension(:)::bstreams
    TYPE(cudaEvent),allocatable,dimension(:)::bevents
    INTEGER::batchsize=16
    INTEGER::subbatchsize=4
    REAL(DP)::fft_dual=4.0d0
    INTEGER::incremental_grid_identifier=0
    TYPE(fft_type_descriptor)::desc
    REAL(DP),INTENT(IN)::gcutm
    INTEGER,INTENT(IN),OPTIONAL::nyfft
    INTEGER,INTENT(in)::comm
    INTEGER::nx,ny,ierr,imany,nzfft
    INTEGER::i,nsubbatches
    INTEGER::mype,root,nproc,nproc2,nproc3,iproc,iproc2,iproc3
    INTEGER::color,key,comm2,comm3
    TYPE(fft_type_descriptor)::desc
    INTEGER::iproc,ierr,imany
    INTEGER::i,nsubbatches
    TYPE(fft_type_descriptor)::desc
    INTEGER,INTENT(in)::nst
    INTEGER::np,nq,i,is,iss,itg,i1,i2,m1,m2,ip
    INTEGER::ncpx,nr1px,nr2px,nr3px
    INTEGER::nr1,nr2,nr3
    INTEGER::nr1x,nr2x,nr3x
    TYPE(fft_type_descriptor),INTENT(INOUT)::dfft
    TYPE(sticks_map),INTENT(INOUT)::smap
    CHARACTER(LEN=*),INTENT(IN)::pers
    LOGICAL,INTENT(IN)::lpara
    LOGICAL,INTENT(IN)::lgamma
    INTEGER,INTENT(IN)::comm
    REAL(DP),INTENT(IN)::gcut_in
    REAL(DP),OPTIONAL,INTENT(IN)::dual_in
    INTEGER,INTENT(IN)::nyfft
    LOGICAL,OPTIONAL,INTENT(IN)::use_pd
    INTEGER::nst
    INTEGER::nstw
    REAL(DP)::gcut,gkcut,dual
    INTEGER::ngm,ngw
    REAL(DP),INTENT(IN)::gcutm
    TYPE(fft_type_descriptor),INTENT(INOUT)::dfft
    TYPE(fft_type_descriptor),INTENT(IN)::dfft
    INTEGER,INTENT(INOUT)::nr1,nr2,nr3
    TYPE(fft_type_descriptor),INTENT(IN)::desc
    INTEGER::fft_stick_index
    INTEGER,INTENT(IN)::i,j
    INTEGER::mc,m1,m2
    TYPE(C_PTR)::plan
    INTEGER(KIND=C_INT)::nz,i
    TYPE(C_PTR)::plan
    TYPE(C_PTR)::plan
    INTEGER(KIND=C_INT)::nx,ny,i
    TYPE(C_PTR)::plan
    TYPE(C_PTR)::plan
    INTEGER(KIND=C_INT)::nx,ny,nz,i
    TYPE(C_PTR)::plan
    TYPE(C_PTR)::plan
    INTEGER(KIND=C_INT)::nx,ny,nz,ldx,ldy
    COMPLEX(KIND=C_DOUBLE)::xy
    TYPE(C_PTR)::plan
    INTEGER(KIND=C_INT)::nx,ny,nz,ldx,ldy
    COMPLEX(KIND=C_DOUBLE)::xy
    TYPE(C_PTR)::plan
    INTEGER(KIND=C_INT)::ny,ldx
    COMPLEX(KIND=C_DOUBLE)::xy
    TYPE(C_PTR)::plan
    INTEGER(KIND=C_INT)::ldz,nzl
    COMPLEX(KIND=C_DOUBLE)::z
    TYPE(C_PTR)::plan
    INTEGER(KIND=C_INT)::ldz
    COMPLEX(KIND=C_DOUBLE)::z
    TYPE(C_PTR)::plan
    INTEGER(KIND=C_INT)::m,inc1,inc2
    COMPLEX(KIND=C_DOUBLE)::z
    TYPE(C_PTR)::plan
    INTEGER(KIND=C_INT)::m,inc1,inc2
    COMPLEX(KIND=C_DOUBLE)::z
    integer,character(len=256),integer(C_INT16_T)::version=1
    integer(C_INT16_T)::size=48!
    integer(C_INT)::category=0
    integer(C_INT)::colorType=1
    integer(C_INT)::color
    integer(C_INT)::payloadType=0
    integer(C_INT)::reserved0
    integer(C_INT64_T)::payload
    integer(C_INT)::messageType=1
    type(C_PTR)::message
    character(kind=C_CHAR,len=*)::name
    character(kind=c_char,len=*)::name
    integer,optional::id
    integer::istat
    character(kind=c_char,len=*)::name
    integer,optional::id
    integer::istat
    TYPE(fft_type_descriptor),INTENT(in)::desc
    INTEGER,INTENT(in)::nxx_,isgn
    INTEGER,INTENT(in)::nr2px,nproc2,my_nr2p
    INTEGER::ierr,me2,iproc2,ncpx
    INTEGER::i,it,j,k,kfrom,kdest,mc,m1,m3,i1,icompact,sendsize
    TYPE(fft_type_descriptor),INTENT(in)::desc
    INTEGER,INTENT(in)::nxx_,isgn
    INTEGER,INTENT(in)::me2_start,me2_end
    INTEGER::ierr,me2,me3,nproc3,iproc3,ncpx,nr3px,ip
    INTEGER::i,it,k,kfrom,kdest,mc,m1,m2,i1,sendsize
    INTEGER::my_nr1p_
    TYPE(fft_type_descriptor),INTENT(in)::desc
    INTEGER,INTENT(in)::nxx_,isgn
    INTEGER::ierr
    TYPE(fft_type_descriptor),INTENT(in)::desc
    INTEGER,INTENT(in)::nxx_,isgn
    INTEGER::ierr
    TYPE(fft_type_descriptor),INTENT(IN)::dfft
    INTEGER::proc,info,offset_in,offset_aux,ir3
    TYPE(fft_type_descriptor),INTENT(IN)::dfft
    INTEGER::proc,info,offset_in,offset_aux,ir3
    TYPE(fft_type_descriptor),INTENT(IN)::dfft
    INTEGER::proc,info,offset_in,offset_aux,ir3
    TYPE(fft_type_descriptor),INTENT(IN)::dfft
    INTEGER::proc,info,offset_in,offset_aux,ir3
    TYPE(fft_type_descriptor),INTENT(in)::dfftp
    INTEGER::proc,info,offset_in,offset_aux,ir3
    TYPE(fft_type_descriptor),INTENT(in)::dfftp
    INTEGER::proc_,proc2_,proc3_,proc,info,offset_in,offset_aux,ir3,nr2px
    INTEGER::ibnd,jbnd,iii
    TYPE(fft_type_descriptor),INTENT(in)::dfftp
    INTEGER::target_ibnd
    INTEGER::proc_,proc2_,proc3_,proc,info,offset_out,offset_aux,ir3
    INTEGER::ibnd,jbnd
    integer::n
    integer::i,ir,j,l
    TYPE(fft_type_descriptor),INTENT(in)::dfft
    INTEGER::k,offset,proc,ierr,me,nprocp,gproc,i,kdest,kfrom
    INTEGER::me_p,nppx,mc,j,npp,nnp,ii,it,ip,ioff,sendsiz,ncpx,ipp,nsiz
    TYPE(fft_type_descriptor),TARGET,INTENT(in)::dfft
    INTEGER::cuf_i,cuf_j,nswip
    INTEGER::istat
    INTEGER::k,offset,proc,ierr,me,nprocp,gproc,gcomm,i,kdest,kfrom
    INTEGER::me_p,nppx,mc,j,npp,nnp,ii,it,ip,ioff,sendsiz,ncpx,ipp,nblk,nsiz
    INTEGER::iter,dest,sorc
    TYPE(fft_type_descriptor),TARGET,INTENT(in)::dfft
    INTEGER,INTENT(IN)::batchsize
    INTEGER::cuf_i,cuf_j,nswip
    INTEGER::istat
    INTEGER::k,offset,proc,ierr,me,nprocp,gproc,gcomm,i,kdest,kfrom
    INTEGER::me_p,nppx,mc,j,npp,nnp,nnr,ii,it,ip,ioff,sendsiz,ncpx,ipp,nblk,nsiz
    INTEGER::iter,dest,sorc
    TYPE(fft_type_descriptor),TARGET,INTENT(in)::dfft
    INTEGER,INTENT(IN)::batchsize,batch_id
    INTEGER::istat
    INTEGER::k,offset,proc,ierr,me,nprocp,gproc,gcomm,i,kdest,kfrom
    INTEGER::me_p,nppx,mc,j,npp,nnp,nnr,ii,it,ip,ioff,sendsiz,ncpx,ipp,nblk,nsiz
    INTEGER,ALLOCATABLE,DIMENSION(:)::offset_proc
    INTEGER::iter,dest,sorc
    TYPE(fft_type_descriptor),TARGET,INTENT(in)::dfft
    INTEGER,INTENT(IN)::batchsize,batch_id
    INTEGER::cuf_i,cuf_j,nswip
    INTEGER::istat
    INTEGER::k,offset,proc,ierr,me,nprocp,gproc,gcomm,i,kdest,kfrom
    INTEGER::me_p,nppx,mc,j,npp,nnp,nnr,ii,it,ip,ioff,sendsiz,ncpx,ipp,nblk,nsiz
    INTEGER::iter,dest,sorc,req_cnt
    TYPE(fft_type_descriptor),TARGET,INTENT(in)::dfft
    INTEGER,INTENT(IN)::batchsize,batch_id

end module test


!!  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.

      subroutine degmp  ( pmsa   , fl     , ipoint , increm , noseg  ,
     &                    noflux , iexpnt , iknmrk , noq1   , noq2   ,
     &                    noq3   , noq4   )
!>\file
!>       Degradation of organic micropolutants (new, generic!)

!
!     Description of the module :
!
!        General water quality module for DELWAQ:
!        Overall degradation of organic micropollutants in the
!        water and sediment.
!
!         ----- old version -----
! Name    T   L I/O   Description                                   Units
! ----    --- -  -    -------------------                            ----
! CRTEMP  R*4 1 I critical temperature for decay                       [xC]
! DEPTH   R*4 1 I actual depth of a segment                            [m]
! FL (1)  R*4 1 O decay flux mixing layer (x=C,N,P,Si)           [gX/m3/d]
! MINRC   R*4 1 I first order decay rate                             [1/d]
! FDIS    R*4 1 I fraction free dissolved mive                         [-]
! MINTCR  R*4 1 I temperature coefficient two bottom layers          [1/d]
! ORG     R*4 1 I amount decaying organic material in mixing layer    [gX]
! TEMP    R*4 1 I ambient temperature                                 [xC]
! TEMP20  R*4 1 L ambient temperature - stand. temp (20)              [xC]
! TEMPC   R*4 1 L temperature coefficient                              [-]
! VOLUME  R*4 1 L volume calculated by DELWAQ                         [m3]
! ZERMIN  R*4 1 I zeroth order decay rate mixing layer           [gX/m2/d]
!
!         ----- new version -----
! Name    T   L I/O   Description                                   Units
! ----    --- -  -    -------------------                            ----
! IVERSN  I   1 I option for version of process                        [-]
! ISWOXY  I   1 I option for oxidising or reducing condition           [-]
! ISWDEG  I   1 I option for fraction micropoll. that is degraded      [-]
! CRTEMP  R*4 1 I critical temperature for decay                      [oC]
! DEPTH   R*4 1 I actual depth of a water segment                      [m]
! FL (1)  R*4 1 O decay flux (x = C, N, P, Si)                   [gX/m3/d]
! FTOTR   R*4 1 - fraction of micropollutant that is gedraded          [-]
! FDFREE  R*4 1 I fraction free dissolved micropollutant               [-]
! FDDOC   R*4 1 I fraction DOC-bound micropollutant                    [-]
! KDEG    R*4 1 - first order degradation rate                       [1/d]
! KDEGO   R*4 1 I first order degradation rate at oxidising cond.    [1/d]
! KDEGR   R*4 1 I first order degradation rate at reducing cond.     [1/d]
! KTDEG   R*4 1 I temperature coefficient for decay                    [-]
! ORGMP   R*4 1 I concentration organic micropollutant             [gX/m3]
! TEMP    R*4 1 I ambient temperature                                 [oC]
! TEMP20  R*4 1 L ambient temperature - reference temp.(20)           [oC]
! TEMPC   R*4 1 L temperature coefficient                              [-]
! VOLUME  R*4 1 L volume calculated by DELWAQ                         [m3]
! ZDEGMP  R*4 1 I zero order degradation rate                    [gX/m3/d]
!
!     Logical Units : -

!     Modules called : -

!     Name     Type   Library
!     ------   -----  ------------
!
      IMPLICIT NONE

      REAL     PMSA  ( * ) , FL    (*)
      INTEGER  IPOINT( * ) , INCREM(*) , NOSEG , NOFLUX,
     +         IEXPNT(4,*) , IKNMRK(*) , NOQ1, NOQ2, NOQ3, NOQ4

      INTEGER  IP1, IP2, IP3, IP4, IP5, IP6, IP7, IP8, IP9, IP10,
     +         IP11, IP12, IP13, IP14, IP15, IP16
      INTEGER  IFLUX, ISEG, IKMRK1, IKMRK2
      REAL     ZERMIN, ORG, FDIS, MINRC, MINTC
      INTEGER  IVERSN, ISWOXY, ISWDEG
      REAL     ZDEGMP, ORGMP, FDFREE, FDDOC, KDEGO, KDEGR, KTDEG,
     +         KDEG, FTOTR
      REAL     TEMP, CRTEMP, TEMPC, TEMP20, VOLUME, DEPTH
      LOGICAL  SEDIME
!
      IP1  = IPOINT( 1 )
      IP2  = IPOINT( 2 )
      IP3  = IPOINT( 3 )
      IP4  = IPOINT( 4 )
      IP5  = IPOINT( 5 )
      IP6  = IPOINT( 6 )
      IP7  = IPOINT( 7 )
      IP8  = IPOINT( 8 )
      IP9  = IPOINT( 9 )
      IP10 = IPOINT( 10)
      IP11 = IPOINT( 11)
      IP12 = IPOINT( 12)
      IP13 = IPOINT( 13)
      IP14 = IPOINT( 14)
      IP15 = IPOINT( 15)
      IP16 = IPOINT( 16)
!
!     Check sediment switch for first segment
!
      SEDIME = .FALSE.
      IF ( PMSA(IP16) .GT. 0.5 ) SEDIME = .TRUE.
!
      IFLUX = 0
      DO 9000 ISEG = 1 , NOSEG
!!    CALL DHKMRK(1,IKNMRK(ISEG),IKMRK1)
!!    IF (IKMRK1.GT.0) THEN
      IF (BTEST(IKNMRK(ISEG),0)) THEN
      CALL DHKMRK(2,IKNMRK(ISEG),IKMRK2)
      IF ((IKMRK2.EQ.0.OR.IKMRK2.EQ.3).OR..NOT.SEDIME) THEN
      IVERSN = NINT( PMSA( IP10 ))
!
!     Use old version when IVERSN=0
!
      IF (IVERSN .EQ. 0) THEN
!
         ZERMIN  = PMSA( IP1 )
         ORG     = MAX (0.0, PMSA( IP2 ) )
         FDIS    = PMSA( IP3 )
         MINRC   = PMSA( IP4 )
         MINTC   = PMSA( IP5 )
         TEMP    = PMSA( IP6 )
         CRTEMP  = PMSA( IP7 )
         VOLUME  = PMSA( IP8 )
         DEPTH   = PMSA( IP9 )
!
!        Calculate the degradation flux
!
         IF (TEMP .LE. CRTEMP) THEN
!
!           Only the zero order term
!
            IF ( SEDIME ) THEN
               FL( 1+IFLUX) = ZERMIN  / DEPTH
            ELSE
               FL( 1+IFLUX) = ZERMIN
            ENDIF
!
         ELSE
!
!           Sum of zero and first order terms
!
            TEMP20 = TEMP - 20.0
            TEMPC  = MINTC ** TEMP20
!
            IF ( SEDIME ) THEN
               FL( 1+IFLUX) = ( ZERMIN  / DEPTH  +
     &                 FDIS * MINRC * TEMPC * ORG / DEPTH  )
            ELSE
               FL( 1+IFLUX) = ZERMIN + FDIS * MINRC * TEMPC *ORG
            ENDIF

         ENDIF
!
!     Use new version when IVERSN=1
!
      ELSE
!
         ZDEGMP = PMSA( IP1 )
         ORGMP  = MAX ( 0.0, PMSA( IP2 ) )
         FDFREE = PMSA( IP3 )
         KTDEG  = PMSA( IP5 )
         TEMP   = PMSA( IP6 )
         CRTEMP = PMSA( IP7 )
         VOLUME = PMSA( IP8 )
         DEPTH  = PMSA( IP9 )
         ISWOXY = NINT( PMSA( IP11))
         ISWDEG = NINT( PMSA( IP12))
         FDDOC  = PMSA( IP13)
         KDEGO  = PMSA( IP14)
         KDEGR  = PMSA( IP15)
!
!        Calculate the degradation flux
!
         IF (TEMP .LE. CRTEMP) THEN
!
!           Only the zero order term
!
            IF ( SEDIME ) THEN
               FL( 1+IFLUX) = ZDEGMP / DEPTH
            ELSE
               FL( 1+IFLUX) = ZDEGMP
            ENDIF
!
         ELSE
!
!           Sum of zero and first order terms
!
            TEMP20 = TEMP - 20.0
            TEMPC  = KTDEG ** TEMP20
!
!           Select rate for oxidising conditions (ISWOXY = 1)
!                        or reducing conditions (ISWOXY = 0)
!
            KDEG = KDEGO
            IF (ISWOXY .EQ. 0) KDEG = KDEGR
!
!           Select the fractions that are degraded,
!           total (ISWDEG = 0), free dissolved (ISWDEG = 1),
!           free dissolved plus DOC-bound (ISWDEG = 2)
!
            IF (ISWDEG .EQ. 1) THEN
               FTOTR = FDFREE
               ELSE IF (ISWDEG .EQ. 2) THEN
               FTOTR = FDFREE + FDDOC
               ELSE
               FTOTR = 1.0
            ENDIF
!
            IF ( SEDIME ) THEN
               FL( 1+IFLUX) = ZDEGMP / DEPTH +
     +                     KDEG * TEMPC * FTOTR * ORGMP / DEPTH
            ELSE
               FL( 1+IFLUX) = ZDEGMP + KDEG * TEMPC * FTOTR * ORGMP
            ENDIF
!
         ENDIF
!
      ENDIF
!
      ENDIF
!
      ENDIF
!
      IFLUX = IFLUX + NOFLUX
      IP1   = IP1   + INCREM ( 1 )
      IP2   = IP2   + INCREM ( 2 )
      IP3   = IP3   + INCREM ( 3 )
      IP4   = IP4   + INCREM ( 4 )
      IP5   = IP5   + INCREM ( 5 )
      IP6   = IP6   + INCREM ( 6 )
      IP7   = IP7   + INCREM ( 7 )
      IP8   = IP8   + INCREM ( 8 )
      IP9   = IP9   + INCREM ( 9 )
      IP10  = IP10  + INCREM ( 10)
      IP11  = IP11  + INCREM ( 11)
      IP12  = IP12  + INCREM ( 12)
      IP13  = IP13  + INCREM ( 13)
      IP14  = IP14  + INCREM ( 14)
      IP15  = IP15  + INCREM ( 15)
!     IP16 wordt niet opgehoogd, want deze staat buiten segmentloop!!!
!
 9000 CONTINUE
!
      RETURN
!
      END


      PARAMETER       ( MXMN = 8 )
      PARAMETER       ( MXLV = 220 )
      PARAMETER       ( NVAR = 13 )
      PARAMETER       ( NSTR = 3 )

      REAL*8 r8arr(MXMN, MXLV), r8arr2(MXMN, MXLV),
     +       r8arr3(MXMN, MXLV)

      parameter(iu=9,iou=10,nz=9999999)
      dimension pr(nz),tt(nz),td(nz)
      integer  xht,nlev,i, iargc, n,minu,k
      real  xu,xv,xy,xm,xh,xmm,xd
      real  temp,v(nz),zx(nz),d(nz),ter(nz)
      real  lat(nz), lon(nz)
      real xt,xtd,xtt
      character*80 fin,fout
      character*10  date_tag, date(nz),M10,xpr
      character   argv*300,minute*2,M11*2,mins(nz)*2
      character*6 dname,staid(nz),M20
      character*3 ilev
      character*8 M1,M2,min,M3,M4,M5,xlat,xlon
      real wlon,elon,slat,nlat

      CHARACTER csubset*8, inf*200,outstg*211
      INTEGER y,z,idate

      CHARACTER*80 ostr(NSTR)

      ostr(1)='RPID YEAR MNTH DAYS'
      ostr(2)='HOUR MINU CLAT CLON SELV'
      ostr(3)='TMDB TMDP PRLC WDIR WSPD'

C*-----------------------------------------------------------------------
c*    Read the command-line arguments
c*
      n = iargc()
      IF (n .GE. 2) THEN
        call getarg( 1, argv )
        inf=argv
        call getarg(2,argv)
        date_tag=argv
        IF (n .eq. 6) THEN  ! User-specified lat/lon boundaries
          call getarg(3,argv)
          read(argv,*) wlon
          call getarg(4,argv)
          read(argv,*) elon
          call getarg(5,argv)
          read(argv,*) slat
          call getarg(6,argv)
          read(argv,*) nlat
          write(*,*) 'Lon/lat boundaries: ',wlon,elon,slat,nlat
        ELSE  ! Default lon/lat boundaries
          slat = -90.
          nlat = 90.
          wlon = -180.
          elon = 180.
        END IF
      ELSE
        write(*,*) 'Usage: bufr_aircar2ob.x gdas.adpsfc.t<HH>z.
     +<YYYYMMDD>.bufr.be <YYYYMMDDHH> west_lon east_lon
     +south_lat north_lat'
        STOP
      END IF

C*-----------------------------------------------------------------------
C*    Open the BUFR messages file.
      OPEN(UNIT=11, FILE=inf, form='unformatted')

      dname='  TEMP'
      fout="Upper"//date_tag//'.obs'

C*    Open output file
      open(18, file=fout, status='unknown', form='formatted')

      iflag = 0
      dumm=99999.9

      iupper=0
      ibogus=0
      dslp=dumm
      do k=1,nz
        date(k)='MMMMMMMMMM'
        mins(k)='MM'
        staid(k)='MMMMMM'
        ter(k)=dumm
        pr(k)=dumm
        zx(k)=dumm
        tt(k)=dumm
        td(k)=dumm
        d(k)=dumm
        v(k)=dumm
      enddo

C*      Associate the tables file with the messages file, and identify
C*      the latter to the BUFRLIB software.

      CALL OPENBF(11, 'IN', 11)

C*      Specify that we would like IDATE values returned using 10 digits
C*      (i.e. YYYYMMDDHH ).

      CALL DATELEN(10)

      ln=0

C*-----------------------------------------------------------------------
      DO WHILE ( .true. )

C*      Read the next BUFR message.
        CALL READNS(11,csubset,idate,ierr)
c            write(*,*)' idate: ',idate,'  ',csubset

        IF (ierr .eq.  -1) THEN
          WRITE (*,*) '[bufr_upa2ob]....all records read, Exit'
          CALL CLOSBF  ( 11 )
          GOTO 1000
        END IF

C*      At this point, we have a data subset within the
C*      internal arrays of BUFRLIB, and we can now begin
C*      reading actual data values:

        CALL UFBINT(11, r8arr,  MXMN, MXLV, nlv, ostr(1))
        CALL UFBINT(11, r8arr2, MXMN, MXLV, nlv, ostr(2))
        CALL UFBINT(11, r8arr3, MXMN, MXLV, nlv, ostr(3))

        minu=int(r8arr2(2,2))
        write (unit=minute, FMT='(I2)') minu
        DO k=1,2
           IF ( minute (k:k) .eq. ' ') THEN
              minute (k:k) = '0'
           ENDIF
        ENDDO

        DO z = 1,nlv
          IF(r8arr3(3,z) .lt. 10E9) THEN
             WRITE (UNIT=outstg, FMT='(I10,1x A8,1X,A6,1X,F6.1,
     +          4(1x,F4.1),2(1X,F7.2),1X,F6.2,1X,F6.2,1X,F6.1,1X,
     +          F8.1,1X,F5.1,1x,F6.2,1X,I4,1X,I6)')
     +          idate,csubset,
     +          (r8arr(i,1), i = 1,4),
     +          (r8arr2(i,1), i = 1,5),(r8arr3(i,z), i = 1,5),
     +          nlv,z
             DO y = 1, 211
                IF ( outstg (y:y) .eq. '*' ) THEN
                  outstg (y:y) = 'm'
                ENDIF
             ENDDO

             read(outstg,21) M10,xn1,M20,xy,xm,xd,xh,min,
     &                       xlat,xlon,M5,M1,M2,xpr,M3,M4
             read(minute,22) M11
!             write(*,*)M10,xlat,xlon,M5,M1,M2,xpr,M3,M4
21           format(A10,1X,A8,1X,A6,1X,A6,4(1x,A4),2(1X,A7),
     &              1X,A6,1X,A6,1X,A6,1X,A8,1X,A5,1x,A6)
22           format(A2)

             iflag=iflag+1
             j=iflag

C*-----------------------------------------------------------------------
c            Prepare output

             CALL READMval(M1,tt(j))
             CALL READMval(M2,td(j))
             CALL READMval(M3,d(j))
             CALL READMval(M4,v(j))
             CALL READMval(M5,ter(j))
             CALL READMval(xlat,lat(j))
             CALL READMval(xlon,lon(j))
             CALL READMval(xpr,pr(j))

             if(pr(j).ne.0 .and. pr(j).ne.99999.9) then
                pr(j)= pr(j)/100
             end if

             date(j)=M10
             mins(j)=M11
             staid(j)=M20
         ENDIF
        END DO
      END DO

C*-----------------------------------------------------------------------
1000  if (iflag .ne. 0) then
        iflag1=0
        iflag2=1
        iflag3=1
        write(18,fmt='(a10)') date_tag
        alat1=9999
        alon1=9999
        l=1
        do k = 1, iflag
          if(slat<=lat(k) .and. nlat>=lat(k) .and.
     &       wlon<=lon(k) .and. elon>=lon(k)) then

            if(alat1.ne.lat(k) .and. alon1.ne.lon(k)) then
               alat1=lat(k)
               alon1=lon(k)
               if(iflag1.ne.0) then
                  CALL SORTWRITE(pr,zx,tt,td,d,v,l,l1,m)
                  write(18,111) iupper,dname,staid(l),
     &                          date(l),mins(l),
     &                          lat(l),lon(l),ter(l),dslp,
     &                          m-l+1,ibogus
                  do i=l,m
                    write(18,112)pr(i),zx(i),tt(i),td(i),d(i),v(i)
                  enddo
!                 write(*,*)l,' ',m,' ',l1
                  iflag2=1
               endif
               iflag1=1
               l=k
            endif
            l1=k
          endif
        enddo
111     format(i1,1x,a6,1x,a6,1x,a10,a2,4(f7.1,1x),i3,1x,i1)
112     format(6(f7.1,1x))

        CALL SORTWRITE(pr,zx,tt,td,d,v,l,l1,m)
        write(18,111) iupper,dname,staid(l),date(l),
     &                lat(l),lon(l),ter(l),dslp,m-l+1,ibogus
        do i=l,m
          write(18,112)pr(i),zx(i),tt(i),td(i),d(i),v(i)
        enddo

        close(18)
      endif

C*-----------------------------------------------------------------------
!       write(*,*)'nlev ', nlev
2000  stop 99999

      END

C*-----------------------------------------------------------------------
      SUBROUTINE READMval(M1,fl)
      character*8 M1
      dumm=99999.9
      if(M1(1:1) ==  'm') then
         fl = dumm
      else
         read(M1,*)fl
      endif

      RETURN
      END

C*-----------------------------------------------------------------------
      SUBROUTINE SORTWRITE(pr,zx,tt,td,d,v,l,k,m)
      parameter(nz=9999999)

      dimension pr(nz),tt(nz),td(nz)
      real temp,v(nz),zx(nz),d(nz)
      dimension prt(nz),ttt(nz),tdt(nz)
      real vt(nz),zxt(nz),dt(nz)

      do i=l,k-1
        do j= i+1,k
          if (pr(i).lt.pr(j)) then
             call SWAPTWO(pr(i),pr(j))
             call SWAPTWO(zx(i),zx(j))
             call SWAPTWO(tt(i),tt(j))
             call SWAPTWO(td(i),td(j))
             call SWAPTWO(v(i),v(j))
             call SWAPTWO(d(i),d(j))
          endif
        enddo
      enddo
      m=l
      do i=l+1,k
        if(pr(i).eq.pr(m))then
           pr(m)=pr(i)
           if(zx(i)<99999) then
              zx(m)=zx(i)
           endif
           if(tt(i)<99999) then
              tt(m)=tt(i)
           endif
           if(td(i)<99999) then
              td(m)=td(i)
           endif
           if(v(i)<99999) then
              v(m)=v(i)
           endif
           if(d(i)<99999) then
              d(m)=d(i)
           endif
        else
           m=m+1
           pr(m)=pr(i)
           zx(m)=zx(i)
           tt(m)=tt(i)
           td(m)=td(i)
           v(m)=v(i)
           d(m)=d(i)
        endif
      enddo

      RETURN
      END

C*-----------------------------------------------------------------------
      SUBROUTINE SWAPTWO(X1,X2)
      temp=X1
      X1=X2
      X2=temp
      RETURN
      END


C$Procedure      ZZEKORDI ( Order of an integer EK column )

      SUBROUTINE ZZEKORDI ( IVALS, NULLOK, NLFLGS, NVALS, IORDER )

C$ Abstract
C
C     Determine the order of elements in an integer EK column, using
C     dictionary ordering on integer data values and array indices.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     EK
C
C$ Keywords
C
C     EK
C     SORT
C
C$ Declarations

      INTEGER               IVALS  ( * )
      LOGICAL               NULLOK
      LOGICAL               NLFLGS ( * )
      INTEGER               NVALS
      INTEGER               IORDER ( * )

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C      IVALS      I   Array of integer column values.
C      NULLOK     I   Logical flag indicating whether nulls are allowed.
C      NLFLGS     I   Flags indicating whether column entries are null.
C      NVALS      I   Dimension of IVALS.
C      IORDER     O   Order vector for IVALS.
C
C$ Detailed_Input
C
C      IVALS          is an array of integer EK column values,
C                     some of which may be null, if null values are
C                     permitted.  See the description of the input
C                     arguments NULLOK and NLFLGS below.
C
C      NULLOK         is a logical flag indicating whether column
C                     elements may be null.  If NULLOK is TRUE, then
C                     NLFLGS must be set to indicate the status of each
C                     element of IVALS.
C
C      NLFLGS         is an array of logical flags that indicate whether
C                     the corresponding elements of IVALS are null.
C                     NLFLGS is meaningful only when NULLOK is .TRUE.
C                     When NULLOK is .TRUE., the Ith element of IVALS is
C                     null if and only if the Ith element of NLFLGS
C                     is .TRUE.
C
C                     When NULLOK is .FALSE., all elements of IVALS are
C                     considered to be non-null.
C
C      NVALS          is the number of elements in the input array.
C
C$ Detailed_Output
C
C      IORDER      is the order vector for the input array.
C                  IORDER(1) is the index of the smallest element
C                  of IVALS; IORDER(2) is the index of the next
C                  smallest; and so on.  Null values, if allowed, are
C                  considered to be less than all non-null values.  The
C                  order relation between equal values is determined
C                  by the indices of the values in the input array;
C                  values with lower indices are considered to be
C                  smaller.
C
C$ Parameters
C
C     None.
C
C$ Particulars
C
C     ZZEKORDI creates an order vector for an array of integer
C     column values.  Null values are allowed.  The order
C     relation used is dictionary ordering on ordered pairs consisting
C     of data values and array indices:  if two input data values
C     are equal, the associated array indices determine the order
C     relation of the values, where the smaller index is considered
C     to precede the greater.
C
C$ Examples
C
C      1)  Sort the following list of values, some of which are
C          null:
C
C                  Value                         Null?
C             --------------             ---------------------
C             IVALS(1)  =  3             NLFLGS(1)  =  .FALSE.
C             IVALS(2)  =  1             NLFLGS(2)  =  .FALSE.
C             IVALS(3)  =  4             NLFLGS(3)  =  .TRUE.
C             IVALS(4)  =  5             NLFLGS(4)  =  .FALSE.
C             IVALS(5)  =  2             NLFLGS(5)  =  .TRUE.
C
C
C          The subroutine call
C
C              CALL ZZEKORDI ( IVALS, .TRUE., NLFLGS, 5, IORDER )
C
C          generates the output
C
C             IORDER(1)  =  3
C             IORDER(2)  =  5
C             IORDER(3)  =  2
C             IORDER(4)  =  1
C             IORDER(5)  =  4
C
C          Note that the order of the null values is determined by
C          their indices in the input array.
C
C
C      2)  Given the same inputs values of IVALS and NLFLGS, the
C          subroutine call
C
C             CALL ZZEKORDI ( IVALS, .FALSE., NLFLGS, 5, IORDER )
C
C          generates the output
C
C             IORDER(1)  =  2
C             IORDER(2)  =  5
C             IORDER(3)  =  1
C             IORDER(4)  =  3
C             IORDER(5)  =  4
C
C$ Restrictions
C
C      None.
C
C$ Exceptions
C
C      Error free.
C
C$ Files
C
C      None.
C
C$ Author_and_Institution
C
C      N.J. Bachman    (JPL)
C      I.M. Underwood  (JPL)
C
C$ Literature_References
C
C      None.
C
C$ Version
C
C-     Beta Version 3.0.0, 26-MAY-1995 (NJB)
C
C         Re-written to use dictionary ordering on values and input
C         array indices.
C
C-     Beta Version 2.0.0, 13-FEB-1995 (NJB)
C
C         Renamed as a private routine.
C
C-     Beta Version 1.0.0, 13-APR-1994 (NJB) (IMU)
C
C-&

C
C     Local variables
C
      INTEGER               I1
      INTEGER               I2
      INTEGER               I3
      INTEGER               I4

      INTEGER               GAP
      INTEGER               I
      INTEGER               J
      INTEGER               JG

      LOGICAL               N1
      LOGICAL               N2
      LOGICAL               OK

C
C     Statement functions
C
      LOGICAL               CMP1
      LOGICAL               CMP2
      LOGICAL               CMP3
      LOGICAL               CMP4
      LOGICAL               LE

      CMP1 ( I1, I2, I3, I4 )          =          ( I1 .LT. I2 )
     .                                    .OR. (  ( I1 .EQ. I2 ) .AND.
     .                                            ( I3 .LT. I4 )       )

      CMP2 ( I3, I4, N1, N2 )          =       ( N1 .AND. .NOT. N2  )
     .                                    .OR. (      ( N1 .AND. N2 )
     .                                          .AND. ( I3 .LT. I4  ) )

      CMP3 ( I1, I2, I3, I4, N1, N2 )  =        ( .NOT. ( N1 .OR. N2 ) )
     .                                   .AND. CMP1 (  I1, I2, I3, I4  )

      CMP4 ( I1, I2, I3, I4, N1, N2 )  = CMP2 ( I3, I4, N1, N2 )
     .                                   .OR.
     .                                   CMP3 ( I1, I2, I3, I4, N1, N2 )

      LE (  I1,  I2, I3, I4, OK,   N1,   N2  )  =
     .
     .        (  (.NOT. OK ) .AND.  CMP1 ( I1, I2, I3, I4 )          )
     .  .OR.  (  (      OK ) .AND.  CMP4 ( I1, I2, I3, I4, N1, N2 )  )

C
C     Begin with the initial ordering.
C
      DO I = 1, NVALS
         IORDER(I) = I
      END DO

C
C     Find the smallest element, then the next smallest, and so on.
C     This uses the Shell Sort algorithm, but swaps the elements of
C     the order vector instead of the array itself.
C
      GAP = NVALS / 2

      DO WHILE ( GAP .GT. 0 )

         DO I = GAP+1, NVALS

            J = I - GAP

            DO WHILE ( J .GT. 0 )

               JG = J + GAP

               IF (   LE (   IVALS ( IORDER(J)  ),
     .                       IVALS ( IORDER(JG) ),
     .                       IORDER(J),
     .                       IORDER(JG),
     .                       NULLOK,
     .                       NLFLGS( IORDER(J)  ),
     .                       NLFLGS( IORDER(JG) )   )    ) THEN
C
C                 Getting here means that
C
C                    IVALS(IORDER(J)) .LE. IVALS(IORDER(JG))
C
C                 according to our order relation.
C
                  J = 0

               ELSE

                  CALL SWAPI ( IORDER(J), IORDER(JG) )

               END IF

               J = J - GAP

            END DO

         END DO

         GAP = GAP / 2

      END DO

      RETURN
      END


      subroutine subday

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine writes daily subbasin output to the output.sub file

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name          |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    da_ha         |ha            |area of watershed in hectares
!!    iida          |julian date   |current day of simulation
!!    ipdvab(:)     |none          |output variable codes for output.sub file
!!    itotb         |none          |number of output variables printed (output.sub)
!!    msubo         |none          |max number of variables in output.sub file
!!    sub_etday(:)  |mm H2O        |actual evapotranspiration on day in subbasin
!!    sub_fr(:)     |none          |fraction of watershed area in subbasin
!!    sub_gwq(:)    |mm H2O        |groundwater flow on day in subbasin
!!    sub_km(:)     |km^2          |area of subbasin in square kilometers
!!    sub_no3(:)    |kg N/ha       |NO3-N in surface runoff on day in subbasin
!!    sub_pet(:)    |mm H2O        |potential evapotranspiration for day in
!!                                 |subbasin
!!    sub_qd(:)     |mm H2O        |surface runoff loading to main channel on
!!                                 |day in subbasin
!!    sub_sedpa(:)  |kg P/ha       |amount of active mineral P attached to
!!                                 |sediment removed in surface runoff on day
!!                                 |in subbasin
!!    sub_sedps(:)  |kg P/ha       |amount of stable mineral P attached to
!!                                 |sediment removed in surface runoff on day
!!                                 |in subbasin
!!    sub_sedy(:)   |metric tons   |sediment yield for the day in subbasin
!!    sub_sep(:)    |mm H2O        |seepage from bottom of soil profile on day
!!                                 |in subbasin
!!    sub_snom(:)   |mm H2O        |snow melt on day in subbasin
!!    sub_solp(:)   |kg P/ha       |soluble P in surface runoff on day in
!!                                 |subbasin
!!    sub_subp(:)   |mm H2O        |precipitation for day in subbasin
!!    sub_sw(:)     |mm H2O        |water in soil profile in subbasin
!!    sub_wyld(:)   |mm H2O        |water yield on day in subbasin
!!    sub_yorgn(:)  |kg N/ha       |organic N in surface runoff on day in
!!                                 |subbasin
!!    sub_yorgp(:)  |kg P/ha       |organic P in surface runoff on day in
!!                                 |subbasin
!!    subgis(:)     |none          |GIS code printed to output files(output.sub)
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ii          |none          |counter
!!    pdvab(:)    |varies        |array to hold subbasin output values
!!    pdvb(:)     |varies        |array of user selected subbasin output
!!                               |values
!!    sb          |none          |subbasin number
!!    sub_ha      |ha            |area of subbasin in hectares
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer :: sb, ii
      real :: sub_ha
      real, dimension (msubo) :: pdvab, pdvb

      sb = 0
      sb = hru_sub(ihru)

      sub_ha = 0.
      sub_ha = da_ha * sub_fr(sb)

      pdvab = 0.
      pdvb = 0.

      pdvab(1) = sub_subp(sb)
      pdvab(2) = sub_snom(sb)
      pdvab(3) = sub_pet(sb)
      pdvab(4) = sub_etday(sb)
      pdvab(5) = sub_sw(sb)
      pdvab(6) = sub_sep(sb)
      pdvab(7) = sub_qd(sb)
      pdvab(8) = sub_gwq(sb)
      pdvab(9) = sub_wyld(sb)
      pdvab(10) = sub_sedy(sb)/ sub_ha
      pdvab(11) = sub_yorgn(sb)
      pdvab(12) = sub_yorgp(sb)
      pdvab(13) = sub_no3(sb)
      pdvab(14) = sub_solp(sb)
      pdvab(15) = sub_sedpa(sb) + sub_sedps(sb)
      pdvab(16) = sub_latq(sb)
      pdvab(17) = sub_latno3(sb)
      pdvab(18) = sub_gwno3(sb)
      pdvab(19) = sub_chl(sb) / sub_ha
      pdvab(20) = sub_cbod(sb) / sub_ha
      pdvab(21) = sub_dox(sb) / sub_ha
      pdvab(23) = sub_tileq(sb)      !! tile flow  jane f.
      pdvab(22) = sub_tileno3(sb)    !! tileno3
      pdvab(24) = sub_vaptile(sb)    !! phos due to crack flow

      if (ipdvab(1) > 0) then
        do ii = 1, itotb
          pdvb(ii) = pdvab(ipdvab(ii))
        end do
        if (icalen == 0) write(31,1000)sb, subgis(sb), iida, sub_km(sb),
     &                                    (pdvb(ii), ii = 1, itotb)
        if (icalen == 1) write(31,1001)sb, subgis(sb), i_mo, icl(iida),
     &         iyr, sub_km(sb), (pdvb(ii), ii = 1, itotb)

!!    added for binary files 3/25/09 gsm line below and write (66666
	      if (ia_b == 1) then
	        write (66666) sb, subgis(sb), iida, sub_km(sb),
     &                                        (pdvb(ii), ii = 1, itotb)
	      endif
      else
        if (icalen == 0)write(31,1000) sb, subgis(sb), iida, sub_km(sb),
     &                                (pdvab(ii), ii = 1, msubo)
        if (icalen == 1)write(31,1001) sb, subgis(sb), i_mo, icl(iida),
     &         iyr, sub_km(sb), (pdvab(ii), ii = 1, msubo)
!!    added for binary files 3/25/09 gsm line below and write (6666
	        if (ia_b == 1) then
                write(66666) sb, subgis(sb), iida, sub_km(sb),
     &                                        (pdvab(ii), ii = 1, msubo)
              endif

	end if

      return
!     changed for jennifer b.
!1000 format ('BIGSUB',i4,1x,i8,1x,i4,e10.5,18f10.3)
!1000 format ('BIGSUB',i4,1x,i8,1x,i4,e10.5,21f10.3)
 1000 format ('BIGSUB',i4,1x,i8,1x,i4,e10.5,18e10.3,1x,e10.5,5e10.3)
 1001 format('BIGSUB',i4,1x,i8,1x,i2,1x,i2,1x,i4,1x,e10.5,18e10.3,1x,
     &  e10.5, 5e10.3)
      end