!> @file
!!  Routines to do tail calculation (correct effect of finite size)
!! @author
!!    Copyright (C) 2007-2011 BigDFT group 
!!    This file is distributed under the terms of the
!!    GNU General Public License, see ~/COPYING file
!!    or http://www.gnu.org/copyleft/gpl.txt .
!!    For the list of contributors, see ~/AUTHORS 


!> Calculate the finite size corrections over wavefunctions
!! Conceived only for isolated Boundary Conditions, no SIC correction
subroutine CalculateTailCorrection(iproc,nproc,at,rbuf,orbs,&
     Glr,nlpsp,ncongt,pot,hgrid,rxyz,crmult,frmult,nspin,&
     psi,output_denspot,ekin_sum,epot_sum,eproj_sum,paw)
  use module_precisions
  use module_types
  use yaml_output
  use module_interfaces, only: orbitals_descriptors
  use psp_projectors_base
  use gaussians, only: gaussian_basis
  use public_enums
  use bounds
  use locregs
  use locreg_operations
  use compression
  use orbitalbasis
  use psp_projectors
  use box, only: cell, cell_new
  use at_domain
  use numerics, only: onehalf,pi
  use f_precisions, only: f_byte
  use module_bigdft_mpi
  use module_bigdft_errors
  use module_bigdft_arrays
  use module_bigdft_profiling
  implicit none
  type(atoms_data), intent(in) :: at
  type(orbitals_data), intent(in) :: orbs
  type(locreg_descriptors), intent(in) :: Glr
  type(DFT_PSP_projectors), intent(inout) :: nlpsp
  integer, intent(in) :: iproc,nproc,ncongt,nspin
  logical, intent(in) :: output_denspot
  real(kind=8), dimension(3), intent(in) :: hgrid
  real(kind=8), intent(in) :: crmult,frmult,rbuf
  !real(kind=8), dimension(at%astruct%ntypes,3), intent(in) :: radii_cf
  real(kind=8), dimension(3,at%astruct%nat), intent(in) :: rxyz
  real(kind=8), dimension(Glr%d%n1i,Glr%d%n2i,Glr%d%n3i,nspin), intent(in) :: pot
  real(kind=8), dimension(Glr%wfd%nvctr_c+7*Glr%wfd%nvctr_f,orbs%norbp), intent(in) :: psi
  real(kind=8), intent(out) :: ekin_sum,epot_sum,eproj_sum
  type(paw_objects),intent(inout)::paw
  !local variables
  type(locreg_descriptors), target :: lr
  character(len=*), parameter :: subname='CalculateTailCorrection'
  integer :: iseg,i0,j0,i1,j1,i2,i3,ii,iat,iorb,npt,ipt,i,ierr,nbuf,ispin
  integer :: nb1,nb2,nb3
  integer :: n1,n2,n3
  real(kind=8) :: alatb1,alatb2,alatb3,ekin,epot,eproj,tt,cprecr,sum_tail !n(c) eproj1 epot1,ekin1
  type(orbitals_data), target :: orbsb
  type(orbital_basis), target :: ob
  type(ket) :: psi_it
  type(DFT_PSP_projector_iter) :: psp_it
  type(cell) :: mesh
  type(domain) :: dom
  logical(f_byte), dimension(:,:,:), allocatable :: logrid_c,logrid_f
  integer, dimension(:,:,:), allocatable :: ibbyz_c,ibbyz_f,ibbxz_c,ibbxz_f,ibbxy_c,ibbxy_f
  real(kind=8), dimension(:,:), allocatable :: wrkallred
  real(kind=8), dimension(:), allocatable, target :: psib,hpsib,psir
  real(kind=8), dimension(:,:), pointer :: txyz
  integer, dimension(2, 3) :: nbox, nboxf
  
  integer nw1,nw2, nwarnings

  type(workarr_locham) :: w

  !SM This routine had as argument hgrid(1), but must now have all three dur to
  !the modified calling sequence of convolutions routine. Still only use the
  !first entry throughout the routine.

  call f_routine(id='CalculateTailCorrection')

  n1=Glr%d%n1
  n2=Glr%d%n2
  n3=Glr%d%n3

  nbuf=nint(rbuf/hgrid(1))
  !    --- new grid sizes n1,n2,n3
  nb1=n1+2*nbuf
  nb2=n2+2*nbuf
  nb3=n3+2*nbuf

  ! Create new structure with modified grid sizes
