module modPressure

    use modValues
    implicit none

    contains

    !========= Pressure Equations ============
    subroutine getPressure(solMethod)
        implicit none

        character(len=*) :: solMethod

        if( trim(solMethod) == 'explicit' ) then
         !   CALL getP_explicit
            stop
        elseif( trim(solMethod) == 'implicit' ) then
            CALL getP_implicit
        endif

    endsubroutine

    !========================================================
    subroutine getP_implicit
        use modFaceValues
        implicit none

        real(8) :: save_dummy(ncell)
        real(8) :: fL_cdp,fR_cdp,fL_drdp,fR_drdp,Rgas,lfs,rfs
        real(8) :: lPFlux,rPFlux,rRhoflux,lRhoflux

        CALL getFaceValues(&
            FaceMethodU=chFluxU &
            )

        do i=nCellStr,nCellEnd
            lFace = i-1; rFace = i

            dPN = dx

            !Rgas = eosCp*(1.d0-1.d0/eosGamma)

            !> @todo : 1/R/T => drdp
            lFs = fU(lFace)*( fgP(lFace)*cDRDP(i-1) &
                             +fgN(lFace)*cDRDP(i) )
            rFs = fU(rFace)*( fgP(rFace)*cDRDP(i) &
                             +fgN(rFace)*cDRDP(i+1) )

            AmatPres(i,i) = cDRDP(i)/timestep
            AmatPres(i,i) = AmatPres(i,i) &
                + 1.d0/cVol(i)*( rFs*(fgP(rFace))*area(rFace) &
                               - lFs*(fgN(lFace))*area(lFace) )&
                - 1.d0/cVol(i)*( (-1.d0)*area(rFace) &
                               - (+1.d0)*area(lFace) ) &
                              /dPN*timestep
            if( i /= nCellStr ) then
                AmatPres(i,i-1) =  &
                    + 1.d0/cVol(i)*( -lFs*(fgP(lFace))*area(lFace) )&
                    - 1.d0/cVol(i)*( -(-1.d0)*area(lFace) ) &
                                  /dPN*timestep
            endif
            if( i /= nCellEnd ) then
                AmatPres(i,i+1) =  &
                    + 1.d0/cVol(i)*( +rFs*(fgN(rFace))*area(rFace) )&
                    - 1.d0/cVol(i)*( +(+1.d0)*area(rFace) ) &
                                  /dPN*timestep
            endif

            BmatPres(i) = &
                - ( cRho(i) - oldCons(i,1) )/timestep &
                +1.d0/cVol(i)*( fMdot(lFace) - fMdot(rFace) )

        enddo

        !> Update Pressure
        CALL matInverse(AmatPres,nCellEnd)

        cDP(nCellStr:nCellEnd) = &
            underRelaxFactP &
            *matmul(AmatPres(nCellStr:nCellEnd,nCellStr:nCellEnd),&
                    BmatPres(nCellStr:nCellEnd))
        cP(nCellStr:nCellEnd) = cP(nCellStr:nCellEnd) + cDP(nCellStr:nCellEnd)

    endsubroutine

    !!========================================================
    !subroutine getP_Xisto
    !    implicit none
    !
    !    real(8) :: save_dummy(ncell)
    !    real(8) :: fL_cdp,fR_cdp,fL_drdp,fR_drdp,Rgas,lfs,rfs
    !    real(8) :: lPFlux,rPFlux
    !
    !    !> Variables initialization AUSM+
    !    do i=nFaceStr,nFaceEnd
    !        lCell = i; rCell = i+1
    !        wL(:) = (/cRho(lCell),cU(lCell),cP(lCell)/)
    !        wR(:) = (/cRho(rCell),cU(rCell),cP(rCell)/)
    !        CALL calfaceValAUSM(wL,wR,eosGamma, fMdot(i),fU(i),fP(i))
    !        fMdot(i) = fMdot(i)*area(i)
    !        fgP(i) = 0.5d0*(1.d0+dsign(1.d0,fU(i)))
    !        fgN(i) = 0.5d0*(1.d0-dsign(1.d0,fU(i)))
    !        fUx(i) = fgP(i)*cU(lCell)  + fgN(i)*cU(rCell)
    !        fcoeffMom1(i) = fgP(i)*coeffMom1(lCell) + fgN(i)*coeffMom1(rCell)
    !        fcoeffMom2(i) = fgP(i)*coeffMom2(lCell) + fgN(i)*coeffMom2(rCell)
    !        fRho(i) = fgP(i)*cRho(lCell) + fgN(i)*cRho(rCell)
    !        fDrDp(i) = fgP(i)*cDrDp(lCell) + fgN(i)*cDrDp(rCell)
    !    enddo
    !
    !    AmatPres = 0.d0
    !    do i=nCellStr,nCellEnd
    !        lFace = i-1; rFace = i
    !
    !        dPN = dx
    !
    !        Rgas = eosCp*(1.d0-1.d0/eosGamma)
    !
    !        !> @todo : 1/R/T => drdp
    !        lFs = fU(lFace)*( fgP(lFace)*(1.d0/Rgas/oldcT(i-1)) &
    !                         +fgN(lFace)*(1.d0/Rgas/oldcT(i)) )
    !        rFs = fU(rFace)*( fgP(rFace)*(1.d0/Rgas/oldcT(i)) &
    !                         +fgN(rFace)*(1.d0/Rgas/oldcT(i+1)) )
    !
    !        AmatPres(i,i) = (1.d0/Rgas/oldcT(i))/timestep
    !        AmatPres(i,i) = AmatPres(i,i) &
    !            + 1.d0/cVol(i)*( rFs*(fgP(rFace))*area(rFace) &
    !                           - lFs*(fgN(lFace))*area(lFace) )&
    !            - 1.d0/cVol(i)*( (-1.d0)*area(rFace) &
    !                           - (+1.d0)*area(lFace) ) &
    !                          /dPN*timestep
    !        if( i /= nCellStr ) then
    !        AmatPres(i,i-1) =  &
    !            + 1.d0/cVol(i)*( -lFs*(fgP(lFace))*area(lFace) )&
    !            - 1.d0/cVol(i)*( -(-1.d0)*area(lFace) ) &
    !                          /dPN*timestep
    !        endif
    !        if( i /= nCellEnd ) then
    !        AmatPres(i,i+1) =  &
    !            + 1.d0/cVol(i)*( +rFs*(fgN(rFace))*area(rFace) )&
    !            - 1.d0/cVol(i)*( +(+1.d0)*area(rFace) ) &
    !                          /dPN*timestep
    !        endif
    !
    !        rPFlux = fgP(rFace)*oldcP(i) + fgN(rFace)*oldcP(i+1)
    !        lPFlux = fgP(lFace)*oldcP(i-1) + fgN(lFace)*oldcP(i)
    !        !BmatPres(i) = oldcRho(i)/timestep
    !        BmatPres(i) = 1.d0/cVol(i)*( lFs*lPFlux*area(lFace) &
    !                                    -rFs*rPFlux*area(rFace) ) &
    !                     -1.d0/cVol(i)*( (oldcP(i)-oldcP(i-1))*area(lFace) &
    !                                    -(oldcP(i+1)-oldcP(i))*area(rFace) )/dPN*timestep
    !
    !    enddo
    !
    !    !> Update Pressure
    !    CALL matInverse(AmatPres,nCellEnd)
    !    save_dummy(nCellStr:nCellEnd) = cP(nCellStr:nCellEnd)
    !    !cP(nCellStr:nCellEnd) = &
    !    !    matmul(AmatPres(nCellStr:nCellEnd,nCellStr:nCellEnd),&
    !    !           BmatPres(nCellStr:nCellEnd))
    !    !cDp(nCellStr:nCellEnd) = 0.5 &
    !    !                        *cDp(nCellStr:nCellEnd)
    !    cP(nCellStr:nCellEnd) = oldcP(nCellStr:nCellEnd) &
    !                           +matmul(AmatPres(nCellStr:nCellEnd,nCellStr:nCellEnd),&
    !                                   BmatPres(nCellStr:nCellEnd))
    !    cDp(nCellStr:nCellEnd) = cP(nCellStr:nCellEnd) &
    !                           - save_dummy(nCellStr:nCellEnd)
    !
    !endsubroutine
    !
    !
    !!========================================================
    !subroutine getP_Xiao
    !    implicit none
    !
    !
    !    do i=nFaceStr,nFaceEnd
    !        lCell = i; rCell = i+1
    !        wL(:) = (/cRho(lCell),cU(lCell),cP(lCell)/)
    !        wR(:) = (/cRho(rCell),cU(rCell),cP(rCell)/)
    !        CALL calfaceValAUSM(wL,wR,eosGamma, fMdot(i),fU(i),fP(i))
    !        fMdot(i) = fMdot(i)*area(i)
    !        fgP(i) = 0.5d0*(1.d0+dsign(1.d0,fU(i)))
    !        fgN(i) = 0.5d0*(1.d0-dsign(1.d0,fU(i)))
    !        fUx(i) = fgP(i)*cU(lCell)  + fgN(i)*cU(rCell)
    !        fcoeffMom1(i) = fgP(i)*coeffMom1(lCell) + fgN(i)*coeffMom1(rCell)
    !        fcoeffMom2(i) = fgP(i)*coeffMom2(lCell) + fgN(i)*coeffMom2(rCell)
    !        fRho(i) = fgP(i)*cRho(lCell) + fgN(i)*cRho(rCell)
    !        fDrDp(i) = fgP(i)*cDrDp(lCell) + fgN(i)*cDrDp(rCell)
    !    enddo
    !
    !    AmatPres(:,:) = 0.d0
    !    do i=nCellStr,nCellEnd
    !        lFace = i-1; rFace = i
    !
    !        dPN = dx
    !
    !        segAlp1 = area(lFace)*timestep &
    !                    /(0.5d0*(cRho(i-1)+cRho(i))) &
    !                    /dPN
    !        segAlp2 = area(rFace)*timestep &
    !                /(0.5d0*(cRho(i+1)+cRho(i))) &
    !                    /dPN
    !        AmatPres(i,i)   = AmatPres(i,i) -segAlp1
    !        AmatPres(i,i)   = AmatPres(i,i) -segAlp2
    !        if( i /= nCellStr ) then
    !            AmatPres(i,i-1) = segAlp1
    !        endif
    !        if( i /= nCellEnd ) then
    !            AmatPres(i,i+1) = segAlp2
    !        endif
    !        AmatPres(i,i) = AmatPres(i,i) - 1.d0/cRho(i)*cDrDp(i)/timestep
    !
    !        BmatPres(i) = area(rFace) * ( fU(rFace) - timestep/fRho(rFace) &
    !                        *(cDp(i-1)-cDp(i))/dPN ) &
    !                    - area(lFace) * ( fU(lFace) - timestep/fRho(lFace) &
    !                        *(cDp(i+1)-cDp(i))/dPN )
    !    enddo
    !
    !    !> Update Pressure
    !    CALL matInverse(AmatPres,nCellEnd)
    !    cDp(nCellStr:nCellEnd) = &
    !        matmul(AmatPres(nCellStr:nCellEnd,nCellStr:nCellEnd),&
    !                BmatPres(nCellStr:nCellEnd))
    !    !cDp(nCellStr:nCellEnd) = 0.5 &
    !    !                        *cDp(nCellStr:nCellEnd)
    !    cP(nCellStr:nCellEnd) = cP(nCellStr:nCellEnd) &
    !                            +cDp(nCellStr:nCellEnd)
    !
    !endsubroutine
    !
    !
    !!========================================================
    !subroutine gePressure_YLL
    !    implicit none
    !
    !    do i=nFaceStr,nFaceEnd
    !        lCell = i; rCell = i+1
    !        wL(:) = (/cRho(lCell),cU(lCell),cP(lCell)/)
    !        wR(:) = (/cRho(rCell),cU(rCell),cP(rCell)/)
    !        CALL calfaceValAUSM(wL,wR,eosGamma, fMdot(i),fU(i),fP(i))
    !        fMdot(i) = fMdot(i)*area(i)
    !        fgP(i) = 0.5d0*(1.d0+dsign(1.d0,fU(i)))
    !        fgN(i) = 0.5d0*(1.d0-dsign(1.d0,fU(i)))
    !        fUx(i) = fgP(i)*cU(lCell)  + fgN(i)*cU(rCell)
    !        fcoeffMom1(i) = fgP(i)*coeffMom1(lCell) + fgN(i)*coeffMom1(rCell)
    !        fcoeffMom2(i) = fgP(i)*coeffMom2(lCell) + fgN(i)*coeffMom2(rCell)
    !        fRho(i) = fgP(i)*cRho(lCell) + fgN(i)*cRho(rCell)
    !        fDrDp(i) = fgP(i)*cDrDp(lCell) + fgN(i)*cDrDp(rCell)
    !    enddo
    !    AmatPres(:,:) = 0.d0
    !    do i=nCellStr,nCellEnd
    !        lFace = i-1; rFace = i
    !
    !        dPN = dx
    !
    !
    !        segAlp1 = fDrDp(lFace)*fcoeffMom1(lFace)/cVol(i)*area(lFace)
    !        !segAlp2 = fcoeffMom2(lFace)/cVol(i)/timestep*area(lFace)
    !        segAlp2 = timestep/cVol(i)*area(lFace)
    !
    !
    !        AmatPres(i,i) = cDrDp(i)/timestep &
    !            - segAlp1*fgN(lFace) + segAlp1*fgP(rFace) &
    !            - segAlp2/dPN - segAlp2/dPN
    !
    !        if( i/=nCellStr ) then
    !            AmatPres(i,i-1) = AmatPres(i,i-1) &
    !                - segAlp1*fgP(lFace) &
    !                + segAlp2/dPN
    !
    !        endif
    !        if( i/=nCellEnd ) then
    !            AmatPres(i,i+1) = AmatPres(i,i+1) &
    !                + segAlp1*fgN(rFace) &
    !                + segAlp2/dPN
    !        endif
    !
    !
    !        BmatPres(i) = -segAlp2 &
    !            *( -( cDp(i) - cDp(i-1) )/dPN + ( cDp(i+1) - cDp(i) )/dPN ) &
    !            + fMdot(lFace) - fMdot(rFace)
    !
    !    enddo
    !
    !    !> Update Pressure
    !    CALL matInverse(AmatPres,nCellEnd)
    !    cDp(nCellStr:nCellEnd) = &
    !        matmul(AmatPres(nCellStr:nCellEnd,nCellStr:nCellEnd),&
    !                BmatPres(nCellStr:nCellEnd))
    !    !cDp(nCellStr:nCellEnd) = 0.001 &
    !    !                        *cDp(nCellStr:nCellEnd)
    !    cP(nCellStr:nCellEnd) = cP(nCellStr:nCellEnd) &
    !                            +cDp(nCellStr:nCellEnd)
    !
    !
    !
    !endsubroutine

endmodule


