*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
*	PROGRAM D_FSTEP
*
* Central reconstruction with fixed steps with positivity constraint
*
* INPUT:
*               First approx. of the object
*	*.V  	Support of the object (direct space)
*	*.G	Regularizing function
*
* OUTPUT:
*	*.PHIX	Final estimation of the object
*
* Log file: *.SUM
*
*
* Pointers :
*  ---------
* p_phit	phit		partie reelle			R4 -
* p_phitcr	phit chapeau	partie reelle			R4 -
* p_phitci	  "     "	partie imaginaire		R4 -
* p_v		support de l'Objet				R4 -
* p_g		Fonction de regularisation			R4 -
* p_phix	Objet reconstruit (module)			R4 -
* p_rn		Memory space for rn  				R4   vm
* p_dphitr	phit		partie reelle		R8	     vm
* p_dphiti	phit		partie imaginaire	R8	     vm
*
* From d_cgrad.for
*
* JLP
* Version 02-05-91
*-------------------------------------------------------------------------------
	program d_fstep
	implicit none
	integer*4 npix(2),n,n4,n8,p_phit,p_phitcr, p_phitci
	integer*4 p_v,p_g,p_rn,p_phix,istatus
	integer*4 p_dphitr,p_dphiti,long,lu,i
	real*4 step
	character name*20,comments*80,filesum*40,buffer*90
 	character*40 fileout,filephit,filev,fileg
	integer*4 madrid(1)
	common /vmr/madrid
*
* Initialisation
	call jlp_begin
	call jlp_inquifmt
        write(6,112)
112     format('******* Program d_fstep  Version 02-11-93',
     1         ' Fixed step with positivity constraint')

*
* ouverture du fichier de la recapitulation
55	write(6,*)' Generic name (should end with a dot) ?'
	read(5,10) name
10	format(a)
	long=index(name,'.')-1
	if(long.le.0)goto 55
*
	filesum=name(:long)//'.SUM'
	lu=1
C "APPEND" is not available for IBM...
C	open(lu,file=filesum,status='OLD',access='APPEND')
	open(lu,file=filesum,status='OLD',access='SEQUENTIAL')
        do i=1,10000
        read(lu,10,end=989) buffer
        enddo
989	write (lu,980)
980	format(/,' MODULE FSTEP',/,' ----------------',/)
*
* Ouverture du fichier contenant la premiere approximation de l'Objet
*
	write(6,*)' First approximation of the object (test.PHIT?) :'
	read(5,10) filephit
	write(6,*)' Reading the first approx. of the object:',filephit
	call jlp_vm_readimag(p_phit,npix(1),npix(2),filephit,comments)
* Recentre image to have gravity center at (1,1):
        call recentre(madrid(p_phit),madrid(p_phit),
     1     npix(1),npix(2),npix(1))
*
	N = npix(1)*npix(2)
*
* reservons de la memoire et passons en D.P. pour les parties R et I
*
        N8 = N*8
	call jlp_getvm (p_dphitr,N8)
	call jlp_getvm (p_dphiti,N8)

* Memory space for FFT of first approximation:
        N4 = N*4
	call jlp_getvm (p_phitcr,N4)
	call jlp_getvm (p_phitci,N4)
*
* Ouverture du fichier contenant le support de l'objet
*
	FileV = name(:long)//'.V'
	write(6,*)' Reading the support of the object (direct space)',filev
	call jlp_vm_readimag(p_v,npix(1),npix(2),filev,comments)
* Recentre image to have gravity center at (1,1):
        call recentre(madrid(p_phit),madrid(p_phit),
     1     npix(1),npix(2),npix(1))
*
* Ouverture du fichier contenant la fonction de regularisation
*
	FileG = name(:long)//'.G'
	write(6,*)' Reading the regularization function (Fourier)',fileg
	call jlp_vm_readimag(p_g,npix(1),npix(2),fileg,comments)
* Recentre image to have zero frequency at (1,1):
        call recentre(madrid(p_g),madrid(p_g),
     1     npix(1),npix(2),npix(1))
*
	write(6,*) ' Step value for constant step gradients:'
	read(5,*) step
*
* Memory working space:
*
        n4 = n*4
        n8 = n*8
* Residuals:
	call jlp_getvm (p_rn,n4)
* FFT of first approximation:
	call jlp_getvm (p_phitcr,N4)
	call jlp_getvm (p_phitci,N4)
* Final approximation:
	call jlp_getvm(p_phix,N4)

*
C	   call restit_cgrad (N,npix,madrid(p_phitcr),madrid(p_phitci),
C     1	madrid(p_phit),madrid(p_dphitr),madrid(p_dphiti),
C     1	madrid(p_v),madrid(p_g),madrid(p_rn),madrid(p_zn),
C     1	madrid(p_ddnr),madrid(p_ddni),madrid(p_ddntemp),
C     1	madrid(p_phix),p_dphitr,p_dphiti,
C     1	p_ddnr,p_ddni,eps,lu)
* Fixed step gradient with positivity constraint:
	   call restit_fstep (N,npix,madrid(p_phitcr),madrid(p_phitci),
     1	madrid(p_phit),madrid(p_dphitr),madrid(p_dphiti),
     1	madrid(p_v),madrid(p_g),madrid(p_rn),
     1	madrid(p_phix),lu,step)
*
* et on ferme les fichiers
*
	fileout = name(:long)//'.PHIX'
	comments = 'Resultat final'
C* Recentre image to have gravity center at (1,1):
C        call recentre(madrid(p_phix),madrid(p_phix),
C     1     npix(1),npix(2),npix(1))
	call jlp_writeimag(madrid(p_phix),npix(1),npix(2),npix(1),
     1	fileout,comments)
*
* Sortie normale
	close(lu)
	call jlp_end
	stop
	end
*------------------------------------------------------------------------------
*
*-----------------------------------------------------------------------
* Like restit_cgrad but with fixed step and positivity
* constraint
* JLP May 1992
*
*-----------------------------------------------------------------------
	subroutine restit_fstep(n,npix,phitcr,phitci,phit,
     1	dphitr,dphiti,v,g,rn,phix,lu,step)
	implicit none
       	integer*4  n,npix(2),lu,imax
	integer*4 k,i,m,mult(35),icn(101),isig,num,nomb,nrac
        real*4 epsilon
	real*4 v(n),g(n),rn(n),phix(n),phitcr(n), phitci(n),phit(n)
 	real*4 rac(35),xnorfin,xx,x,xnun,pas,xnfinc
        real*4 deltan,ron,tete,tetap,xmum,step
	real*8 dphitr(n), dphiti(n)
	real*8 dg2,xnorrn,psdz,omegan
	real*8 error,major,y,xnorrnp

