module mod_output

use mod_common
use mod_common_mpi
use decomp_2d
use decomp_2d_io
!use mod_post
use mod_zredistribute
implicit none
private
public post1d,post2d,post3d,writeallpart
contains

subroutine post1d(time,istep,nstep)
implicit none

integer, intent(in) :: istep,nstep
real, intent(in) :: time
real, dimension(0:k1) :: um,vm,wm,pm, &
                         ur,vr,wr,pr, &
                         uw
real, dimension(0:k1) :: um_all,vm_all,wm_all,pm_all, &
                         ur_all,vr_all,wr_all,pr_all, &
                         uw_all,vw,vw_all
integer :: i,j,k
real :: dpdx, dpdx_all
!
do k=1,kmax
  um(k) = 0.
  vm(k) = 0.
  wm(k) = 0.
  pm(k) = 0.
  do j=1,jmax
    do i=1,imax
      um(k) = um(k) + unew(i,j,k)
      vm(k) = vm(k) + vnew(i,j,k)
      wm(k) = wm(k) + wnew(i,j,k)
      pm(k) = pm(k) + pnew(i,j,k)
    enddo
  enddo
enddo
!
! no-slip and no-penetration b.c.'s
!
um(0)    = -um(1)
vm(0)    = -vm(1)
wm(0)    =  0.
pm(0)    =  pm(1)      !Neumann
um(k1)   = -um(kmax)
vm(k1)   = -vm(kmax)
wm(kmax) =  0.
wm(k1)   =  wm(kmax-1) !dw/dz=0 (not used in code)
pm(k1)   =  pm(kmax)   !Neumann

call mpi_allreduce(um,um_all,k1+1,mpi_real8,mpi_sum,comm_cart,error)
call mpi_allreduce(vm,vm_all,k1+1,mpi_real8,mpi_sum,comm_cart,error)
call mpi_allreduce(wm,wm_all,k1+1,mpi_real8,mpi_sum,comm_cart,error)
call mpi_allreduce(pm,pm_all,k1+1,mpi_real8,mpi_sum,comm_cart,error)

um(:) = um_all(:)/(1.*itot*jtot)
vm(:) = vm_all(:)/(1.*itot*jtot)
wm(:) = wm_all(:)/(1.*itot*jtot)
pm(:) = pm_all(:)/(1.*itot*jtot)
!
! rms of velocities
!
do k=1,kmax
  ur(k) = 0.
  vr(k) = 0.
  wr(k) = 0.
  pr(k) = 0.
  do j=1,jmax
    do i=1,imax
      ur(k) = ur(k) + (unew(i,j,k)-um(k))**2
      vr(k) = vr(k) + (vnew(i,j,k)-vm(k))**2
      wr(k) = wr(k) + (wnew(i,j,k)-wm(k))**2
      pr(k) = pr(k) + (pnew(i,j,k)-pm(k))**2
    enddo
  enddo
enddo
!No-slip and no-penetration b.c.'s
ur(0)    = -ur(1)
vr(0)    = -vr(1)
wr(0)    =  0.
pr(0)    =  pr(1)        ! Neumann
ur(k1)   = -ur(kmax)
vr(k1)   = -vr(kmax)
wr(kmax) =  0.
wr(k1)   =  wr(kmax-1)   ! dw/dz=0
pr(k1)   =  pr(kmax)     ! Neumann
call mpi_reduce(ur,ur_all,k1+1,mpi_real8,mpi_sum,0,comm_cart,error)
call mpi_reduce(vr,vr_all,k1+1,mpi_real8,mpi_sum,0,comm_cart,error)
call mpi_reduce(wr,wr_all,k1+1,mpi_real8,mpi_sum,0,comm_cart,error)
call mpi_reduce(pr,pr_all,k1+1,mpi_real8,mpi_sum,0,comm_cart,error)
ur(:) = ur_all(:)/(1.*itot*jtot)
vr(:) = vr_all(:)/(1.*itot*jtot)
wr(:) = wr_all(:)/(1.*itot*jtot)
pr(:) = pr_all(:)/(1.*itot*jtot)
!
do k=1,kmax
  uw(k)=0.
  do j=1,jmax
    do i=1,imax
      uw(k) = uw(k) + 0.25*(unew(i,j,k+1)-um(k+1) + unew(i,j,k)-um(k))* &
                           (wnew(i+1,j,k)-wm(k  ) + wnew(i,j,k)-wm(k))
    enddo
  enddo
enddo

call mpi_allreduce(uw(0),uw_all(0),k1+1,mpi_real8,mpi_sum, &
                   comm_cart,error)
uw(1:kmax) = -uw_all(1:kmax)/(1.*itot*jtot)
!
! BC
!
uw(0)    = 0.
uw(kmax) = 0.
uw(k1)   = uw(kmax-1) !d(uw)/dz = 0 at solid wall
!
do k=1,kmax
  vw(k)=0.
  do j=1,jmax
    do i=1,imax
      vw(k) = vw(k) + 0.25*(vnew(i,j,k+1)-vm(k+1) + vnew(i,j,k)-vm(k))* &
                           (wnew(i,j+1,k)-wm(k  ) + wnew(i,j,k)-wm(k))
    enddo
  enddo
enddo

call mpi_allreduce(vw(0),vw_all(0),k1+1,mpi_real8,mpi_sum, &
                   comm_cart,error)