module Mod_nsc_nscbc_ex
contains
subroutine nsc_nscbc_ex(e,accph,accvh,gpden,gpmom,gpene,grden,grmom,grene,coef,tract)
!-----------------------------------------------------------------------
!****f* Nscomp/nsc_nscbc
! NAME
!    nsc_nscbc
! DESCRIPTION
!    This routine computes a non-reflecting boundary condition
!    for subsonic flows, based on the NSCBC approach.
!    Higher order derivatives (stress and heat flux) are neglected.
!    It recalculates the essential boundary conditions.
!    Transverse, and pressure terms are neglected (commented).
! USED BY
!    nsc_Endbouope
!***
!-----------------------------------------------------------------------
   use typre
   use Mod_Element
   implicit none
   class(FiniteElement) :: e
   real(rp) :: accph,accvh
   real(rp) :: gpden,gpmom(e%ndime),gpene
   real(rp) :: grden(e%ndime),grmom(e%ndime,e%ndime),grene(e%ndime)
   real(rp) :: coef(3)
   real(rp),    intent(inout) :: tract(e%ndime+2)

   integer(ip)                :: idime
   integer(ip)                :: inodb,jnode,inode,jnodb

   real(rp) :: cgamma,aux_k,gptem
   real(rp) :: lomom(e%ndime),auxlogrm(e%ndime,e%ndime)
   real(rp) :: logrd(e%ndime),logrm(e%ndime,e%ndime),logre(e%ndime)
   real(rp) :: logrv(e%ndime,e%ndime),logrp(e%ndime)
   real(rp) :: gppre,lospd,dens,veloc(e%ndime),cartvel(e%ndime),tempe
   real(rp) :: L1,L2,L5,d(4)

   cgamma = accph/accvh
   aux_k = dot_product(gpmom,gpmom)/(gpden*gpden)

   !baloc is (t1,t2,n)
   !therefore (ndime) is the normal component.
   !(1) is a transversal for 2d and (2) transversal for 3d
   !local density derivative
   logrd = matmul(grden,e%baloc)

   !local momentum and derivatives
   lomom = matmul(gpmom,e%baloc)
   ! d_l m_l = T_lc (d_c m_c) T_cl
   auxlogrm = matmul(transpose(grmom),e%baloc)
   logrm = matmul(transpose(auxlogrm),e%baloc)

   !local energy derivative
   logre = matmul(grene,e%baloc)

   !Calulate local pressure and gradient
   gppre = (cgamma-1.0_rp)*(gpene-gpden*aux_k/2.0_rp)

   !d_j(p)=(gamma-1)*(dj(etot) - m/rho dj(m) + m·m/rho·rho dj(rho))
   logrp = 0.0_rp
   logrp = logrp + (cgamma-1.0_rp) * (logre + aux_k*logrd)
   logrp = logrp - (cgamma-1.0_rp) * matmul(lomom,logrm)/gpden

   !Calulate local temperature
   gptem = gppre/(gpden*(accph-accvh))

   !Calculate speed of sound
   lospd = sqrt(cgamma*gppre/gpden)

   !Calculate local velocity derivatives
   !dj(ui) = dj(mi)/rho - ui/rho (dj rho)
   do idime=1,e%ndime
      logrv(idime,1:e%ndime) = logrm(idime,1:e%ndime)/gpden -&
                               lomom(idime)*logrd(1:e%ndime)/(gpden*gpden)
   end do

   !Calculate amplitudes of characteristic waves

   if(e%ndime == 3) then
        veloc(2) = veloc(2) + lomom(3)*logrv(2,3)/gpden
   end if

   !L1 Linear Relaxation Method
   L1 = coef(1)*abs(1.0_rp-aux_k/(lospd*lospd))*(gppre-coef(3))/(sqrt(2.0_rp)*gpden*coef(2))
!   L1 = (-lospd+lomom(e%ndime)/gpden)*(-gpden*lospd*logrv(e%ndime,e%ndime)+logrp(e%ndime))
   !L2 and L5
   L2 = (lomom(e%ndime)/gpden)*(lospd*lospd*logrd(e%ndime)-logrp(e%ndime))
   L5 = (lospd+lomom(e%ndime)/gpden)*(gpden*lospd*logrv(e%ndime,e%ndime)+logrp(e%ndime))

   !Calculate vector of derivatives
   !d1, d2, ...,d5
   d = 0.0_rp
   d(2) = (L1+L5)/2.0_rp
   d(1) = (L2+d(2))/(lospd*lospd)
   d(3) = (L5-L1)/(2.0_rp*gpden*lospd)
   d(4) = (lomom(e%ndime)/gpden)*logrv(1,e%ndime)

   !Density equation
   dens = 0.0_rp
   dens = dens + d(1)

   !Temperature equation
   tempe = 0.0_rp
   tempe = tempe - gptem*L2/(gpden*lospd*lospd)
   tempe = tempe + gptem*(cgamma-1.0_rp)*d(2)/(gpden*lospd*lospd)

   veloc = 0.0_rp
   veloc(e%ndime) = veloc(e%ndime) + d(3)
   veloc(1) = veloc(1) + d(4)

   cartvel = matmul(e%baloc,veloc)

   ! Compute prescribed traction
   tract(1)           = dens
   tract(2:e%ndime+1) = cartvel(1:e%ndime)
   tract(e%ndime+2)   = tempe

end subroutine nsc_nscbc_ex
end module


      subroutine getpot5(rho,vion,rhocr,vtot,v0,E_Hxc,workr_n,
     & E_coul,E_ion)
******************************************
cc     Written by Lin-Wang Wang, March 30, 2001.
*************************************************************************
**  copyright (c) 2003, The Regents of the University of California,
**  through Lawrence Berkeley National Laboratory (subject to receipt of any
**  required approvals from the U.S. Dept. of Energy).  All rights reserved.
*************************************************************************

******************************************

***********************************************************
**** This subroutine calculates the GGA, using PBE-GGA,
**** by J.P. Perdew, K. Burke and M. Ernzerhof, Phys. Rev. Lett. 77, 3865
**** (1996); ibid. 78, 1396 (1997) (E).
**** It assumes that there are up and down spins.
*************************************

      use fft_data
      use load_data
      use data

      implicit double precision (a-h,o-z)
      include 'param.escan_real'

      real*8 workr_n(mr_n)
      real*8 vtot(mr_n,2)
      real*8 rho(mr_n,2),vion(mr_n),rhocr(mr_n)

      real*8, allocatable, dimension(:) :: vi,vitmp

      real*8, allocatable, dimension(:,:) :: drho,ddrho,dotrho

      real*8, allocatable, dimension(:,:,:) :: vtmp

**************************************************
ccccc generate the potential vtot from rho(i)
ccccc (mr_n,3): 1, spin up; 2, spin down; 3 spin up+spin down

      allocate(drho(mr_n,3))         !  |grad(rho)|
      allocate(dotrho(mr_n,3))       !  [grad(rho)]\cdot[grad|grad(rho)|]
      allocate(ddrho(mr_n,2))        !  \nablda^2(rho)

ccccccccc drho,dotrho,ddrho are all we need to call the one r point gga subroutines

      drho=0.d0
      dotrho=0.d0
      ddrho=0.d0

      allocate(vi(mr_n))
      allocate(vitmp(mr_n))
      allocate(vtmp(mr_n,3,2))

****************************************************

      ng2_n=ngtotnod2(inode)

      vi = 0.0d0

      do i=1,nr_n
      workr_n(i) = rho(i,1)+rho(i,2)     ! total charge for Coulomb potential
      enddo

      call d3fft_real2(vi,workr_n,1,0)

      pi=4*datan(1.d0)

      do 100 i=1,ng2_n

      if(inode.eq.iorg2(1).and.i.eq.iorg2(2)) then
      ig = iorg2(2)
      vi(ig*2)=0.d0
      vi(ig*2-1)=0.d0
      else
      vi(i*2)=vi(i*2)*2*pi/gkk2_n(i)
      vi(i*2-1)=vi(i*2-1)*2*pi/gkk2_n(i)
      endif

100   continue

      call d3fft_real2(vi,workr_n,-1,0)

      do iislda=1,2
      do i=1,nr_n
      vtot(i,iislda) = workr_n(i)
      enddo
      enddo

*************************************************************
****** finished the Coulomb potential
*************************************************************
****** now,  calculate drho, ddrho, dotrho
*************************************************************

      do 200 iislda=1,2

      do i=1,nr_n
      workr_n(i)=rho(i,iislda)+rhocr(i)*0.5d0
      enddo

      call d3fft_real2(vi,workr_n,1,0)

      do 201 ixyz=1,3

      call vitmp_eq_vigkxyz()     ! multiply i*gkx,i*gky,i*gkz to vi

      call d3fft_real2(vitmp,workr_n,-1,0)

      do i=1,nr_n
      vtmp(i,ixyz,iislda)=workr_n(i)
      enddo

201   continue

      do i=1,nr_n
      drho(i,iislda)=dsqrt(vtmp(i,1,iislda)**2+
     &  vtmp(i,2,iislda)**2+vtmp(i,3,iislda)**2)
      enddo

******************************************
      do i=1,ng2_n
      vitmp(i*2)=2*vi(i*2)*gkk2_n(i)
      vitmp(i*2-1)=2*vi(i*2-1)*gkk2_n(i)
      enddo
      call d3fft_real2(vitmp,workr_n,-1,0)
      do i=1,nr_n
      ddrho(i,iislda)=-workr_n(i)
      enddo
*******************************************
      do i=1,nr_n
      workr_n(i)=drho(i,iislda)
      enddo

      call d3fft_real2(vi,workr_n,1,0)

      do 202 ixyz=1,3

      call vitmp_eq_vigkxyz()     ! multiply i*gkx,i*gky,i*gkz to vi

      call d3fft_real2(vitmp,workr_n,-1,0)

      do i=1,nr_n
      dotrho(i,iislda)=dotrho(i,iislda)+workr_n(i)*vtmp(i,ixyz,iislda)
      enddo
202   continue

200   continue
********************************************

      do i=1,nr_n
      drho(i,3)=dsqrt((vtmp(i,1,1)+vtmp(i,1,2))**2+
     &                (vtmp(i,2,1)+vtmp(i,2,2))**2+
     &                (vtmp(i,3,1)+vtmp(i,3,2))**2)
      enddo

      do i=1,nr_n
      workr_n(i)=drho(i,3)
      enddo

      call d3fft_real2(vi,workr_n,1,0)

      do 203 ixyz=1,3

      call vitmp_eq_vigkxyz()     ! multiply i*gkx,i*gky,i*gkz to vi

      call d3fft_real2(vitmp,workr_n,-1,0)

      do i=1,nr_n
      dotrho(i,3)=dotrho(i,iislda)+workr_n(i)*
     &     (vtmp(i,ixyz,1)+vtmp(i,ixyz,2))
      enddo

203   continue

*********************************************************
      deallocate(vi)
      deallocate(vitmp)
      deallocate(vtmp)
*********************************************************
**** finished the calculation of drho, ddrho and dotrho,
**** now, we can call GGA subroutine one r point at a time
*********************************************************
ccccc (mr_n,3): 1, spin up; 2, spin down; 3 spin up+spin down
ccc
ccc      drho(mr_n,3)        !  |grad(rho)|
ccc      dotrho(mr_n,3)       !  [grad(rho)]\cdot[grad|grad(rho)|]
ccc      ddrho(mr_n,2)        !  \nablda^2(rho)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      s=0.d0
      E_Hxc=0.d0
      E_coul=0.d0
      E_ion=0.d0

      do 1000 i=1,nr_n

cccccccccccccccccccccccccccccccccccccccccccc
cccccccccc Hartree energy

      E_Hxc=E_Hxc+0.5d0*(vtot(i,1)*rho(i,1)+
     &                   vtot(i,2)*rho(i,2))
      E_coul=E_coul+0.5d0*(vtot(i,1)*rho(i,1)+
     &                   vtot(i,2)*rho(i,2))
      E_ion=E_ion+vion(i)*(rho(i,1)+rho(i,2))

       up=rho(i,1)+rhocr(i)*0.5d0
       agrup=drho(i,1)
       delgrup=dotrho(i,1)
       uplap=ddrho(i,1)
       dn=rho(i,2)+rhocr(i)*0.5d0
       agrdn=drho(i,2)
       delgrdn=dotrho(i,2)
       dnlap=ddrho(i,2)
       agr=drho(i,3)
       delgr=dotrho(i,3)
       lcor=1
       lpot=1
      call easypbe(up,agrup,delgrup,uplap,dn,agrdn,delgrdn,dnlap,
     &           agr,delgr,lcor,lpot,
     &           exlsd,vxuplsd,vxdnlsd,eclsd,vcuplsd,vcdnlsd,
     &           expw91,vxuppw91,vxdnpw91,ecpw91,vcuppw91,vcdnpw91,
     &           expbe,vxuppbe,vxdnpbe,ecpbe,vcuppbe,vcdnpbe)

      vtot(i,1)=vtot(i,1)+vion(i)+vxuppbe+vcuppbe
      vtot(i,2)=vtot(i,2)+vion(i)+vxdnpbe+vcdnpbe
      E_Hxc=E_Hxc+(expbe+ecpbe)*(rho(i,1)+rho(i,2)+rhocr(i))

c      vtot(i,1)=vtot(i,1)+vion(i)+vxuplsd+vcuplsd
c      vtot(i,2)=vtot(i,2)+vion(i)+vxdnlsd+vcdnlsd
c      E_Hxc=E_Hxc+(exlsd+eclsd)*(rho(i,1)+rho(i,2)+rhocr(i))

      s=s+(vtot(i,1)+vtot(i,2))*0.5d0
1000  continue

****************************************************
      deallocate(drho)
      deallocate(dotrho)
      deallocate(ddrho)
****************************************************
****************************************************

      do iislda=1,2
      do i=1,nr_n
      workr_n(i) = vtot(i,iislda)
      enddo

***** only keep the G components within Ecut2
      call d3fft_real2(vtot(1,iislda),workr_n,1,0)
      call d3fft_real2(vtot(1,iislda),workr_n,-1,0)
***** we can save one fft by rearrange the order.

      do i=1,nr_n
      vtot(i,iislda) = workr_n(i)
      enddo
      enddo

      call global_sumr(s)
      call global_sumr(E_Hxc)
      call global_sumr(E_coul)
      call global_sumr(E_ion)

      E_Hxc=E_Hxc*vol/nr
      E_coul=E_coul*vol/nr
      E_ion=E_ion*vol/nr

      s=s/nr
      do i=1,nr_n
      vtot(i,1)=vtot(i,1)-s
      vtot(i,2)=vtot(i,2)-s
      enddo

      v0=s
ccccccccccccccccccccc
cccccc ave_vtot=0.d0 is necessary for mch_Broyden and mch_pulay,
cccccc otherwise it doesn't work
ccccccccccccccccccccc
      return

      contains

      subroutine vitmp_eq_vigkxyz()

      implicit double precision (a-h,o-z)

        if(ixyz.eq.1) then
        do i=1,ng2_n
        vitmp(i*2)=-vi(i*2-1)*gkx2_n(i)
        vitmp(i*2-1)=vi(i*2)*gkx2_n(i)
        enddo
        endif
        if(ixyz.eq.2) then
        do i=1,ng2_n
        vitmp(i*2)=-vi(i*2-1)*gky2_n(i)
        vitmp(i*2-1)=vi(i*2)*gky2_n(i)
        enddo
        endif
        if(ixyz.eq.3) then
        do i=1,ng2_n
        vitmp(i*2)=-vi(i*2-1)*gkz2_n(i)
        vitmp(i*2-1)=vi(i*2)*gkz2_n(i)
        enddo
        endif

      end subroutine vitmp_eq_vigkxyz

      end