* Majorant de 1/mu:
	major=10.
*
*
*
* Computing FFT of the first approximation of the object:
*
* Transfer to work arrays:
	do k = 1, n
	 phitcr(k)=phit(k)
	 phitci(k)=0.
	end do
* Compute phi_n chap
        ioption=1
	call fft_2d(phitcr,phitci,npix(1),npix(2),npix(1),ioption)
************************************************************************
*
*
* N = npix ** 2       nombre total de pixels
* (phitcr,phitci)     tf de phit - parties reelle et imaginaire
* (phit)	     module de phit
* dphitr et dphiti  tableaux associes en dp
* V		   support de l'objet
* G		   fonction de regularisation
*
************************************************************************
*
* initialisation
* of first guess  phi_zero = v * phit
	do k = 1, n
	 phix(k)=v(k)*phit(k)
	end do
*******************************************************************************
*
*			I T E R A T I O N
*
*******************************************************************************
*
	write(6,105)
	write(lu,105)
105	format('  N         Error',/)
*
	imax = 30
        epsilon = 0.1
        do 600 iter=1,imax
*
* Compute residuals: r_n = || aa*(psi - aa phi)||
*  i.e., r_n = modulus of ( v U* g2 (phitc - phi_n chap))
*

* Transfer to work arrays:
	xnorrn = 0.
	do k = 1, n
	 dphitr(k)=dble(phix(k))
	 dphiti(k)=0.
	 xnorrn = xnorrn + dphitr(k) * dphitr(k)
	end do
C        print *,' norm of FFT of phit troncated:',xnorrn

* Compute phi_n chap
        ioption=1
	call fourier1(dphitr,dphiti,npix(1),npix(2),ioption)
*
	xnorrn = 0.
        work = 0.
	do k = 1, n
	 dg2 = dble(g(k)) * dble(g(k))
	 dphitr(k) = (dble(phitcr(k)) - dphitr(k)) * dg2
	 dphiti(k) = (dble(phitci(k)) - dphiti(k)) * dg2
	 xnorrn = xnorrn + dphitr(k) * dphitr(k)
         work = work + dg2
	end do
C        print *,' norm of FFT of initial phit - FFT of phit troncated:',xnorrn
C        print *,' norm of dg2:',work
* Inverse FFT:
        ioption=-1
	call fourier1(dphitr,dphiti,npix(1),npix(2),ioption)

* Compute FFT modulus, and store it in real part array:
* I assume zero phase (real image), so I take the modulus of the inverse FFT:
	call mod_tf(n,dphitr,dphiti)

* Compute residuals:
	xnorrn = 0.
	do k = 1, n
	 rn(k) = sngl(dphitr(k)) * v(k)
	 xnorrn = xnorrn + rn(k) * rn(k)
	end do
*
*
* Compute phi_n+1 and ||phi_n+1||**2
* Compute r_n+1 and ||r_n+1||**2
*
	xnorfin = 0.
*
	do k = 1, N
C New approximation:
	 phix(k) = phix(k) + step * rn(k)
C Positivity constraint:
         if(phix(k).lt.0.)phix(k)=0.
	 x = phix(k) * phix(k)
	 xnorfin = xnorfin + x
	end do
*
* test d'arret
*
	error = xnorrn/xnorfin
	error = major * sqrt(error)
*
	write (6,102) iter, error
	write (lu,102) iter, error
102	format(1x, i3, 4x, g12.6)
*
* Test to exit from the loop:
	if (error .le. epsilon) goto 500

* Go to beginning of loop:
600     continue
*
* ********************  FIN D'ITERATION   ********************
*
        write(6,28)
        write(lu,28)
28      format('jlp_fstep/ Warning: error larger than expected!')

500	return
	end
C-----------------------------------------------------------------------
	subroutine dnormel2(n,reel,imagi,norme)
*
* Calcul de la norme L2 du complexe (REEL, IMAG) dans l'espace de Fourier
*
* NE DOIT PAS ETRE APPELE EN UTILISANT LE MECANISME	%VAL
* ----------------------------------------------------------
*
	implicit none
	integer*4 n,i
	real*8	reel(*), imagi(*)
	real*4	norme
*
	norme = 0.
	do i = 1, n
	 norme = norme + (reel(i)*reel(i)+imagi(i)*imagi(i))
	end do
*
	norme = sqrt(norme/float(n))
*
	return
	end
C-----------------------------------------------------------------------------
C	include 'd_utilities.for'


!***********************************/
!	Name:基礎変数から保存変数へ変換するプログラム
!	Alias:Primitive2Conserve
!	Description:定義通りに計算するだけ
!	Type:Geom,CellCenter
!	Input:Geom,CC
!	Output:CC%PrimitiveVariable
!	Note:1~3次元すべてに対応済み
!	Author:Akitaka Toyota
!	Date:2017.10.26
!	Update:2017.11.06
!	Other:
!***********************************/
subroutine Primitive2Conserve(Geom,CC)
    use StructVar_Mod
    use LoopVar_Mod
    use ConstantVar_Mod, Gamma => SpecificOfHeatRatio
    implicit none
    type(Geometry), intent(in) :: Geom
    type(CellCenter),intent(inout) :: CC

    nullify(iVar,iCX,iCY,iCZ)
    iVar => iVariable
    iCX => iCenterX
    iCY => iCenterY
    iCZ => iCenterZ
    iDim = Geom%Dimension

        if(iDim <= 2) iCZ => iOne
        if(iDim == 1) iCY => iOne

    do iCenterZ=0, Geom%CellNumber(3)+1
        do iCenterY=0, Geom%CellNumber(2)+1
            do iCenterX=0, Geom%CellNumber(1)+1
                CC%ConservedQuantity(1,iCX,iCY,iCZ) = CC%PrimitiveVariable(1,iCX,iCY,iCZ)

                do iVariable = 2, iDim+1
                    CC%ConservedQuantity(iVar,iCX,iCY,iCZ) = &
                        &   CC%PrimitiveVariable(iVar,iCX,iCY,iCZ)*CC%PrimitiveVariable(1,iCX,iCY,iCZ)
                end do

                CC%ConservedQuantity(iDim+2,iCX,iCY,iCZ) = &
                    &   InverseGmin1 * (CC%PrimitiveVariable(iDim+2,iCX,iCY,iCZ) + 0.5d0 * CC%PrimitiveVariable(1,iCX,iCY,iCZ) &
                    &   * dot_product(CC%PrimitiveVariable(2:iDim+1,iCX,iCY,iCZ),CC%PrimitiveVariable(2:iDim+1,iCX,iCY,iCZ)))

                !if(CC%PrimitiveVariable(1,iCX,iCY,iCZ) <= 0.0d0) call ErrorMessage(1)
                do iVariable=1,iDim+2
                if(CC%PrimitiveVariable(iVariable,iCX,iCY,iCZ) <= 0.0d0)then
                    write(6,*) CC%ConservedQuantity(1,iCX,iCY,iCZ),iCX,iCY,iCZ
                    write(6,*) CC%PrimitiveVariable(1,iCX,iCY,iCZ)
                    write(6,*) lbound(CC%ConservedQuantity)
                    write(6,*) ubound(CC%ConservedQuantity)
                   stop
               end if
               end do
               ! if(CC%PrimitiveVariable(iDim+2,iCX,iCY,iCZ) <= 0.0d0) call ErrorMessage(2)
            end do
            if(iDim == 1) exit
        end do
        if(iDim <= 2) exit
    end do