!!$  call init_lr(lr,Glr%geocode,0.5*hgrid,nb1,nb2,nb3,&
  !call init_lr(lr,domain_geocode(Glr%mesh%dom),0.5*hgrid,nb1,nb2,nb3,&
  nbox(1, :) = 0
  nbox(2, :) = (/ nb1, nb2, nb3 /)
  nboxf(1, 1) = Glr%d%nfl1+nbuf
  nboxf(1, 2) = Glr%d%nfl2+nbuf
  nboxf(1, 3) = Glr%d%nfl3+nbuf
  nboxf(2, 1) = Glr%d%nfu1+nbuf
  nboxf(2, 2) = Glr%d%nfu2+nbuf
  nboxf(2, 3) = Glr%d%nfu3+nbuf
  call init_lr(lr,Glr%mesh%dom,0.5*hgrid,nbox,nboxf,.true.)
 
  alatb1=real(nb1,kind=8)*hgrid(1) 
  alatb2=real(nb2,kind=8)*hgrid(1) 
  alatb3=real(nb3,kind=8)*hgrid(1)

  if (iproc == 0) then
     call yaml_comment('Finite-Size correction',hfill='-')
     call yaml_mapping_open('Estimation of Finite-Size Corrections')
     call yaml_map('Effective AU space more around each external atom',rbuf,fmt='(f6.3)')
     call yaml_map('Adding grid points around cell',nbuf)
     call yaml_map('Effective box size (AU)', (/ alatb1,alatb2,alatb3 /), fmt='(1pe12.5)')
     call yaml_map('Grid spacing units', (/ nb1,nb2,nb3 /))
     !write(*,'(1x,a)')&
     !     '---------------------------------------------- Estimation of Finite-Size Corrections'
     !write(*,'(1x,a,f6.3,a)') &
     !     'F-S Correction for an effective space of ',rbuf,' AU more around each external atom'
     !write(*,'(1x,a,i6,a)') &
     !     '                  requires the adding of ',nbuf,' additional grid points around cell'
     !write(*,'(1x,a,19x,a)') &
     !     '   Effective box size,   Atomic Units:','grid spacing units:'
     !write(*,'(1x,a,3(1x,1pe12.5),3x,3(1x,i9))')&
     !     '            ',alatb1,alatb2,alatb3,nb1,nb2,nb3
  end if

!end do

  !---reformat wavefunctions

  ! fine grid size (needed for creation of input wavefunction, preconditioning)
  if (iproc == 0) then
     call yaml_map('Extremes for the new high resolution grid points', &
          & (/ lr%d%nfl1, lr%d%nfu1, lr%d%nfl2,lr%d%nfu2,lr%d%nfl3,lr%d%nfu3 /))

     !write(*,'(1x,a,3x,3(3x,i4,a1,i0))')&
     !     '  Extremes for the new high resolution grid points:',&
     !     nbfl1,'<',nbfu1,nbfl2,'<',nbfu2,nbfl3,'<',nbfu3
  endif

  ! change atom coordinates according to the enlarged box
  txyz = f_malloc_ptr((/ 3, at%astruct%nat /),id='txyz')
  do iat=1,at%astruct%nat
     txyz(1,iat)=rxyz(1,iat)+real(nbuf,kind=8)*hgrid(1)
     txyz(2,iat)=rxyz(2,iat)+real(nbuf,kind=8)*hgrid(1)
     txyz(3,iat)=rxyz(3,iat)+real(nbuf,kind=8)*hgrid(1)
  enddo

  ! determine localization region for all orbitals, but do not yet fill the descriptor arrays
  logrid_c = f_malloc((/ 0.to.nb1, 0.to.nb2, 0.to.nb3 /),id='logrid_c')
  logrid_f = f_malloc((/ 0.to.nb1, 0.to.nb2, 0.to.nb3 /),id='logrid_f')

  if (domain_geocode(at%astruct%dom) /= 'F') call f_err_throw('Geocode has to be F to set mesh here',&
       err_name='BIGDFT_RUNTIME_ERROR')
  mesh=cell_new(at%astruct%dom,[nb1+1, nb2+1, nb3+1],hgrid)

  call fill_logrid(mesh,0,nb1,0,nb2,0,nb3,nbuf,at%astruct%nat,at%astruct%ntypes,at%astruct%iatype,txyz, & 
       at%radii_cf(1,1),crmult,logrid_c)
  call fill_logrid(mesh,0,nb1,0,nb2,0,nb3,0,at%astruct%nat,at%astruct%ntypes,at%astruct%iatype,txyz, & 
       at%radii_cf(1,2),frmult,logrid_f)

  call init_wfd_from_full_grids(lr%wfd, nb1, nb2, nb3, logrid_c, logrid_f)
  
  if (iproc == 0) then
     call yaml_mapping_open('Coarse resolution grid',flow=.true.)
     call yaml_map('Segments',lr%wfd%nseg_c)
     call yaml_map('Points',lr%wfd%nvctr_c)
     call yaml_mapping_close()
     call yaml_mapping_open('Fine resolution grid',flow=.true.)
     call yaml_map('Segments',lr%wfd%nseg_f)
     call yaml_map('Points',lr%wfd%nvctr_f)
     call yaml_mapping_close()
  end if

  call locreg_bounds_from_grids(nb1,nb2,nb3, &
       lr%d%nfl1,lr%d%nfu1,lr%d%nfl2,lr%d%nfu2,lr%d%nfl3,lr%d%nfu3, &
       logrid_c, logrid_f, lr%bounds)

  ! Create the file grid.xyz to visualize the grid of functions
  if (iproc ==0 .and. output_denspot) then
     call yaml_comment('Writing the file describing the new atomic positions of the effective system')
     !write(*,'(1x,a)')&
     !     'Writing the file describing the new atomic positions of the effective system'
     open(unit=22,file='grid_tail.xyz',status='unknown') !here the output directory can be passed
     write(22,*) lr%wfd%nvctr_c+lr%wfd%nvctr_f,' atomic' 
     write(22,*)'complete simulation grid for the tail correction'
     do iat=1,at%astruct%nat
        write(22,'(a6,2x,3(1x,e12.5),3x)') &
             trim(at%astruct%atomnames(at%astruct%iatype(iat))),txyz(1,iat),txyz(2,iat),txyz(3,iat)
     enddo
     do i3=0,nb3  
        do i2=0,nb2  
           do i1=0,nb1
              if (logrid_c(i1,i2,i3))&
                   write(22,'(a4,2x,3(1x,e10.3))') &
                   '  g ',real(i1,kind=8)*hgrid(1),real(i2,kind=8)*hgrid(1),real(i3,kind=8)*hgrid(1)
           enddo
        enddo
     end do
     do i3=0,nb3 
        do i2=0,nb2 
           do i1=0,nb1
              if (logrid_f(i1,i2,i3))&
                   write(22,'(a4,2x,3(1x,e10.3))') &
                   '  G ',real(i1,kind=8)*hgrid(1),real(i2,kind=8)*hgrid(1),real(i3,kind=8)*hgrid(1)
           enddo
        enddo
     enddo
     close(22)
  endif

  call f_free(logrid_c)
  call f_free(logrid_f)


  ! allocations for arrays holding the wavefunction
  !if (iproc == 0) &
  !     write(*,'(1x,a,i0)') 'Allocate words for psib and hpsib ',2*(nvctrb_c+7*nvctrb_f)
  psib = f_malloc(lr%wfd%nvctr_c+7*lr%wfd%nvctr_f,id='psib')
  hpsib = f_malloc(lr%wfd%nvctr_c+7*lr%wfd%nvctr_f,id='hpsib')
  !if (iproc == 0) write(*,*) 'Allocation done'

  ! work arrays applylocpotkin
  psir = f_malloc0((2*nb1+31)*(2*nb2+31)*(2*nb3+31),id='psir')

  if (iproc == 0) then
     call yaml_map('Wavefunction memory occupation in the extended grid (Bytes):', &
          (lr%wfd%nvctr_c+7*lr%wfd%nvctr_f)*8)
     call yaml_comment('Calculating tail corrections, orbitals are processed separately')
     !write(*,'(1x,a,i0)') &
     !     'Wavefunction memory occupation in the extended grid (Bytes): ',&
     !     (nvctrb_c+7*nvctrb_f)*8
     !write(*,'(1x,a,i0,a)') &
     !     'Calculating tail corrections on ',orbs%norbp,' orbitals per processor.'
     !write(*,'(1x,a)',advance='no') &
     !     '     orbitals are processed separately'
  end if

  call initialize_work_arrays_locham(lr, 1, .true., w)

  ekin_sum=0.d0
  epot_sum=0.d0
  eproj_sum=0.d0

  !allocate the fake orbital structure for the application of projectors
  call orbitals_descriptors(0,1,1,1,0,1,1,1, &
       reshape((/0._gp,0._gp,0._gp/),(/3,1/)),(/1._gp /),orbsb,LINEAR_PARTITION_NONE)

  !change positions in gaussian projectors
  call psp_update_positions(nlpsp, lr, Glr, txyz)

  do iorb=1,orbs%norbp

     !build the compressed wavefunction in the enlarged box
     call transform_fortail(n1,n2,n3,nb1,nb2,lr%d%nfl1,lr%d%nfu1,lr%d%nfl2,lr%d%nfu2,lr%d%nfl3,lr%d%nfu3,&
        & Glr%wfd, lr%wfd, nbuf,psi(1,iorb),psi(Glr%wfd%nvctr_c+1,iorb),  & 
        & w%x_c,w%x_f,psib(1),psib(lr%wfd%nvctr_c+1))

     !write(*,*) 'transform_fortail finished',iproc,iorb

     if(orbs%spinsgn(iorb+orbs%isorb)>0.0d0) then
        ispin=1
     else
        ispin=2
     end if
     psi_it%ncplx = 1
     psi_it%n_ket = 1
     psi_it%lr => lr
     psi_it%phi_wvl => psib
     psi_it%ispin = ispin
     psi_it%ispsi = 1
     psi_it%nphidim = lr%wfd%nvctr_c+7*lr%wfd%nvctr_f
     psi_it%ob => ob
     ob%orbs => orbsb
     orbsb%npsidim_orbs = lr%wfd%nvctr_c+7*lr%wfd%nvctr_f
     hpsib = 0.
       
     npt=2
     tail_adding: do ipt=1,npt

        !for the tail application leave the old-fashioned hamiltonian
        !since it only deals with Free BC and thus no k-points or so

        !calculate gradient
        call daub_to_isf_locham(1, lr, w, psib, psir)
        call apply_potential(lr%d%n1,lr%d%n2,lr%d%n3,1,1,1,nbuf,1,1,psir,pot,epot,&
          lr%bounds%ibyyzz_r) !optional
        call isf_to_daub_kinetic(hgrid(1),hgrid(2),hgrid(3), 0._gp, 0._gp, 0._gp, &
             1, lr, w, psir, hpsib, ekin)
        !write(*,'(a,3i3,2f12.8)') 'applylocpotkinone finished',iproc,iorb,ipt,epot,ekin

        eproj=0.0d0
        call DFT_PSP_projectors_iter_new(psp_it, nlpsp)
        loop_proj: do while (DFT_PSP_projectors_iter_next(psp_it, ilr = 1, lr = lr, glr = lr))
           call DFT_PSP_projectors_iter_ensure(psp_it, [0._gp, 0._gp, 0._gp], 0, nwarnings, lr)
           call DFT_PSP_projectors_iter_apply(psp_it, psi_it, at, eproj, hpsi = hpsib, paw = paw)
        end do loop_proj

        !calculate residue for the single orbital
        tt=0.d0
        do i=1,lr%wfd%nvctr_c+7*lr%wfd%nvctr_f
           hpsib(i)=hpsib(i)-orbs%eval(iorb+orbs%isorb)*psib(i)
           tt=tt+hpsib(i)**2
        enddo
        tt=sqrt(tt)

        if (ipt == npt) exit tail_adding

        !calculate tail using the preconditioner as solver for the green function application
        cprecr=-orbs%eval(iorb+orbs%isorb)
        call precong(nb1,nb2,nb3,lr%d%nfl1,lr%d%nfu1,lr%d%nfl2,lr%d%nfu2,lr%d%nfl3,lr%d%nfu3, &
             lr%wfd%nseg_c,lr%wfd%nvctr_c,lr%wfd%nseg_f,lr%wfd%nvctr_f,&
             lr%wfd%keyglob,lr%wfd%keyvglob,ncongt,cprecr,hgrid(1),&
             lr%bounds%kb%ibyz_c,lr%bounds%kb%ibxz_c,lr%bounds%kb%ibxy_c,&
             lr%bounds%kb%ibyz_f,lr%bounds%kb%ibxz_f,lr%bounds%kb%ibxy_f,hpsib)
        !call plot_wf(10,nb1,nb2,nb3,hgrid,nsegb_c,nvctrb_c,keyg,keyv,nsegb_f,nvctrb_f,  & 
        !      txyz(1,1),txyz(2,1),txyz(3,1),psib)

        ! add tail to the bulk wavefunction
        sum_tail=0.d0
        do i=1,lr%wfd%nvctr_c+7*lr%wfd%nvctr_f
           psib(i)=psib(i)-hpsib(i)
           sum_tail=sum_tail+psib(i)**2
        enddo
        sum_tail=sqrt(sum_tail)
        !write(*,'(1x,a,i3,3(1x,1pe13.6),1x,1pe9.2)') &
        !     'BIG: iorb,ekin,epot,eproj,gnrm',iorb,ekin,epot,eproj,tt

        !values of the energies before tail application
        !n(c) ekin1=ekin
        !n(c) epot1=epot
        !n(c) eproj1=eproj
        !write(*,'(1x,a,1x,i0,f18.14)') 'norm orbital + tail',iorb,sum_tail
        !call plot_wf(20,nb1,nb2,nb3,hgrid,nsegb_c,nvctrb_c,keyg,keyv,nsegb_f,nvctrb_f,  & 
        !      txyz(1,1),txyz(2,1),txyz(3,1),psib)

        sum_tail=1.d0/sum_tail
        do i=1,lr%wfd%nvctr_c+7*lr%wfd%nvctr_f
           psib(i)=psib(i)*sum_tail
        enddo

     end do tail_adding

!!!     write(*,'(1x,a,i3,3(1x,1pe13.6),2(1x,1pe9.2))') &
!!!          'BIG: iorb,denergies,gnrm,dnorm',&
!!!          iorb,ekin-ekin1,epot-epot1,eproj-eproj1,tt,sum_tail-1.d0

     if (iproc == 0) then
        !write(*,'(a)',advance='no') &
        !     repeat('.',((iorb+orbs%isorb)*40)/orbs%norbp-((iorb-1)*40)/orbs%norbp)
     end if
     ekin_sum=ekin_sum+ekin*orbs%occup(iorb+orbs%isorb)
     epot_sum=epot_sum+epot*orbs%occup(iorb+orbs%isorb)
     eproj_sum=eproj_sum+eproj*orbs%occup(iorb+orbs%isorb)
  end do

  call deallocate_orbs(orbsb)

  call f_free_ptr(txyz)
  call f_free(psir)
  call f_free(psib)
  call f_free(hpsib)

  call deallocate_locreg_descriptors(lr)

  call deallocate_work_arrays_locham(w)

  if (nproc > 1) then
     !if (iproc == 0) then
     !   write(*,'(1x,a,f27.14)')'Tail calculation ended'
     !endif
     wrkallred = f_malloc((/ 3, 2 /),id='wrkallred')
     wrkallred(1,2)=ekin_sum
     wrkallred(2,2)=epot_sum 
     wrkallred(3,2)=eproj_sum 
     call MPI_ALLREDUCE(wrkallred(1,2),wrkallred(1,1),3,&
          MPI_DOUBLE_PRECISION,MPI_SUM,bigdft_mpi%mpi_comm,ierr)
     ekin_sum=wrkallred(1,1) 
     epot_sum=wrkallred(2,1) 
     eproj_sum=wrkallred(3,1)
     call f_free(wrkallred)
  endif

  call f_release_routine()

END SUBROUTINE CalculateTailCorrection


subroutine transform_fortail(n1,n2,n3,nb1,nb2,nbfl1,nbfu1,nbfl2,nbfu2,nbfl3,nbfu3,& 
     wfd, wfdb, nbuf,psi_c,psi_f,psig_c,psig_f,psib_c,psib_f)
  use module_bigdft_arrays
  use compression
  implicit none
  type(wavefunctions_descriptors), intent(in) :: wfd, wfdb
  integer, intent(in) :: n1,n2,n3,nb1,nb2,nbfl1,nbfu1,nbfl2,nbfu2,nbfl3,nbfu3
  integer, intent(in) :: nbuf
  real(kind=8) :: psi_c(wfd%nvctr_c),psi_f(7,wfd%nvctr_f)
  real(kind=8) :: psib_c(wfdb%nvctr_c),psib_f(7,wfdb%nvctr_f)
  real(kind=8) :: psig_c(0:n1+2*nbuf,0:n2+2*nbuf,0:n3+2*nbuf)
  real(kind=8) :: psig_f(7,nbfl1:nbfu1,nbfl2:nbfu2,nbfl3:nbfu3)
  !Local variables
  integer :: iseg,jj,j0,j1,i0,i1,i2,i3,ii,i

  call f_zero(psig_c)
  call f_zero(psig_f)

  ! coarse part
  do iseg=1,wfd%nseg_c
     jj=wfd%keyvloc(iseg)
     j0=wfd%keygloc(1,iseg)
     j1=wfd%keygloc(2,iseg)
     ii=j0-1
     i3=ii/((n1+1)*(n2+1))
     ii=ii-i3*(n1+1)*(n2+1)
     i2=ii/(n1+1)
     i0=ii-i2*(n1+1)
     i1=i0+j1-j0
     do i=i0,i1
        psig_c(i+nbuf,i2+nbuf,i3+nbuf)=psi_c(i-i0+jj)
     enddo
  enddo

  do iseg=1,wfdb%nseg_c
     jj=wfdb%keyvglob(iseg)
     j0=wfdb%keyglob(1,iseg)
     j1=wfdb%keyglob(2,iseg)
     ii=j0-1
     i3=ii/((nb1+1)*(nb2+1))
     ii=ii-i3*(nb1+1)*(nb2+1)
     i2=ii/(nb1+1)
     i0=ii-i2*(nb1+1)
     i1=i0+j1-j0
     do i=i0,i1
        psib_c(i-i0+jj)=psig_c(i,i2,i3)
     enddo
  enddo


  ! fine part
  do iseg=1,wfd%nseg_f
     jj=wfd%keyvloc(wfd%nseg_c+iseg)
     j0=wfd%keygloc(1,wfd%nseg_c+iseg)
     j1=wfd%keygloc(2,wfd%nseg_c+iseg)
     ii=j0-1
     i3=ii/((n1+1)*(n2+1))
     ii=ii-i3*(n1+1)*(n2+1)
     i2=ii/(n1+1)
     i0=ii-i2*(n1+1)
     i1=i0+j1-j0
     do i=i0,i1
        psig_f(1,i+nbuf,i2+nbuf,i3+nbuf)=psi_f(1,i-i0+jj)
        psig_f(2,i+nbuf,i2+nbuf,i3+nbuf)=psi_f(2,i-i0+jj)
        psig_f(3,i+nbuf,i2+nbuf,i3+nbuf)=psi_f(3,i-i0+jj)
        psig_f(4,i+nbuf,i2+nbuf,i3+nbuf)=psi_f(4,i-i0+jj)
        psig_f(5,i+nbuf,i2+nbuf,i3+nbuf)=psi_f(5,i-i0+jj)
        psig_f(6,i+nbuf,i2+nbuf,i3+nbuf)=psi_f(6,i-i0+jj)
        psig_f(7,i+nbuf,i2+nbuf,i3+nbuf)=psi_f(7,i-i0+jj)
     enddo
  enddo

  do iseg=1,wfdb%nseg_f
     jj=wfdb%keyvglob(wfdb%nseg_c+iseg)
     j0=wfdb%keyglob(1,wfdb%nseg_c+iseg)
     j1=wfdb%keyglob(2,wfdb%nseg_c+iseg)
     ii=j0-1
     i3=ii/((nb1+1)*(nb2+1))
     ii=ii-i3*(nb1+1)*(nb2+1)
     i2=ii/(nb1+1)
     i0=ii-i2*(nb1+1)
     i1=i0+j1-j0
     do i=i0,i1
        psib_f(1,i-i0+jj)=psig_f(1,i,i2,i3)
        psib_f(2,i-i0+jj)=psig_f(2,i,i2,i3)
        psib_f(3,i-i0+jj)=psig_f(3,i,i2,i3)
        psib_f(4,i-i0+jj)=psig_f(4,i,i2,i3)
        psib_f(5,i-i0+jj)=psig_f(5,i,i2,i3)
        psib_f(6,i-i0+jj)=psig_f(6,i,i2,i3)
        psib_f(7,i-i0+jj)=psig_f(7,i,i2,i3)
     enddo
  enddo

END SUBROUTINE transform_fortail