program ch0602
    ! People's Weights and Setting the Array Size
    ! With a Parameter
    implicit none

    integer, parameter :: number_of_people = 10
    real :: total = 0., average = 0.
    integer :: person
    real, dimension(1:number_of_people) :: weight

    do  person = 1, number_of_people
        print *, ' type in the weight for person ', &
            person
        read *, weight(person)
        total = total+weight(person)
    end do
    average = total/number_of_people
    print *, ' The total of the weights is ', &
        total
    print *, ' Average Weight is ', average
    print *, ' ', number_of_people, &
        ' Weights were '
    do person = 1, number_of_people
        print *, weight(person)
    end do
end program


! Simplification of unary and binary expressions containing
! array constructors.
!
! See PR33288
!
! { dg-do run }
  real, parameter :: x(1) = 42
  real, parameter :: x1(1) = (/ x /) + 1
  real, parameter :: x2(1) = 1 + (/ x /)
  real, parameter :: x3(1) = -(/ x /)
  real, parameter :: x4(2) = (/ x, 1. /) + (/ 2, (/3/) /)

  if (any (x1 /= (/43./))) call abort
  if (any (x2 /= (/43./))) call abort
  if (any (x3 /= (/-42./))) call abort
  if (any (x4 /= (/44., 4./))) call abort
end


program calculator
    use, intrinsic :: iso_fortran_env, only : DP => REAL64
    implicit none
    real(kind=DP) :: x, y
    character(len=1) :: op

    call get_expression(op, x, y)
    print '(E15.7)', calculate(op, x, y)

contains

    subroutine get_expression(op, x, y)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        real(kind=DP), intent(out) :: x, y
        character, intent(out) :: op
        character(len=1024) :: string
        integer :: status
        character(len=1024) :: msg

        if (command_argument_count() /= 1) then
            write (unit=error_unit, fmt='(A)') &
                'error: expecting real operand real on command line'
            stop 1
        end if
        call get_command_argument(1, string)
        print *, trim(string)
        read(string, fmt=*, iostat=status, iomsg=msg) x, op, y
        if (status /= 0) then
            write (unit=error_unit, fmt='(2A)') &
                'parse error: ', msg
            stop 2
        end if
    end subroutine get_expression

    real(kind=DP) function calculate(op, x, y)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        character(len=1), intent(in) :: op
        real(kind=DP), intent(in) :: x, y

        select case (op)
            case ('+')
                calculate = x + y
            case ('-')
                calculate = x - y
            case ('*')
                calculate = x*y
            case default
                write (unit=error_unit, fmt='(3A)') &
                    'error: ', op, ' is not a valid operator'
                stop 3
        end select
    end function calculate

end program calculator


c Author: Anand Patil, anand.prabhakar.patil@gmail.com

      SUBROUTINE checksymm(X,n,cs)
c Checks symmetry
cf2py intent(hide) n
cf2py intent(out) cs
      DOUBLE PRECISION X(n,n)
      INTEGER n,i,j
      LOGICAL cs

      cs = .FALSE.
      do j=1,n-1
          do i=j+1,n
              if (X(i,j).NE.X(j,i)) then
                  cs = .TRUE.
                  return
              end if
          end do
      end do

      return
      END

      SUBROUTINE chol_mvnorm(x, mu, sig, n, like, info)

cf2py double precision dimension(n), intent(copy) :: x
cf2py double precision dimension(n), intent(copy) :: mu
cf2py integer intent(hide),depend(x) :: n=len(x)
cf2py double precision dimension(n,n), intent(in) :: sig
cf2py double precision intent(out) :: like
cf2py integer intent(hide) :: info
cf2py threadsafe

      DOUBLE PRECISION sig(n,n), x(n), mu(n), like
      INTEGER n, info, i
      DOUBLE PRECISION twopi_N, log_detC, gd
      DOUBLE PRECISION infinity
      PARAMETER (infinity = 1.7976931348623157d308)
      DOUBLE PRECISION PI
      PARAMETER (PI=3.141592653589793238462643d0)

      EXTERNAL DPOTRS
! DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) Solves triangular system
      EXTERNAL DAXPY
! DAXPY(N,DA,DX,INCX,DY,INCY) Adding vectors
      EXTERNAL DCOPY
! DCOPY(N,DX,INCX,DY,INCY) copies x to y
! NB DDOT from ATLAS, compiled with gfortran 4.2 on Ubuntu Gutsy,
! was producing bad output- hence the manual dot product.

!     x <- (x-mu)
      call DAXPY(n, -1.0D0, mu, 1, x, 1)

!       mu <- x
      call DCOPY(n,x,1,mu,1)

!     x <- sig ^-1 * x
      call DPOTRS('L',n,1,sig,n,x,n,info)

      gd=0.0D0
      do i=1,n
          gd=gd+x(i)*mu(i)
      end do

!     like <- .5 dot(x,mu) (.5 (x-mu) C^{-1} (x-mu)^T)
      like = -0.5D0 * gd
!       print *, like

      twopi_N = 0.5D0 * N * dlog(2.0D0*PI)
!       print *, twopi_N

      log_detC = 0.0D0
      do i=1,n
        log_detC = log_detC + log(sig(i,i))
      enddo
!       print *, log_detC

      like = like - twopi_N - log_detC

      return
      END

      SUBROUTINE cov_mvnorm(x, mu, C, n, like, info)

cf2py double precision dimension(n), intent(copy) :: x
cf2py double precision dimension(n), intent(copy) :: mu
cf2py integer intent(hide),depend(x) :: n=len(x)
cf2py double precision dimension(n,n), intent(copy) :: C
cf2py double precision intent(out) :: like
cf2py integer intent(hide) :: info
cf2py threadsafe

      DOUBLE PRECISION C(n,n), x(n), mu(n), like
      INTEGER n, info
      DOUBLE PRECISION infinity
      PARAMETER (infinity = 1.7976931348623157d308)
      DOUBLE PRECISION PI
      PARAMETER (PI=3.141592653589793238462643d0)

      EXTERNAL DPOTRF
! DPOTRF( UPLO, N, A, LDA, INFO ) Cholesky factorization

!     C <- cholesky(C)
      call DPOTRF( 'L', n, C, n, info )
!       print *, C

!      If cholesky failed, puke.
       if (info .GT. 0) then
         like = -infinity
         RETURN
       endif

!     Call to chol_mvnorm
      call chol_mvnorm(x,mu,C,n,like,info)

      return
      END

      SUBROUTINE prec_mvnorm(x, mu, tau, n, like)

cf2py double precision dimension(n), intent(copy) :: x
cf2py double precision dimension(n), intent(copy) :: mu
cf2py integer intent(hide),depend(x) :: n=len(x)
cf2py double precision dimension(n,n), intent(copy) :: tau
cf2py double precision intent(out) :: like
cf2py threadsafe

      DOUBLE PRECISION tau(n,n), x(n), mu(n), like, gd
      INTEGER n, info, i
      DOUBLE PRECISION infinity
      PARAMETER (infinity = 1.7976931348623157d308)
      DOUBLE PRECISION PI
      PARAMETER (PI=3.141592653589793238462643d0)
      DOUBLE PRECISION twopi_N, log_dettau

      EXTERNAL DPOTRF
! DPOTRF( UPLO, N, A, LDA, INFO ) Cholesky factorization
      EXTERNAL DSYMV
! DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) Symmetric matrix-vector multiply
      EXTERNAL DAXPY
! DAXPY(N,DA,DX,INCX,DY,INCY) Adding vectors
      EXTERNAL DCOPY
! DCOPY(N,DX,INCX,DY,INCY) copies x to y

      twopi_N = 0.5D0 * N * dlog(2.0D0*PI)

!     x <- (x-mu)
      call DAXPY(n, -1.0D0, mu, 1, x, 1)

!       mu <- x
      call DCOPY(n,x,1,mu,1)

!     mu <- tau * x
      call DSYMV('L',n,1.0D0,tau,n,x,1,0.0D0,mu,1)

      gd = 0.0D0
      do i=1,n
          gd=gd+x(i)*mu(i)
      end do

!     like <- -.5 dot(x,mu) (.5 (x-mu) C^{-1} (x-mu)^T)
      like = -0.5D0 * gd

!      Cholesky factorize tau for the determinant.
       call DPOTRF( 'L', n, tau, n, info )

!      If cholesky failed, puke.
       if (info .GT. 0) then
         like = -infinity
         RETURN
       endif

!      Otherwise read off determinant.
       log_dettau = 0.0D0
       do i=1,n
         log_dettau = log_dettau + dlog(tau(i,i))
       enddo

       like = like - twopi_N + log_dettau

      return
      END

      SUBROUTINE blas_wishart(X,k,n,T,like)

c Wishart log-likelihood function.

cf2py double precision dimension(k,k),intent(copy) :: X,T
cf2py double precision intent(out) :: like
cf2py integer intent(hide),depend(X) :: k=len(X)
cf2py threadsafe

      INTEGER i,k,n
      DOUBLE PRECISION X(k,k),T(k,k),bx(k,k)
      DOUBLE PRECISION dx,db,tbx,a,g,like
      DOUBLE PRECISION infinity
      PARAMETER (infinity = 1.7976931348623157d308)
      DOUBLE PRECISION PI
      LOGICAL csx
      PARAMETER (PI=3.141592653589793238462643d0)

      EXTERNAL DCOPY
! DCOPY(N,DX,INCX,DY,INCY) copies x to y
      EXTERNAL DSYMM
! DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) alpha*A*B + beta*C when side='l'
      EXTERNAL DPOTRF
! DPOTRF( UPLO, N, A, LDA, INFO ) Cholesky factorization

c Check X for symmetry
      CALL checksymm(X,k,csx)
      if (csx) then
          like = -infinity
          return
      end if

c trace of T*X
!     bx <- T * X
      call DSYMM('L','L',k,k,1.0D0,T,k,x,k,0.0D0,bx,k)

c Cholesky factor T, puke if not pos def.
      call DPOTRF( 'L', k, T, k, info )
      if (info .GT. 0) then
        like = -infinity
        RETURN
      endif

c Cholesky factor X, puke if not pos def.
      call DPOTRF( 'L', k, X, k, info )
      if (info .GT. 0) then
        like = -infinity
        RETURN
      endif

c Get the trace and log-sqrt-determinants
      tbx = 0.0D0
      dx = 0.0D0
      db = 0.0D0

      do i=1,k
        tbx = tbx + bx(i,i)
        dx = dx + dlog(X(i,i))
        db = db + dlog(T(i,i))
      enddo

      if (k .GT. n) then
        like = -infinity
        RETURN
      endif

      like = 0.0D0
      like = (n - k - 1) * dx
      like = like + n * db
      like = like - 0.5D0 * tbx
      like = like - (n*k/2.0d0)*dlog(2.0d0)

      do i=1,k
        a = (n - i + 1)/2.0D0
        call gamfun(a, g)
        like = like - g
      enddo

      like = like - k * (k-1) * 0.25D0 * dlog(PI)
!
      return
      END

c

      SUBROUTINE blas_wishart_cov(X,k,n,V,like)

c Wishart log-likelihood function.
c Doesn't vectorize the determinants, just the matrix multiplication.

cf2py double precision dimension(k,k),intent(copy) :: V,X
cf2py double precision intent(out) :: like
cf2py integer intent(hide),depend(X) :: k=len(X)
cf2py threadsafe

      INTEGER i,k,info, n
      DOUBLE PRECISION X(k,k),V(k,k),bx(k,k)
      DOUBLE PRECISION dx,db,tbx,a,g,like
      DOUBLE PRECISION infinity
      PARAMETER (infinity = 1.7976931348623157d308)
      DOUBLE PRECISION PI
      LOGICAL csx
      PARAMETER (PI=3.141592653589793238462643d0)
c
      EXTERNAL DCOPY
! DCOPY(N,DX,INCX,DY,INCY) copies x to y
      EXTERNAL DPOTRF
! DPOTRF( UPLO, N, A, LDA, INFO ) Cholesky factorization
      EXTERNAL DPOTRS
! DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) Solves triangular system

c determinants
c Check X for symmetry
      CALL checksymm(X,k,csx)
      if (csx) then
          like = -infinity
          return
      end if

c Cholesky factorize sigma, puke if not pos def
!     V <- cholesky(V)
      call DPOTRF( 'L', k, V, k, info )
      if (info .GT. 0) then
        like = -infinity
        RETURN
      endif

c trace of V^{-1}*X
!     bx <- X
      call DCOPY(k * k,X,1,bx,1)
!     bx <- V^{-1} * bx
      call DPOTRS('L',k,k,V,k,bx,k,info)

!     X <- cholesky(X)
      call DPOTRF( 'L', k, X, k, info )

! sqrt-log-determinant of sigma and X, and trace
      db=0.0D0
      dx=0.0D0
      tbx = 0.0D0
      do i=1,k
        db = db + dlog(V(i,i))
        dx = dx + dlog(X(i,i))
        tbx = tbx + bx(i,i)
      enddo

      if (k .GT. n) then
        like = -infinity
        RETURN
      endif

      like = (n - k - 1) * dx
      like = like - n * db
      like = like - 0.5D0*tbx
      like = like - (n*k/2.0D0)*dlog(2.0d0)

      do i=1,k
        a = (n - i + 1)/2.0D0
        call gamfun(a, g)
        like = like - g
      enddo

      like = like - k * (k-1) * 0.25D0 * dlog(PI)

      return
      END

      SUBROUTINE blas_inv_wishart(X,k,n,T,like)

c Inverse Wishart log-likelihood function.

cf2py double precision dimension(k,k),intent(copy) :: X,T
cf2py double precision intent(out) :: like
cf2py integer intent(hide),depend(X) :: k=len(X)
cf2py threadsafe

      INTEGER i,k,n
      DOUBLE PRECISION X(k,k),T(k,k),TX(k,k)
      DOUBLE PRECISION dx,db,tbx,a,g,like
      DOUBLE PRECISION infinity
      PARAMETER (infinity = 1.7976931348623157d308)
      DOUBLE PRECISION PI
      LOGICAL csx
      PARAMETER (PI=3.141592653589793238462643d0)

      EXTERNAL DCOPY
! DCOPY(N,DX,INCX,DY,INCY) copies x to y
      EXTERNAL DPOTRF
! DPOTRF( UPLO, N, A, LDA, INFO ) Cholesky factorization
      EXTERNAL DTRMM
! DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) B := alpha*B*op( A )

c Check X and T for symmetry
C       CALL checksymm(X,k,csx)
C       if (csx) then
C           print *,"checksymm failed"
C           like = -infinity
C           return
C       end if

c trace of T*X^{-1}
!     TX <- T
      call DCOPY(k*k,T,1,TX,1)
!     TX <- T * X^{-1}
      call DTRMM('R','L','T','N',k,k,1.0D0,X,k,TX,k)

c Cholesky factor T, puke if not pos def.
      call DPOTRF( 'L', k, T, k, info )
      if (info .GT. 0) then
        print *,"cholesky of T failed"
        like = -infinity
        RETURN
      endif