return
end subroutine Primitive2Conserve


C
C	EFFECT OF INPUT (211) BOARD
C
	WCC = W*CCOMP
	Z2 = CMPLX(R2C,-1./WCC)
	Y1 = 1./(R1C + Z2) + CMPLX(0.,W*C16)
C*****************   effect of compensation
	CGAIN = CGAIN*(Z2/(R1C+Z2))*CGAIN/(1. + R33*Y1)
C*************


      double complex function nAmpppp(j5,j1,j2,j3,j4)
c--- Caclculation of the amplitudes using results of S. Badger
c--- as adapted from routines written by F. Caola
      include 'constants.f'
      include 'zprods_com.f'
      include 'sprods_com.f'
      integer j1,j2,j3,j4,j5
      double complex zaa_5_pH_12_5, zaa_2_pH_34_5, zaa_2_pH_pH12_5,
     & zaa_3_pH_12_5,zab_5_pH_1, zab_2_pH_1, zab_5_pH_4, zab_3_pH_4,
     & zab_5_pH2_1, zab_5_pH3_4, zab_2_pH3_4, zab_3_pH2_1,
     & zab2, zab3
      double precision sH1, sH2, sH3, sH4, s125, s145, s345
      double precision s3, s4
      double precision qsq
C--- begin statement functions
      zab2(j1,j2,j3,j4)=za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4)
      zab3(j1,j2,j3,j4,j5)=
     & za(j1,j2)*zb(j2,j5)+za(j1,j3)*zb(j3,j5)+za(j1,j4)*zb(j4,j5)
      s3(j1,j2,j3)=s(j1,j2)+s(j1,j3)+s(j2,j3)
      s4(j1,j2,j3,j4)=s(j1,j2)+s(j1,j3)+s(j1,j4)
     &               +s(j2,j3)+s(j2,j4)+s(j3,j4)
C--- end statement functions

      qsq=
     & +s(j1,j2)+s(j1,j3)+s(j1,j4)+s(j1,j5)
     &          +s(j2,j3)+s(j2,j4)+s(j2,j5)
     &                   +s(j3,j4)+s(j3,j5)
     &                            +s(j4,j5)

      sH1 = s4(j2,j3,j4,j5)
      sH2 = s4(j1,j3,j4,j5)
      sH3 = s4(j1,j2,j4,j5)
      sH4 = s4(j1,j2,j3,j5)
      s125 = s3(j1,j2,j5)
      s145 = s3(j1,j4,j5)
      s345 = s3(j3,j4,j5)

      zaa_5_pH_12_5=-za(j1,j5)*zab2(j5,j3,j4,j1)
     & -za(j2,j5)*zab2(j5,j3,j4,j2)
      zaa_2_pH_34_5 = -za(j2,j5)*s345 - za(j2,j1)*zab2(j5,j3,j4,j1)
      zaa_2_pH_pH12_5 = - zaa_2_pH_34_5
      zaa_3_pH_12_5 = -za(j3,j5)*s125 - za(j3,j4)*zab2(j5,j1,j2,j4)

      zab_5_pH_1 = -zab3(j5,j2,j3,j4,j1)
      zab_2_pH_1 = -zab3(j2,j3,j4,j5,j1)
      zab_5_pH_4 = -zab3(j5,j1,j2,j3,j4)
      zab_3_pH_4 = -zab3(j3,j1,j2,j5,j4)
      zab_5_pH2_1 = -zab2(j5,j3,j4,j1)
      zab_5_pH3_4 = -zab2(j5,j1,j2,j4)
      zab_2_pH3_4 = -zab2(j2,j1,j5,j4)
      zab_3_pH2_1 = -zab2(j3,j4,j5,j1)

      nAmpppp = -zaa_5_pH_12_5**3/(za(j1,j2)*za(j3,j4)*za(j4,j5)
     & *za(j1,j5)*
     &   zaa_2_pH_34_5 * zaa_3_pH_12_5)
     &   + zab_5_pH_1**3/(sH1*za(j2,j3)*za(j3,j4)*za(j4,j5)*zab_2_pH_1)
     &   - zab_5_pH_4**3/(sH4*za(j1,j2)*za(j2,j3)*za(j1,j5)*zab_3_pH_4)
     &   - qsq**2 * zab_5_pH2_1**4/(sH2*s345*za(j3,j4)*za(j4,j5)*
     &   zaa_2_pH_pH12_5*zab_2_pH_1*zab_3_pH2_1)
     &   + qsq**2 * zab_5_pH3_4**4/(sH3*s125*za(j1,j2)*za(j1,j5)*
     &   zaa_3_pH_12_5*zab_2_pH3_4*zab_3_pH_4)
     &   -qsq**2 * zb(j4,j1)**4/(s145*za(j2,j3)*zab_2_pH3_4*
     &   zab_3_pH2_1*zb(j5,j1)*zb(j5,j4))

      return
      end