vw(1:kmax) = -vw_all(1:kmax)/(1.*itot*jtot)
!
! BC
!
vw(0)    = 0.
vw(kmax) = 0.
vw(k1)   = vw(kmax-1) !d(uw)/dz = 0 at solid wall
!
if (myid .eq. 0) then
  open(unit=30,file=datadir//'progress.out')
  write(30,'(A6,E16.8,A8,I7,A5,E16.8)') 'time =', time, &
   ' istep =', istep, ' dt =',dt
  write(30,'(A10,E16.8,A2)') 'progress =',100.*istep/(1.*nstep),' %'
  close(30)
!  !velocity profiles !CREATE ONE FILE PER SAVE
  open(40,file=datadir//'vel_stats.out')
  write(40,*)
  do k=1,kmax
    write(40,'(10E15.7)') (k-0.5)/dzi, (k-0.5)/dzi/visc, um(k), &
                                vm(k),(wm(k)+wm(k-1))*0.5,pm(k), &
                                ur(k),vr(k),0.5*(wr(k)+wr(k-1)),pr(k)
  enddo
  close(40)
!
! various stress profiles
!
  open(42,file=datadir//'str_stats.out')
  write(42,*)
  do k=0,kmax
    write(42,'(5E15.7)') k/dzi, k/dzi/visc, &
      visc * ( vm(k+1)-vm(k) )*dzi,  vw(k), &
      visc * ( vm(k+1)-vm(k) )*dzi + vw(k)
  enddo
  close(42)
endif

!
return
end subroutine post1d
!

subroutine post2d(istep)
implicit none

integer, intent(in) :: istep
real, dimension(imax,jmax,kmax) :: aux
real    :: u4(1:jmax,1:kmax)
real    :: v4(1:jmax,1:kmax)
real    :: w4(1:jmax,1:kmax)
real    :: p4(1:jmax,1:kmax)
real    :: y4(1:jmax,1:kmax)
real    :: h4(1:jmax,1:kmax) !#
real    :: cc4(1:jmax,1:kmax) !#
real    :: indie4(1:jmax,1:kmax) !#

real    :: u4r(0:(jtot+1),0:(kmax+1))
real    :: v4r(0:(jtot+1),0:(kmax+1))
real    :: w4r(0:(jtot+1),0:(kmax+1))
real    :: p4r(0:(jtot+1),0:(kmax+1))
real    :: y4r(0:(jtot+1),0:(kmax+1))
real    :: h4r(0:(jtot+1),0:(kmax+1)) !#
real    :: cc4r(0:(jtot+1),0:(kmax+1)) !#
real    :: indie4r(0:(jtot+1),0:(kmax+1)) !#

integer, parameter :: k_shift = 0  !##

integer :: ksol,nprocs
parameter(nprocs=dims(1)*dims(2),ksol=kmax/nprocs)
real ::   w2(0:i1,0:j1,0:k1)
real ::   unew2(itot,jtot,ksol)
real ::   vnew2(itot,jtot,ksol)
real ::   wnew2(itot,jtot,ksol)
real ::   pnew2(itot,jtot,ksol)

integer :: l,q,rank,sub_rank,sub_coords(ndims)
integer :: npoints
integer :: i,j,k,im,jm,km,it,jt,iloc,jloc
 character*3 number
 character*7 filenumber

!# plot in paraview
!aux(:,:,:) = ynew(1:imax,1:jmax,1:kmax)
!call write2dplane(aux,1,itot/2,'yzy',istep)

!aux(:,:,:) = 0.5*(vnew(1:imax,1+1:jmax+1,1:kmax) + vnew(1:imax,1:jmax,1:kmax))
!call write2dplane(aux,1,itot/2,'yzv',istep)

      i = itot/2
      q=-1
  114 q=q+1
      if ( (1+q*imax) .lt. i ) go to 114
      q=q-1
      iloc = i - q*imax
      sub_coords(1) = q
      sub_coords(2) = 0
      call MPI_CART_RANK(comm_cart,sub_coords,rank,error) !rank of process to which data has to be sent
      do l=1,dims(2)-1
        sub_coords(1) = q
        sub_coords(2) = l
        call MPI_CART_RANK(comm_cart,sub_coords,sub_rank,error)
        if (myid .eq. sub_rank) then
          do k=1,kmax
            do j=1,jmax

              u4(j,k)= 0.5*(unew(iloc,j,k)+unew(-1+iloc,j,k))
              v4(j,k)= vnew(iloc,j,k)
!              v4(j,k)= v_l(iloc,j,k)  !#
              w4(j,k)= wnew(iloc,j,k) !w_l(iloc,j,k)
!              w4(j,k)= w_l(iloc,j,k)  !#
              p4(j,k)= pnew(iloc,j,k)
              y4(j,k)= lvset(iloc,j,k +k_shift ,1) !##
              h4(j,k)= fixhv(iloc,j,k) !#
              cc4(j,k)= cutcell(iloc,j,k) !#
              indie4(j,k)= jiemian(iloc,j,k)  !#

            enddo
          enddo
          call MPI_SSEND(u4,jmax*kmax,MPI_REAL8,rank,7,comm_cart,error)
          call MPI_SSEND(v4,jmax*kmax,MPI_REAL8,rank,8,comm_cart,error)
          call MPI_SSEND(w4,jmax*kmax,MPI_REAL8,rank,9,comm_cart,error)
          call MPI_SSEND(p4,jmax*kmax,MPI_REAL8,rank,10,comm_cart,error)
          call MPI_SSEND(y4,jmax*kmax,MPI_REAL8,rank,11,comm_cart,error)
          call MPI_SSEND(h4,jmax*kmax,MPI_REAL8,rank,12,comm_cart,error) !#
          call MPI_SSEND(cc4,jmax*kmax,MPI_REAL8,rank,13,comm_cart,error) !#
          call MPI_SSEND(indie4,jmax*kmax,MPI_REAL8,rank,14,comm_cart,error) !#

        endif
        if (myid .eq. rank) then
          call MPI_RECV(u4,jmax*kmax,MPI_REAL8,sub_rank,7,  &
                        comm_cart,status,error)
          call MPI_RECV(v4,jmax*kmax,MPI_REAL8,sub_rank,8,  &
                        comm_cart,status,error)
          call MPI_RECV(w4,jmax*kmax,MPI_REAL8,sub_rank,9,  &
                        comm_cart,status,error)
          call MPI_RECV(p4,jmax*kmax,MPI_REAL8,sub_rank,10, &
                        comm_cart,status,error)
          call MPI_RECV(y4,jmax*kmax,MPI_REAL8,sub_rank,11, &
                        comm_cart,status,error)
          call MPI_RECV(h4,jmax*kmax,MPI_REAL8,sub_rank,12, &
                        comm_cart,status,error) !#
          call MPI_RECV(cc4,jmax*kmax,MPI_REAL8,sub_rank,13, &
                        comm_cart,status,error) !#
          call MPI_RECV(indie4,jmax*kmax,MPI_REAL8,sub_rank,14, &
                        comm_cart,status,error) !#

          do k=1,kmax
            do j=1,jmax

              u4r(j+l*jmax,k)=u4(j,k)
              v4r(j+l*jmax,k)=v4(j,k)
              w4r(j+l*jmax,k)=w4(j,k)
              p4r(j+l*jmax,k)=p4(j,k)
              y4r(j+l*jmax,k)=y4(j,k)
              h4r(j+l*jmax,k)=h4(j,k) !#
              cc4r(j+l*jmax,k)=cc4(j,k) !#
              indie4r(j+l*jmax,k)=indie4(j,k) !#

            enddo
          enddo
        endif
      enddo
      if (myid .eq. rank) then
        do k=1,kmax
          do j=1,jmax
            u4r(j,k)= 0.5*(unew(iloc,j,k)+unew(-1+iloc,j,k))
            v4r(j,k)= vnew(iloc,j,k)
!            v4r(j,k)= v_l(iloc,j,k)  !#
            w4r(j,k)= wnew(iloc,j,k) !w_l(iloc,j,k)
!            w4r(j,k)= w_l(iloc,j,k)  !#
            p4r(j,k)= pnew(iloc,j,k)
            y4r(j,k)= lvset(iloc,j,k +k_shift,1) !##
            h4r(j,k)=fixhv(iloc,j,k) !#
            cc4r(j,k)= cutcell(iloc,j,k) !#
            indie4r(j,k)= jiemian(iloc,j,k)  !#

          enddo
          !periodic b.c.
          u4r(0,k)     =u4r(jtot,k)
        enddo
        !b.c.
        do j=1,jtot
          w4r(j,0)=0.
        enddo

!!#
!        do k=1,kmax
!          do j=1,jmax
!            h4r(j,k)=0.
!            do i=1,imax

!              h4r(j,k)=h4r(j,k)+hnew(i,j,k)
!            enddo
!            h4r(j,k)=h4r(j,k)/imax
!          enddo
!        enddo
!!#

        if(mod(istep,1).eq.0) then

          write(filenumber,'(i7.7)') istep
!#          write(filenumber,'(i7.7)') iterations  !# comment if not validating level set re-init
          open(43,file=datadir//'yz_mid'//filenumber//'.dat')
          write(43,*) 'VARIABLES = "y","z","u","v","w","p","s","indie","fixhv"'  !#
          write(43,*) 'ZONE T="Zone1"',' I=',jtot+2*npoints,' J=',kmax,', F=POINT'
!'
          do k=1,kmax
            km=k-1
            do jt=-npoints+1,jtot+npoints
              j=jt
              if (j .lt. 1)    j = j+jtot
              if (j .gt. jtot) j = j-jtot
              jm=jt-1
              if (jm .lt. 1)    jm = jm+jtot
              if (jm .gt. jtot) jm = jm-jtot
              write(43,'(9E15.7)') (jt-0.5)/dyi,(k-0.5)/dzi,u4r(j,k), &
                                   0.5*(v4r(j,k)+v4r(jm,k)),                    &
                                   0.5*(w4r(j,k)+w4r(j,km)),p4r(j,k),&
                                   y4r(j,k), indie4r(j,k), h4r(j,k)  !cc4r(j,k)
            enddo
          enddo
          close(43)

        endif

      endif

!!!!!!!XY
!      do k=1,k1
!        do j=0,j1
!          do i=0,i1
!            w2(i,j,k) = 0.5*(wnew(i,j,k)+wnew(i,j,k-1))
!          enddo
!        enddo
!      enddo
!!     B.c.'s: zero velocity at walls
!      do j=0,j1
!        do i=0,i1
!          w2(i,j,0)    = 0.
!          w2(i,j,kmax) = 0.
!        enddo
!      enddo
!      call zredistribute(unew,unew2,0)
!      call zredistribute(vnew,vnew2,0)
!      call zredistribute(w2  ,wnew2,0)
!      call zredistribute(pnew,pnew2,0)
!      k = kmax/2
!      l = -1
!  199 l = l+1
!      if ( (1+l*ksol) .lt. k ) go to 199
!      l = l-1
!      rank = l
!      if (myid .eq. rank) then
!        write(number,'(i3.3)') k
!        k    = k - rank*ksol

!        if(mod(istep,100).eq.0) then
!        open(42,file=datadir//'xy'//number//'time'//filenumber//'.dat')
!        write(filenumber,'(i7.7)') istep
!        write(42,*) 'VARIABLES = "x","y","u","v","w","p"'
!        write(42,*) 'ZONE T="Zone1"',' I=',itot+2*npoints,' J=',jtot+2*npoints,', F=POINT'
!        do jt=-npoints+1,jtot+npoints
!          j=jt
!          if (j .lt. 1)    j = j+jtot
!          if (j .gt. jtot) j = j-jtot
!          jm=jt-1
!          if (jm .lt. 1)    jm = jm+jtot
!          if (jm .gt. jtot) jm = jm-jtot
!          do it=-npoints+1,itot+npoints
!            i=it
!            if (i .lt. 1)    i = i+itot
!            if (i .gt. itot) i = i-itot
!            im=it-1
!            if (im .lt. 1)    im = im+itot
!            if (im .gt. itot) im = im-itot
!            write(42,'(6E15.7)') (it-0.5)/dxi/L_ref,(jt-0.5)/dyi/L_ref,0.5*(unew2(i,j,k)+unew2(im,j,k))/U_ref, &
!                                0.5*(vnew2(i,j,k)+vnew2(i,jm,k))/U_ref,                                      &
!                                wnew2(i,j,k)/U_ref,pnew2(i,j,k)/(U_ref**2.)
!          enddo
!        enddo
!        close(42)
!        endif
!      endif

return
end subroutine post2d

subroutine write2dplane(var,norm,islice,name,istep)
implicit none
real, intent(in), dimension(imax,jmax,kmax) :: var
integer, intent(in) :: norm,islice,istep
character(len=3) :: name
character(len=4) :: slicechar
character(len=7) :: fldnum

write(fldnum,'(i7.7)') istep
write(slicechar,'(i4.4)') islice
select case(norm)
case(1) !normal to x --> yz plane
  call decomp_2d_write_plane(3,var,norm,islice,datadir//name//'_xeq_'//slicechar//'_fld_'//fldnum//'.out')
case(2) !normal to y --> zx plane
  call decomp_2d_write_plane(3,var,norm,islice,datadir//name//'_yeq_'//slicechar//'_fld_'//fldnum//'.out')
case(3) !normal to z --> xy plane
  call decomp_2d_write_plane(3,var,norm,islice,datadir//name//'_zeq_'//slicechar//'_fld_'//fldnum//'.out')
end select

return
end subroutine write2dplane

subroutine post3d(istep)
implicit none
integer, intent(in) :: istep
real, allocatable, dimension(:,:,:) :: var1,var2,var3,var4
integer, parameter :: nprocs=dims(1)*dims(2),ksol=kmax/nprocs
integer :: p
!!
!! pressure
!!
!allocate(var1(1:imax,1:jmax,1:kmax))
!var1(:,:,:) = pnew(1:imax,1:jmax,1:kmax)
!call write3dscal(istep,imax,jmax,kmax,var1,'pre')
!!
!! u velocity
!!
!var1(:,:,:) = unew(1:imax,1:jmax,1:kmax)
!call write3dscal(istep,imax,jmax,kmax,var1,'vex')
!!
!! v velocity
!!
!var1(:,:,:) = vnew(1:imax,1:jmax,1:kmax)
!call write3dscal(istep,imax,jmax,kmax,var1,'vey')
!!
!! w velocity
!!
!var1(:,:,:) = wnew(1:imax,1:jmax,1:kmax)
!call write3dscal(istep,imax,jmax,kmax,var1,'vez')
!!
!! dissipation (rate-of-strain)
!!
!call strain_rate(unew,vnew,wnew,var1)
!call write3dscal(istep,imax,jmax,kmax,var1,'dis')
!!
!! enstrophy
!!
!allocate(var2(1:imax,1:jmax,1:kmax))
!call enstrophy(unew,vnew,wnew,var2)
!!
!! Q-criterion
!!
!allocate(var3(1:imax,1:jmax,1:kmax))
!call q_criterion(var2,var1,var3)
!call write3dscal(istep,imax,jmax,kmax,var3,'qcr')
!!
!! R (third invariant of the velocity-gradient tensor
!!
!allocate(var4(1:imax,1:jmax,1:kmax))
!call compute_r(unew,vnew,wnew,var4)
!!
!! swirling strength (lambda_{ci})
!!
!call swirl(var3,var4,var1)
!call write3dscal(istep,imax,jmax,kmax,var3,'swr')
!!
return
end subroutine post3d

subroutine write3dscal(istep,n1,n2,n3,var,name)
implicit none
integer, intent(in) :: istep,n1,n2,n3
real, intent(in), dimension(n1,n2,n3) :: var
character(len=3), intent(in) :: name
integer :: fh
integer(kind=MPI_OFFSET_KIND) :: filesize,disp
character :: istepchar*7
!
write(istepchar,'(i7.7)') istep
call MPI_FILE_OPEN(MPI_COMM_WORLD, datadir//name//istepchar, &
     MPI_MODE_CREATE+MPI_MODE_WRONLY, MPI_INFO_NULL,fh, error)
filesize = 0_MPI_OFFSET_KIND
call MPI_FILE_SET_SIZE(fh,filesize,error)  ! guarantee overwriting
disp = 0_MPI_OFFSET_KIND
call decomp_2d_write_var(fh,disp,3,var)
call MPI_FILE_CLOSE(fh,error)
!
return
end subroutine write3dscal

subroutine writeallpart(istep,irank,nprank)
implicit none
integer,intent(in) :: istep,irank,nprank
character(len=1), parameter :: lf = char(10)
character(len=400) :: buffer
character(len=50) :: filename,filename2
integer :: ivtk
integer :: p
integer :: e_io,indent
real :: dummy
integer(kind=4) :: idummy
integer(kind=1) :: idummy1
integer :: offst
integer :: counter
offst = 0
!

!ivtk = 99+irank
!write(filename,fmt='(A,(i6.6),A,(i7.7),A)') datadir//'allpart_rk',irank,'_fld',istep,'.vtu'
!
!open(unit = ivtk, file = trim(filename), form = 'binary',access='sequential',  &
!     action = 'write', convert ='big_endian', recordtype='stream', buffered = 'yes', &
!     iostat = e_io)
!write(unit=ivtk,iostat=e_io)'<?xml version="1.0"?>'//lf
!write(unit=ivtk,iostat=e_io)'<VTKFile type="'//'UnstructuredGrid'//'" version="0.1" byte_order="BigEndian">'//lf
!indent = 2
!write(buffer,fmt='(A)',iostat=e_io)repeat(' ',indent)//'<'//'UnstructuredGrid'//'>'
!write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!  indent = indent + 2
!  write(buffer,fmt='(A,(I6),A,(I6),A)',iostat=e_io)repeat(' ',indent)//'<'//'Piece'//' NumberOfPoints="',nprank,'"'// &
!                                                                              ' NumberOfCells="',nprank,'">'
!  write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!  indent = indent + 2
!      write(unit=ivtk,iostat=e_io)repeat(' ',indent)//'<PointData Vectors="vectors">'//lf
!      indent = indent + 2
!      write(buffer,fmt='(A,(I12),A)')repeat(' ',indent)//'<DataArray Name="velocity" NumberOfComponents="3" type="Float64" format="appended" offset="',offst,'">'
!      write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!      offst = offst + nprank*3*sizeof(dummy)+sizeof(idummy)
!      write(buffer,fmt='(A)')repeat(' ',indent)//'</DataArray'//'>'
!      write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!      write(buffer,fmt='(A,(I12),A)')repeat(' ',indent)//'<DataArray Name="omegaxyz" NumberOfComponents="3" type="Float64" format="appended" offset="',offst,'">'
!      write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!      offst = offst + nprank*3*sizeof(dummy)+sizeof(idummy)
!      write(buffer,fmt='(A)')repeat(' ',indent)//'</DataArray'//'>'
!      write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!      write(buffer,fmt='(A,(I12),A)')repeat(' ',indent)//'<DataArray Name="thetaxyz" NumberOfComponents="3" type="Float64" format="appended" offset="',offst,'">'
!      write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!      offst = offst + nprank*3*sizeof(dummy)+sizeof(idummy)
!      write(buffer,fmt='(A)')repeat(' ',indent)//'</DataArray'//'>'
!      write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!    indent = indent - 2
!    write(unit=ivtk,iostat=e_io)repeat(' ',indent)//'</PointData>'//lf
!    write(unit=ivtk,iostat=e_io)repeat(' ',indent)//'<Points>'//lf
!      indent = indent + 2
!      write(buffer,fmt='(A,(I12),A)')repeat(' ',indent)//'<DataArray Name="Point" NumberOfComponents="3" type="Float64" format="appended" offset="',offst,'">'
!      write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!      offst = offst + nprank*3*sizeof(dummy)+sizeof(idummy)
!      write(buffer,fmt='(A)')repeat(' ',indent)//'</DataArray'//'>'
!      write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!      indent = indent - 2
!      write(unit=ivtk,iostat=e_io)repeat(' ',indent)//'</Points>'//lf
!  write(unit=ivtk,iostat=e_io)repeat(' ',indent)//'<Cells>'//lf
!  indent = indent + 2
!  write(buffer,fmt='(A,(I8),A)')repeat(' ',indent)//'<DataArray type="Int32" Name="connectivity" format="appended" offset="',offst,'"></DataArray>'
!      write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!  offst = offst + sizeof(idummy) + nprank*sizeof(idummy)
!  write(buffer,fmt='(A,(I8),A)')repeat(' ',indent)//'<DataArray type="Int32" Name="offsets" format="appended" offset="',offst,'"></DataArray>'
!      write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!  offst = offst + sizeof(idummy) + nprank*sizeof(idummy)
!  write(buffer,fmt='(A,(I8),A)')repeat(' ',indent)//'<DataArray type="Int8" Name="types" format="appended" offset="',offst,'"></DataArray>'
!      write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!  offst = offst + sizeof(idummy) + nprank*sizeof(idummy1)
!  indent = indent - 2

!  write(unit=ivtk,iostat=e_io)repeat(' ',indent)//'</Cells>'//lf
!    indent = indent - 2
!    write(buffer,fmt='(A)',iostat=e_io)repeat(' ',indent)//'</'//'Piece'//'>'
!    write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!    indent = indent - 2
!  write(buffer,fmt='(A)',iostat=e_io)repeat(' ',indent)//'</'//'UnstructuredGrid'//'>'
!  write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!  write(unit=ivtk,iostat=e_io)repeat(' ',indent)//'<AppendedData encoding="raw">'//lf
!  write(unit=ivtk,iostat=e_io)'_'
!  write(unit=ivtk,iostat=e_io) 3*nprank*8!sizeof(dummy) !position and 3 vectors
!  do p=1,pmax
!    if(ap(p)%mslv.gt.0) then
!      write(ivtk,iostat=e_io) ap(p)%u,ap(p)%v,ap(p)%w
!    endif
!  enddo
!  write(unit=ivtk,iostat=e_io) 3*nprank*8!*sizeof(dummy) !position and 3 vectors
!  do p=1,pmax
!    if(ap(p)%mslv.gt.0) then
!      write(ivtk,iostat=e_io) ap(p)%omx,ap(p)%omy,ap(p)%omz
!    endif
!  enddo
!  write(unit=ivtk,iostat=e_io) 3*nprank*8!*sizeof(dummy) !position and 3 vectors
!  do p=1,pmax
!    if(ap(p)%mslv.gt.0) then
!      write(ivtk,iostat=e_io) ap(p)%omx,ap(p)%omy,ap(p)%omz
!    endif
!  enddo
!  write(unit=ivtk,iostat=e_io) 3*nprank*8!sizeof(dummy) !position
!  do p=1,pmax
!    if(ap(p)%mslv.gt.0) then
!      write(ivtk,iostat=e_io) ap(p)%x,ap(p)%y,ap(p)%z
!    endif
!  enddo
!  write(unit=ivtk,iostat=e_io) nprank*4!sizeof(idummy)
!  write(unit=ivtk,iostat=e_io) (p-1,p=1,nprank)
!  write(unit=ivtk,iostat=e_io) nprank*4!sizeof(idummy)
!  write(unit=ivtk,iostat=e_io) (p,p=1,nprank)
!  write(unit=ivtk,iostat=e_io) nprank*1!sizeof(idummy1)
!  idummy1 = 1
!  write(unit=ivtk,iostat=e_io) (idummy1,p=1,nprank)
!  write(unit=ivtk,iostat=e_io) lf
!  write(unit=ivtk,iostat=e_io)repeat(' ',indent)//'</AppendedData>'//lf
!  indent = indent - 2
!write(unit=ivtk,iostat=e_io)repeat(' ',indent)//'</VTKFile>'//lf
!close(ivtk)
!
!if(myid.eq.0) then
!  offst = 0
!  write(filename,fmt='(A,(i6.6),A,(i7.7),A)') datadir//'allpart_fld',istep,'.pvtu'
!  open(unit = ivtk, file = trim(filename), form = 'binary',access='sequential',  &
!       action = 'write', convert ='big_endian', recordtype='stream', buffered = 'yes', &
!       iostat = e_io)
!  write(unit=ivtk,iostat=e_io)'<?xml version="1.0"?>'//lf
!  write(unit=ivtk,iostat=e_io)'<VTKFile type="'//'PUnstructuredGrid'//'" version="0.1" byte_order="BigEndian">'//lf
!  indent = 2
!  write(buffer,fmt='(A)',iostat=e_io)repeat(' ',indent)//'<'//'PUnstructuredGrid GhostLevel="0"'//'>'
!  write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!  indent = indent + 2
!      write(unit=ivtk,iostat=e_io)repeat(' ',indent)//'<PPointData Vectors="vectors">'//lf
!      indent = indent + 2
!      write(buffer,fmt='(A,(I12),A)')repeat(' ',indent)//'<PDataArray Name="velocity" NumberOfComponents="3" type="Float64" format="appended" offset="',offst,'">'
!      write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!      offst = offst + nprank*3*sizeof(dummy)+sizeof(idummy)
!      write(buffer,fmt='(A)')repeat(' ',indent)//'</PDataArray'//'>'
!      write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!      write(buffer,fmt='(A,(I12),A)')repeat(' ',indent)//'<PDataArray Name="omegaxyz" NumberOfComponents="3" type="Float64" format="appended" offset="',offst,'">'
!      write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!      offst = offst + nprank*3*sizeof(dummy)+sizeof(idummy)
!      write(buffer,fmt='(A)')repeat(' ',indent)//'</PDataArray'//'>'
!      write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!      write(buffer,fmt='(A,(I12),A)')repeat(' ',indent)//'<PDataArray Name="thetaxyz" NumberOfComponents="3" type="Float64" format="appended" offset="',offst,'">'
!      write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!      offst = offst + nprank*3*sizeof(dummy)+sizeof(idummy)
!      write(buffer,fmt='(A)')repeat(' ',indent)//'</PDataArray'//'>'
!      write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!    indent = indent - 2
!    write(unit=ivtk,iostat=e_io)repeat(' ',indent)//'</PPointData>'//lf
!    write(unit=ivtk,iostat=e_io)repeat(' ',indent)//'<PPoints>'//lf
!      indent = indent + 2
!      write(buffer,fmt='(A,(I12),A)')repeat(' ',indent)//'<PDataArray Name="Point" NumberOfComponents="3" type="Float64" format="appended" offset="',offst,'">'
!      write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!      offst = offst + nprank*3*sizeof(dummy)+sizeof(idummy)
!      write(buffer,fmt='(A)')repeat(' ',indent)//'</PDataArray'//'>'
!      write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!      indent = indent - 2
!      write(unit=ivtk,iostat=e_io)repeat(' ',indent)//'</PPoints>'//lf
!  write(unit=ivtk,iostat=e_io)repeat(' ',indent)//'<PCells>'//lf
!  indent = indent + 2
!  write(buffer,fmt='(A,(I8),A)')repeat(' ',indent)//'<PDataArray type="Int32" Name="connectivity" format="appended" offset="',offst,'"></PDataArray>'
!      write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!  offst = offst + sizeof(idummy) + nprank*sizeof(idummy)
!  write(buffer,fmt='(A,(I8),A)')repeat(' ',indent)//'<PDataArray type="Int32" Name="offsets" format="appended" offset="',offst,'"></PDataArray>'
!      write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!  offst = offst + sizeof(idummy) + nprank*sizeof(idummy)
!  write(buffer,fmt='(A,(I8),A)')repeat(' ',indent)//'<PDataArray type="Int8" Name="types" format="appended" offset="',offst,'"></PDataArray>'
!      write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!  offst = offst + sizeof(idummy) + nprank*sizeof(idummy1)
!  indent = indent - 2
!  write(unit=ivtk,iostat=e_io)repeat(' ',indent)//'</PCells>'//lf
!  do p=0,product(dims)-1
!    write(filename2,fmt='(A,(i6.6),A,(i7.7),A)') 'allpart_rk',p,'_fld',istep,'.vtu'
!    write(unit=ivtk,iostat=e_io) repeat(' ',indent)//'<Piece Source="'//trim(filename2)//'"/>'//lf
!  enddo
!  indent = indent - 2
!  write(buffer,fmt='(A)',iostat=e_io) repeat(' ',indent)//'<'//'/PUnstructuredGrid'//'>'
!  write(unit=ivtk,iostat=e_io)trim(buffer)//lf
!  indent = indent - 2
!  write(buffer,fmt='(A)',iostat=e_io) repeat(' ',indent)//'</VTKFile>'
!  write(unit=ivtk,iostat=e_io)trim(buffer)
!  close(ivtk)
!endif
!
return
end subroutine writeallpart
!
end module mod_output


module tt2
  real(8), allocatable :: core(:)
  type, public ::  pointd
    double precision, dimension(:), pointer :: p=>null()
  end type pointd

contains

  subroutine full_to_tt(a,asize,n,d,eps,r)
    use matrix_util
    implicit none
    integer, intent(in) :: d
    real(8), intent(in) :: eps
    integer, intent(in) :: n(d)
    integer, intent(in) :: asize
    integer, intent(out) :: r(d+1)
    real(8), intent(inout) :: a(asize)
    integer :: rmax = 150
    double precision, allocatable :: sv(:)
    type(pointd) :: cr(d+1)
    integer :: i, rnew, M, k, nn
    integer :: lwork, info
    double precision, allocatable :: work(:)
    M = product(n(2:d))
    lwork = 0
    r(1) = 1
    r(d+1) = 1
    allocate(sv(rmax))
    print *,'d=',d
    print *,n
    do i = 1, d
        rnew = min(r(i)*n(i),M)
        if ( lwork < 256*max(M, r(i)*n(i)) .or. .not. (allocated(work))) then
           lwork = 256*max(M, r(i)*n(i))
           if ( allocated(work) ) then
              deallocate(work)
           end if
           allocate(work(lwork))
        end if
        if ( rnew > rmax ) then
           deallocate(sv)
           rmax = 2 * rnew
           allocate(sv(rmax))
        end if
        allocate(cr(i)%p(r(i)*n(i)*rnew))
        print *,'i=',i,'M=',M,'rnew=',rnew
        call dgesvd('s','o',r(i)*n(i),M,a,r(i)*n(i),sv,cr(i)%p,r(i)*n(i), a, rnew, work, lwork, info)
        if ( info .ne. 0 ) then
           print *,'tt2 full_to_tt failed with info=',info
           exit
        end if
        r(i+1) = my_chop3(rnew,sv,eps/sqrt(1d0*(d-1)))
        do k = 1,r(i+1)
           call dscal(r(i)*n(i), sv(k), cr(i)%p((k-1)*r(i)*n(i)+1), 1)
        end do
        M = (r(i+1)*M)/(n(i)*r(i))
    end do
    print *,'HERE!'
    !And parse the input
    nn = 0
    do i = 1,d
       nn = nn + r(i) * n(i) * r(i+1)
    end do
    if ( allocated(core) ) then
        if ( size(core) < nn ) then
            deallocate(core)
            allocate(core(nn))
        end if
    else
        allocate(core(nn))
    end if
    nn = 1
    print *,'And here!'
    do i = 1,d
        call dcopy(r(i)*n(i)*r(i+1),cr(i)%p,1,core(nn),1)
        nn = nn + r(i)*n(i)*r(i+1)
        deallocate(cr(i)%p)
    end do
    deallocate(work)
    deallocate(sv)
    print *,'And(2) here!'
 end subroutine full_to_tt

  subroutine tt_dealloc()
    deallocate(core)
  end subroutine tt_dealloc

  subroutine tt_to_full(n,r,d,cr,crsize,a,asize)
    use matrix_util
    implicit none
    integer, intent(in) :: d
    integer, intent(in) :: n(d)
    integer, intent(in) :: r(d+1)
    integer, intent(in) :: asize
    integer, intent(in) :: crsize
    double precision, intent(in) :: cr(crsize)
    double precision, intent(out) :: a(asize)
    double precision :: tmp(asize)
    integer :: ps(d+1)
    integer :: i, M
    call compute_ps(d,r,n,ps)
    !call dcopy(r(1)*n(1)*r(2), cr(ps(1)), 1, a, 1)
    call eye(r(1),a) !first core is M x r(i) x r(i) x n(i) x r(i+1)
    !M = r(1; M = r(i) x n(i);
    M = r(1)
    do i = 1,d
      call dgemm('n','n',M,n(i)*r(i+1),r(i),1d0,a,M,cr(ps(i)),r(i),0d0,tmp,M)
      call dcopy(M*n(i)*r(i+1),tmp,1,a,1)
      M = M * n(i)
    end do
  end subroutine tt_to_full

  subroutine tt_add(n,d,r1,r2,ps1,ps2,core1,core2,rres,psres)
    implicit none
    integer, intent(in)  :: d
    integer, intent(in)  :: n(d)
    integer, intent(in)  :: r1(d+1)
    integer, intent(in)  :: r2(d+1)
    integer, intent(in)  :: ps1(d+1)
    integer, intent(in)  :: ps2(d+1)
    integer, intent(out) :: rres(d+1)
    integer, intent(out) :: psres(d+1)
    real(8), intent(in) :: core1(:)
    real(8), intent(in) :: core2(:)

  end subroutine tt_add

  subroutine tt_compr2(n,d,r,ps,cr,eps)
    implicit none
    integer, intent(in) :: d
    integer, intent(in) :: n(d)
    integer, intent(inout) :: r(d+1)
    integer, intent(inout) :: ps(d+1)
    real(8), intent(in) :: cr(:)
    real(8), intent(in) :: eps
  end subroutine tt_compr2

  subroutine tt_norm(n,d,r,ps,cr,nrm)
    implicit none
    integer, intent(in) :: d
    integer, intent(in) :: n(d)
    integer, intent(in) :: r(d+1)
    integer, intent(in) :: ps(d+1)
    real(8), intent(in) :: cr(:)
    real(8), intent(out) :: nrm
    integer :: i

  end subroutine tt_norm
    !Later on we will avoid allocation in + and hdm, where the result have a very specific
    !size, i.e., ranks core size can be precomputed
    subroutine tt_hdm(n,d,r1,r2,ps1,ps2,core1,core2,rres,psres)
      integer, intent(in)  :: d
      integer, intent(in)  :: n(d)
      integer, intent(in)  :: r1(d+1)
      integer, intent(in)  :: r2(d+1)
      integer, intent(in)  :: ps1(d+1)
      integer, intent(in)  :: ps2(d+1)
      integer, intent(out) :: rres(d+1)
      integer, intent(out) :: psres(d+1)
      real(8),    intent(in) :: core1(:)
      real(8),    intent(in) :: core2(:)
    end subroutine tt_hdm

end module tt2


!> This subroutine is used for calculating energy
!> dispersion with wannier functions
! Copyright (c) 2010 QuanSheng Wu. All rights reserved.
  subroutine ek_ribbon

     use wmpi
     use para
     implicit none

! loop index
     integer :: i
     integer :: j
     integer :: l

     integer :: lwork

! wave vector
     real(Dp) :: k

     real(dp) :: emin, emax

! parameters for zheev
     integer :: ierr
     real(Dp), allocatable ::  rwork(:)
     complex(Dp), allocatable :: work(:)

! eigenvalue
     real(Dp), allocatable :: eigenvalue(:)

! energy dispersion
     real(Dp),allocatable :: ekribbon(:,:)
     real(Dp),allocatable :: ekribbon_mpi(:,:)

     !> color for plot, surface state weight
     real(dp), allocatable :: surf_weight(:, :)
     real(dp), allocatable :: surf_weight_mpi(:, :)

! hamiltonian ribbon
     complex(Dp),allocatable ::CHamk(:,:)

     lwork= 16*Nslab*Num_wann
     ierr = 0

     allocate(eigenvalue(nslab*Num_wann))
     allocate( surf_weight (Nslab* Num_wann, knv1))
     allocate( surf_weight_mpi (Nslab* Num_wann, knv1))
     allocate(ekribbon(Nslab*Num_wann,knv1))
     allocate(ekribbon_mpi(Nslab*Num_wann,knv1))
     allocate(CHamk(nslab*Num_wann,nslab*Num_wann))
     allocate(work(lwork))
     allocate(rwork(lwork))

     surf_weight= 0d0
     surf_weight_mpi= 0d0

     ! sweep k
     ekribbon=0.0d0
     ekribbon_mpi=0.0d0
     do i=1+cpuid,knv1,num_cpu
        if (cpuid==0) write(stdout, *), 'ribbonEk, ik ',  i, knv1
        k= k1_path(i)
        chamk=0.0d0

        !> no magnetgic field
        if (abs(Bx)<eps9.and. abs(By)<eps9.and. abs(Bz)<eps9)then
           call ham_ribbon(k,Chamk)
        !> in-plane magnetic field
        elseif (abs(Bx)>eps9 .or. abs(By)>eps9)then
           write(stdout, *)'>> magnetic field is larger than zero'
           call ham_ribbon(k,Chamk)
          !call ham_slab_parallel_B(k,Chamk)
        !> vertical magnetic field
        else
           print *, 'Error: we only support in-plane magnetic field at present'
           stop 'please set Bz= 0'
        endif

        eigenvalue=0.0d0

        ! diagonal Chamk
        call eigensystem_c('V', 'U', Num_wann*Nslab, CHamk, eigenvalue)

        ekribbon(:,i)=eigenvalue

        do j=1, Nslab*Num_wann
           do l=1, Num_wann
              surf_weight(j, i)= surf_weight(j, i) &
                 + abs(CHamk(l, j))**2 & ! first slab
                 + abs(CHamk(Num_wann*Nslab- l+ 1, j))**2 !& ! last slab
                !+ abs(CHamk(Num_wann+ l, j))**2 & ! the second slab
                !+ abs(CHamk(Num_wann*(Nslab-1)- l, j))**2 ! last second slab
           enddo ! l
           surf_weight(j, i)= sqrt(surf_weight(j, i))
        enddo ! j
     enddo ! i

     call mpi_allreduce(ekribbon,ekribbon_mpi,size(ekribbon),&
                       mpi_dp,mpi_sum,mpi_cmw,ierr)
     call mpi_allreduce(surf_weight, surf_weight_mpi,size(surf_weight),&
                       mpi_dp,mpi_sum,mpi_cmw,ierr)

     ekribbon=ekribbon_mpi
     if (maxval(surf_weight_mpi)<0.00001d0)surf_weight_mpi=1d0
     surf_weight= surf_weight_mpi/ maxval(surf_weight_mpi)

     if(cpuid==0)then
        open(unit=100, file='ribbonek.dat')
        do j=1, Num_wann*Nslab
           do i=1, knv2
             !write(100,'(3f15.7, i8)')k1len(i), ekslab(j,i), &
             !   (surf_weight(j, i))
              write(100,'(2f15.7, i8)')k1len(i), ekribbon(j,i), &
                 int(255-surf_weight(j, i)*255d0)
           enddo
           write(100 , *)''
        enddo
        close(100)
        write(stdout,*) 'calculate energy band  done'
     endif

     emin= minval(ekribbon)-0.5d0
     emax= maxval(ekribbon)+0.5d0
     !> write script for gnuplot
     if (cpuid==0) then
        open(unit=113, file='ribbonek.gnu')
        write(113, '(a)')"set encoding iso_8859_1"
        write(113, '(a)')'#set terminal  postscript enhanced color'
        write(113, '(a)')"#set output 'ribbonek.eps'"
        write(113, '(3a)')'#set terminal  pngcairo truecolor enhanced', &
           '  font ",60" size 1920, 1680'
        write(113, '(3a)')'set terminal  png truecolor enhanced', &
           '  font ",60" size 1920, 1680'
        write(113, '(a)')"set output 'ribbonek.png'"
        write(113,'(2a)') 'set palette defined ( 0  "green", ', &
           '5 "yellow", 10 "red" )'
        write(113, '(a)')'set style data linespoints'
        write(113, '(a)')'unset ztics'
        write(113, '(a)')'unset key'
        write(113, '(a)')'set pointsize 0.8'
        write(113, '(a)')'set border lw 3 '
        write(113, '(a)')'set view 0,0'
        write(113, '(a)')'#set xtics font ",36"'
        write(113, '(a)')'#set ytics font ",36"'
        write(113, '(a)')'#set ylabel font ",36"'
        write(113, '(a)')'#set xtics offset 0, -1'
        write(113, '(a)')'set ylabel offset -1, 0 '
        write(113, '(a)')'set ylabel "Energy (eV)"'
        write(113, '(a, f10.5, a)')'set xrange [0: ', maxval(k1len), ']'
        write(113, '(a, f10.5, a, f10.5, a)')'set yrange [', emin, ':', emax, ']'
        write(113, 202, advance="no") (trim(k1line_name(i)), k1line_stop(i), i=1, nk1lines)
        write(113, 203)trim(k1line_name(nk1lines+1)), k1line_stop(nk1lines+1)

        do i=1, nk1lines-1
           write(113, 204)k1line_stop(i+1), emin, k1line_stop(i+1), emax
        enddo
        write(113, '(a)')'rgb(r,g,b) = int(r)*65536 + int(g)*256 + int(b)'
        write(113, '(2a)')"plot 'ribbonek.dat' u 1:2:(rgb(255,$3, 3)) ",  &
            "w lp lw 2 pt 7  ps 1 lc rgb variable"

        !write(113, '(2a)')"splot 'ribbonek.dat' u 1:2:3 ",  &
        !   "w lp lw 2 pt 13 palette"
        close(113)
     endif

     202 format('set xtics (',:20('"',A3,'" ',F10.5,','))
     203 format(A3,'" ',F10.5,')')
     204 format('set arrow from ',F10.5,',',F10.5, &
        ' to ',F10.5,',',F10.5, ' nohead')

  return
  end subroutine ek_ribbon


program main
    implicit none

    character(len=20) :: yn
    real(8) :: A, B, Tg, Tr, dh, T, c1, c2, Q, Tpeak, k, Ac, Ea, delta, mol, TgJump, T0, Tf

    !activation energy for curation
    Ea = 1000.0
    !amount present in the sample to cure
    mol = 0.6
    !chemicals A and B; proxy DGEBA-DDM, reaction ratio
    A = 2.0
    B = 1.0

    !vitreous transition temperature for the resin, size of jump
    Tg = 60.0
    TgJump = 0.70

    !temperature for which a curation reaction starts occuring
    Tr = 120.0
    !peak reaction temperature
    Tpeak = 164.0

    !temperature scanning range
    T0 = 0.0
    Tf = 300.0

    !temperature variable
    T = T0

    !heat coeficient before and after vitreous transition
    c1 = 0.01
    c2 = 0.015

    A = A*mol
    B = B*mol

    !enthalpy for curation reaction
    dh = -10000.0

    !heat flow function y(0)
    Q = 13.0

    print *, "Enter values? [y/n]"
    read *, yn

    if (yn == "y") then
      print *, "Enter activation energy:"
      read *, Ea

      print *, "Enter amount:"
      read *, mol

      print *, "Enter chemical ratio:"
      read *, A

      print *, "Enter vitreous transition temperature:"
      read *, Tg

      print *, "Enter vitreous transition jump size:"
      read *, TgJump

      print *, "Enter reaction temperature:"
      read *, Tr

      print *, "Enter peak reaction temperature:"
      read *, Tpeak

      print *, "Enter temperature scanning range:"
      read *, T0
      read *, Tf
      T = T0

      print *, "Enter heat coeficients, before/after vitreous transition:"
      read *, c1
      read *, c2

      A = A*mol
      B = B*mol

      print *, "Enter reaction enthalpy:"
      read *, dh

      print *, "Enter heat flow at T0:"
      read *, Q
    end if

    !output file
    open(1100, file="dsc1.dat", status="new")

    !scanning range loop
    do

      !specific heat
      if (T < Tg) then
        Q = Q + c1
      else
        Q = Q + c2
      end if

      !vitreous transition heat
      if (abs(T-Tg) < 15) then
        Q = Q + TgJump*1/dble(1+abs(T-Tg))
      end if

      !curation reaction heat
      if (T > Tg .and. A > 0 .and. B > 0) then

        !collision frequency factor
        Ac = exp(-(T-Tpeak)**2 / (2*Tpeak - 2*Tr)**1.7)
        !kinetic reaction factor
        k = Ac*exp(-Ea/T)

        print *, k, A, B

        !reaction
        A = 1/dble(1/A + k)
        delta = exp(log(B)-k) !amount
        B = exp(log(B)-k)
      else
        k = 0d0
      end if

      !log
      write(1100, *) T, Q + dh*k*delta

      if (T > Tf) exit
      T = T + 1
    end do

    close(1100)

end program


! { dg-do run }
! Verify that when decimal precision is zero, no error.
! Submitted by Jerry DeLisle  <jvdelisle@gcc.gnu.org>
program test
  character(20) :: astr
  50 FORMAT (d20.0)
  astr = ""
  write(astr,50) -8.0D0
  if (astr.ne."              0.D+01") call abort()
end program test


C NCLFORTSTART
      SUBROUTINE GRID2TRIPLE(X,Y,Z,MX,NY,D,LDMAX,LD,ZMSG,IER)
      IMPLICIT NONE
c NCL:   d = grid2triple (x,y,z)     ;
c                                               input
      INTEGER MX,NY,LDMAX
      DOUBLE PRECISION X(MX),Y(NY),Z(MX,NY),ZMSG
c                                               output
      INTEGER LD,IER
      DOUBLE PRECISION D(LDMAX,3)
C NCLEND

c nomenclature
c .   x,y   - 1D coord variables dimensioned (mx and ny)
c .   z     - 2D grid containing functional values z(x,y)
c .   mx,ny - length of x and y; dimensions of z(mx,ny)
c .   d     - 2D vector of size (ldmax,3)
c .   ldmax - mx*ny
c .   ld    - actual number of non-missing values
c .   zmsg  - missing value code for z
c .           if no missing values set to some number which
c .           can not be encountered
c .   ier   - eeor flag
c                                               local
      INTEGER M,N

      IER = 0
      LD = 0

      DO N = 1,NY
          DO M = 1,MX
              IF (Z(M,N).NE.ZMSG) THEN
                  LD = LD + 1
                  D(LD,1) = X(M)
                  D(LD,2) = Y(N)
                  D(LD,3) = Z(M,N)
              END IF
          END DO
      END DO

      IF (LD.EQ.0) THEN
          IER = -10
C          PRINT *,'grid2triple: ld=0: all values missing'
      END IF
      RETURN
      END


! RUN: bbc -emit-fir %s -o - | FileCheck %s

! CHECK-LABEL: len_trim_test
integer function len_trim_test(c)
character(*) :: c
ltrim = len_trim(c)
! CHECK-DAG: %[[c0:.*]] = arith.constant 0 : index
! CHECK-DAG: %[[c1:.*]] = arith.constant 1 : index
! CHECK-DAG: %[[cm1:.*]] = arith.constant -1 : index
! CHECK-DAG: %[[lastChar:.*]] = arith.subi {{.*}}, %[[c1]]
! CHECK: %[[iterateResult:.*]]:2 = fir.iterate_while (%[[index:.*]] = %[[lastChar]] to %[[c0]] step %[[cm1]]) and ({{.*}}) iter_args({{.*}}) {
  ! CHECK: %[[addr:.*]] = fir.coordinate_of {{.*}}, %[[index]]
  ! CHECK: %[[codeAddr:.*]] = fir.convert %[[addr]]
  ! CHECK: %[[code:.*]] = fir.load %[[codeAddr]]
  ! CHECK: %[[bool:.*]] = arith.cmpi eq
  ! CHECK: fir.result %[[bool]], %[[index]]
! CHECK: }
! CHECK: %[[len:.*]] = arith.addi %[[iterateResult]]#1, %[[c1]]
! CHECK: select %[[iterateResult]]#0, %[[c0]], %[[len]]
end function


module neville

contains

subroutine nevillealg (input,output,dt,timeend,timestrt,cols,lines,errorflag)

  implicit none

  real(kind=8), dimension (:,:), intent (in) :: input
  real(kind=8), dimension (:,:), intent (inout) :: output
  real(kind=8), intent (in) :: dt, timestrt, timeend
  integer, intent (inout) :: errorflag
  integer, intent (in) :: cols, lines
  real(kind=8) :: time, timetmp, dataout, errout
  real(kind=8), dimension (:), allocatable :: timein, datain, timeall
  integer :: i, k, n, z, jdown, jup, jold

  if (errorflag==1) return

  time = timestrt

  allocate(timeall(lines))

  do i=1,lines
     timeall(i) = input(1,i)
  end do

  n=4

  if (lines.le.n) then
     print *, "File Error! There is not enough data in the files to interpolate!"
     errorflag=1
     return
  end if

  if (input(1,1) == timestrt) then
     output(:,1) = input (:,1)
     time = timestrt
  else
     print *, "Something is wrong. Input array does not start at start time"
     errorflag = 1
     return
  end if

  if (input(1,2) == timestrt + dt) then
     output(:,2) = input (:,2)
     time = time + dt
  else
     print *, "I expected the first timestep to be the same as the initial timestep"
     errorflag = 1
     return
  end if

  jold = 2
  z=2
  timetmp=time

  do while (time.lt.timeend)

     z=z+1

     if (timeend-dt.lt.time) then
        timetmp = timeend
     else
        timetmp = timetmp + dt
     end if

     jdown = jold

     call hunt(timeall,lines,timetmp,jdown,errorflag)
     if (errorflag==1) return

     jup = jdown + 1

     if (timetmp==timeend) then
        n=3
     end if

     jold = jdown

     if (mod(n,2)==0) then
        jdown = jdown - (n/2) + 1
        jup = jup + (n/2) - 1
     else
        if (((abs(input(1,jup)-timetmp)).lt.(abs(input(1,jdown)-timetmp))).and.(timetmp/=timeend)) then
           jup = jup + (n/2)
           jdown = jdown - (n/2) + 1
        else
           jup = jup + (n/2) - 1
           jdown = jdown - (n/2)
        end if
     end if

     allocate (timein(n), datain(n))

     do i=1,n
        timein(i) = input(1,jdown+i-1)
     end do

     do k=2,cols
        do i=1,n
           datain(i) = input(k,jdown+i-1)
        end do

        call polint (timein, datain, n, timetmp, dataout, errout, errorflag)
        if (errorflag==1) return

        output(k,z) = dataout

     end do

     time = timetmp

     output(1,z) = time

     deallocate(timein, datain)

  end do

end subroutine nevillealg

!--------------------------------------------------------------------------------------------------

subroutine polint (xa,ya,n,x,y,dy,errorflag)

  implicit none

  integer, intent (in) :: n
  integer, intent (inout) :: errorflag
  integer :: NMAX, i, m, na
  real(kind=8), intent (inout) :: dy, x, y
  real(kind=8), dimension (:), intent (inout) :: xa, ya
  real(kind=8), dimension (:), allocatable :: c, d
  real(kind=8) :: den, dif, dift, ho, hp, w

  if (errorflag==1) return

  na=1
  NMAX=10

  allocate (c(NMAX), d(NMAX))

  dif = abs(x-xa(1))
  do i=1,n
     dift=abs(x-xa(i))
     if (dift.lt.dif) then
        na=i
        dif=dift
     end if
     c(i)=ya(i)
     d(i)=ya(i)
  end do
  y=ya(na)
  na=na-1
  do m=1,n-1
     do i=1,n-m
        ho=xa(i)-x
        hp=xa(i+m)-x
        w=c(i+1)-d(i)
        den=ho-hp
        if (den.eq.0) then
           print *, "Error in polint"
           errorflag=1
           return
        end if
        den=w/den
        d(i)=hp*den
        c(i)=ho*den
     end do
     if (2*na.lt.n-m) then
        dy=c(na+1)
     else
        dy=d(na)
        na=na-1
     end if
     y=y+dy
  end do
  return

end subroutine polint

!-------------------------------------------------------------------------------------------------

subroutine hunt(timeall,lines,timetmp,jdown,errorflag)

  implicit none

  integer, intent (inout) :: jdown, errorflag
  integer, intent (in) :: lines
  real(kind=8), intent (in) :: timetmp
  real(kind=8), dimension(:), intent (in) :: timeall
  integer :: inc, jup, jm
  logical :: ascnd

  if (errorflag==1) return

  ascnd=timeall(lines).gt.timeall(1)

  if ((timetmp.ge.timeall(jdown)).or.(jdown.gt.lines)) then
     jdown = 0
     jup=lines+1
     goto 3
  end if
  inc=1
  if ((timetmp.ge.timeall(jdown)).eqv.ascnd) then
1    jup=jdown+inc
     if (jup.gt.lines) then
        jup=lines+1
     else if ((timetmp.ge.timeall(jup)).eqv.ascnd) then
        jdown=jup
        inc=inc+inc
        goto 1
     end if
  else
     jup = jdown
2    jdown = jup - inc
     if (jdown.lt.1) then
        jdown = 0
     else if ((timetmp.lt.timeall(jdown)).eqv.ascnd) then
        jup=jdown
        inc=inc+inc
        goto 2
     end if
  end if
3 if ((jup - jdown).eq.1) then
     if (timetmp.eq.timeall(lines)) jdown=lines-1
     if (timetmp.eq.timeall(1)) jdown=1
     return
  end if
  jm=(jup+jdown)/2
  if ((timetmp.ge.timeall(jm)).eqv.ascnd) then
     jdown=jm
  else
     jup=jm
  end if
  goto 3

end subroutine hunt

end module


c
c     This is a test program for PGAPack.  The objective is to maximize the
c     number of 1-bits in a chromosome.
c

      include 'pgapackf.h'

      double precision NumberOfSetBits
      external         NumberOfSetBits

c
c     user main program
c
      integer ctx
      integer       ierror

      call MPI_Init(ierror)

      ctx = PGACreate(PGA_DATATYPE_BINARY, 256, PGA_MAXIMIZE)
      call PGASetRandomSeed(ctx, 1)

      call PGASetUp(ctx)
      call PGARun(ctx, NumberOfSetBits)
      call PGADestroy(ctx)

      call MPI_Finalize(ierror)

      stop
      end

c
c     user defined evaluation function
c     ctx - contex variable
c     p   - chromosome index in population
c     pop - which population to refer to
c
      double precision function NumberOfSetBits(ctx, p, pop)
      include    'pgapackf.h'
      integer ctx
      integer     p, pop
      integer     i, nbits, stringlen

      stringlen = PGAGetStringLength(ctx)

      nbits = 0
      do i=1, stringlen
         if (PGAGetBinaryAllele(ctx, p, pop, i) .eq. 1) then
            nbits = nbits + 1
         endif
      enddo

      NumberOfSetBits = dble(nbits)
      return
      end


      SUBROUTINE MB01SD( JOBS, M, N, A, LDA, R, C )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To scale a general M-by-N matrix A using the row and column
C     scaling factors in the vectors R and C.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBS    CHARACTER*1
C             Specifies the scaling operation to be done, as follows:
C             = 'R':  row scaling, i.e., A will be premultiplied
C                     by diag(R);
C             = 'C':  column scaling, i.e., A will be postmultiplied
C                     by diag(C);
C             = 'B':  both row and column scaling, i.e., A will be
C                     replaced by diag(R) * A * diag(C).
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix A.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrix A.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the M-by-N matrix A.
C             On exit, the scaled matrix.  See JOBS for the form of the
C             scaled matrix.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,M).
C
C     R       (input) DOUBLE PRECISION array, dimension (M)
C             The row scale factors for A.
C             R is not referenced if JOBS = 'C'.
C
C     C       (input) DOUBLE PRECISION array, dimension (N)
C             The column scale factors for A.
C             C is not referenced if JOBS = 'R'.
C
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center,
C     DLR Oberpfaffenhofen, April 1998.
C     Based on the RASP routine DMSCAL.
C
C    ******************************************************************
C
C     .. Scalar Arguments ..
      CHARACTER          JOBS
      INTEGER            LDA, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*), C(*), R(*)
C     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   CJ
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. Executable Statements ..
C
C     Quick return if possible.
C
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
C
      IF( LSAME( JOBS, 'C' ) ) THEN
C
C        Column scaling, no row scaling.
C
         DO 20 J = 1, N
            CJ = C(J)
            DO 10 I = 1, M
               A(I,J) = CJ*A(I,J)
   10       CONTINUE
   20    CONTINUE
      ELSE IF( LSAME( JOBS, 'R' ) ) THEN
C
C        Row scaling, no column scaling.
C
         DO 40 J = 1, N
            DO 30 I = 1, M
               A(I,J) = R(I)*A(I,J)
   30       CONTINUE
   40    CONTINUE
      ELSE IF( LSAME( JOBS, 'B' ) ) THEN
C
C        Row and column scaling.
C
         DO 60 J = 1, N
            CJ = C(J)
            DO 50 I = 1, M
               A(I,J) = CJ*R(I)*A(I,J)
   50       CONTINUE
   60    CONTINUE
      END IF
C
      RETURN
C *** Last line of MB01SD ***
      END


      subroutine tridib(n,eps1,d,e,e2,lb,ub,m11,m,w,ind,ierr,rv4,rv5)
c***begin prologue  tridib
c***date written   760101   (yymmdd)
c***revision date  830518   (yymmdd)
c***category no.  d4a5,d4c2a
c***keywords  eigenvalues,eigenvectors,eispack
c***author  smith, b. t., et al.
c***purpose  computes eigenvalues of symmetric tridiagonal matrix
c            given interval using sturm sequencing.
c***description
c
c     this subroutine is a translation of the algol procedure bisect,
c     num. math. 9, 386-393(1967) by barth, martin, and wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 249-256(1971).
c
c     this subroutine finds those eigenvalues of a tridiagonal
c     symmetric matrix between specified boundary indices,
c     using bisection.
c
c     on input
c
c        n is the order of the matrix.
c
c        eps1 is an absolute error tolerance for the computed
c          eigenvalues.  if the input eps1 is non-positive,
c          it is reset for each submatrix to a default value,
c          namely, minus the product of the relative machine
c          precision and the 1-norm of the submatrix.
c
c        d contains the diagonal elements of the input matrix.
c
c        e contains the subdiagonal elements of the input matrix
c          in its last n-1 positions.  e(1) is arbitrary.
c
c        e2 contains the squares of the corresponding elements of e.
c          e2(1) is arbitrary.
c
c        m11 specifies the lower boundary index for the desired
c          eigenvalues.
c
c        m specifies the number of eigenvalues desired.  the upper
c          boundary index m22 is then obtained as m22=m11+m-1.
c
c     on output
c
c        eps1 is unaltered unless it has been reset to its
c          (last) default value.
c
c        d and e are unaltered.
c
c        elements of e2, corresponding to elements of e regarded
c          as negligible, have been replaced by zero causing the
c          matrix to split into a direct sum of submatrices.
c          e2(1) is also set to zero.
c
c        lb and ub define an interval containing exactly the desired
c          eigenvalues.
c
c        w contains, in its first m positions, the eigenvalues
c          between indices m11 and m22 in ascending order.
c
c        ind contains in its first m positions the submatrix indices
c          associated with the corresponding eigenvalues in w --
c          1 for eigenvalues belonging to the first submatrix from
c          the top, 2 for those belonging to the second submatrix, etc.
c
c        ierr is set to
c          zero       for normal return,
c          3*n+1      if multiple eigenvalues at index m11 make
c                     unique selection impossible,
c          3*n+2      if multiple eigenvalues at index m22 make
c                     unique selection impossible.
c
c        rv4 and rv5 are temporary storage arrays.
c
c     note that subroutine tql1, imtql1, or tqlrat is generally faster
c     than tridib, if more than n/4 eigenvalues are to be found.
c
c     questions and comments should be directed to b. s. garbow,
c     applied mathematics division, argonne national laboratory
c     ------------------------------------------------------------------
c***references  b. t. smith, j. m. boyle, j. j. dongarra, b. s. garbow,
c                 y. ikebe, v. c. klema, c. b. moler, *matrix eigen-
c                 system routines - eispack guide*, springer-verlag,
c                 1976.
c***routines called  (none)
c***end prologue  tridib
c
      implicit double precision (a-h,o-z)
      integer p,q,r,s,tag
      dimension d(n),e(n),e2(n),w(m),rv4(n),rv5(n)
      double precision lb,machep
      integer ind(m)
	data machep/1.0d-10/
c
c***first executable statement  tridib
c
   10 ierr = 0
      tag = 0
      xu = d(1)
      x0 = d(1)
      u = 0.0d0
c     .......... look for small sub-diagonal entries and determine an
c                interval containing all the eigenvalues ..........
      do 40 i = 1, n
         x1 = u
         u = 0.0d0
         if (i .ne. n) u = abs(e(i+1))
         xu = min(d(i)-(x1+u),xu)
         x0 = max(d(i)+(x1+u),x0)
         if (i .eq. 1) go to 20
         s1 = abs(d(i)) + abs(d(i-1))
         s2 = s1 + abs(e(i))
         if (s2 .gt. s1) go to 40
   20    e2(i) = 0.0d0
   40 continue
c
      x1 = max(abs(xu),abs(x0)) * machep * dble(n)
      xu = xu - x1
      t1 = xu
      x0 = x0 + x1
      t2 = x0
c     .......... determine an interval containing exactly
c                the desired eigenvalues ..........
      p = 1
      q = n
      m1 = m11 - 1
      if (m1 .eq. 0) go to 75
      isturm = 1
   50 v = x1
      x1 = xu + (x0 - xu) * 0.5d0
      if (x1 .eq. v) go to 980
      go to 320
   60 if (s - m1) 65, 73, 70
   65 xu = x1
      go to 50
   70 x0 = x1
      go to 50
   73 xu = x1
      t1 = x1
   75 m22 = m1 + m
      if (m22 .eq. n) go to 90
      x0 = t2
      isturm = 2
      go to 50
   80 if (s - m22) 65, 85, 70
   85 t2 = x1
   90 q = 0
      r = 0
c     .......... establish and process next submatrix, refining
c                interval by the gerschgorin bounds ..........
  100 if (r .eq. m) go to 1001
      tag = tag + 1
      p = q + 1
      xu = d(p)
      x0 = d(p)
      u = 0.0d0
c
      do 120 q = p, n
         x1 = u
         u = 0.0d0
         v = 0.0d0
         if (q .eq. n) go to 110
         u = abs(e(q+1))
         v = e2(q+1)
  110    xu = min(d(q)-(x1+u),xu)
         x0 = max(d(q)+(x1+u),x0)
         if (v .eq. 0.0d0) go to 140
  120 continue
c
  140 x1 = max(abs(xu),abs(x0)) * machep
      if (eps1 .le. 0.0d0) eps1 = -x1
      if (p .ne. q) go to 180
c     .......... check for isolated root within interval ..........
      if (t1 .gt. d(p) .or. d(p) .ge. t2) go to 940
      m1 = p
      m2 = p
      rv5(p) = d(p)
      go to 900
  180 x1 = x1 * float(q-p+1)
      lb = max(t1,xu-x1)
      ub = min(t2,x0+x1)
      x1 = lb
      isturm = 3
      go to 320
  200 m1 = s + 1
      x1 = ub
      isturm = 4
      go to 320
  220 m2 = s
      if (m1 .gt. m2) go to 940
c     .......... find roots by bisection ..........
      x0 = ub
      isturm = 5
c
      do 240 i = m1, m2
         rv5(i) = ub
         rv4(i) = lb
  240 continue
c     .......... loop for k-th eigenvalue
c                for k=m2 step -1 until m1 do --
c                (-do- not used to legalize -computed go to-) ..........
      k = m2
  250    xu = lb
c     .......... for i=k step -1 until m1 do -- ..........
         do 260 ii = m1, k
            i = m1 + k - ii
            if (xu .ge. rv4(i)) go to 260
            xu = rv4(i)
            go to 280
  260    continue
c
  280    if (x0 .gt. rv5(k)) x0 = rv5(k)
c     .......... next bisection step ..........
  300    x1 = (xu + x0) * 0.5d0
         s1 = abs(xu) + abs(x0) + abs(eps1)
         s2 = s1 + abs(x0-xu)/2.0d0
         if (s2 .eq. s1) go to 420
c     .......... in-line procedure for sturm sequence ..........
  320    s = p - 1
         u = 1.0d0
c
         do 340 i = p, q
            if (u .ne. 0.0d0) go to 325
            v = abs(e(i)) / machep
            if (e2(i) .eq. 0.0d0) v = 0.0d0
            go to 330
  325       v = e2(i) / u
  330       u = d(i) - x1 - v
            if (u .lt. 0.0d0) s = s + 1
  340    continue
c
         go to (60,80,200,220,360), isturm
c     .......... refine intervals ..........
  360    if (s .ge. k) go to 400
         xu = x1
         if (s .ge. m1) go to 380
         rv4(m1) = x1
         go to 300
  380    rv4(s+1) = x1
         if (rv5(s) .gt. x1) rv5(s) = x1
         go to 300
  400    x0 = x1
         go to 300
c     .......... k-th eigenvalue found ..........
  420    rv5(k) = x1
      k = k - 1
      if (k .ge. m1) go to 250
c     .......... order eigenvalues tagged with their
c                submatrix associations ..........
  900 s = r
      r = r + m2 - m1 + 1
      j = 1
      k = m1
c
      do 920 l = 1, r
         if (j .gt. s) go to 910
         if (k .gt. m2) go to 940
         if (rv5(k) .ge. w(l)) go to 915
c
         do 905 ii = j, s
            i = l + s - ii
            w(i+1) = w(i)
            ind(i+1) = ind(i)
  905    continue
c
  910    w(l) = rv5(k)
         ind(l) = tag
         k = k + 1
         go to 920
  915    j = j + 1
  920 continue
c
  940 if (q .lt. n) go to 100
      go to 1001
c     .......... set error -- interval cannot be found containing
c                exactly the desired eigenvalues ..........
  980 ierr = 3 * n + isturm
 1001 lb = t1
      ub = t2
      return
      end

c $Id$


!
! Example illustrating the use of the frand123 Fortran interface for the
! generation of 64-bit signed integer random numbers.
! The signed integer random numbers ar used as experiment for coin flip.
!

program integer64
   use, intrinsic :: iso_c_binding, only: c_int64_t
   use frand123, only: frand123State_t, frand123Init, frand123Integer64
   implicit none

   ! state for frand123
   type( frand123State_t ) :: state

   ! init state
   call frand123Init( state, 0, 0 )

   ! use coinFlipScalar
   write(*,*) 'Generate one random number at a time'
   call coinFlipScalar( state )

   ! use coinFlip10
   write(*,*) 'Generate all 10 random numbers afront'
   call coinFlip10( state )

contains

   ! simulate coin flip by generating one random number at a time
   subroutine coinFlipScalar( state )
      implicit none
      type( frand123State_t ), intent( inout ) :: state

      ! result of coin flip
      integer( kind = c_int64_t ) :: coin

      ! iteration variable
      integer :: i

      ! simulate 10 coin flips
      ! > 0 heads
      ! < 0 tails
      ! = 0 what a luck
      do i = 1, 10
         ! create 32-bit signed random integer
         call frand123Integer64( state, coin )
         ! result
         if( coin .eq. 0 ) then
            write(*,*) 'What a luck'
         elseif( coin .gt. 0 ) then
            write(*,*) 'heads'
         else
            write(*,*) 'tails'
         endif
      enddo
   end subroutine coinFlipScalar

   ! simulate coin flip by generating all random numbers afront
   subroutine coinFlip10( state )
      implicit none
      type( frand123State_t ), intent( inout ) :: state

      ! result of coin flip
      integer( kind = c_int64_t ), dimension( 10 ) :: coin

      ! iteration variable
      integer :: i

      ! create 32-bit signed random integers
      call frand123Integer64( state, coin )

      ! simulate 10 coin flips
      ! > 0 heads
      ! < 0 tails
      ! = 0 what a luck
      do i = 1, 10
         ! result
         if( coin( i ) .eq. 0 ) then
            write(*,*) 'What a luck'
         elseif( coin( i ) .gt. 0 ) then
            write(*,*) 'heads'
         else
            write(*,*) 'tails'
         endif
      enddo
   end subroutine coinFlip10
end program integer64


program test2
  use genetics
  use cities
  use myio
  use cmparser
  use slf_random
  implicit none
  real*8  :: x
  real*8, allocatable  ::  places(:,:), distances(:,:)
  type(group), allocatable  :: population(:), bestpopulation(:), temppop(:)
  integer :: time  = 1000,&
  popNo = 1000
  real*8  :: xmen = 0.0001d0
  real*8  :: meanCase
  integer  :: i,t,p,p1,p2, genNo
  integer  :: dt
  real*8   :: data(1:200)
  character(len=200) :: cPlace="", loadFile=""
  logical :: file_exists

  ! Turn on a random number generator
  call random_init_urandom()

  !!! Load favourite places
  ! TODO
  ! Load SOUTH AMERICA
  ! include 'data/eu.f'
  include 'data/sa.f'
  genNo = size(places,2)
  allocate(distances(genNo,genNo))
  call calcDistances(places,distances)

  !!! Set population & heuristics
  ! TODO
  allocate(bestpopulation(2*popNo))
  allocate(population(popNo))
  call growPopulation(population,genNo)
  allocate(temppop(popNo)) ! auxilary population
  do i=1,popNo
    call group_create(temppop(i),genNo)
  enddo!i

  INQUIRE(FILE=trim(loadFile),EXIST=file_exists)
  if (file_exists) call loadSnapshot('EU',popNo,xmen,time,population,bestpopulation(1:popNo))

  do i=1,popNo
    call cycleLength(population(i),distances)
  enddo!i
  meanCase = mean(population(:)%fitness)
  ! DATA
  dt = time/size(data)

  !!!!! MAIN LOOP OF THE PROGRAM
  !!! Fitness Base Selection
  ! TODO
  do t=1,time
    if (mod(t,time/10)==0) print *, "Generation #",t,"out of",time
    do p=1,popNo
      call fitness(population(p),distances,meanCase)
    enddo!p
    call QSort(population,popNo)
    do p=1,popNo/2
      ! Pick parents
      call rouletteWheelSelection(population(:)%fitness,p1)
      call rouletteWheelSelection(population(:)%fitness,p2)
      ! Breed chromosomes using Crossover
      call CrossoverOX1(population(p1)%chromosome,population(p2)%chromosome,temppop(p)%chromosome,temppop(p+popNo/2)%chromosome)
      ! Apply mutation with some probability 'XMEN'
      call random_number(x)
      if (x<xmen) call ScrambleMutation(temppop(p)%chromosome)
      call random_number(x)
      if (x<xmen) call ScrambleMutation(temppop(p+popNo/2)%chromosome)
      call random_number(x)
      if (x<xmen) call InversionMutation(temppop(p)%chromosome)
      call random_number(x)
      if (x<xmen) call InversionMutation(temppop(p+popNo/2)%chromosome)
    enddo!p

    ! Copy temp population
    do i=1,popNo
      population(i)%chromosome = temppop(i)%chromosome
    enddo
    if(mod(t,4)==0) then
      bestpopulation((popNo+1):2*popNo) = population(:)
      call QSort(bestpopulation,2*popNo)
    endif
    if(mod(t,dt)==0) then
      open(1,file='time.dat',action='write',access='append')
      write(1,*) t, meanCase - mean(population(:)%fitness), variance(population(:)%fitness)
      close(1)
    endif
  enddo!t
  !!! Save data
  ! TODO
  do i=1,10
    print "(52(I3))", population(i)%chromosome
  enddo

end program test2


c--------------------------------------------------------------------c
c     ALL RIGHT RESERVED. USE AND DISTRIBUTE UNDER PERMISSION ONLY.  c
c              (JIANHANC@UCI.EDU, MANDELSH@UCI.EDU)                  c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Collections of subroutines for calculating U matrices
c---------------------------------------------------------------------
c     Author: Jianhan Chen (jianhanc@uci.edu)
c
c     Purpuse: Given the signal, window range, basis information,
c     construct the U matrices and C vector. (see refences in main)
c
c     Note: Actually only 2-Scale FDM. Uncomment corresponding lines
c     to activate the true multi-scale FDM.
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     UMatrix1D_MS0: implementation based on the MS-FDM paper         c
c     Author: Jianhan Chen (jianhanc@uci.edu)
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      subroutine UMatrix1D_MS0(coef, Nsig, delt, Nb0, Nbc, Nb,
     &     wminl, wmaxl, gsave, U)
      implicit none
      integer i,j,n,k,l,Ml,Nsig,Nb,Nbc,Nb0,M(Nb)
      complex*16 U(Nb,Nb,0:1),coef(0:Nsig),f(Nb),g(Nb),z(Nb),wk(Nb),
     &     gh(Nb,Nb),gsave(Nb),cc,z1,z2
      real*8 delt, wminl, wmaxl, wmin, wmax, dw0, pi, rhoc
c
      pi=dacos(-1d0)
      Ml=(Nsig-2)/2
      wmin=wminl*delt
      wmax=wmaxl*delt
      Nbc = Nbc + mod(Nbc,2) ! Nb0, Nbc have to be even numbers
      Nb0 = Nb0 + mod(Nb0,2)
      Nb = Nbc + Nb0
c
c     generate the basis
c
      dw0=(wmax-wmin)/Nb0
      do n=1, Nb0
         z(n+Nbc/2)=wmin+(n-0.5)*dw0
         M(n+Nbc/2)=Ml
      enddo
c      do n=Nbc/2, 1, -1  !!! uncomment to generate Multi-scale Basis
c         t=dfloat(2*n-1)/dfloat(Nbc)
c         rhoc=dsin(pi*t/2.0)
c         rhoc=(dsin(pi*t/2.0))**2 !!! replace with any distribution fxn
c         rhoc=dfloat(Nbc)/dfloat(Ml-Nb0)
c         M(n)=Ml*rhoc
c         if(M(n).lt.4) M(n)=4
c         M(Nb-n+1)=M(n)
c         z(n)=z(n+1)-(dw0*Ml)/dfloat(M(n))
c         z(Nb-n+1)=z(Nb-n)+(dw0*Ml)/dfloat(M(n))
c      enddo
      do n=1, Nbc !!! comment this part to disable double-scale basis
         if(n.le.Nbc/2) then
            M(n)=Nbc-1
            z(n)=-pi+(n-0.5)*2*pi/Nbc
         else
            M(n+Nb0)=Nbc-1
            z(n+Nb0)=-pi+(n-0.5)*2*pi/Nbc
         endif
      enddo
c
      do n=1, Nbc/2    ! REMOVE ANY OVERLAP BETWEEN WINDOW AND COARSE BASIS
         if(dreal(z(n)).lt.-pi) then
            k=(z(n)+pi)/(2*pi)
            z(n)=(z(n)-k*2*pi)+2*pi
         endif
         i=1
         do while (dabs(dreal(z(n)-z(i+Nbc/2))).gt.1d-8.and.i.le.Nb0)
            i=i+1
         enddo
         if(dabs(dreal(z(n)-z(i+Nbc/2))).le.1d-8.and.i.le.Nb0)
     &        z(n)=z(n)+5d-2*dw0
c
         if(dreal(z(Nb-n+1)).gt.pi) then
            k=(z(Nb-n+1)-pi)/(2*pi)
            z(Nb-n+1)=(z(Nb-n+1)-k*2*pi)-2*pi
         endif
         i=1
         do while
     &        (dabs(dreal(z(Nb-n+1)-z(i+Nbc/2))).gt.1d-8.and.i.le.Nb0)
            i=i+1
         enddo
         if(dabs(dreal(z(Nb-n+1)-z(i+Nbc/2))).le.1d-8.and.i.le.Nb0)
     &        z(Nb-n+1)=z(Nb-n+1)+5d-2*dw0
      enddo
      do n=1, Nb
         write(11,*) n, dreal(z(n))/delt, M(n)/dfloat(Ml), 1
         z(n)=cdexp((0,1d0)*z(n))
      enddo
      close(11)
c
c     basis generated; calculate the U matrices
c
      call HybridFT(Ml, M, Nb, coef, z, f, g)
c
c     call the matrix elements
c
      do l=0, 1
         if(l.eq.0) then
            do i=1, Nb
               wk(i)=f(i)
            enddo
            call diagME(Nb, M, coef, z, U)
            call rotFTgh(coef,Nb,Nb0,Nbc,Ml,M,z,g,gh)
         else
            do i=1, Nb
               z1=z(i)**M(i)
               U(i,i,l)=(U(i,i,l-1)-coef(l-1)-wk(i)+gh(i,i))/z(i)
     &              +coef(2*M(i)+l)*z1*z1
               wk(i)=wk(i)/z(i)-coef(l)+coef(M(i)+l)*z1
               do j=1, Nb/2
                  z2=z(i)**M(j)
                  gh(j,i)=gh(j,i)/z(i)-coef(M(j)+l)*z2
     &                 +coef(M(i)+M(j)+l)*z1*z2
                  gh(Nb-j+1,i)=gh(j,i)
               enddo
            enddo
         endif
         do i=1, Nb
            do j=1, i-1
               cc=z(j)/z(i)
               U(i,j,l)=coef(l)+(wk(i)-cc*wk(j)+
     &              cc**(-M(i))*gh(i,j)-cc**(M(j)+1)*gh(j,i))
     &              /(1-cc)
               U(j,i,l)=U(i,j,l)
            enddo
         enddo
      enddo
c
      do i=1, Nb                ! generate correct array C
         gsave(i)=f(i)+coef(0)
      enddo
      return
      end
c_____________________________________________________________________
c     END OF "UMatrix1D_MS0" SUBROUTINE
c----------------------------------------------------------------------
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Name: Umatrix1D_dMS0
c
c     A routine using 'old' MS-FDM to construct U_Nskip & U_Nskip+1 for
c     specified window, and calculate gsave_0. Can be used to do linear
c     phase correction of delay = Nskip * tau by solving:
c
c       U_Nskip+1 Bk = uk U_Nskip Bk
c       dk^(1/2) = gsave' * Bk
c
c     Note: when called with Nskip=0, it will be exactly the same as
c           subroutine Umatrix1D_MS0().
c
c     Author: Jianhan Chen (jianhanc@uci.edu)
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine Umatrix1D_dMS0(coef,Nsig,Nskip,delt,Nb0,Nbc,Nb,
     &     wminl,wmaxl,gsave,U)
      implicit none
      integer i,j,n,k,l,Ml,Nsig,Nskip,Nb,Nbc,Nb0,M(Nb)
      complex*16 U(Nb,Nb,0:1), coef(0:Nsig+Nskip), gsave(Nb),
     &     wk(Nb), f(Nb), g(Nb), z(Nb), gh(Nb,Nb), cc, z1, z2
      real*8 delt, wminl, wmaxl, wmin, wmax, dw0, pi, rhoc, t

      pi=dacos(-1d0)
      Ml=(Nsig-2)/2
      wmin=wminl*delt
      wmax=wmaxl*delt
      Nbc = Nbc + mod(Nbc,2) ! Nb0, Nbc have to be even numbers
      Nb0 = Nb0 + mod(Nb0,2)
      Nb = Nbc + Nb0
c
c     generate the basis
c
      dw0=(wmax-wmin)/Nb0
      do n=1, Nb0
         z(n+Nbc/2)=wmin+(n-0.5)*dw0
         M(n+Nbc/2)=Ml
      enddo
c      do n=Nbc/2, 1, -1  !!! uncomment to generate Multi-scale Basis
c         t=dfloat(2*n-1)/dfloat(Nbc)
c         rhoc=dsin(pi*t/2.0)
c         rhoc=(dsin(pi*t/2.0))**2 !!! replace with any distribution fxn
c         rhoc=dfloat(Nbc)/dfloat(Ml-Nb0)
c         M(n)=Ml*rhoc
c         if(M(n).lt.4) M(n)=4
c         M(Nb-n+1)=M(n)
c         z(n)=z(n+1)-(dw0*Ml)/dfloat(M(n))
c         z(Nb-n+1)=z(Nb-n)+(dw0*Ml)/dfloat(M(n))
c      enddo
      do n=1, Nbc !!! comment this part to disable double-scale basis
         if(n.le.Nbc/2) then
            M(n)=Nbc-1
            z(n)=-pi+(n-0.5)*2*pi/Nbc
         else
            M(n+Nb0)=Nbc-1
            z(n+Nb0)=-pi+(n-0.5)*2*pi/Nbc
         endif
      enddo

      do n=1, Nbc/2             ! check and correct basis positions
         if(dreal(z(n)).lt.-pi) then
            k=(z(n)+pi)/(2*pi)
            z(n)=(z(n)-k*2*pi)+2*pi
         endif
         i=1
         do while (dabs(dreal(z(n)-z(i+Nbc/2))).gt.1d-8.and.i.le.Nb0)
            i=i+1
         enddo
         if(dabs(dreal(z(n)-z(i+Nbc/2))).le.1d-8.and.i.le.Nb0)
     &        z(n)=z(n)+5d-2*dw0

         if(dreal(z(Nb-n+1)).gt.pi) then
            k=(z(Nb-n+1)-pi)/(2*pi)
            z(Nb-n+1)=(z(Nb-n+1)-k*2*pi)-2*pi
         endif
         i=1
         do while
     &        (dabs(dreal(z(Nb-n+1)-z(i+Nbc/2))).gt.1d-8.and.i.le.Nb0)
            i=i+1
         enddo
         if(dabs(dreal(z(Nb-n+1)-z(i+Nbc/2))).le.1d-8.and.i.le.Nb0)
     &        z(Nb-n+1)=z(Nb-n+1)+5d-2*dw0
      enddo
      do n=1, Nb
         write(11,*) n, dreal(z(n))/delt, M(n)/dfloat(Ml), 1
         z(n)=cdexp((0,1d0)*z(n))
      enddo
      close(11)
c
c     basis generated; calculate the U matrices
c
      call HybridFT(Ml, M, Nb, coef(Nskip), z, f, g)
c
c     GENERATE THE MATRICES U_Nskip & U_Nskip+1 (U1, U0 if Nskip=0)
c
      do l=0, 2
         if(l.eq.0) then
            do i=1, Nb
               wk(i)=f(i)
            enddo
            call diagME(Nb, M, coef(Nskip), z, U)
            call rotFTgh(coef(Nskip),Nb,Nb0,Nbc,Ml,M,z,g,gh)
         else
            do i=1, Nb
               z1=z(i)**M(i)
               U(i,i,l)=(U(i,i,l-1)-coef(Nskip+l-1)-wk(i)+gh(i,i))/z(i)
     &              +coef(Nskip+2*M(i)+l)*z1*z1
               wk(i)=wk(i)/z(i)-coef(Nskip+l)+coef(Nskip+M(i)+l)*z1
               do j=1, Nb/2
                  z2=z(i)**M(j)
                  gh(j,i)=gh(j,i)/z(i)-coef(Nskip+M(j)+l)*z2
     &                 +coef(Nskip+M(i)+M(j)+l)*z1*z2
                  gh(Nb-j+1,i)=gh(j,i)
               enddo
            enddo
         endif
c
         do i=1, Nb
            do j=1, i-1
               cc=z(j)/z(i)
               U(i,j,l)=coef(Nskip+l)+(wk(i)-cc*wk(j)+
     &              cc**(-M(i))*gh(i,j)-cc**(M(j)+1)*gh(j,i))
     &              /(1-cc)
               U(j,i,l)=U(i,j,l)
            enddo
         enddo
      enddo
c
c     calculate gsave_Nskip and obtain gsave_0 by back rotating
c
      do i=1, Nb                ! actually gsave_Nskip (vector C)
         gsave(i)=f(i)+coef(Nskip)
      enddo
      do n=Nskip-1,0,-1         ! back-rotate gsave_Nskip to get gsave_0
         do i=1, Nb
            gsave(i)=gsave(i)*z(i)-z(i)**(M(i)+1)*coef(M(i)+n+1)+coef(n)
         enddo
      enddo
      return
      end
c________________________________________________________________________
c     END OF  UMatrix1D_dMS0
c------------------------------------------------------------------------
c     Exact the same purpose as UMatrix1D_dMS0(), but implemented using
c     a more efficient way: instead of using various Mj to multi-scale
c     basis, complex frequency grids are used, Im(zj) <-> Mj.
c
c     Author: Jianhan Chen (jianhanc@uci.edu)
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine Umatrix1D_dMS1(coef,Nsig,Nskip,delt,Nb0,Nbc,Nb,
     &     wminl,wmaxl,gsave,U)
      implicit none
      integer Nb,i,j,n,k,M,Nsig,Nskip,l,Nb0,Nbc,Mc
      complex*16 U(Nb,Nb,0:1),coef(0:Nsig),f(Nb),g(Nb),diag(Nb),z(Nb),
     &     Z1,Z2,cc,xi,gsave(Nb),wk(Nb),dk(Nb),sp
      real*8 delt,wminl,wmaxl,wminl_new,wmaxl_new,pi,z_re,z_im,dw,
     &     r1,rhoc,dw0,ros,Omega
      logical MULTI_SCALE
c      MULTI_SCALE=.true.
      MULTI_SCALE=.false.
c
c     NOTE:  set MULTI_SCALE = .false. if only 2-scale needed
c     NOTE:  for multi-scale case, diffierent rhoc(j) distribution
c            can be chosen by inserting new formula for rhoc(j) at line 180
c
      pi=dacos(-1d0)
      xi=(0,1d0)
      M=(Nsig-2)/2
      wminl_new=wminl*delt
      wmaxl_new=wmaxl*delt
      Nbc = Nbc + mod(Nbc,2) ! Nbc have to be even numbers
      Nb = Nbc + Nb0
      dw0=(wmaxl_new-wminl_new)/Nb0
c      z_im=dw0
      z_im=0d0
      do i=1,Nb0
         z_re=wminl_new+(i-0.5d0)*dw0
         z(i+Nbc/2)=dcmplx(z_re,z_im)
      enddo
      if(.not.MULTI_SCALE.and.Nbc.gt.0) then !     two-scale
c        write(*,*) 'generate double-scale basis ...'
         r1=dfloat(Nbc)/dfloat(M+1)
         call Im_Mj(r1,z_im)
         z_im=z_im*delt
         if(Nbc.ne.0) dw=(2d0*pi-(wmaxl_new-wminl_new))/Nbc
         do i=1, Nbc
            if(i.le.Nbc/2) then
               z(i)=dcmplx(-pi+(i-0.5)*2*pi/Nbc,z_im)
            else
               z(i+Nb0)=dcmplx(-pi+(i-0.5)*2*pi/Nbc,z_im)
            endif
         enddo
      else if(Nbc.gt.0) then    ! multi-scale coarse basis
c         write(*,*) 'generate mulit-scale basis ...'
         do n=Nbc/2, 1, -1
            r1=dfloat(2*n-1)/dfloat(Nbc)
c 180        rhoc=dsin(pi*r1/2.0)
            rhoc=(dsin(pi*r1/2.0))**2
c      rhoc=dfloat(Nbc)/dfloat(Ml-Nb0)
c      rhoc=dsin(pi*r1/2.0)**2*(3.0/Mmin)
            Mc=M*rhoc
            if(Mc.lt.4) Mc=4
            rhoc=dfloat(Mc)/dfloat(M)
            call Im_Mj(rhoc,z_im)
            z_im=z_im*delt
            z_re=dreal(z(n+1))-dw0/rhoc
            z(n)=dcmplx(z_re,z_im)
            z_re=dreal(z(Nb-n))+dw0/rhoc
            z(Nb-n+1)=dcmplx(z_re,z_im)
         enddo
c         do n=1, Nbc/2          ! fold back into [-pi,pi]; unnecessary
c            if(dreal(z(n)).lt.-pi) then
c               k=(dreal(z(n))+pi)/(2*pi)
c               z(n)=dcmplx(dreal(z(n))-(k-1)*2*pi,dimag(z(n)))
c            endif
c            if(dreal(z(Nb-n+1)).gt.pi) then
c               k=(z(Nb-n+1)-pi)/(2*pi)
c               z(Nb-n+1)=dcmplx(dreal(z(Nb-n+1))-(k+1)*2*pi,
c     &              dimag(z(Nb-n+1)))
c            endif
c         enddo
      endif
      do n=1, Nb
         write(11,*) n, dreal(z(n))/delt, dimag(z(n))/delt, 1
         z(n)=cdexp(z(n)*xi)
      enddo
      close(11)
c
c      write(*,*) 'calculating the 1D FT series ...'
      call arrays(Nsig,M,coef(Nskip),Nb,z,f,g,diag)
c
c      write(*,*) 'calculating the U matrices ...'
      do l=0,1
         do i=1,Nb
            Z1=z(i)**M
            Z2=Z1**2
            if(l.eq.0) then
               U(i,i,0)=diag(i)
               wk(i)=f(i)
               dk(i)=g(i)
            else
               U(i,i,l)=( U(i,i,l-1)-coef(Nskip+l-1)
     &              - wk(i) + dk(i)*Z1 ) / z(i)
     &              + coef(Nskip+2*M+l) * Z2
               wk(i)=wk(i)/z(i)-coef(Nskip+l)+coef(Nskip+M+l)*Z1
               dk(i)=dk(i)/z(i)-coef(Nskip+M+l)+coef(Nskip+2*M+l)*Z1
            endif
         enddo
         do i=1,Nb
            Z1=z(i)**M
            do j=1,i-1
               Z2=z(j)**M
               cc=z(i)/z(j)
               U(i,j,l)=coef(Nskip+l)
     &              +(wk(j)-cc*Z1*dk(j)
     &              -cc*wk(i)+Z2*dk(i))/(1-cc)
               U(j,i,l)=U(i,j,l)
            enddo
         enddo
      enddo
      do i=1, Nb                ! actually gsave_Nskip
         gsave(i)=f(i)+coef(Nskip)
      enddo
      do n=Nskip-1,0,-1         ! back-rotate gsave_Nskip to get gsave_0
         do i=1, Nb
            gsave(i)=gsave(i)*z(i)-z(i)**(M+1)*coef(M+n+1)+coef(n)
         enddo
      enddo
c      write(*,*) 'UMatrix1D_dMS1 is done'
      return
      end
c__________________________________________________________________________
c     END OF UMatrix_dMS1()
c--------------------------------------------------------------------------
c
c     calculate FT f=sum_1^Mj() and g=sum_(Ml+1)^(Ml+Mj)()
c
      subroutine HybridFT(Ml,M,Nb,coef,z,f,g)
      implicit none
      integer Ml, Nb, M(Nb), i, j, n
      complex*16 z(Nb), f(Nb), g(Nb), coef(0:100), c1

      do i=1, Nb
         f(i)=(0,0d0)
         g(i)=(0,0d0)
         do n=1, M(i)
            if(mod(n, 100).eq.1) then
               c1=z(i)**n
            else
               c1=c1*z(i)
            endif
            f(i)=f(i)+coef(n)*c1
            g(i)=g(i)+coef(n+Ml)*c1
         enddo
         g(i)=g(i)*z(i)**Ml
      enddo
      return
      end
c
c     'rotate' g(j) to get gh(i,j)=sum_(Mi+1)^(Mi+Mj)()
c
      subroutine rotFTgh(coef,Nb,Nb0,Nbc,Ml,M,z,g,gh)
      implicit none
      integer Ml, Nb, Nb0, Nbc, M(Nb), i, j, n, Mpre
      complex*16 coef(0:100), z(Nbc), g(Nb), gh(Nb, Nb),
     &     c1, c2, gpre

      do i=1, Nb
         gpre=g(i)
         Mpre=Ml
         c1=z(i)**M(i)
         do j=Nb/2, 1, -1
            do n=Mpre, M(j)+1, -1
               c2=z(i)**n
               gpre=gpre-coef(M(i)+n)*c1*c2+coef(n)*c2
            enddo
            gh(j,i)=gpre
            gh(Nb-j+1,i)=gpre
            Mpre=M(j)
         enddo
      enddo
      return
      end
c
c     a subroutine calculating the diagonal matrix elements
c
      subroutine diagME(Nb, M, coef, z, U)
      implicit none
      integer Nb, M(Nb), i, n
      complex*16 coef(0:100), z(Nb), U(Nb,Nb), cc, tmp1, tmp2

      do n=1, Nb
         tmp1=(0,0d0)
         tmp2=(0,0d0)
         do i=1, M(n)
            if(mod(i,100).eq.1) then
               cc=z(n)**i
            else
               cc=cc*z(n)
            endif
            tmp1=tmp1+coef(i)*(i+1)*cc
            tmp2=tmp2+coef(i+M(n))*(M(n)+1-i)*cc
         enddo
         U(n,n)=coef(0)+tmp1+tmp2*cc
      enddo
      return
      end
c
c     modified by J.Chen at 10-21-2001. now calculate:
c
c        f(i) = sum_i=1^M z(i)**i * c(i)
c        g(i) = sum_i=1^M z(i)**i * c(i+M)
c
      subroutine arrays(Nsig,M,coef,Nz,z,f,g,diag)
      implicit none
      integer Nz,i,n,M,Nsig
      complex*16 coef(0:Nsig),f(Nz),g(Nz),diag(Nz),z(Nz),coef1(M),Z1
c      write(6,*) 'construction of 1D arrays for the U-matrices'
      do n=1,M
         coef1(n)=(n+1)*coef(n)
      enddo
      call Slow_FT(M,coef1(1),Nz,z,diag)
      do n=1,M
         coef1(n)=(n+1)*coef(n+M)
      enddo
      call Slow_FT(M,coef1(1),Nz,z,f)
      call Slow_FT(M,coef(M+1),Nz,z,g)
      do i=1,Nz
         Z1=z(i)**M
c        g(i)=g(i)*z(i)**M        ! bad !!!
         diag(i)=diag(i)+coef(0)+((M+2)*g(i)-f(i))*Z1
      enddo
      call Slow_FT(M,coef(1),Nz,z,f)
      return
      end
c
c     More accurate slow FT
      subroutine Slow_FT(M,coef,Nz,z,f)
      implicit none
      integer M,n,Nz,i
      complex*16 coef(M),z(Nz),f(Nz),fff
      do i=1,Nz
         f(i) = (0,0d0)
         fff = coef(M)*z(i)
         do n=M-1,1,-1
            fff = (fff+coef(n))*z(i)
            if(mod(n,100).eq.0.or.n.eq.1) then
               f(i)=f(i)+fff*z(i)**(n-1)
               fff=(0,0d0)
            endif
         enddo
      enddo
      return
      end
c
c     Given t=(Mj+1)/(M+1), calculate z_im which satisfies:
c        sum_{n=0}^M exp(-z_im*n)= Mj+1
c
      subroutine Im_Mj(t, Im)
      implicit none
      real*8 t, x, Im
      if(t.le.0.or.t.gt.1.0) then
         write(*,1999) t
 1999    format('WARNING: t=',E13.7,'; t be between 0 and 1.0')
         t=1d-2
      endif
      if(t.le.0.685) then
         x=0d0
         if(t.gt.1d-2) x=-dexp(-1d0/t)/t
         Im=1d0/t+x-x**2+1.5d0*x**3-8d0*x**4/3d0+125d0*x**5/24d0
      else
         Im=2.82d0*(1d0-t)
      endif
      return
      end


!==========================================================================
elemental function gsw_specvol_ice (t, p)
!==========================================================================
!
!  Calculates the specific volume of ice.
!
!  t  =  in-situ temperature (ITS-90)                             [ deg C ]
!  p  =  sea pressure                                              [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  specvol_ice  =  specific volume                               [ m^3/kg ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_gibbs_ice

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: t, p

real (r8) :: gsw_specvol_ice

gsw_specvol_ice = gsw_gibbs_ice(0,1,t,p)

return
end function

!--------------------------------------------------------------------------