c Cholesky factor X, puke if not pos def.
      call DPOTRF( 'L', k, X, k, info )
      if (info .GT. 0) then
        print *,"cholesky of X failed"
        like = -infinity
        RETURN
      endif

c Get the trace and log-sqrt-determinants
      tbx = 0.0D0
      dx = 0.0D0
      db = 0.0D0

      do i=1,k
        tbx = tbx + TX(i,i)
        dx = dx + dlog(X(i,i))
        db = db + dlog(T(i,i))
      enddo

      if (k .GT. n) then
        print *, "k > n"
        like = -infinity
        RETURN
      endif

      like = -1.0D0*(n + k + 1) * dx
      like = like + 0.5D0 * n * db
      like = like - 0.5D0 * tbx
      like = like - (n*k/2.0d0)*dlog(2.0d0)

      do i=1,k
        a = (n - i + 1)/2.0D0
        call gamfun(a, g)
        like = like - g
      enddo

      like = like - k * (k-1) * 0.25D0 * dlog(PI)
!
      return
      END


      module mod_usdot
      use blas_sparse_namedconstants
      interface usdot
      module procedure iusdot
      module procedure susdot
      module procedure dusdot
      module procedure cusdot
      module procedure zusdot
      end interface
      contains
! **********************************************************************
! **********************************************************************
integer  function iusdot (x,indx,y,conj)
    implicit none
    integer,dimension(:),intent(in) :: indx
    integer  ,dimension(:),intent(in) ::x,y
    integer  ,dimension(:),allocatable :: zy
    integer,optional ::conj
    integer                        ::t
    intrinsic dot_product,conjg,cmplx
    t=size(indx)
    if(t.le.0) then
       iusdot =0.
    else
       allocate(zy(t))
       zy= y(indx)
       if(present(conj)) then
          iusdot =dot_product(x,zy)
       else
          iusdot =dot_product(conjg(cmplx(x)),zy)
       end if
       deallocate(zy)
    end if
  end function iusdot
! **********************************************************************
! **********************************************************************
real(KIND=sp)  function susdot (x,indx,y,conj)
    implicit none
    integer,dimension(:),intent(in) :: indx
    real(KIND=sp)  ,dimension(:),intent(in) ::x,y
    real(KIND=sp)  ,dimension(:),allocatable :: zy
    integer,optional ::conj
    integer                        ::t
    intrinsic dot_product,conjg,cmplx
    t=size(indx)
    if(t.le.0) then
       susdot =0.
    else
       allocate(zy(t))
       zy= y(indx)
       if(present(conj)) then
          susdot =dot_product(x,zy)
       else
          susdot =dot_product(conjg(cmplx(x)),zy)
       end if
       deallocate(zy)
    end if
  end function susdot
! **********************************************************************
! **********************************************************************
real(KIND=dp)  function dusdot (x,indx,y,conj)
    implicit none
    integer,dimension(:),intent(in) :: indx
    real(KIND=dp)  ,dimension(:),intent(in) ::x,y
    real(KIND=dp)  ,dimension(:),allocatable :: zy
    integer,optional ::conj
    integer                        ::t
    intrinsic dot_product,conjg,cmplx
    t=size(indx)
    if(t.le.0) then
       dusdot =0.
    else
       allocate(zy(t))
       zy= y(indx)
       if(present(conj)) then
          dusdot =dot_product(x,zy)
       else
          dusdot =dot_product(conjg(cmplx(x)),zy)
       end if
       deallocate(zy)
    end if
  end function dusdot
! **********************************************************************
! **********************************************************************
complex(KIND=sp)  function cusdot (x,indx,y,conj)
    implicit none
    integer,dimension(:),intent(in) :: indx
    complex(KIND=sp)  ,dimension(:),intent(in) ::x,y
    complex(KIND=sp)  ,dimension(:),allocatable :: zy
    integer,optional ::conj
    integer                        ::t
    intrinsic dot_product,conjg,cmplx
    t=size(indx)
    if(t.le.0) then
       cusdot =0.
    else
       allocate(zy(t))
       zy= y(indx)
       if(present(conj)) then
          cusdot =dot_product(x,zy)
       else
          cusdot =dot_product(conjg(cmplx(x)),zy)
       end if
       deallocate(zy)
    end if
  end function cusdot
! **********************************************************************
! **********************************************************************
complex(KIND=dp)  function zusdot (x,indx,y,conj)
    implicit none
    integer,dimension(:),intent(in) :: indx
    complex(KIND=dp)  ,dimension(:),intent(in) ::x,y
    complex(KIND=dp)  ,dimension(:),allocatable :: zy
    integer,optional ::conj
    integer                        ::t
    intrinsic dot_product,conjg,cmplx
    t=size(indx)
    if(t.le.0) then
       zusdot =0.
    else
       allocate(zy(t))
       zy= y(indx)
       if(present(conj)) then
          zusdot =dot_product(x,zy)
       else
          zusdot =dot_product(conjg(cmplx(x)),zy)
       end if
       deallocate(zy)
    end if
  end function zusdot
! **********************************************************************
! **********************************************************************
      end module mod_usdot


      SUBROUTINE PINVS(IE1,IE2,JE1,JSF,JC1,K,C,NCI,NCJ,NCK,S,NSI,NSJ)
      PARAMETER (ZERO=0.,ONE=1.,NMAX=10)
      DIMENSION C(NCI,NCJ,NCK),S(NSI,NSJ),PSCL(NMAX),INDXR(NMAX)
      JE2=JE1+IE2-IE1
      JS1=JE2+1
      DO 12 I=IE1,IE2
        BIG=ZERO
        DO 11 J=JE1,JE2
          IF(ABS(S(I,J)).GT.BIG) BIG=ABS(S(I,J))
11      CONTINUE
        IF(BIG.EQ.ZERO) PAUSE 'Singular matrix, row all 0'
        PSCL(I)=ONE/BIG
        INDXR(I)=0
12    CONTINUE
      DO 18 ID=IE1,IE2
        PIV=ZERO
        DO 14 I=IE1,IE2
          IF(INDXR(I).EQ.0) THEN
            BIG=ZERO
            DO 13 J=JE1,JE2
              IF(ABS(S(I,J)).GT.BIG) THEN
                JP=J
                BIG=ABS(S(I,J))
              ENDIF
13          CONTINUE
            IF(BIG*PSCL(I).GT.PIV) THEN
              IPIV=I
              JPIV=JP
              PIV=BIG*PSCL(I)
            ENDIF
          ENDIF
14      CONTINUE
        IF(S(IPIV,JPIV).EQ.ZERO) PAUSE 'Singular matrix'
        INDXR(IPIV)=JPIV
        PIVINV=ONE/S(IPIV,JPIV)
        DO 15 J=JE1,JSF
          S(IPIV,J)=S(IPIV,J)*PIVINV
15      CONTINUE
        S(IPIV,JPIV)=ONE
        DO 17 I=IE1,IE2
          IF(INDXR(I).NE.JPIV) THEN
            IF(S(I,JPIV).NE.ZERO) THEN
              DUM=S(I,JPIV)
              DO 16 J=JE1,JSF
                S(I,J)=S(I,J)-DUM*S(IPIV,J)
16            CONTINUE
              S(I,JPIV)=ZERO
            ENDIF
          ENDIF
17      CONTINUE
18    CONTINUE
      JCOFF=JC1-JS1
      ICOFF=IE1-JE1
      DO 21 I=IE1,IE2
        IROW=INDXR(I)+ICOFF
        DO 19 J=JS1,JSF
          C(IROW,J+JCOFF,K)=S(I,J)
19      CONTINUE
21    CONTINUE
      RETURN
      END


subroutine threshold_image(image, n, threshold, output)
    ! Inputs: image, n, threshold.
    ! Output: output
    !   output(i,j) is 1 if image(i,j) > threshold and 0 otherwise.

    integer n
    real(8) threshold
    real(8), dimension(n,n) :: image, output

    !f2py intent(in) :: image, threshold
    !f2py intent(hide), depend(image) :: n = shape(image, 0)
    !f2py intent(out) output

    write(*,*) "Hello from the Fortran subroutine!"

    ! Loop through columns and rows and threshold the image.
    do j=1,n
        do i=1,n
            if (image(i,j) > threshold) then
                output(i,j) = 1.0
            else
                output(i,j) = 0.0
            end if
        end do
    end do
end subroutine


PROGRAM MONTECARLO
	USE ISING
	IMPLICIT NONE
	REAL                          :: tprob(1:8)
	REAL                          :: temperature(NTEMP)
	INTEGER                       :: spin(LSIZE+2,LSIZE+2)
	INTEGER                       :: itemp

	! scan NTEMP temperature
	temperature = (/ (TEMP - (itemp-1)*dTEMP, itemp = 1, NTEMP) /)

	! initialize spin configuration with total magnetization = 0
	CALL INIT_CONFIGURATION(spin, 0)

	! output files
	OPEN (UNIT = 10, FILE = 'output.dat')
	OPEN (UNIT = 20, FILE = 'configuration.dat')
	OPEN (UNIT = 30, FILE = 'correlation.dat')

	! main loop
	DO itemp = 1, NTEMP
		! compute the transition probability
		CALL INIT_TRANSITION_PROBABILITY(tprob, temperature(itemp))
		! equilibrate system for ESTEP
		CALL EQUILIBRATION(tprob, spin)
		! statistical analysis for NSTEP
		CALL STATISTICAL_ANALYSIS(tprob, spin, temperature(itemp), 10, 20, 30)
	END DO

	! finalize
	CLOSE (10)
	CLOSE (20)
	CLOSE (30)
END PROGRAM MONTECARLO

SUBROUTINE EQUILIBRATION(tprob, spin)
	USE ISING, ONLY: LSIZE, ESTEP, METROPOLIS
	IMPLICIT NONE
	REAL, INTENT(IN)            :: tprob(1:8)
	INTEGER, INTENT(INOUT)      :: spin(LSIZE+2,LSIZE+2)
	INTEGER                     :: i, j, istep

	DO istep = 1, ESTEP
		DO i = 2, LSIZE + 1
			DO j = 2, LSIZE + 1
				CALL METROPOLIS(tprob, spin,  i, j)
			END DO
		END DO
	END DO
END SUBROUTINE EQUILIBRATION

SUBROUTINE STATISTICAL_ANALYSIS(tprob, spin, temperature, output, configuration, correlation)
	USE ISING, ONLY: LSIZE, NSTEP, NSPIN,&
		             METROPOLIS, RESPONSE_FUNCTION,&
		             SPIN_CONFIGURATION, SPIN_CORRELATION
	IMPLICIT NONE
	REAL, INTENT(IN)            :: tprob(1:8)
	INTEGER, INTENT(INOUT)      :: spin(LSIZE+2,LSIZE+2)
	REAL, INTENT(IN)            :: temperature
	INTEGER, INTENT(IN)         :: output, configuration, correlation
	INTEGER                     :: ene(NSTEP*NSPIN), mag(NSTEP*NSPIN)
	REAL                        :: ene_per_spin(NSTEP*NSPIN), mag_per_spin(NSTEP*NSPIN)
	REAL                        :: ss1(NSTEP*NSPIN), ss2(NSTEP*NSPIN), ss3(NSTEP*NSPIN),&
		                           ss4(NSTEP*NSPIN), ss5(NSTEP*NSPIN), s(NSTEP*NSPIN)
	INTEGER                     :: idata, istep, i, j, l, m

	! use the center spin for correlation
	l = LSIZE/2 + 1
	m = LSIZE/2 + 1
	idata = 0
	DO istep = 1, NSTEP
		DO i = 2, LSIZE + 1
			DO j = 2, LSIZE + 1
				idata = idata + 1
				CALL METROPOLIS(tprob, spin, i, j, idata, ene(idata), mag(idata))
				s(idata)   = spin(l,m)
				! 1st nearest neighbor
				ss1(idata) = 0.25*spin(l,m)*(spin(l-1,m) + spin(l+1,m) + spin(l,m-1) + spin(l,m+1))
				! 2nd nearest neighbor
				ss2(idata) = 0.25*spin(l,m)*(spin(l-1,m-1) + spin(l-1,m+1) + spin(l+1,m-1) + spin(l+1,m+1))
				! 3rd nearest neighbor
				ss3(idata) = 0.25*spin(l,m)*(spin(l-2,m) + spin(l+2,m) + spin(l,m-2) + spin(l,m+2))
				! 4th nearest neighbor
				ss4(idata) = 0.125*spin(l,m)*(spin(l+2,m+1) + spin(l+1,m+2) + spin(l-1,m+2) + spin(l-2,m+1) + &
					spin(l+2,m-1) + spin(l+1,m-2) + spin(l-1,m-2) + spin(l-2,m-1))
				! 5th nearest neighbor
				ss5(idata) = 0.25*spin(l,m)*(spin(l-2,m-2) + spin(l-2,m+2) + spin(l+2,m-2) + spin(l+2,m+2))
			END DO
		END DO
	END DO
	ene_per_spin = REAL(ene)/NSPIN
	mag_per_spin = ABS(REAL(mag))/NSPIN
	CALL RESPONSE_FUNCTION(ene_per_spin, mag_per_spin, temperature, output)
	CALL SPIN_CONFIGURATION(spin, configuration)
	CALL SPIN_CORRELATION(s, ss1, ss2, ss3, ss4, ss5, temperature, correlation)
END SUBROUTINE STATISTICAL_ANALYSIS


!
! Copyright (c) 2019, NVIDIA CORPORATION.  All rights reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
program main

   !use cudafor
   !use cublas
   use matmul_m
   use matmul_cublas_m

   integer :: i, j, m, n, k
   integer :: AllocateStatus
   real, allocatable :: A(:,:)   ! A(m,k)
   real, allocatable :: B(:,:)   ! B(k,n)
   real, allocatable :: C(:,:)   ! C(m,n)
   real, allocatable :: D(:,:)   ! D(m,n)

   m = 2
   n = 2
   k = 2

   write(*,*) 'Running with m,n,k: ', m, n, k

   allocate( A(m,k), stat = AllocateStatus)
   IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"

   allocate( B(k,n), stat = AllocateStatus)
   IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"

   allocate( C(m,n), stat = AllocateStatus)
   IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"

   allocate( D(m,n), stat = AllocateStatus)
   IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"

   call srand(0)

   do i=1,m
      do j=1,k
         A(i,j) = rand()
      enddo
   enddo

   do i=1,k
      do j=1,n
         B(i,j) = rand()
      enddo
   enddo

   call matmul(A, B, C, m, n, k);

!$acc enter data copyin(A(:), B(:)) create(D(:))
!$acc host_data use_device(A, B, D)
   call matmul_cublas(A, B, D, m, n, k)
!$acc end host_data
!$acc exit data delete(A, B) copyout(D(:))

   ! Check accuracy
   write(*,*) 'maxval(abs(C-D)): ',maxval(abs(C-D))

   write(*,*) "Program finished sucessfully."