#INCLUDE 'MR_H_ALIGN_PADDING.H'
!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_GEN_INI_ZB

    USE MR_ERRORS_NONLINEAR_EQN_SOLVE

    USE MR_KINDS

    USE MR_MAC_PI

    USE MR_DEF_RANKS
    USE MR_DEF_CONSTS_N_REF_PARS
    USE MR_DEF_CURVED_GEOS

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_GEN_INI_ZB

    REAL   (GJRD_KIND) , ALLOCATABLE , DIMENSION(:) :: DAREA
    REAL   (GJRD_KIND) , ALLOCATABLE , DIMENSION(:) :: WTH , RTH
    REAL   (GJRD_KIND) , ALLOCATABLE , DIMENSION(:) :: RTH_BK_L , RTH_BK_R

    REAL   (PARD_KIND) , ALLOCATABLE , DIMENSION(:) :: DZB_BK_L , DZB_BK_R

    REAL   (CARD_KIND) , ALLOCATABLE , DIMENSION(:) :: ALFA_LBOUND , ALFA_RBOUND

    REAL   (CARD_KIND) , ALLOCATABLE , DIMENSION(:) :: ALFA , BETA , GAMA

!***********************************************************************************************************************************

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_INIT_WTH_N_RTH

    IMPLICIT NONE

    INTEGER(IJID_KIND) :: I , J

    ALLOCATE( DAREA(1:NI1(NI,GJRD_KIND)) )

      DAREA = 0
      DO J = 1 , NJ
        !DIR$ VECTOR ALIGNED
        DO I = 1 , NI
          DAREA( I ) = DAREA( I ) + MW( I , J )
        END DO
      END DO

      !DIR$ VECTOR ALIGNED
      DO I = 1 , NI
        WTH( I ) = 2.0 * DAREA( I )   &
        / ( SQRT( GVV( I , 0 ,1,1) ) + SQRT( GVV( I ,NJ ,1,1) ) )
      END DO

    DEALLOCATE( DAREA )

   !DIR$ VECTOR ALIGNED
    DO I = 1 , NI

      RTH( I ) =   &
      ( ( SIGN( ACOS( JOO(I-1, 0 ,1,1) / SQRT(GOO(I-1, 0 ,1,1)) ) , JOO(I-1, 0 ,2,1) )   &
        + SIGN( ACOS( JOO(I-1,NJ ,1,1) / SQRT(GOO(I-1,NJ ,1,1)) ) , JOO(I-1,NJ ,2,1) )   &
        )   &
      - ( SIGN( ACOS( JOO( I , 0 ,1,1) / SQRT(GOO( I , 0 ,1,1)) ) , JOO( I , 0 ,2,1) )   &
        + SIGN( ACOS( JOO( I ,NJ ,1,1) / SQRT(GOO( I ,NJ ,1,1)) ) , JOO( I ,NJ ,2,1) )   &
        )   &
      ) / ( SQRT( GVV( I , 0 ,1,1) ) + SQRT( GVV( I ,NJ ,1,1) ) )

      RTH( I ) = 1.0 / SIGN( MAX( ABS(RTH( I )) , 10.0*EPSILON(RTH( I )) ) , RTH( I ) )

      RTH_BK_L( I ) = RTH( I ) + 0.5 * WTH( I )
      RTH_BK_R( I ) = RTH( I ) - 0.5 * WTH( I )

    END DO

  END SUBROUTINE MR_INIT_WTH_N_RTH

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_GEN_INI_ZB( HTH , DZB_BK_MIN , DZB_BK_MAX , XI0 , XXIM , NBENDS , NI , NJ , ZB , ERROR , ERRMSG )

    IMPLICIT NONE

    REAL   (PARD_KIND) , INTENT(IN ) :: HTH
    REAL   (PARD_KIND) , INTENT(IN ) :: DZB_BK_MIN , DZB_BK_MAX
    REAL   (PARD_KIND) , INTENT(IN ) :: XI0 , XXIM

    INTEGER            , INTENT(IN ) :: NBENDS

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ

    REAL   (FDRD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ) :: ZB

    INTEGER            , INTENT(OUT) :: ERROR
    CHARACTER(   *   ) , INTENT(OUT) :: ERRMSG

    REAL   (PARD_KIND) :: COEFFI_XXIM
    REAL   (PARD_KIND) :: COEFFI_DZB_BK_MIN_N_MAX_1 , COEFFI_DZB_BK_MIN_N_MAX_2

    REAL   (PARD_KIND) :: DYJ

    INTEGER(IJID_KIND) :: I , J

    COEFFI_XXIM = ( 0.25 - XXIM ) / ( 1.0 + SIN( 2.0 * PI * XXIM ) )

    COEFFI_DZB_BK_MIN_N_MAX_1 = 0.25 * ( DZB_BK_MAX + DZB_BK_MIN )
    COEFFI_DZB_BK_MIN_N_MAX_2 = 0.50 * ( DZB_BK_MAX - DZB_BK_MIN )

    IF( (.NOT. ALLOCATED(DZB_BK_L) ) .AND. (.NOT. ALLOCATED(DZB_BK_R) ) ) THEN
      ALLOCATE( DZB_BK_L(1:NI1(NI,PARD_KIND)) , DZB_BK_R(1:NI1(NI,PARD_KIND)) )
      CALL MR_GEN_INI_DZB_BK( XI0 , COEFFI_XXIM , COEFFI_DZB_BK_MIN_N_MAX_1 , COEFFI_DZB_BK_MIN_N_MAX_2 ,   &
      & NBENDS , NI , DZB_BK_L , DZB_BK_R , ERROR , ERRMSG )
      IF( ERROR < 0 ) THEN
        DEALLOCATE( DZB_BK_L , DZB_BK_R )
        RETURN
      END IF
    END IF

      IF( (.NOT. ALLOCATED(WTH) ) .AND. (.NOT. ALLOCATED(RTH) )   &
      &  .AND. (.NOT. ALLOCATED(RTH_BK_L) ) .AND. (.NOT. ALLOCATED(RTH_BK_R) ) ) THEN
        ALLOCATE( WTH(1:NI1(NI,GJRD_KIND)) , RTH(1:NI1(NI,GJRD_KIND)) ,   &
        & RTH_BK_L(1:NI1(NI,GJRD_KIND)) , RTH_BK_R(1:NI1(NI,GJRD_KIND)) )
        CALL MR_INIT_WTH_N_RTH
      END IF

        ALLOCATE( ALFA(1:NI1(NI,CARD_KIND)) , BETA(1:NI1(NI,CARD_KIND)) , GAMA(1:NI1(NI,CARD_KIND)) )

          IF( (.NOT. ALLOCATED(ALFA_LBOUND) ) .AND. (.NOT. ALLOCATED(ALFA_RBOUND) ) ) THEN
            ALLOCATE( ALFA_LBOUND(1:NI1(NI,CARD_KIND)) , ALFA_RBOUND(1:NI1(NI,CARD_KIND)) )
            ALFA_LBOUND = -8.001 ; ALFA_RBOUND = +10.001
          END IF

            CALL MR_GEN_INI_DZB_PROFILE_COEFFIS( NI , DZB_BK_L , DZB_BK_R , RTH_BK_L , RTH_BK_R , RTH , WTH ,   &
            & ALFA_LBOUND , ALFA_RBOUND , ALFA , BETA , GAMA , ERROR , ERRMSG )
            IF( ERROR < 0 ) THEN
              DEALLOCATE( ALFA , BETA , GAMA )
              RETURN
            END IF

            DYJ = 1.0_PARD_KIND / NJ

            DO J = 1 , NJ
             !DIR$ VECTOR ALIGNED
              DO I = 1 , NI
                ZB( I , J ) = ( GAMA( I ) - BETA( I ) * EXP( -ALFA( I ) * ( 1.0 - (J-0.5)*DYJ ) ) ) - HTH
              END DO
            END DO

          DEALLOCATE( ALFA_LBOUND , ALFA_RBOUND )

        DEALLOCATE( ALFA , BETA , GAMA )

      DEALLOCATE( WTH , RTH , RTH_BK_L , RTH_BK_R )

    DEALLOCATE( DZB_BK_L , DZB_BK_R )

  END SUBROUTINE MR_GEN_INI_ZB

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_GEN_INI_DZB_BK( XI0 , COEFFI_XXIM , COEFFI_DZB_BK_MIN_N_MAX_1 , COEFFI_DZB_BK_MIN_N_MAX_2 ,   &
  & NBENDS , NI , DZB_BK_L , DZB_BK_R , ERROR , ERRMSG )

    IMPLICIT NONE

    REAL   (PARD_KIND) , INTENT(IN ) :: XI0
    REAL   (PARD_KIND) , INTENT(IN ) :: COEFFI_XXIM
    REAL   (PARD_KIND) , INTENT(IN ) :: COEFFI_DZB_BK_MIN_N_MAX_1 , COEFFI_DZB_BK_MIN_N_MAX_2

    INTEGER            , INTENT(IN ) :: NBENDS

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI

    REAL   (PARD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,PARD_KIND)) :: DZB_BK_L , DZB_BK_R

    INTEGER            , INTENT(OUT) :: ERROR
    CHARACTER(   *   ) , INTENT(OUT) :: ERRMSG

    REAL   (PARD_KIND) , DIMENSION(1:NI1(NI,PARD_KIND)) :: XXI , XXXI

    REAL   (PARD_KIND) :: DUMMY_DZB_BK_1 , DUMMY_DZB_BK_2

    REAL   (PARD_KIND) :: DXI

    CHARACTER( 2**03 ) :: I_CHAR
    INTEGER(IJID_KIND) :: I

    DXI = 0.5_PARD_KIND * NBENDS / NI

   !DIR$ VECTOR ALIGNED
    DO I = 1 , NI
      XXI( I ) = (I-0.5)*DXI - XI0
    END DO

   !DIR$ NOVECTOR
    DO I = 1 , NI
      CALL MR_NEWTON_SOLVE_FEQ_XXXI( COEFFI_XXIM , XXI( I ) , XXXI( I ) , XXI( I ) , ERROR , ERRMSG )
      IF( ERROR < 0 ) THEN
        WRITE( I_CHAR , '(I<LEN(I_CHAR)>)' ) I
        ERRMSG = TRIM(ERRMSG)//" for cross section no. "//TRIM(ADJUSTL(I_CHAR))
        RETURN
      END IF
    END DO

   !DIR$ VECTOR ALIGNED
    DO I = 1 , NI

      DUMMY_DZB_BK_1 = COEFFI_DZB_BK_MIN_N_MAX_1 - COEFFI_DZB_BK_MIN_N_MAX_1 * COS( 4.0 * PI * XXXI( I ) )
      DUMMY_DZB_BK_2 = COEFFI_DZB_BK_MIN_N_MAX_2 * SIN( 2.0 * PI * XXXI( I ) )

      DZB_BK_L( I ) = DUMMY_DZB_BK_1 - DUMMY_DZB_BK_2
      DZB_BK_R( I ) = DUMMY_DZB_BK_1 + DUMMY_DZB_BK_2

    END DO

  END SUBROUTINE MR_GEN_INI_DZB_BK

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_NEWTON_SOLVE_FEQ_XXXI( COEFFI_XXIM , XXI , XXXI , XXXI_NEAR , ERROR , ERRMSG )

    IMPLICIT NONE

    REAL   (PARD_KIND) , INTENT(IN ) :: COEFFI_XXIM

    REAL   (PARD_KIND) , INTENT(IN ) :: XXI

    REAL   (PARD_KIND) , INTENT(OUT) :: XXXI

    REAL   (PARD_KIND) , INTENT(IN ) :: XXXI_NEAR

    REAL   (PARD_KIND) , PARAMETER   :: EPS_XXXI = 10.0*EPSILON(EPS_XXXI)
    REAL   (CARD_KIND) , PARAMETER   :: EPS_FEQ_XXXI = 10.0*EPSILON(EPS_FEQ_XXXI)
    REAL   (CARD_KIND) , PARAMETER   :: EPS_FFEQ_XXXI = 10.0*EPSILON(EPS_FFEQ_XXXI)

    INTEGER            , PARAMETER   :: N_ITERS = 10000

    INTEGER            , INTENT(OUT) :: ERROR
    CHARACTER(   *   ) , INTENT(OUT) :: ERRMSG

    REAL   (PARD_KIND) :: XXXI0 , XXXI1
    REAL   (CARD_KIND) :: FEQ_XXXI0 , FEQ_XXXI1
    REAL   (CARD_KIND) :: FFEQ_XXXI0

    INTEGER            :: I_ITER

    ERRMSG = ""

    XXXI0 = XXXI_NEAR
    FEQ_XXXI0 = MR_FUNC_FEQ_XXXI( COEFFI_XXIM , XXI , XXXI0 )

    DO I_ITER = 1 , N_ITERS

      FFEQ_XXXI0 = MR_FUNC_FFEQ_XXXI( COEFFI_XXIM , XXI , XXXI0 )
      IF( FFEQ_XXXI0 <= EPS_FFEQ_XXXI ) THEN
        XXXI = HUGE(XXXI)
        ERROR = ERROR_NEWTON_SOLVE_ZERO_DERIVATIVE
        ERRMSG = "Zero deivative when using newton method to solve xxxi"
        RETURN
      END IF

      XXXI1 = XXXI0 - FEQ_XXXI0 / FFEQ_XXXI0

      FEQ_XXXI1 = MR_FUNC_FEQ_XXXI( COEFFI_XXIM , XXI , XXXI1 )
      IF( ABS( XXXI1 - XXXI0 ) <= EPS_XXXI .OR. ABS( FEQ_XXXI1 ) <= EPS_FEQ_XXXI ) THEN
        XXXI = XXXI1
        ERROR = 0
        RETURN
      ELSE
        XXXI0 = XXXI1
        FEQ_XXXI0 = FEQ_XXXI1
      END IF

    END DO

    XXXI = HUGE(XXXI)
    ERROR = ERROR_NEWTON_SOLVE_MAX_NUMBER_OF_ITERATION
    ERRMSG = "Max number of iterations when using newton method to solve xxxi"

  END SUBROUTINE MR_NEWTON_SOLVE_FEQ_XXXI

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_FUNC_FEQ_XXXI( COEFFI_XXIM , XXI , XXXI ) RESULT( FEQ_XXXI )

   !DIR$ ATTRIBUTES VECTOR : UNIFORM( COEFFI_XXIM ) :: MR_FUNC_FEQ_XXXI

    IMPLICIT NONE

    REAL   (PARD_KIND) , INTENT(IN ) :: COEFFI_XXIM

    REAL   (PARD_KIND) , INTENT(IN ) :: XXI
    REAL   (PARD_KIND) , INTENT(IN ) :: XXXI

    REAL   (CARD_KIND) :: FEQ_XXXI

    FEQ_XXXI = (XXXI-XXI) - COEFFI_XXIM * ( 1.0 - COS( 2.0 * PI * (XXXI+XXI) ) )

  END FUNCTION MR_FUNC_FEQ_XXXI

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_FUNC_FFEQ_XXXI( COEFFI_XXIM , XXI , XXXI ) RESULT( FFEQ_XXXI )

   !DIR$ ATTRIBUTES VECTOR : UNIFORM( COEFFI_XXIM ) :: MR_FUNC_FFEQ_XXXI

    IMPLICIT NONE

    REAL   (PARD_KIND) , INTENT(IN ) :: COEFFI_XXIM

    REAL   (PARD_KIND) , INTENT(IN ) :: XXI
    REAL   (PARD_KIND) , INTENT(IN ) :: XXXI

    REAL   (CARD_KIND) :: FFEQ_XXXI

    FFEQ_XXXI = 1.0 - 2.0 * PI * COEFFI_XXIM * SIN( 2.0 * PI * (XXXI+XXI) )

  END FUNCTION MR_FUNC_FFEQ_XXXI

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_GEN_INI_DZB_PROFILE_COEFFIS( NI , DZB_BK_L , DZB_BK_R , RTH_BK_L , RTH_BK_R , RTH , WTH ,   &
  & ALFA_LBOUND , ALFA_RBOUND , ALFA , BETA , GAMA , ERROR , ERRMSG )

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI

    REAL   (PARD_KIND) , INTENT(IN ) , DIMENSION(1:NI1(NI,PARD_KIND)) :: DZB_BK_L , DZB_BK_R
    REAL   (GJRD_KIND) , INTENT(IN ) , DIMENSION(1:NI1(NI,GJRD_KIND)) :: RTH_BK_L , RTH_BK_R , RTH , WTH

    REAL   (CARD_KIND) , INTENT(IN ) , DIMENSION(1:NI1(NI,CARD_KIND)) :: ALFA_LBOUND , ALFA_RBOUND

    REAL   (CARD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,CARD_KIND)) :: ALFA , BETA , GAMA

    INTEGER            , INTENT(OUT) :: ERROR
    CHARACTER(   *   ) , INTENT(OUT) :: ERRMSG

    CHARACTER( 2**03 ) :: I_CHAR
    INTEGER(IJID_KIND) :: I

   !DIR$ NOVECTOR
    DO I = 1 , NI
      CALL MR_BISECT_SOLVE_FEQ_ALFA( DZB_BK_L( I ) , DZB_BK_R( I ) , RTH_BK_L( I ) , RTH_BK_R( I ) , RTH( I ) , WTH( I ) ,   &
      & ALFA( I ) , ALFA_LBOUND( I ) , ALFA_RBOUND( I ) , ERROR , ERRMSG )
      IF( ERROR < 0 ) THEN
        WRITE( I_CHAR , '(I<LEN(I_CHAR)>)' ) I
        ERRMSG = TRIM(ERRMSG)//" for cross section no. "//TRIM(ADJUSTL(I_CHAR))
        RETURN
      END IF
    END DO

   !DIR$ VECTOR ALIGNED
    DO I = 1 , NI
      CALL MR_CALC_BETA_N_GAMA( DZB_BK_L( I ) , DZB_BK_R( I ) , ALFA( I ) , BETA( I ) , GAMA( I ) )
    END DO

  END SUBROUTINE MR_GEN_INI_DZB_PROFILE_COEFFIS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_BISECT_SOLVE_FEQ_ALFA( DZB_BK_L , DZB_BK_R , RTH_BK_L , RTH_BK_R , RTH , WTH ,   &
  & ALFA , ALFA_LBOUND , ALFA_RBOUND , ERROR , ERRMSG )

    IMPLICIT NONE

    REAL   (PARD_KIND) , INTENT(IN ) :: DZB_BK_L , DZB_BK_R
    REAL   (GJRD_KIND) , INTENT(IN ) :: RTH_BK_L , RTH_BK_R , RTH , WTH

    REAL   (CARD_KIND) , INTENT(OUT) :: ALFA

    REAL   (CARD_KIND) , INTENT(IN ) :: ALFA_LBOUND , ALFA_RBOUND

    REAL   (CARD_KIND) , PARAMETER   :: EPS_ALFA = 10.0*EPSILON(EPS_ALFA)
    REAL   (CARD_KIND) , PARAMETER   :: EPS_FEQ_ALFA = 10.0*EPSILON(EPS_FEQ_ALFA)

    INTEGER            , INTENT(OUT) :: ERROR
    CHARACTER(   *   ) , INTENT(OUT) :: ERRMSG

    REAL   (CARD_KIND) :: ALFA_LAPPRX , ALFA_RAPPRX , ALFA_MIDDLE
    REAL   (CARD_KIND) :: FEQ_ALFA_LAPPRX , FEQ_ALFA_RAPPRX , FEQ_ALFA_MIDDLE

    ERRMSG = ""

    ALFA_LAPPRX = ALFA_LBOUND
    FEQ_ALFA_LAPPRX = MR_FUNC_FEQ_ALFA( DZB_BK_L , DZB_BK_R , RTH_BK_L , RTH_BK_R , RTH , WTH , ALFA_LAPPRX )
    IF( ABS( FEQ_ALFA_LAPPRX ) <= EPS_FEQ_ALFA ) THEN
      ALFA = ALFA_LAPPRX
      ERROR = 0
      RETURN
    END IF
    ALFA_RAPPRX = ALFA_RBOUND
    FEQ_ALFA_RAPPRX = MR_FUNC_FEQ_ALFA( DZB_BK_L , DZB_BK_R , RTH_BK_L , RTH_BK_R , RTH , WTH , ALFA_RAPPRX )
    IF( ABS( FEQ_ALFA_RAPPRX ) <= EPS_FEQ_ALFA ) THEN
      ALFA = ALFA_RAPPRX
      ERROR = 0
      RETURN
    END IF

    IF( FEQ_ALFA_LAPPRX * FEQ_ALFA_RAPPRX > 0 ) THEN
      ALFA = HUGE(ALFA)
      ERROR = ERROR_BISECT_SOLVE_NO_UNIQUE_ROOT_IN_REGION
      ERRMSG = "No unique root in given region when using bisection method to solve alpha"
      RETURN
    END IF

    DO WHILE( 0.5 * ABS( ALFA_RAPPRX - ALFA_LAPPRX ) > EPS_ALFA )

      ALFA_MIDDLE = 0.5 * ( ALFA_LAPPRX + ALFA_RAPPRX )
      FEQ_ALFA_MIDDLE = MR_FUNC_FEQ_ALFA( DZB_BK_L , DZB_BK_R , RTH_BK_L , RTH_BK_R , RTH , WTH , ALFA_MIDDLE )

      IF( ABS( FEQ_ALFA_MIDDLE ) <= EPS_FEQ_ALFA ) THEN
        EXIT
      ELSE IF( FEQ_ALFA_LAPPRX * FEQ_ALFA_MIDDLE < 0 ) THEN
        ALFA_RAPPRX = ALFA_MIDDLE
        FEQ_ALFA_RAPPRX = FEQ_ALFA_MIDDLE
      ELSE
        ALFA_LAPPRX = ALFA_MIDDLE
        FEQ_ALFA_LAPPRX = FEQ_ALFA_MIDDLE
      END IF

    END DO

    ALFA = 0.5 * ( ALFA_LAPPRX + ALFA_RAPPRX )
    ERROR = 0

  END SUBROUTINE MR_BISECT_SOLVE_FEQ_ALFA

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_FUNC_FEQ_ALFA( DZB_BK_L , DZB_BK_R , RTH_BK_L , RTH_BK_R , RTH , WTH , ALFA ) RESULT( FEQ_ALFA )

   !DIR$ ATTRIBUTES VECTOR :: MR_FUNC_FEQ_ALFA

    IMPLICIT NONE

    REAL   (PARD_KIND) , INTENT(IN ) :: DZB_BK_L , DZB_BK_R
    REAL   (GJRD_KIND) , INTENT(IN ) :: RTH_BK_L , RTH_BK_R , RTH , WTH

    REAL   (CARD_KIND) , INTENT(IN ) :: ALFA

    REAL   (CARD_KIND) :: BETA , GAMA

    REAL   (CARD_KIND) :: FEQ_ALFA

    CALL MR_CALC_BETA_N_GAMA( DZB_BK_L , DZB_BK_R , ALFA , BETA , GAMA )

    FEQ_ALFA =   &
    & BETA * ( EXP(-ALFA) * ( ALFA * ( RTH_BK_R / WTH ) - 1.0 ) - ALFA * ( RTH_BK_L / WTH ) + 1.0 ) +   &
    & GAMA * ALFA * ALFA * ( RTH / WTH )

  END FUNCTION MR_FUNC_FEQ_ALFA

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_CALC_BETA_N_GAMA( DZB_BK_L , DZB_BK_R , ALFA , BETA , GAMA )

   !DIR$ ATTRIBUTES VECTOR :: MR_CALC_BETA_N_GAMA

    IMPLICIT NONE

    REAL   (PARD_KIND) , INTENT(IN ) :: DZB_BK_L , DZB_BK_R

    REAL   (CARD_KIND) , INTENT(IN ) :: ALFA

    REAL   (CARD_KIND) , INTENT(OUT) :: BETA , GAMA

    BETA = ( DZB_BK_L - DZB_BK_R ) / ( EXP(-ALFA) - 1.0 )
    GAMA =   DZB_BK_L + BETA

  END SUBROUTINE MR_CALC_BETA_N_GAMA

  END MODULE MR_MOD_GEN_INI_ZB


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