end program


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! d_orthfact_buildbulge
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the first Givens' rotations that start a real
! Francis iteration. If JOB = 'S' a single Givens' rotation is
! constructed. If JOB = 'D' two Givens' rotations are constructed for
! a real double shift step.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  DBL             LOGICAL
!                    .TRUE.: real doubleshift
!                    .FALSE.: real singleshift
!
!  Q               REAL(8) array of dimension (4)
!                    array of generators for givens rotations
!
!  D               REAL(8) array of dimension (2)
!                    array of generators for complex diagonal matrix
!
!  SHFT            REAL(8) array of dimension (2)
!                    real and imaginary part of complex shift
!
! OUTPUT VARIABLES:
!
!  B1, B2          REAL(8) array of dimension (2)
!                    generators for givens rotations that represent
!                    the first transformations
!                    if DBL == .FALSE. then B2 is unused
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine d_orthfact_buildbulge(DBL,Q,D,SHFT,B1,B2)

  implicit none

  ! input variables
  logical, intent(in) :: DBL
  real(8), intent(in) :: Q(4), D(2), SHFT(2)
  real(8), intent(inout) :: B1(2), B2(2)

  ! compute variables
  real(8) :: nrm, COL(3), T(3,2)

  ! double shift
  if (DBL) then

    ! compute first two columns of A
    call d_orthfact_2x2diagblock(.TRUE.,Q,D,T(1:2,1:2))
    T(3,1) = 0d0
    T(3,2) = Q(4)*D(2)

    ! compute p(A)e_1
    COL(1) = T(1,1)*T(1,1) + T(1,2)*T(2,1) + SHFT(1)*SHFT(1) + SHFT(2)*SHFT(2) - 2d0*T(1,1)*SHFT(1)
    COL(2) = T(2,1)*(T(1,1)+T(2,2)-2d0*SHFT(1))
    COL(3) = T(2,1)*T(3,2)

    ! compute first givens rotations
    call d_rot2_vec2gen(COL(2),COL(3),B1(1),B1(2),nrm)

    ! compute second givens rotations
    call d_rot2_vec2gen(COL(1),nrm,B2(1),B2(2),nrm)

  ! single shift
  else

    ! compute first block of A
    call d_orthfact_2x2diagblock(.TRUE.,Q,D,T(1:2,1:2))

    ! compute first Givens' rotation
    call d_rot2_vec2gen(T(1,1)-SHFT(1),T(2,1),B1(1),B1(2),nrm)

  end if

end subroutine d_orthfact_buildbulge


Real Function rhomas(dmax, iseed)
  Common /rndf77/nseed
  Save
  dmin = 0.28
  If (dmax<0.77) Then
     fm = frho(dmax)
  Else
     fm = 1.
  End If
  If (fm==0.) fm = 1.E-06
  ntry1 = 0
10 dm = ranart(nseed)*(dmax-dmin) + dmin
  ntry1 = ntry1 + 1
  If ((ranart(nseed)>frho(dm)/fm) .And. (ntry1<=10)) Goto 10
  If (dm>1.07) Goto 10
  rhomas = dm
  Return
End Function rhomas


module Df_allDa
	! contains functions that compute the df/dalpha vectors of the material model
	! and one main (model-indepenent) function that calls all df/dalpha functions of the model
	! and returns the function values as a matrix

	! load additional modules
	use constants
	use material_info
	use derived_types
	use stress_routines
    implicit none

contains

	function DfDa(sigma, alpha)
		! computes the derivatives (gradient vectors) of the yield functions
		! with respect to the alpha vector
		! in case of multi surface plasticity the gradients of all yield functions
		! of the model must be computed in this subroutine
		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(6), intent(in) :: 	sigma		! stress vector
		real(kind=dbl), dimension(:), intent(in) :: 	alpha		! internal variables vector

		! return variable
		real(kind=dbl), dimension(size(alpha),n_yf) :: 			DfDa	! results array

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

		! --------------------------------------
		! computation of all gradient vectors
		! returning hardening function values in hardening_function vector
		! --------------------------------------

		DfDa(:,1) = Df_1Da(sigma, alpha)

	end function DfDa

	function Df_1Da(sigma, alpha)
		! gradient vector of first yield function

		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(6), intent(in) :: 	sigma			! stress vector
		real(kind=dbl), dimension(:), intent(in) :: 	alpha			! internal variables vector

		! return variable
		real(kind=dbl), dimension(size(alpha,1)) :: Df_1Da

		! internal variables
		! --------------------------------------------------------------------------

		! ...

	end function Df_1Da

end module Df_allDa


MODULE ATOMIC_PROPERTIES
  USE physical_constants
  IMPLICIT NONE
  DOUBLE PRECISION :: L=0.0,  S = 0.5
  DOUBLE PRECISION :: mass_at = 87*amu
  DOUBLE PRECISION :: I,g_I,g_J
  DOUBLE PRECISION :: J,F,gf,mf
  DOUBLE PRECISION :: gF_2,gF_1,G_F
  DOUBLE PRECISION :: A,a_s,alpha_E
  INTEGER          :: Fup,Fdown,Ftotal
  INTEGER          :: Total_states_LSI
  CHARACTER(LEN=7) :: ID_name

  !87Rb
  DOUBLE PRECISION :: I_87Rb   =  1.5
  DOUBLE PRECISION :: J_87Rb   =  0.5
  DOUBLE PRECISION :: gJ_87Rb  =  2.0
  DOUBLE PRECISION :: gI_87Rb  = -0.000995
  DOUBLE PRECISION :: A_87Rb   =  2*pi*hbar*3.417341E9
  DOUBLE PRECISION :: a_s_87Rb = 5.77E-9
  DOUBLE PRECISION :: alpha_E_87Rb = 2*pi*hbar*0.0794*1E-4
  INTEGER          :: Fup_87Rb     =  2
  INTEGER          :: Fdown_87Rb   =  1
  CHARACTER(LEN=7) :: ID_name_87Rb = "87Rb"

  !6Li
  DOUBLE PRECISION :: I_6Li   =  1.0
  DOUBLE PRECISION :: J_6Li   =  0.5
  DOUBLE PRECISION :: gJ_6Li  =  2.0
  DOUBLE PRECISION :: gI_6Li  = -0.000995
  DOUBLE PRECISION :: A_6Li   =  2*pi*hbar*152.137E6
  DOUBLE PRECISION :: a_s_6Li = 5.77E-9
  DOUBLE PRECISION :: alpha_E_6Li = 2*pi*hbar*0.0794*1E-4
  INTEGER          :: Fup_6Li     =  1
  INTEGER          :: Fdown_6Li   =  1
  CHARACTER(LEN=7) :: ID_name_6Li = "6Li"

  !qubit
  DOUBLE PRECISION :: I_qubit   =  0.0
  DOUBLE PRECISION :: J_qubit   =  0.0
  DOUBLE PRECISION :: gJ_qubit  =  1.0
  DOUBLE PRECISION :: gI_qubit  =  0.0
  DOUBLE PRECISION :: A_qubit   =  1.0
  DOUBLE PRECISION :: a_s_qubit =  0.0
  DOUBLE PRECISION :: alpha_E_qubit = 0.0
  INTEGER          :: Fup_qubit     =  1
  INTEGER          :: Fdown_qubit   =  1
  CHARACTER(LEN=7) :: ID_name_qubit = "qubit"

  !spin
  DOUBLE PRECISION :: I_spin   =  0.0
  DOUBLE PRECISION :: J_spin   =  0.0
  DOUBLE PRECISION :: gJ_spin  =  1.0
  DOUBLE PRECISION :: gI_spin  =  0.0
  DOUBLE PRECISION :: A_spin   =  1.0
  DOUBLE PRECISION :: a_s_spin =  0.0
  DOUBLE PRECISION :: alpha_E_spin = 0.0
  INTEGER          :: Fup_spin     =  1
  INTEGER          :: Fdown_spin   =  1
  CHARACTER(LEN=7) :: ID_name_spin = "spin"

  !lattice
  CHARACTER        :: PERIODIC
  CHARACTER(LEN=7) :: ID_name_lattice = "lattice"

END MODULE ATOMIC_PROPERTIES


      SUBROUTINE CALIMP2T
C
C **  SUBROUTINE CALEXP CALCULATES IMPLICIT MOMENTUM EQUATION
C **  CORIOLIS AND CURVATURE TERMS FOR 1/2 STEP PREDICTOR
C CHANGE RECORD
C
      USE GLOBAL
      IF(ISDYNSTP.EQ.0)THEN
        DELT=DT
        DELTD2=0.5*DT
        DELTI=1./DELT
      ELSE
        DELT=DTDYN
        DELTD2=0.5*DTDYN
        DELTI=1./DELT
      ENDIF
      DO K=1,KC
        TVAR1W(1,K)=0.
        TVAR1S(1,K)=0.
        TVAR1E(1,K)=0.
        TVAR1N(1,K)=0.
        TVAR2W(1,K)=0.
        TVAR2S(1,K)=0.
        TVAR2E(1,K)=0.
        TVAR2N(1,K)=0.
        TVAR1W(LC,K)=0.
        TVAR1S(LC,K)=0.
        TVAR1E(LC,K)=0.
        TVAR1N(LC,K)=0.
        TVAR2W(LC,K)=0.
        TVAR2S(LC,K)=0.
        TVAR2E(LC,K)=0.
        TVAR2N(LC,K)=0.
      ENDDO
      DO K=1,KC
        DO L=2,LA
          TVAR1W(L,K)=0.
          TVAR1S(L,K)=0.
          TVAR1E(L,K)=0.
          TVAR1N(L,K)=0.
          TVAR2W(L,K)=0.
          TVAR2S(L,K)=0.
          TVAR2E(L,K)=0.
          TVAR2N(L,K)=0.
        ENDDO
      ENDDO
      TVAR3W(1)=0.
      TVAR3S(1)=0.
      TVAR3E(1)=0.
      TVAR3N(1)=0.
      TVAR3W(LC)=0.
      TVAR3S(LC)=0.
      TVAR3E(LC)=0.
      TVAR3N(LC)=0.
      DO ND=1,NDM
        LF=2+(ND-1)*LDM
        LL=LF+LDM-1
        DO L=LF,LL
          TVAR3W(L)=0.
          TVAR3S(L)=0.
          TVAR3E(L)=0.
          TVAR3N(L)=0.
        ENDDO
      ENDDO
C
C **  INITIALIZE EXTERNAL CORIOLIS-CURVATURE AND ADVECTIVE FLUX TERMS
C
      DO L=1,LC
        FCAXE(L)=0.
        FCAYE(L)=0.
C PMC          FCAX1E(L)=0.
C PMC          FCAY1E(L)=0.
        FXE(L)=0.
        FYE(L)=0.
      ENDDO
C
C **  CALCULATE TIME LEVEL TIME LEVEL N INTERNAL STRESSES
C **  AND WAVE INDUCED CURRENT FORCINGS
C **  CALCULATE FRACTIONAL STEP WITH STRESSES AND WV FORCES
C
      ! *** Surface & Bottom Stresses
      DO ND=1,NDM
        LF=2+(ND-1)*LDM
        LL=LF+LDM-1
        DO L=LF,LL
          TVAR2W(L,1)=TBX(L)
          TVAR2S(L,1)=TBY(L)
          TVAR2E(L,KC)=TSX(L)
          TVAR2N(L,KC)=TSY(L)
        ENDDO
      ENDDO
      ! *** Vertical Eddy Viscosity Impacts
      DO K=1,KS
        TMPVAL=DZIG(K)
        DO L=2,LA
          TVAR2E(L,K)=TMPVAL*(U(L,K+1)-U(L,K))/AVUI(L,K)
          TVAR2N(L,K)=TMPVAL*(V(L,K+1)-V(L,K))/AVVI(L,K)
        ENDDO
      ENDDO

      DO K=2,KC
        DO L=2,LA
          TVAR2W(L,K)=TVAR2E(L,K-1)
          TVAR2S(L,K)=TVAR2N(L,K-1)
        ENDDO
      ENDDO

      DO K=1,KC
        DO L=2,LA
          TVAR1W(L,K)=DYIU(L)*UHDY(L,K)
          TVAR1S(L,K)=DXIV(L)*VHDX(L,K)
        ENDDO
      ENDDO
      DO K=1,KC
        TMPVAL=DELTD2*DZIC(K)
        DO L=2,LA
          ! *** Vertical Shear in the X direction
          TVAR1W(L,K)=TVAR1W(L,K)+TMPVAL*(TVAR2E(L,K)-TVAR2W(L,K))
          ! *** Vertical Shear in the Y direction
          TVAR1S(L,K)=TVAR1S(L,K)+TMPVAL*(TVAR2N(L,K)-TVAR2S(L,K))
        ENDDO
      ENDDO
C
C *** DSLLC BEGIN BLOCK
C
      IF(ISWAVE.EQ.2)THEN
        IF(N.LT.NTSWV)THEN
          TMPVAL=FLOAT(N)/FLOAT(NTSWV)
          WVFACT=0.5-0.5*COS(PI*TMPVAL)
        ELSE
          WVFACT=1.0
        ENDIF
        WVFACT=DELTD2*WVFACT
C
        DO K=1,KC
          DO L=2,LA
            TVAR1W(L,K)=TVAR1W(L,K)+WVFACT*SAAX(L)*DXYIU(L)*FXWAVE(L,K)
            TVAR1S(L,K)=TVAR1S(L,K)+WVFACT*SAAY(L)*DXYIV(L)*FYWAVE(L,K)
          ENDDO
        ENDDO
      ENDIF
C
C *** DSLLC END BLOCK
C
      DO K=1,KC
        DO L=2,LA
          TVAR1W(L,K)=SUB(L)*TVAR1W(L,K)
          TVAR1S(L,K)=SVB(L)*TVAR1S(L,K)
        ENDDO
      ENDDO
C
C **  ADD PRESSURE GRADIENT TERMS
C **  HRU=SUB*HMU*DYU/DXU & HRV=SVB*HMV*DXV/DYV
C
      DO ND=1,NDM
        LF=2+(ND-1)*LDM
        LL=LF+LDM-1
        DO L=LF,LL
          TVAR1E(L,KC)=DZC(KC)*B(L,KC)
        ENDDO
      ENDDO
      DO K=KS,1,-1
        DO L=2,LA
          TVAR1E(L,K)=TVAR1E(L,K+1)+DZC(K)*B(L,K)
        ENDDO
      ENDDO
      DO K=1,KC
        DO L=2,LA
          TVAR1E(L,K)=TVAR1E(L,K)-0.5*DZC(K)*B(L,K)
        ENDDO
      ENDDO
      DO K=1,KC
        DO L=2,LA
          TVAR1N(L,K)=TVAR1E(L,K)+0.5*(Z(K)+Z(K-1))*B(L,K)
        ENDDO
      ENDDO
      DO K=1,KC
        DO L=2,LA
          TVAR1N(L,K)=GP*TVAR1N(L,K)
          TVAR1E(L,K)=GP*TVAR1E(L,K)
        ENDDO
      ENDDO
      DO ND=1,NDM
        LF=2+(ND-1)*LDM
        LL=LF+LDM-1
        DO L=LF,LL
          TVAR3W(L)=DELTD2*SUB(L)*HU(L)*DXIU(L)
          TVAR3S(L)=DELTD2*SVB(L)*HV(L)*DYIV(L)
        ENDDO
      ENDDO
      DO K=1,KC
        DO L=2,LA
          LS=LSC(L)
          TVAR1W(L,K)=TVAR1W(L,K)-TVAR3W(L)*( P(L)-P(LWEST(L)) )
          TVAR1S(L,K)=TVAR1S(L,K)-TVAR3S(L)*( P(L)-P(LS ) )
        ENDDO
      ENDDO
      DO ND=1,NDM
        LF=2+(ND-1)*LDM
        LL=LF+LDM-1
        DO L=LF,LL
          TVAR3W(L)=DELT*SUB(L)*HU(L)*DXYIU(L)*SBX(L)  ! *** PMC H1U --> HU
          TVAR3S(L)=DELT*SVB(L)*HV(L)*DXYIV(L)*SBY(L)  ! *** PMC H1V --> HV
        ENDDO
      ENDDO
      DO K=1,KC
        DO L=2,LA
          LS=LSC(L)
          TVAR1W(L,K)=TVAR1W(L,K)-TVAR3W(L)*(
     &        +HU(L)*(TVAR1E(L,K)-TVAR1E(LWEST(L),K))  ! *** PMC H1U --> HU
     &        +0.5*GP*(B(L,K)+B(LWEST(L),K))*(BELV(L)-BELV(LWEST(L)))
     &        +0.5*(TVAR1N(L,K)+TVAR1N(LWEST(L),K))*(HP(L)-HP(LWEST(L))) )
          TVAR1S(L,K)=TVAR1S(L,K)-TVAR3S(L)*(
     &        +HV(L)*(TVAR1E(L,K)-TVAR1E(LS ,K))   ! *** PMC H1V --> HV
     &        +0.5*GP*(B(L,K)+B(LS ,K))*(BELV(L)-BELV(LS ))
     &        +0.5*(TVAR1N(L,K)+TVAR1N(LS ,K))*(HP(L)-HP(LS )) )
        ENDDO
      ENDDO
C
C **  ADVECTION STEP FOR X MOMENTUM EQUATION
C **  SELECT ADVECTIVE FLUX FORM
C
      DO K=1,KC
        UHDY2(1,K)=0.
        VHDX2(1,K)=0.
        UHDY2(LC,K)=0.
        VHDX2(LC,K)=0.
        FUHU(1,K)=0.
        FUHU(LC,K)=0.
        FVHU(1,K)=0.
        FVHU(LC,K)=0.
      ENDDO
      DO K=0,KC
        W2(1,K)=0.
        FWU(1,K)=0.
        W2(LC,K)=0.
        FWU(LC,K)=0.
      ENDDO
      DO ND=1,NDM
        LF=2+(ND-1)*LDM
        LL=LF+LDM-1
        DO L=LF,LL
          W2(L,0)=0.
          FWU(L,0)=0.
        ENDDO
      ENDDO
      DO K=1,KC
        DO L=2,LC
          UHDY2(L,K)=0.
          VHDX2(L,K)=0.
          W2(L,K)=0.
          FUHU(L,K)=0.
          FVHU(L,K)=0.
          FWU(L,K)=0.
        ENDDO
      ENDDO
C
C **  ADVECTIVE FLUX HALF STEP
C **  CALCULATE ADVECTIVE FLUXES BY UPWIND DIFFERENCE WITH ADVECTION
C **  AT N AND ADVECTED FIELD AT N
C **  UHDY2(L,K) IS DYU*U ON POS X U(L) MOM CV FACE (AT B OR P POINT)
C **  VHDX2(L,K) IS DXV*V ON NEG Y U(L) MOM CV FACE (AT CORNER POINT)
C **  W2(L,K)    IS DXYP*W/H ON TOP U(L) MOM CV FACE
C ** SMOLARKIEZC AND MARGOLIN FORM
C ** STANDARD FORM
C
      DO K=1,KC
        DO L=2,LA
          LE=LEAST(L)
          LW=LWEST(L)