MODULE m_qpwtonmt
  !***************************************************************
  !     This subroutine calculates the lattice harmonic expansions
  !     for the plane wave density inside the spheres.
  !
  !             Stefan Bl"ugel  , IFF, Nov. 1997
  !***************************************************************
CONTAINS
  SUBROUTINE qpw_to_nmt(sphhar,atoms,stars,sym,cell,oneD,fmpi,jspin,l_cutoff,qpwc,rho)
    !
    USE m_constants
    USE m_phasy1
    USE m_sphbes
    USE m_types
    USE m_od_phasy

    IMPLICIT NONE
    !     ..
    !     .. Scalar Arguments ..
    TYPE(t_sphhar),INTENT(IN)   :: sphhar
    TYPE(t_atoms),INTENT(IN)    :: atoms
    TYPE(t_stars),INTENT(IN)    :: stars
    TYPE(t_cell),INTENT(IN)     :: cell
    TYPE(t_sym),INTENT(IN)      :: sym
    TYPE(t_oneD),INTENT(IN)     :: oneD
    TYPE(t_mpi),INTENT(IN)     :: fmpi

    INTEGER, INTENT (IN) :: jspin,l_cutoff
    !     ..
    !     .. Array Arguments ..
    COMPLEX, INTENT (IN) :: qpwc(stars%ng3)
    REAL,    INTENT (INOUT) :: rho(:,0:,:,:) !(atoms%jmtd,0:sphhar%nlhd,atoms%ntype,input%jspins)
    !-odim
    !+odim
    !     ..
    !     .. Local Scalars ..
    REAL,    PARAMETER :: zero = 0.0
    COMPLEX, PARAMETER :: czero = (0.0,0.0)
    INTEGER in,j,jl,j0,jm,k,l,lh,m,n,nd,nrm,n1,n2,na,lm
    REAL    d0,gr,r0,rr
    COMPLEX cp,sm,cprr2
    !     ..
    !     .. Local Arrays ..
    COMPLEX pylm( (atoms%lmaxd+1)**2,atoms%ntype ) !,bsl_c(atoms%jmtd,0:lmaxd)
    REAL    bsl(0:atoms%lmaxd),bsl_r(atoms%jmtd,0:atoms%lmaxd),bsl_i(atoms%jmtd,0:atoms%lmaxd)
    INTEGER mr(atoms%ntype),lmx(atoms%ntype),lmxx(atoms%ntype),ntypsy_o(atoms%ntype)
    !     ..
    !$      REAL,ALLOCATABLE        :: rho_tmp(:,:,:)

    !----> cut-off l-expansion of non-spherical charge contribution
    !      from coretails of neighboring atom for l> l_cutoff
    !
    na = 1
    DO n = 1,atoms%ntype
       lmx(n) = MIN( atoms%lmax(n) , l_cutoff )
       ntypsy_o(n) = sym%ntypsy(na)
       na = na + atoms%neq(n)
    END DO
    !
    !----> identify atoms with the same radial mesh
    !
    j0 = 0
    r0 = zero
    d0 = zero
    nrm= 0
    DO n = 1 , atoms%ntype
       IF (.NOT.(atoms%jri(n).EQ.j0 .AND. atoms%rmsh(1,n).EQ.r0 &
            &                          .AND. atoms%dx(n).EQ.d0)) THEN
          j0 = atoms%jri(n)
          r0 = atoms%rmsh(1,n)
          d0 = atoms%dx(n)
          nrm= nrm + 1
          lmxx(nrm) = lmx(n)
       END IF
       mr(nrm)=n
       lmxx(nrm) = MAX( lmx(n) , lmx(nrm) )
    END DO
    !
    !=====> Loop over the g-vectors
    !
    ! ----> g=0 component
    CALL timestart("qpw_to_nmt")
    IF (fmpi%irank == 0) THEN
       cp = qpwc(1)*stars%nstr(1)
       DO  n = 1 , atoms%ntype
          DO j = 1,atoms%jri(n)
             rr = atoms%rmsh(j,n)*atoms%rmsh(j,n)
             rho(j,0,n,jspin) = rho(j,0,n,jspin) + rr*sfp_const*cp
          ENDDO
       ENDDO
    ELSE
       rho(:,:,:,jspin) = 0.0
    ENDIF

    ! ----> g.ne.0 components
    !
    !     g=|=0 terms : \sum_{g =|= 0} 4 \pi i^l \rho_int(g) r_i^{2} \times
    !                    j_{l} (gr_i) \exp{ig\xi_i} Y^*_{lm} (g)
    !
    ! ---->     calculate structure constant for each atom
    !     (4pi*i**l/nop(3)*sum(R){exp(iRG(taual-taur)*conjg(ylm(RG))
    !
    !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(k,cp,pylm,n1,in,n2,j)      &
    !$OMP  PRIVATE(cprr2,gr,bsl,jl,bsl_r,bsl_i,n,nd,lh,l,sm,jm,m,lm)  &
    !$OMP  PRIVATE(rho_tmp)

    !$    ALLOCATE(rho_tmp(size(rho,1),0:size(rho,2)-1,size(rho,3)))
    !$    rho_tmp=0
    !$OMP DO
    DO k = fmpi%irank+2,stars%ng3,fmpi%isize
       cp = qpwc(k)*stars%nstr(k)
       IF (.NOT.oneD%odi%d1) THEN
          CALL phasy1(atoms,stars,sym,cell,k,pylm)
       ELSE
          !-odim
          CALL od_phasy(atoms%ntype,stars%ng3,atoms%nat,atoms%lmaxd,atoms%ntype,atoms%neq,atoms%lmax,&
               atoms%taual,cell%bmat,stars%kv3,k,oneD%odi,oneD%ods,pylm) !keep
          !+odim
       END IF
       !
       n1 = 1
       DO in = 1 , nrm
          n2 = mr(in)
          bsl_r = 0.0
          bsl_i = 0.0
          DO j = 1,atoms%jri(n1)
             cprr2 = cp*atoms%rmsh(j,n1)*atoms%rmsh(j,n1)
             gr = stars%sk3(k)*atoms%rmsh(j,n1)
             CALL sphbes(lmxx(in),gr,bsl)
             DO jl=0,lmxx(in)
                bsl_r(j,jl) = bsl(jl) *  REAL(cprr2)
                bsl_i(j,jl) = bsl(jl) * AIMAG(cprr2)
             END DO
          END DO
          DO n = n1,n2
             nd = ntypsy_o(n)
             DO lh = 0,sphhar%nlh(nd)
                l = sphhar%llh(lh,nd)
                IF ( l.LE.lmx(n) ) THEN
                   sm = czero
                   DO jm = 1,sphhar%nmem(lh,nd)
                      m  = sphhar%mlh(jm,lh,nd)
                      lm = l*(l+1) + m + 1
                      sm = sm + CONJG(sphhar%clnu(jm,lh,nd)) *pylm(lm,n)
                   END DO
                   !$                if (.false.) THEN
                   rho(:,lh,n,jspin) = rho(:,lh,n,jspin) + bsl_r(:,l) *  REAL(sm)
                   rho(:,lh,n,jspin) = rho(:,lh,n,jspin) - bsl_i(:,l) * AIMAG(sm)
                   !$                 endif
                   !$            rho_tmp(:,lh,n)=rho_tmp(:,lh,n)+bsl_r(:,l)*real(sm)
                   !$            rho_tmp(:,lh,n)=rho_tmp(:,lh,n)-bsl_i(:,l)*aimag(sm)
                END IF
             END DO
          END DO
          n1 = n2 + 1
       ENDDO
    ENDDO
    !$OMP END DO
    !$OMP CRITICAL
    !$          rho(:,:,:,jspin)=rho(:,:,:,jspin)+rho_tmp
    !$OMP END CRITICAL
    !$      DEALLOCATE(rho_tmp)
    !$OMP END PARALLEL
    !
    CALL timestop("qpw_to_nmt")
    !
  END SUBROUTINE qpw_to_nmt
END MODULE m_qpwtonmt