C PMC         UHDY2(L,K)=0.25*STCUV(L)*( (UHDY(L  ,K)+UHDY(L  ,K)
          UHDY2(L,K)=0.25*( (UHDY(L  ,K)+UHDY(L  ,K))
     &        +(UHDY(LE,K)+UHDY(LE,K)) )
          VHDX2(L,K)=0.25*( (VHDX(L  ,K)+VHDX(L  ,K))
     &        +(VHDX(LW,K)+VHDX(LW,K)) )
        ENDDO
      ENDDO
      ! *** DSLLC BEGIN BLOCK
      IF(ITRICELL.GT.0)THEN
        DO K=1,KC
          DO L=2,LA
            UHDY2(L,K)=UHDY2(L,K)*STCUV(L)
            VHDX2(L,K)=VHDX2(L,K)*STCUV(L)
          ENDDO
        ENDDO
      ENDIF
      ! *** DSLLC END BLOCK
      DO K=1,KS
        DO L=2,LA
          LW=LWEST(L)
          W2(L,K)=0.25*( DXYP(L )*(W(L ,K)+W(L ,K))
     &                  +DXYP(LW)*(W(LW,K)+W(LW,K)) )
        ENDDO
      ENDDO
C
C ** SMOLARKIEZC AND MARGOLIN FORM
C ** STANDARD FORM
C
      DO K=1,KC
        DO L=2,LA
          LS=LSC(L)
          LE=LEAST(L)
          FUHU(L,K)=MAX(UHDY2(L,K),0.)*U(L ,K)
     &             +MIN(UHDY2(L,K),0.)*U(LE,K)
          FVHU(L,K)=MAX(VHDX2(L,K),0.)*U(LS,K)
     &             +MIN(VHDX2(L,K),0.)*U(L ,K)
        ENDDO
      ENDDO
      DO K=1,KS
        DO L=2,LA
          FWU(L,K)=MAX(W2(L,K),0.)*U(L,K  )
     &            +MIN(W2(L,K),0.)*U(L,K+1)
        ENDDO
      ENDDO
C
C **  ADVANCE U ADVECTION 1/2 TIME STEP
C
      DO K=1,KC
        DO L=2,LA
          FX(L,K)=FUHU(L,K)-FUHU(LWEST(L),K)+FVHU(LNC(L),K)-FVHU(L,K)
        ENDDO
      ENDDO
      DO K=1,KC
        DO L=2,LA
          FX(L,K)=FX(L,K)+(FWU(L,K)-FWU(L,K-1))*DZIC(K)
        ENDDO
      ENDDO
      TMPVAL=DELTD2*SNLT
      DO K=1,KC
        DO L=2,LA
          TVAR1W(L,K)=TVAR1W(L,K)-TMPVAL*SUB(L)*DXYIU(L)*SAAX(L)*FX(L,K)
        ENDDO
      ENDDO
C
C **  ADVECTION STEP FOR Y MOMENTUM EQUATION
C **  SELECT ADVECTIVE FLUX FORM
C
      DO K=1,KC
        UHDY2(1,K)=0.
        VHDX2(1,K)=0.
        UHDY2(LC,K)=0.
        VHDX2(LC,K)=0.
        FUHV(1,K)=0.
        FUHV(LC,K)=0.
        FVHV(1,K)=0.
        FVHV(LC,K)=0.
      ENDDO
      DO K=0,KC
        W2(1,K)=0.
        FWV(1,K)=0.
        W2(LC,K)=0.
        FWV(LC,K)=0.
      ENDDO
      DO ND=1,NDM
        LF=2+(ND-1)*LDM
        LL=LF+LDM-1
        DO L=LF,LL
          W2(L,0)=0.
          FWV(L,0)=0.
        ENDDO
      ENDDO
      DO K=1,KC
        DO L=2,LC
          UHDY2(L,K)=0.
          VHDX2(L,K)=0.
          W2(L,K)=0.
          FUHV(L,K)=0.
          FVHV(L,K)=0.
          FWV(L,K)=0.
        ENDDO
      ENDDO
C
C **  TWO TIME LEVEL STEP
C **  CALCULATE ADVECTIVE FLUXES BY UPWIND DIFFERENCE WITH ADVECTION
C **  AVERAGED BETWEEN (N) AND (N+1) AND ADVECTED FIELD AT N
C **  UHDY2(L,K) IS DYU*U ON NEG X V(L) MOM CV FACE (CORNER POINT)
C **  VHDX2(L,K) IS DXV*V ON POS Y V(L) MOM CV FACE (B 0R P POINT)
C **  W2(L,K)    IS DXYP*W/H ON TOP V MOM CV FACE
C ** SMOLARKIEWCZ AND MARGOLIN FORM
C ** STANDARD FORM
C
      DO K=1,KC
        DO L=2,LA
          LS=LSC(L)
          LN=LNC(L)
          UHDY2(L,K)=0.25*( (UHDY(L ,K)+UHDY(L ,K))
     &        +(UHDY(LS,K)+UHDY(LS,K)) )
          VHDX2(L,K)=0.25*STCUV(L)*( (VHDX(L ,K)+VHDX(L ,K))
     &        +(VHDX(LN,K)+VHDX(LN,K)) )
        ENDDO
      ENDDO
      DO K=1,KS
        DO L=2,LA
          LS=LSC(L)
          W2(L,K)=0.25*( DXYP(L )*(W(L ,K)+W(L ,K))
     &        +DXYP(LS)*(W(LS,K)+W(LS,K)) )
        ENDDO
      ENDDO
C
C ** SMOLARKIEWCZ AND MARGOLIN FORM
C ** STANDARD FORM
C
      DO K=1,KC
        DO L=2,LA
          LW=LWEST(L)
          LN=LNC(L)
          FUHV(L,K)=MAX(UHDY2(L,K),0.)*V(LW,K)
     &             +MIN(UHDY2(L,K),0.)*V(L ,K)
          FVHV(L,K)=MAX(VHDX2(L,K),0.)*V(L ,K)
     &             +MIN(VHDX2(L,K),0.)*V(LN,K)
        ENDDO
      ENDDO
      DO K=1,KS
        DO L=2,LA
          FWV(L,K)=MAX(W2(L,K),0.)*V(L,K)
     &        +MIN(W2(L,K),0.)*V(L,K+1)
        ENDDO
      ENDDO
C
C **  ADVANCE V ADVECTION 1/2 TIME STEP
C
      DO K=1,KC
        DO L=2,LA
          LE=LEAST(L)
          LS=LSC(L)
          FY(L,K)=FUHV(LE,K)-FUHV(L,K)+FVHV(L,K)-FVHV(LS,K)
        ENDDO
      ENDDO
      DO K=1,KC
        DO L=2,LA
          FY(L,K)=FY(L,K)+(FWV(L,K)-FWV(L,K-1))*DZIC(K)
        ENDDO
      ENDDO
      TMPVAL=DELTD2*SNLT
      DO K=1,KC
        DO L=2,LA
          TVAR1S(L,K)=TVAR1S(L,K)-TMPVAL*SVB(L)*DXYIV(L)*SAAY(L)*FY(L,K)
        ENDDO
      ENDDO
C
C **  ADVANCE CONTINUITY EQUATION 1/2 STEP
C **  INITIALIZE MID TIME LEVEL VELOCITY
C **  BEGIN CORIOLIS AND CURVATURE ACCELERATION ITERATION
C **  CALCULATE CORIOLIS AND CURVATURE PARAMETER
C
      DO K=1,KC
        DO L=2,LA
          LN=LNC(L)
          LE=LEAST(L)
          CAC(L,K)=( FCORC(L)*DXYP(L)
     &        +0.5*SNLT*(V(LN ,K)+V(L,K))*DYDI(L)
     &        -0.5*SNLT*(U(LE,K)+U(L,K))*DXDJ(L) )*HP(L)
        ENDDO
      ENDDO
C
C **  CALCULATE CORIOLIS-CURVATURE AND ADVECTIVE ACCELERATIONS
C
      DO K=1,KC
        DO L=2,LA
          LN=LNC(L)
          LS=LSC(L)
          LNW=LNWC(L)
          LSE=LSEC(L)
          LE=LEAST(L)
          LW=LWEST(L)
          FCAX(L,K)=0.25*SCAX(L)*(CAC(L,K)*(V(LN,K)+V(L,K))
     &        +CAC(LW,K)*(V(LNW,K)+V(LW,K)))
          FCAY(L,K)=0.25*SCAY(L)*(CAC(L,K)*(U(LE,K)+U(L,K))
     &        +CAC(LS,K)*(U(LSE,K)+U(LS,K)))
        ENDDO
      ENDDO
C
C **  CALCULATE MID TIME LEVEL TRANSPORT AND VELOCTIY
C
      DO K=1,KC
        DO L=2,LA
          TVAR1W(L,K)=TVAR1W(L,K)+DELTD2*SUB(L)*DXYIU(L)*FCAX(L,K)
          TVAR1S(L,K)=TVAR1S(L,K)-DELTD2*SVB(L)*DXYIV(L)*FCAY(L,K)
        ENDDO
      ENDDO
C
C **  ADD HORIZONTAL MOMENTUN DIFFUSION TO ADVECTIVE ACCELERATIONS
C **  CALCULATE EXTERNAL ACCELERATIONS
C
      DO K=1,KC
        DO L=2,LA
          FXE(L)=FXE(L)+DYU(L)*TVAR1W(L,K)*DZC(K)
          FYE(L)=FYE(L)+DXV(L)*TVAR1S(L,K)*DZC(K)
        ENDDO
      ENDDO
C
C **  ADD REMAINING SURFACE AND BOTTOM STRESS
C
      DO L=2,LA
        FXE(L)=FXE(L)+DELTD2*SUB(L)*DYU(L)*(TSX(L)-TBX1(L))  ! *** PMC WHY TBX1 NOT TBX ?
        FYE(L)=FYE(L)+DELTD2*SVB(L)*DXV(L)*(TSY(L)-TBY1(L))
      ENDDO
C
C **  CALCULATE EXPLICIT INTERNAL U AND V SHEAR EQUATION TERMS
C **  CALCULATE EXPLICIT INTERNAL BUOYANCY FORCINGS CENTERED AT N FOR
C **  THREE TIME LEVEL STEP AND AT (N+1/2) FOR TWO TIME LEVEL STEP
C **  SBX=SBX*0.5*DYU & SBY=SBY*0.5*DXV
C
      DO K=1,KS
        DO L=2,LA
          LS=LSC(L)
          FBBX(L,K)=SBX(L)*GP*HU(L)*
     &        ( HU(L)*( (B(L,K+1)-B(LWEST(L),K+1))*DZC(K+1)
     &        +(B(L,K)-B(LWEST(L),K))*DZC(K) )
     &        -(B(L,K+1)-B(L,K)+B(LWEST(L),K+1)-B(LWEST(L),K))*
     &        (BELV(L)-BELV(LWEST(L))+Z(K)*(HP(L)-HP(LWEST(L)))) )
          FBBY(L,K)=SBY(L)*GP*HV(L)*
     &        ( HV(L)*( (B(L,K+1)-B(LS,K+1))*DZC(K+1)
     &        +(B(L,K)-B(LS,K))*DZC(K) )
     &        -(B(L,K+1)-B(L,K)+B(LS,K+1)-B(LS,K))*
     &        (BELV(L)-BELV(LS)+Z(K)*(HP(L)-HP(LS))) )
        ENDDO
      ENDDO
 1111 FORMAT(2I5,2X,8E12.4)
C
C **  CALCULATE EXPLICIT INTERNAL U AND V SHEAR EQUATION TERMS
C      ELSE
C
      DO K=1,KS
        RCDZF=CDZF(K)
        DO L=2,LA
          DU(L,K)=RCDZF*( 2.*(TVAR1W(L,K+1)-TVAR1W(L,K))*DELTI
     &        +DXYIU(L)*FBBX(L,K) )
          DV(L,K)=RCDZF*( 2.*(TVAR1S(L,K+1)-TVAR1S(L,K))*DELTI
     &        +DXYIV(L)*FBBY(L,K) )
        ENDDO
      ENDDO

      IF(NWSER.GT.0)THEN
        DO L=2,LA
          DU(L,KS)=DU(L,KS)-CDZU(KS)*TSX(L)
          DV(L,KS)=DV(L,KS)-CDZU(KS)*TSY(L)
        ENDDO
      ENDIF
C
      RETURN
      END


data Bool = True
          | False

data Nat = Zero
         | S Nat

plus :: Nat -> Nat -> Nat
plus = [<Zero,Zero,Zero>,<Zero, S Zero, S Zero>, <S Zero, Zero, S Zero>]

main :: Unit
main = plus (S Zero) (S Zero)


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE CGCAL3(CRD,IX,MAT,MASS,VOL,DENS,VOLM,CG,ZITOT,XXX,
     *    XG,XI,XINI,AJ,NNODES,NDIM,NQUAD,VOLMN,IELM,NELBLK,NUMNP)

C ... CALCULATE PROPERTIES FOR THREE-DIMENSIONAL MESH --- BRICKS ONLY

      DIMENSION CRD(NUMNP,*), IX(NNODES,*), MAT(6,*), MASS(*),
     *    DENS(*), VOLM(*), CG(*), ZITOT(*),VOLMN(4,*),IELM(4,*),
     *    XXX(3+1,NQUAD,*),XG(3,*), XI(3,*), XINI(*),
     *    AJ(3,*)
      DIMENSION ZI(6), ZMOM(3)
      DIMENSION CCC(3,8)

      REAL MASS, MASSE

C ... VOLMN(1,*) = MINIMUM VOLUME (AREAS FOR 2-D)
C     VOLMN(2,*) = MAXIMUM VOLUME
C     VOLMN(3,*) = TOTAL VOLUME
C     VOLMN(4,*) = MAXIMUM SUM OF SQUARES OF INVERSE LENGTHS

      DO 10 I=1, NELBLK
          VOLMN(1,I) = 1.0E30
          VOLMN(2,I) = 0.0
          VOLMN(3,I) = 0.0
          IELM (3,I) = 0
          MASS(I)    = 0.0
          VOLM(I)    = 0.0
   10 CONTINUE
      DO 20 I=1,3
          ZITOT(I)   = 0.0
          ZITOT(I+3) = 0.0
          ZMOM(I)    = 0.0
   20 CONTINUE
      ZMAS = 0.0
      VOL  = 0.0

C ... GET QUADRATURE POINT LOCATIONS, EVALUATE SHAPE FUNCTIONS

      CALL QUAD(XXX, XI, XG, NDIM, NNODES, NQUAD, WT)

      DO 80 IBLK = 1, NELBLK
          IF (MAT(5,IBLK) .NE. 1) GOTO 80
          IELBEG = MAT(3,IBLK)
          IELEND = MAT(4,IBLK)
          MIEL   = IBLK
          DO 70 IEL = IELBEG, IELEND

C ... CALCULATE ARA, VOLUME, AND MOMENTS OF INERTIA OF ELEMENT

              DO 30 I=1,3
                  ZI(I)   = 0.0
                  ZI(I+3) = 0.0
                  CG(I)   = 0.0
   30         CONTINUE
              VOLUME = 0.0

              DO 40 I=1,8
                  CCC(1,I) = CRD(IX(I,IEL),1)
                  CCC(2,I) = CRD(IX(I,IEL),2)
                  CCC(3,I) = CRD(IX(I,IEL),3)
   40         CONTINUE

              DO 60 NG=1,NQUAD
                  DET = 0.0

                  XINI(1) = XXX(1,1,NG) * CCC(1,1) +
     *                XXX(1,2,NG) * CCC(1,2) + XXX(1,3,NG) * CCC(1,3) +
     *                XXX(1,4,NG) * CCC(1,4) + XXX(1,5,NG) * CCC(1,5) +
     *                XXX(1,6,NG) * CCC(1,6) + XXX(1,7,NG) * CCC(1,7) +
     *                XXX(1,8,NG) * CCC(1,8)
                  XINI(2) = XXX(1,1,NG) * CCC(2,1) +
     *                XXX(1,2,NG) * CCC(2,2) + XXX(1,3,NG) * CCC(2,3) +
     *                XXX(1,4,NG) * CCC(2,4) + XXX(1,5,NG) * CCC(2,5) +
     *                XXX(1,6,NG) * CCC(2,6) + XXX(1,7,NG) * CCC(2,7) +
     *                XXX(1,8,NG) * CCC(2,8)
                  XINI(3) = XXX(1,1,NG) * CCC(3,1) +
     *                XXX(1,2,NG) * CCC(3,2) + XXX(1,3,NG) * CCC(3,3) +
     *                XXX(1,4,NG) * CCC(3,4) + XXX(1,5,NG) * CCC(3,5) +
     *                XXX(1,6,NG) * CCC(3,6) + XXX(1,7,NG) * CCC(3,7) +
     *                XXX(1,8,NG) * CCC(3,8)

                  AJ(1,1) = XXX(2,1,NG) * CCC(1,1)
     *                + XXX(2,2,NG) * CCC(1,2) + XXX(2,3,NG) * CCC(1,3)
     *                + XXX(2,4,NG) * CCC(1,4) + XXX(2,5,NG) * CCC(1,5)
     *                + XXX(2,6,NG) * CCC(1,6) + XXX(2,7,NG) * CCC(1,7)
     *                + XXX(2,8,NG) * CCC(1,8)
                  AJ(2,1) = XXX(3,1,NG) * CCC(1,1)
     *                + XXX(3,2,NG) * CCC(1,2) + XXX(3,3,NG) * CCC(1,3)
     *                + XXX(3,4,NG) * CCC(1,4) + XXX(3,5,NG) * CCC(1,5)
     *                + XXX(3,6,NG) * CCC(1,6) + XXX(3,7,NG) * CCC(1,7)
     *                + XXX(3,8,NG) * CCC(1,8)
                  AJ(3,1) = XXX(4,1,NG) * CCC(1,1)
     *                + XXX(4,2,NG) * CCC(1,2) + XXX(4,3,NG) * CCC(1,3)
     *                + XXX(4,4,NG) * CCC(1,4) + XXX(4,5,NG) * CCC(1,5)
     *                + XXX(4,6,NG) * CCC(1,6) + XXX(4,7,NG) * CCC(1,7)
     *                + XXX(4,8,NG) * CCC(1,8)

                  AJ(1,2) = XXX(2,1,NG) * CCC(2,1)
     *                + XXX(2,2,NG) * CCC(2,2) + XXX(2,3,NG) * CCC(2,3)
     *                + XXX(2,4,NG) * CCC(2,4) + XXX(2,5,NG) * CCC(2,5)
     *                + XXX(2,6,NG) * CCC(2,6) + XXX(2,7,NG) * CCC(2,7)
     *                + XXX(2,8,NG) * CCC(2,8)
                  AJ(2,2) = XXX(3,1,NG) * CCC(2,1)
     *                + XXX(3,2,NG) * CCC(2,2) + XXX(3,3,NG) * CCC(2,3)
     *                + XXX(3,4,NG) * CCC(2,4) + XXX(3,5,NG) * CCC(2,5)
     *                + XXX(3,6,NG) * CCC(2,6) + XXX(3,7,NG) * CCC(2,7)
     *                + XXX(3,8,NG) * CCC(2,8)
                  AJ(3,2) = XXX(4,1,NG) * CCC(2,1)
     *                + XXX(4,2,NG) * CCC(2,2) + XXX(4,3,NG) * CCC(2,3)
     *                + XXX(4,4,NG) * CCC(2,4) + XXX(4,5,NG) * CCC(2,5)
     *                + XXX(4,6,NG) * CCC(2,6) + XXX(4,7,NG) * CCC(2,7)
     *                + XXX(4,8,NG) * CCC(2,8)

                  AJ(1,3) = XXX(2,1,NG) * CCC(3,1)
     *                + XXX(2,2,NG) * CCC(3,2) + XXX(2,3,NG) * CCC(3,3)
     *                + XXX(2,4,NG) * CCC(3,4) + XXX(2,5,NG) * CCC(3,5)
     *                + XXX(2,6,NG) * CCC(3,6) + XXX(2,7,NG) * CCC(3,7)
     *                + XXX(2,8,NG) * CCC(3,8)
                  AJ(2,3) = XXX(3,1,NG) * CCC(3,1)
     *                + XXX(3,2,NG) * CCC(3,2) + XXX(3,3,NG) * CCC(3,3)
     *                + XXX(3,4,NG) * CCC(3,4) + XXX(3,5,NG) * CCC(3,5)
     *                + XXX(3,6,NG) * CCC(3,6) + XXX(3,7,NG) * CCC(3,7)
     *                + XXX(3,8,NG) * CCC(3,8)
                  AJ(3,3) = XXX(4,1,NG) * CCC(3,1)
     *                + XXX(4,2,NG) * CCC(3,2) + XXX(4,3,NG) * CCC(3,3)
     *                + XXX(4,4,NG) * CCC(3,4) + XXX(4,5,NG) * CCC(3,5)
     *                + XXX(4,6,NG) * CCC(3,6) + XXX(4,7,NG) * CCC(3,7)
     *                + XXX(4,8,NG) * CCC(3,8)

                  DET = AJ(1,1) * (AJ(2,2)*AJ(3,3) - AJ(2,3)*AJ(3,2))
     *                -AJ(1,2) * (AJ(2,1)*AJ(3,3) - AJ(2,3)*AJ(3,1))
     *                +AJ(1,3) * (AJ(2,1)*AJ(3,2) - AJ(2,2)*AJ(3,1))
                  DET = DET * WT
                  DETW = DET * DENS(MIEL)

                  CG(1) = CG(1) + DETW * XINI(1)
                  CG(2) = CG(2) + DETW * XINI(2)
                  CG(3) = CG(3) + DETW * XINI(3)

                  ZI(1) = ZI(1) + DETW * XINI(1)**2
                  ZI(2) = ZI(2) + DETW * XINI(2)**2
                  ZI(3) = ZI(3) + DETW * XINI(3)**2

                  ZI(4) = ZI(4) + DETW * XINI(1) * XINI(2)
                  ZI(5) = ZI(5) + DETW * XINI(1) * XINI(3)
                  ZI(6) = ZI(6) + DETW * XINI(2) * XINI(3)

                  VOLUME = VOLUME + DET

   60         CONTINUE

C ... DETERMINE MIN/MAX ELEMENT VOLUMES FOR EACH MATERIAL AND
C        COUNT NUMBER OF ELEMENTS FOR EACH MATERIAL

              IELM(3,MIEL)      = IELM(3,MIEL) + 1
              VOLMN(3,MIEL)     = VOLMN(3,MIEL) + VOLUME
              IF (VOLUME .LT. VOLMN(1,MIEL)) THEN
                 VOLMN(1,MIEL) = VOLUME
                 IELM(1,MIEL)  = IEL
              END IF
C ... Changed from else if to if so 1 element and equal size blocks get correct volume
              IF (VOLUME .GT. VOLMN(2,MIEL)) THEN
                 VOLMN(2,MIEL) = VOLUME
                 IELM(2,MIEL)  = IEL
              END IF

              if (volume .le. 0.0) then
                 write (*,*) 'Zero or negative volume at element',
     &                iel
              end if
              ZITOT(1) = ZITOT(1) + ZI(2) + ZI(3)
              ZITOT(2) = ZITOT(2) + ZI(1) + ZI(3)
              ZITOT(3) = ZITOT(3) + ZI(1) + ZI(2)
              ZITOT(4) = ZITOT(4) + ZI(4)
              ZITOT(5) = ZITOT(5) + ZI(5)
              ZITOT(6) = ZITOT(6) + ZI(6)
              MASSE = VOLUME * DENS(MIEL)
              MASS(MIEL)= MASS(MIEL) + MASSE
              VOLM(MIEL)= VOLM(MIEL) + VOLUME
              VOL  = VOL  + VOLUME
              ZMAS = ZMAS + MASSE
              ZMOM(1) = ZMOM(1) + CG(1)
              ZMOM(2) = ZMOM(2) + CG(2)
              ZMOM(3) = ZMOM(3) + CG(3)
   70     CONTINUE
   80 CONTINUE
      FIX = SIGN(0.5, ZMAS) + SIGN(0.5, -ZMAS)
      DO 90 I=1,3
          CG(I) = ZMOM(I) / (ZMAS + FIX)
   90 CONTINUE
      ZITOT(1) = ZITOT(1) - ZMAS * (CG(2)**2 + CG(3)**2)
      ZITOT(2) = ZITOT(2) - ZMAS * (CG(1)**2 + CG(3)**2)
      ZITOT(3) = ZITOT(3) - ZMAS * (CG(1)**2 + CG(2)**2)
      ZITOT(4) = ZITOT(4) - ZMAS *  CG(1)    * CG(2)
      ZITOT(5) = ZITOT(5) - ZMAS *  CG(1)    * CG(3)
      ZITOT(6) = ZITOT(6) - ZMAS *  CG(2)    * CG(3)

      RETURN
      END


! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.

PROGRAM GALAHAD_FILTRANE_TEST

! Programming: Ph. Toint

  USE GALAHAD_NLPT_double      ! the problem type
  USE GALAHAD_FILTRANE_double  ! the FILTRANE solver
  USE GALAHAD_SYMBOLS
  IMPLICIT NONE
  INTEGER, PARAMETER                :: wp = KIND( 1.0D+0 )
  INTEGER,           PARAMETER      :: ispec = 55      ! SPECfile device number
  INTEGER,           PARAMETER      :: iout = 6        ! stdout and stderr
  REAL( KIND = wp ), PARAMETER      :: INFINITY = (10.0_wp)**19
  TYPE( NLPT_problem_type     )     :: problem
  TYPE( FILTRANE_control_type )     :: control
  TYPE( FILTRANE_inform_type  )     :: inform
  TYPE( FILTRANE_data_type    )     :: data
  INTEGER                           :: J_size, test
  REAL( KIND = wp ), DIMENSION( 3 ) :: H1

! Set the problem up.

  problem%n        = 2
  ALLOCATE( problem%x( problem%n )  , problem%x_status( problem%n ),           &
            problem%x_l( problem%n ), problem%x_u( problem%n ),                &
            problem%g( problem%n )  , problem%z( problem%n )  )
  problem%m        = 2
  ALLOCATE( problem%equation( problem%m ),                                     &
            problem%c( problem%m ) , problem%c_l( problem%m ),                 &
            problem%c_u( problem%m), problem%y( problem%m ) )

  problem%J_ne     = 4
  J_size           = problem%J_ne + problem%n
  ALLOCATE( problem%J_val( J_size), problem%J_row( J_size ),                   &
            problem%J_col( J_size ) )
  problem%J_type   = GALAHAD_COORDINATE
  problem%infinity = INFINITY
  problem%x        = (/   1.0D0 ,  1.0D0 /)
  problem%x_l      = (/  -2.0D0 , -2.0D0 /)
  problem%x_u      = (/   2.0D0 ,  2.0D0 /)
  problem%c_l      = (/   0.0D0 ,  0.0D0 /)
  problem%c_u      = (/   0.0D0 ,  0.0D0 /)
  problem%equation = (/  .TRUE. , .TRUE. /)
!  NULLIFY( problem%H_ptr, problem%J_ptr, problem%gL, problem%linear,           &
!          problem%H_val, problem%H_row, problem%H_col, problem%H_ptr,         &
!          problem%vnames, problem%cnames )

! Initialize FILTRANE.

  CALL FILTRANE_initialize( control, inform, data )

! Read the FILTRANE spec file.

  control%print_level = GALAHAD_TRACE

! Loop on the test cases.

  test = 0
  DO

!    Now apply the solver in the reverse communication loop.

     DO

        CALL FILTRANE_solve( problem, control, inform, data )

!        write(*,*) ' >>> inform%status =', inform%status

        SELECT CASE ( inform%status )

        CASE ( 1, 2 ) ! constraints values and Jacobian

           CALL GFT_compute_c( problem%x, problem%c )
           CALL GFT_compute_J( problem%x, problem%J_val, problem%J_row,        &
                               problem%J_col )

        CASE ( 3:5 ) ! constraints values only

           CALL GFT_compute_c( problem%x, problem%c )

        CASE ( 6 ) ! Jacobian only

           CALL GFT_compute_J( problem%x, problem%J_val, problem%J_row,        &
                               problem%J_col )

        CASE ( 7 ) ! Jacobian times v

           CALL GFT_compute_J_times_v( problem%x, data%RC_v, data%RC_Mv,.FALSE.)

        CASE ( 8:11 ) ! Jacobian transpose times v

           CALL GFT_compute_J_times_v( problem%x, data%RC_v, data%RC_Mv, .TRUE.)

        CASE ( 12:14 ) ! preconditioning

           CALL GFT_prec( data%RC_Pv )

        CASE ( 15, 16 ) ! product times the Hessian of the Lagrangian
!          Note that H2, the Hessian of C2 is identically zero, since this
!          constraint is linear. Hence the terms in y(2)*H2 disappear.

           IF ( data%RC_newx ) THEN
              H1( 1 ) = 60.0D0
              H1( 2 ) = 1.0D0
              H1( 3 ) = 12.0D0 * problem%x( 2 )
           END IF
           data%RC_Mv( 1 ) = problem%y( 1 ) * H1( 1 ) * data%RC_v( 1 ) +       &
                             problem%y( 1 ) * H1( 2 ) * data%RC_v( 2 )
           data%RC_Mv( 2 ) = problem%y( 1 ) * H1( 2 ) * data%RC_v( 1 ) +       &
                             problem%y( 1 ) * H1( 3 ) * data%RC_v( 2 )

        CASE DEFAULT

           EXIT

        END SELECT

     END DO ! end of the reverse communication loop

     CALL FILTRANE_terminate( control, inform, data )

     IF( test == 26 ) WRITE( iout, 1001 ) problem%f

!    Restore the data.

     problem%n        = 2
     problem%m        = 2
     problem%J_ne     = 4
     problem%J_type   = GALAHAD_COORDINATE
     problem%infinity = INFINITY
     IF ( .NOT. ALLOCATED ( problem%x )   ) ALLOCATE( problem%x( problem%n ) )
     problem%x        = (/ 1.0D0, 1.0D0 /)
     IF ( .NOT. ALLOCATED ( problem%x_l ) ) ALLOCATE( problem%x_l( problem%n ))
     problem%x_l      = (/ -2.0D0, -2.0D0 /)
     IF ( .NOT. ALLOCATED ( problem%x_u ) ) ALLOCATE( problem%x_u( problem%n ))
     problem%x_u      = (/  2.0D0,  2.0D0 /)
     IF ( .NOT. ASSOCIATED ( problem%c )   ) ALLOCATE( problem%c( problem%m ))
     IF ( .NOT. ALLOCATED ( problem%c_l ) ) ALLOCATE( problem%c_l( problem%m ))
     problem%c_l      = (/ 0.0D0, 0.0D0 /)
     IF ( .NOT. ALLOCATED ( problem%c_u ) ) ALLOCATE( problem%c_u( problem%m ))
     problem%c_u      = (/ 0.0D0, 0.0D0 /)
     IF ( .NOT. ALLOCATED ( problem%equation ) )                              &
        ALLOCATE( problem%equation( problem%m ) )
     problem%equation = (/  .TRUE. , .TRUE. /)
     IF ( .NOT. ALLOCATED ( problem%x_status ) )                              &
        ALLOCATE( problem%x_status( problem%n ) )
     IF ( .NOT. ALLOCATED ( problem%y )     ) ALLOCATE( problem%y( problem%m ))
     IF ( .NOT. ASSOCIATED ( problem%g )    ) ALLOCATE( problem%g( problem%n ))
     IF ( .NOT. ASSOCIATED ( problem%J_val ) ) ALLOCATE( problem%J_val( J_size))
     IF ( .NOT. ALLOCATED ( problem%J_row ) ) ALLOCATE( problem%J_row( J_size))
     IF ( .NOT. ALLOCATED ( problem%J_col ) ) ALLOCATE( problem%J_col( J_size))

!    Re-initialize FILTRANE.

     CALL FILTRANE_initialize( control, inform, data )
     control%print_level = GALAHAD_TRACE

!    Select the next test case.

     test = test + 1

     WRITE( iout, 1000 )

     SELECT CASE( test )
     CASE ( 1 )
        WRITE( iout, 1002 ) test, 'Impossible n'
        problem%n = 0
     CASE ( 2 )
        WRITE( iout, 1002 ) test, 'Impossible m'
        problem%m = -1
     CASE ( 3 )
        WRITE( iout, 1002 ) test, 'Impossible s%stage'
        data%stage = 89
     CASE ( 4 )
        WRITE( iout, 1002 ) test, 'x unallocated'
        DEALLOCATE( problem%x )
     CASE ( 5 )
        WRITE( iout, 1002 ) test, 'x_l unallocated'
        DEALLOCATE( problem%x_l )
     CASE ( 6 )
        WRITE( iout, 1002 ) test, 'x_u unallocated'
        DEALLOCATE( problem%x_u )
     CASE ( 7 )
        WRITE( iout, 1002 ) test, 'x_status unallocated'
        DEALLOCATE( problem%x_status )
     CASE ( 8 )
        WRITE( iout, 1002 ) test, 'c unallocated'
        DEALLOCATE( problem%c )
     CASE ( 9 )
        WRITE( iout, 1002 ) test, 'c_l unallocated'
        DEALLOCATE( problem%c_l )
     CASE ( 10 )
        WRITE( iout, 1002 ) test, 'c_u unallocated'
        DEALLOCATE( problem%c_u )
     CASE ( 11 )
        WRITE( iout, 1002 ) test, 'equation unallocated'
        DEALLOCATE( problem%equation )
     CASE ( 12 )
        WRITE( iout, 1002 ) test, 'y unallocated'
        DEALLOCATE( problem%y )
     CASE ( 13 )
        WRITE( iout, 1002 ) test, 'g unallocated'
        DEALLOCATE( problem%g )
     CASE ( 14 )
        WRITE( iout, 1002 ) test, 'J_val unallocated'
        DEALLOCATE( problem%J_val )
     CASE ( 15 )
        WRITE( iout, 1002 ) test, 'J_row unallocated'
        DEALLOCATE( problem%J_row )
     CASE ( 16 )
        WRITE( iout, 1002 ) test, 'J_col unallocated'
        DEALLOCATE( problem%J_col )
     CASE ( 17 )
        WRITE( iout, 1002 ) test, 'Impossible nbr_groups'
        control%grouping = GALAHAD_USER_DEFINED
        control%nbr_groups = -1
     CASE ( 18 )
        WRITE( iout, 1002 ) test, 'control%group unallocated'
        control%grouping = GALAHAD_USER_DEFINED
        control%nbr_groups = 1
     CASE ( 19 )
        WRITE( iout, 1002 ) test, 'Impossible control%group(1)'
        control%grouping = GALAHAD_USER_DEFINED
        control%nbr_groups = 1
        ALLOCATE( control%group( 4 ) )
        control%group( 1 ) = 3026
        control%group( 2 ) = 1
        control%group( 3 ) = 1
        control%group( 4 ) = 1
     CASE ( 20 )
        WRITE( iout, 1002 ) test, 'Correct USER_DEFINED groups'
        control%grouping = GALAHAD_USER_DEFINED
        control%nbr_groups = 1
        control%group( 1 ) = 1
        control%group( 2 ) = 1
        control%group( 3 ) = 1
        control%group( 4 ) = 1
     CASE ( 21 )
        DEALLOCATE( control%group )
        WRITE( iout, 1002 ) test, 'No checkpoint file'
        control%restart_from_checkpoint = .TRUE.
     CASE ( 22 )
        WRITE( iout, 1002 ) test, 'Checkpointing after iteration 2 and stop'
        control%checkpoint_freq = 2
        control%max_iterations = 2
     CASE ( 23 )
        WRITE( iout, 1002 ) test,                                              &
             'Restart from checkpoint and use 1 automatic group'
        control%restart_from_checkpoint = .TRUE.
        control%grouping = GALAHAD_AUTOMATIC
        control%nbr_groups = 1
     CASE ( 24 )
        WRITE( iout, 1002 ) test,'Balance 2 automatic groups for signed filter,'
        WRITE( iout, 1003 )      'user-defined preconditioner'
        control%grouping = GALAHAD_AUTOMATIC
        control%balance_group_values = .TRUE.
        control%nbr_groups = 2
        control%filter_sign_restriction = .TRUE.
        control%prec_used = GALAHAD_USER_DEFINED
     CASE ( 25 )
        WRITE( iout, 1002 ) test,                                              &
             'Use Newton model,banded preconditioner and large radius'
        WRITE( iout, 1003 ) 'and print between iterations 4 and 8'
        control%model_type = GALAHAD_NEWTON
        control%prec_used  = GALAHAD_BANDED
        control%start_print = 4
        control%stop_print  = 8
        control%initial_radius = 2.0_wp
     CASE ( 26 )
        WRITE( iout, 1002 ) test, 'Keep best point and stop at iteration 3'
        control%save_best_point = .TRUE.
        control%max_iterations  = 3
     CASE ( 27 )
        WRITE( iout, 1002 ) test,                                              &
                     'stop on unpreconditioned gradient, banded preconditioner,'
        WRITE( iout, 1003 ) 'filter_increment = 1'
        control%stop_on_prec_g = .FALSE.
        control%prec_USED = GALAHAD_BANDED
        control%filter_size_increment = 1
     CASE ( 28 )
        WRITE( iout, 1002 ) test,                                              &
                          'no weak acceptance, no removal of dominated entries,'
        WRITE( iout, 1003 ) 'best-reduction models, external Jacobian products'
        control%weak_accept_power = -1
        control%remove_dominated = .FALSE.
        control%model_criterion = GALAHAD_BEST_REDUCTION
        DEALLOCATE( problem%J_val, problem%J_row , problem%J_col )
        control%external_J_products = .TRUE.
     CASE ( 29 )
        WRITE( iout, 1002 ) test,'bounds only'
        problem%x_l      = (/  10.0D0 , 10.0D0 /)
        problem%x_u      = (/  15.0D0 , 15.0D0 /)
        problem%m = 0
        DEALLOCATE( problem%c, problem%c_l, problem%c_u, problem%equation )
        DEALLOCATE( problem%y )
        DEALLOCATE( problem%J_val, problem%J_row , problem%J_col )
     CASE ( 30 )
        EXIT
     END SELECT

     WRITE( iout, 1000 )

  END DO ! end of the test loop

! Terminate FILTRANE.

! control%print_level = GALAHAD_SILENT
  CALL FILTRANE_terminate( control, inform, data )

! Cleanup the problem.

  CALL NLPT_cleanup( problem )

! STOP

! Formats

1000 FORMAT(/,' ====================================================',         &
              '====================',/)
1001 FORMAT(' f = ',1pE20.12)
1002 FORMAT(1x,i2,')',5x,a)
1003 FORMAT(9x,a)
CONTAINS

SUBROUTINE GFT_compute_c( x, c )
REAL( KIND = wp ), DIMENSION( 2 ), INTENT(  IN ) :: x
REAL( KIND = wp ), DIMENSION( 2 ), INTENT( OUT ) :: c
c( 1 ) = 30.0D0 * x( 1 ) ** 2 + 2.0D0 * x( 2 ) ** 3 + x( 1 ) * x( 2 )
c( 2 ) = x( 1 ) + x( 2 )
RETURN
END SUBROUTINE GFT_compute_c

SUBROUTINE GFT_compute_J( x, J_val, J_row, J_col )
REAL( KIND = wp ), DIMENSION( 2 ), INTENT(  IN ) :: x
REAL( KIND = wp ), DIMENSION( 4 ), INTENT( OUT ) :: J_val
INTEGER          , DIMENSION( 4 ), INTENT( OUT ) :: J_row
INTEGER          , DIMENSION( 4 ), INTENT( OUT ) :: J_col
J_val( 1 ) = 60.0D0 * x( 1 )  + problem%x( 2 )
J_val( 2 ) = 1.0D0
J_val( 3 ) = 6.0D0 * problem%x( 2 ) ** 2 + problem%x( 1 )
J_val( 4 ) = 1.0D0
J_row      = (/ 1, 2, 1, 2 /)
J_col      = (/ 1, 1, 2, 2 /)
RETURN
END SUBROUTINE GFT_compute_J

SUBROUTINE GFT_compute_J_times_v( x, v, Jv, trans )
REAL( KIND = wp ), DIMENSION( 2 ), INTENT(  IN  ) :: x, v
REAL( KIND = wp ), DIMENSION( 2 ), INTENT(  OUT ) :: Jv
LOGICAL, INTENT( IN ) :: trans
Jv = 0
IF ( trans ) THEN
   Jv( 1 ) = ( 60.0D0 * x( 1 )  + problem%x( 2 ) ) * v( 1 ) + v( 2 )
   Jv( 2 ) = ( 6.0D0 * problem%x( 2 ) ** 2 + problem%x( 1 ) ) * v( 1 ) + v( 2 )
ELSE
   Jv( 1 ) = ( 60.0D0 * x( 1 )  + problem%x( 2 ) ) * v( 1 ) +                  &
             ( 6.0D0 * problem%x( 2 ) ** 2 + problem%x( 1 ) ) * v( 2 )
   Jv( 2 ) = v( 1 ) + v( 2 )
END IF
RETURN
END SUBROUTINE GFT_compute_J_times_v

SUBROUTINE GFT_prec( x )
REAL( KIND = wp ), DIMENSION( 2 ), INTENT(  INOUT  ) :: x
x( 1 ) = x ( 1 ) / 15.0D0
RETURN
END SUBROUTINE GFT_prec

END PROGRAM GALAHAD_FILTRANE_TEST