!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!! FEAST general Driver sparse !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!! solving Ax=eBx or Ax=eX      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!! symmetric, hermitian or general matrices !!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!! single or double precision !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!! where A (and B if any), provided by user in coordinate format !!!!
!!!!!!! by Eric Polizzi- 2009-2015  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program pdriver_feast_sparse

  implicit none
  include "mpif.h"

!!!!!!!!!!!!!!!!! Feast declaration variable
  integer,dimension(64) :: fpm
  double precision :: depsout
  real :: sepsout
  integer :: loop

  character(len=100) :: name
  character(len=1) :: UPLO,PRE,SHG,EG
  integer :: n,nnza,nnzb
  real,dimension(:),allocatable :: ssa,ssb,sca,scb
  double precision,dimension(:),allocatable :: dsa,dsb,dca,dcb
  complex,dimension(:),allocatable :: csa,csb,cca,ccb
  complex(kind=kind(1.0d0)),dimension(:),allocatable :: zsa,zsb,zca,zcb
  integer,dimension(:),allocatable :: isa,jsa,isb,jsb,ica,jca,icb,jcb

  double precision :: t1,t2
  integer :: i,j,k,pc
  integer :: M0,M,info
  character(len=1) :: cc

  double precision :: dEmin,dEmax,dr
  complex(kind=kind(1.0d0)):: zEmid
  complex:: cEmid
  real :: sEmin,sEmax,sr
  double precision:: drea,dimg
  real:: srea,simg

  double precision,dimension(:,:),allocatable :: dX
  real,dimension(:,:),allocatable :: sX
  complex,dimension(:,:),allocatable :: cX
  complex(kind=kind(1.0d0)),dimension(:,:),allocatable :: zX

  double precision,dimension(:),allocatable :: dres
  real,dimension(:),allocatable :: sres

  double precision,dimension(:),allocatable :: dE
  real,dimension(:),allocatable :: sE
  complex,dimension(:),allocatable :: cE
  complex(kind=kind(1.0d0)),dimension(:),allocatable :: zE
  integer :: code,rank,nb_procs
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MPI!!!!!!!!!!!!!!!!!!!!
  call MPI_INIT(code)
  call MPI_COMM_SIZE(MPI_COMM_WORLD,nb_procs,code)
  call MPI_COMM_RANK(MPI_COMM_WORLD,rank,code)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!! read main input file !!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  call getarg(1,name)

  call feastinit(fpm)

!!!!!!!!!!!! DRIVER_FEAST_SPARSE input file
  open(10,file=trim(name)//'.in',status='old')
  read(10,*) SHG ! type of eigenvalue problem "General, Hermitian, Symmetric"
  read(10,*) EG ! type of eigenvalue probl  g== sparse generalized, e== sparse standard
  read(10,*) PRE  ! "PRE"==(s,d,c,z) resp. (single real,double real,complex,double complex)
  read(10,*) UPLO ! UPLO==(F,L,U) reps. (Full csr, Lower csr, Upper csr)

  if (SHG=='s') then

     if (PRE=='d') then
        read(10,*) dEmin
        read(10,*) dEmax
     elseif (PRE=='s') then
        read(10,*) sEmin
        read(10,*) sEmax
     elseif (PRE=='z') then
        read(10,*) drea,dimg
        zEmid=drea*(1.0d0,0.0d0)+dimg*(0.0d0,1.0d0)
        read(10,*) dr
     elseif (PRE=='c') then
        read(10,*) srea,simg
        cEmid=srea*(1.0e0,0.0e0)+simg*(0.0e0,1.0e0)
        read(10,*) sr
     end if

  elseif (SHG=='h') then

     if (PRE=='z') then
        read(10,*) dEmin
        read(10,*) dEmax
     else
        read(10,*) sEmin
        read(10,*) sEmax
     end if

  elseif (SHG=='g') then

     if ((PRE=='d').or.(PRE=='z')) then
        read(10,*) drea,dimg
        zEmid=drea*(1.0d0,0.0d0)+dimg*(0.0d0,1.0d0)
        read(10,*) dr
     else
        read(10,*) srea,simg
        cEmid=srea*(1.0e0,0.0e0)+simg*(0.0e0,1.0e0)
        read(10,*) sr
     end if
  end if

  read(10,*) M0   ! size subspace

  read(10,*) pc ! Some changes from default for fpm
  do i=1,pc
     read(10,*) j,fpm(j)
  enddo

  close(10)

!!!!!!!!!!!read matrix A

  open(10,file=trim(name)//'_A.mtx',status='old')
  k=0
  cc='%'
  do while(cc=='%')
     k=k+1
     read(10,'(A1)') cc
  end do
  close(10)

  open(10,file=trim(name)//'_A.mtx',status='old')
  do i=1,k-1
     read(10,'(A1)') cc
  enddo
  read(10,*) n,n,nnza
  allocate(ica(nnza))
  allocate(jca(nnza))
  if (PRE=='s') then
     allocate(sca(nnza))
     do i=1,nnza
        read(10,*) ica(i),jca(i),sca(i)
     end do
  elseif (PRE=='d') then
     allocate(dca(nnza))
     do i=1,nnza
        read(10,*) ica(i),jca(i),dca(i)
     end do
  elseif (PRE=='c') then
     allocate(cca(nnza))
     do i=1,nnza
        read(10,*) ica(i),jca(i),srea,simg
        cca(i)=srea*(1.0e0,0.0e0)+simg*(0.0e0,1.0e0)
     end do
  elseif (PRE=='z') then
     allocate(zca(nnza))
     do i=1,nnza
        read(10,*) ica(i),jca(i),drea,dimg
        zca(i)=drea*(1.0d0,0.0d0)+dimg*(0.0d0,1.0d0)
     end do
  end if
  close(10)

  !! create csr format
  allocate(isa(1:n+1))
  allocate(jsa(1:nnza))

  if (PRE=='s') then
     allocate(ssa(1:nnza))
     call scoo2csr(n,nnza,ica,jca,sca,isa,jsa,ssa)
  elseif (PRE=='d') then
     allocate(dsa(1:nnza))
     call dcoo2csr(n,nnza,ica,jca,dca,isa,jsa,dsa)
  elseif (PRE=='c') then
     allocate(csa(1:nnza))
     call ccoo2csr(n,nnza,ica,jca,cca,isa,jsa,csa)
  elseif (PRE=='z') then
     allocate(zsa(1:nnza))
     call zcoo2csr(n,nnza,ica,jca,zca,isa,jsa,zsa)
  end if

!!!!!!!!!!!read matrix B if any
  if (EG=='g') then

     open(10,file=trim(name)//'_B.mtx',status='old')
     k=0
     cc='%'
     do while(cc=='%')
        k=k+1
        read(10,'(A1)') cc
     end do
     close(10)

     open(10,file=trim(name)//'_B.mtx',status='old')
     do i=1,k-1
        read(10,'(A1)') cc
     enddo
     read(10,*) n,n,nnzb
     allocate(icb(nnzb))
     allocate(jcb(nnzb))
     if (PRE=='s') then
        allocate(scb(nnzb))
        do i=1,nnzb
           read(10,*) icb(i),jcb(i),scb(i)
        end do
     elseif (PRE=='d') then
        allocate(dcb(nnzb))
        do i=1,nnzb
           read(10,*) icb(i),jcb(i),dcb(i)
        end do
     elseif (PRE=='c') then
        allocate(ccb(nnzb))
        do i=1,nnzb
           read(10,*) icb(i),jcb(i),srea,simg
           ccb(i)=srea*(1.0e0,0.0e0)+simg*(0.0e0,1.0e0)
        end do
     elseif (PRE=='z') then
        allocate(zcb(nnzb))
        do i=1,nnzb
           read(10,*) icb(i),jcb(i),drea,dimg
           zcb(i)=drea*(1.0d0,0.0d0)+dimg*(0.0d0,1.0d0)
        end do
     end if
     close(10)

     !! create csr format
     allocate(isb(1:n+1))
     allocate(jsb(1:nnzb))

     if (PRE=='s') then
        allocate(ssb(1:nnzb))
        call scoo2csr(n,nnzb,icb,jcb,scb,isb,jsb,ssb)
     elseif (PRE=='d') then
        allocate(dsb(1:nnzb))
        call dcoo2csr(n,nnzb,icb,jcb,dcb,isb,jsb,dsb)
     elseif (PRE=='c') then
        allocate(csb(1:nnzb))
        call ccoo2csr(n,nnzb,icb,jcb,ccb,isb,jsb,csb)
     elseif (PRE=='z') then
        allocate(zsb(1:nnzb))
        call zcoo2csr(n,nnzb,icb,jcb,zcb,isb,jsb,zsb)
     end if

  end if

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!! INFORMATION ABOUT MATRIX !!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  if (rank==0) then
     print *,'matrix name ',trim(name)
     print *,'matrix -coordinate format- size',n
     print *,'sparse matrix A- nnz',nnza
     if (EG=='g') print *,'sparse matrix B- nnz',nnzb
     print *,''
  endif

  info=-1
  t1=MPI_WTIME()
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!! FEAST  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!  FEAST SYMMETRIC

  if (SHG=='s') then

     if ((PRE=='d').and.(EG=='g')) then
        if (rank==0) print *,'Routine  ','dfeast_scsrgv'
        allocate(dE(1:M0))     ! Eigenvalue
        allocate(dres(1:M0))   ! Residual
        allocate(dX(1:n,1:M0))
        call dfeast_scsrgv(UPLO,N,dsa,isa,jsa,dsb,isb,jsb,fpm,depsout,loop,dEmin,dEmax,M0,dE,dX,M,dres,info)

     elseif  ((PRE=='d').and.(EG=='e')) then
        if (rank==0) print *,'Routine  ','dfeast_scsrev'
        allocate(dE(1:M0))     ! Eigenvalue
        allocate(dres(1:M0))   ! Residual
        allocate(dX(1:n,1:M0))
        call dfeast_scsrev(UPLO,N,dsa,isa,jsa,fpm,depsout,loop,dEmin,dEmax,M0,dE,dX,M,dres,info)

     elseif ((PRE=='s').and.(EG=='g')) then
        if (rank==0) print *,'Routine  ','sfeast_scsrgv'
        allocate(sE(1:M0))     ! Eigenvalue
        allocate(sres(1:M0))   ! Residual
        allocate(sX(1:n,1:M0))
        call sfeast_scsrgv(UPLO,N,ssa,isa,jsa,ssb,isb,jsb,fpm,sepsout,loop,sEmin,sEmax,M0,sE,sX,M,sres,info)

     elseif ((PRE=='s').and.(EG=='e')) then
        if (rank==0) print *,'Routine  ','sfeast_scsrev'
        allocate(sE(1:M0))     ! Eigenvalue
        allocate(sres(1:M0))   ! Residual
        allocate(sX(1:n,1:M0))
        call sfeast_scsrev(UPLO,N,ssa,isa,jsa,fpm,sepsout,loop,sEmin,sEmax,M0,sE,sX,M,sres,info)

     elseif ((PRE=='z').and.(EG=='g')) then
        if (rank==0) print *,'Routine  ','zfeast_scsrgv'
        allocate(zE(1:M0))     ! Eigenvalue
        allocate(dres(1:M0))   ! Residual
        allocate(zX(1:n,1:M0))
        call zfeast_scsrgv(UPLO,N,zsa,isa,jsa,zsb,isb,jsb,fpm,depsout,loop,zEmid,dr,M0,zE,zX,M,dres,info)

     elseif ((PRE=='z').and.(EG=='e')) then
        if (rank==0) print *,'Routine  ','zfeast_scsrev'
        allocate(zE(1:M0))     ! Eigenvalue
        allocate(dres(1:M0))   ! Residual
        allocate(zX(1:n,1:M0))
        call zfeast_scsrev(UPLO,N,zsa,isa,jsa,fpm,depsout,loop,zEmid,dr,M0,zE,zX,M,dres,info)

     elseif ((PRE=='c').and.(EG=='g')) then
        if (rank==0) print *,'Routine  ','cfeast_scsrgv'
        allocate(cE(1:M0))     ! Eigenvalue
        allocate(sres(1:M0))   ! Residual
        allocate(cX(1:n,1:M0))
        call cfeast_scsrgv(UPLO,N,csa,isa,jsa,csb,isb,jsb,fpm,sepsout,loop,cEmid,sr,M0,cE,cX,M,sres,info)

     elseif ((PRE=='c').and.(EG=='e')) then
        if (rank==0) print *,'Routine  ','cfeast_scsrev'
        allocate(cE(1:M0))     ! Eigenvalue
        allocate(sres(1:M0))   ! Residual
        allocate(cX(1:n,1:M0))
        call cfeast_scsrev(UPLO,N,csa,isa,jsa,fpm,sepsout,loop,cEmid,sr,M0,cE,cX,M,sres,info)

     end if

!!!!!!!!!!!!!  FEAST HERMITIAN

  elseif (SHG=='h') then

     if ((PRE=='z').and.(EG=='g')) then
        if (rank==0) print *,'Routine  ','zfeast_hcsrgv'
        allocate(dE(1:M0))     ! Eigenvalue
        allocate(dres(1:M0))   ! Residual
        allocate(zX(1:n,1:M0))
        call zfeast_hcsrgv(UPLO,N,zsa,isa,jsa,zsb,isb,jsb,fpm,depsout,loop,dEmin,dEmax,M0,dE,zX,M,dres,info)

     elseif ((PRE=='z').and.(EG=='e')) then
        if (rank==0) print *,'Routine  ','zfeast_hcsrev'
        allocate(dE(1:M0))     ! Eigenvalue
        allocate(dres(1:M0))   ! Residual
        allocate(zX(1:n,1:M0))
        call zfeast_hcsrev(UPLO,N,zsa,isa,jsa,fpm,depsout,loop,dEmin,dEmax,M0,dE,zX,M,dres,info)

     elseif ((PRE=='c').and.(EG=='g')) then
        if (rank==0) print *,'Routine  ','cfeast_hcsrgv'
        allocate(sE(1:M0))     ! Eigenvalue
        allocate(sres(1:M0))   ! Residual
        allocate(cX(1:n,1:M0))
        call cfeast_hcsrgv(UPLO,N,csa,isa,jsa,csb,isb,jsb,fpm,sepsout,loop,sEmin,sEmax,M0,sE,cX,M,sres,info)

     elseif ((PRE=='c').and.(EG=='e')) then
        if (rank==0) print *,'Routine  ','cfeast_hcsrev'
        allocate(sE(1:M0))     ! Eigenvalue
        allocate(sres(1:M0))   ! Residual
        allocate(cX(1:n,1:M0))
        call cfeast_hcsrev(UPLO,N,csa,isa,jsa,fpm,sepsout,loop,sEmin,sEmax,M0,sE,cX,M,sres,info)

     end if

!!!!!!!!!!!!!  FEAST GENERAL

  elseif (SHG=='g') then

     if ((PRE=='d').and.(EG=='g')) then
        if (rank==0) print *,'Routine  ','dfeast_gcsrgv'
        allocate(zE(1:M0))     ! Eigenvalue
        allocate(dres(1:2*M0))   ! Residual
        allocate(zX(1:n,1:2*M0))
        call dfeast_gcsrgv(N,dsa,isa,jsa,dsb,isb,jsb,fpm,depsout,loop,zEmid,dr,M0,zE,zX,M,dres,info)

     elseif  ((PRE=='d').and.(EG=='e')) then
        if (rank==0) print *,'Routine  ','dfeast_gcsrev'
        allocate(zE(1:M0))     ! Eigenvalue
        allocate(dres(1:2*M0))   ! Residual
        allocate(zX(1:n,1:2*M0))
        call dfeast_gcsrev(N,dsa,isa,jsa,fpm,depsout,loop,zEmid,dr,M0,zE,zX,M,dres,info)

     elseif ((PRE=='s').and.(EG=='g')) then
        if (rank==0) print *,'Routine  ','sfeast_gcsrgv'
        allocate(cE(1:M0))     ! Eigenvalue
        allocate(sres(1:2*M0))   ! Residual
        allocate(cX(1:n,1:2*M0))
        call sfeast_gcsrgv(N,ssa,isa,jsa,ssb,isb,jsb,fpm,sepsout,loop,cEmid,sr,M0,cE,cX,M,sres,info)

     elseif ((PRE=='s').and.(EG=='e')) then
        if (rank==0) print *,'Routine  ','sfeast_gcsrev'
        allocate(cE(1:M0))     ! Eigenvalue
        allocate(sres(1:2*M0))   ! Residual
        allocate(cX(1:n,1:2*M0))
        call sfeast_gcsrev(N,ssa,isa,jsa,fpm,sepsout,loop,cEmid,sr,M0,cE,cX,M,sres,info)

     elseif ((PRE=='z').and.(EG=='g')) then
        if (rank==0) print *,'Routine  ','zfeast_gcsrgv'
        allocate(zE(1:M0))     ! Eigenvalue
        allocate(dres(1:2*M0))   ! Residual
        allocate(zX(1:n,1:2*M0))
        call zfeast_gcsrgv(N,zsa,isa,jsa,zsb,isb,jsb,fpm,depsout,loop,zEmid,dr,M0,zE,zX,M,dres,info)

     elseif ((PRE=='z').and.(EG=='e')) then
        if (rank==0) print *,'Routine  ','zfeast_gcsrev'
        allocate(zE(1:M0))     ! Eigenvalue
        allocate(dres(1:2*M0))   ! Residual
        allocate(zX(1:n,1:2*M0))
        call zfeast_gcsrev(N,zsa,isa,jsa,fpm,depsout,loop,zEmid,dr,M0,zE,zX,M,dres,info)

     elseif ((PRE=='c').and.(EG=='g')) then
        if (rank==0) print *,'Routine  ','cfeast_gcsrgv'
        allocate(cE(1:M0))     ! Eigenvalue
        allocate(sres(1:2*M0))   ! Residual
        allocate(cX(1:n,1:2*M0))
        call cfeast_gcsrgv(N,csa,isa,jsa,csb,isb,jsb,fpm,sepsout,loop,cEmid,sr,M0,cE,cX,M,sres,info)

     elseif ((PRE=='c').and.(EG=='e')) then
        if (rank==0) print *,'Routine  ','cfeast_gcsrev'
        allocate(cE(1:M0))     ! Eigenvalue
        allocate(sres(1:2*M0))   ! Residual
        allocate(cX(1:n,1:2*M0))
        call cfeast_gcsrev(N,csa,isa,jsa,fpm,sepsout,loop,cEmid,sr,M0,cE,cX,M,sres,info)

     end if

  end if

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!! POST-PROCESSING !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  t2=MPI_WTIME()

  if (rank==0) then
     print *,'FEAST OUTPUT INFO',info

     IF ((info==0).or.(info==5).or.(info==6)) then
        print *,'*************************************************'
        print *,'************** REPORT ***************************'
        print *,'*************************************************'

        if (fpm(14)==0) then
           print *,'Eigenvalues/Residuals'

           if (SHG/='g') then
              print *,'inside interval'
              do i=1,M0
                 if ((SHG=='s').and.(PRE=='z')) then
                    print *,i,zE(i),dres(i)
                 elseif ((SHG=='s').and.(PRE=='c')) then
                    print *,i,cE(i),sres(i)
                 elseif ((SHG=='s').and.(PRE=='d')) then
                    print *,i,dE(i),dres(i)
                 elseif ((SHG=='s').and.(PRE=='s')) then
                    print *,i,sE(i),sres(i)
                 elseif ((SHG=='h').and.(PRE=='z')) then
                    print *,i,dE(i),dres(i)
                 elseif ((SHG=='h').and.(PRE=='c')) then
                    print *,i,sE(i),sres(i)
                 end if
                 if (i==M) then
print *,''
print *,'outside interval'
endif
              enddo
           else
              print *,'inside interval'
              do i=1,M0
                 if ((PRE=='s').or.(PRE=='c')) then
                    print *,i,cE(i),sres(i),sres(i+M0)
                 else
                    print *,i,zE(i),dres(i),dres(i+M0)
                 end if
                 if (i==M) then
print *,''
print *,'outside interval'
endif
              enddo

           end if

        elseif (fpm(14)==2) then
           print *,'Running average for estimation (1 -> M0)'
           do i=1,M0
              if ((PRE=='s').or.(PRE=='c')) then
                 print *,i,sres(i)
              else
                 print *,i,dres(i)
              end if
           enddo
        endif

        print *,'------------------------------------'
        print *,'SIMULATION TIME',(t2-t1)*1.0d0

        if ((SHG=='g').or.((SHG=='s').and.((PRE=='c').or.(PRE=='z')))) then
           print *,'# Search interval [Emid,r]'
           if ((PRE=='s').or.(PRE=='c')) then
              print *,cEmid,sr
           else
              print *,zEmid,dr
           end if
        else
           print *,'# Search interval [Emin,Emax]'
           if ((PRE=='s').or.(PRE=='c')) then
              print *,sEmin,sEmax
           else
              print *,dEmin,dEmax
           end if
        end if

        if (fpm(14)==2) then
           print *,'Subspace size M0        ',M0
           print *,'# estimated eigenvalue M',M

        else

           print *,'Subspace size M0    ',M0
           print *,'# eigenvalue found M',M
           print *,'# FEAST iterations  ',loop
           if ((PRE=='s').or.(PRE=='c')) then
              print *,'Relative error on the Trace  ',sepsout
              if (SHG/='g') then
                 print *,'Maximum eigenvector residual ',maxval(sres(1:M))
              else
                 print *,'Maximum eigenvector residuals',maxval(sres(1:M)),maxval(sres(M0+1:M0+M))
              end if
           else
              print *,'Relative error on the Trace  ',depsout
              if (SHG/='g') then
                 print *,'Maximum eigenvector residual ',maxval(dres(1:M))
              else
                 print *,'Maximum eigenvector residuals',maxval(dres(1:M)),maxval(dres(M0+1:M0+M))
              end if
           end if

        end if

     end IF
  end if

  call MPI_FINALIZE(code)

end program pdriver_feast_sparse

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine dcoo2csr(n,nnz,ic,jc,c,isa,jsa,sa)
  implicit none
  integer :: n,nnz
  integer,dimension(*) :: ic,jc,isa,jsa
  double precision,dimension(*) :: c,sa
!!!
  integer :: k,k1,i,j,idum
  integer,dimension(n) :: iloc
  double precision :: adum

  isa(1:N+1) = 0
  !find how many elements in row
  do  k=1, nnz
     isa(ic(k)) = isa(ic(k))+1
  end do

  !build isa
  k = 1
  do  i=1,N+1
     k1 = isa(i)
     isa(i) = k
     k = k+k1
  end do

  iloc(1:n)=isa(1:n)
  !Build jsa, sa - increment local row counter
  do  k=1, nnz
     sa(iloc(ic(k))) =  c(k)
     jsa(iloc(ic(k))) = jc(k)
     iloc(ic(k)) = iloc(ic(k))+1
  end do
  ! Reorder by increasing column
  do i=1,n
     do k=isa(i),isa(i+1)-1
        do k1=k,isa(i+1)-1
           if (jsa(k1)<jsa(k)) then
              idum=jsa(k)
              jsa(k)=jsa(k1)
              jsa(k1)=idum
              adum=sa(k)
              sa(k)=sa(k1)
              sa(k1)=adum
           endif
        enddo
     enddo
  enddo

end subroutine dcoo2csr

subroutine zcoo2csr(n,nnz,ic,jc,c,isa,jsa,sa)
  implicit none
  integer :: n,nnz
  integer,dimension(*) :: ic,jc,isa,jsa
  complex(kind=kind(1.0d0)),dimension(*) :: c,sa
!!!
  integer :: k,k1,i,j,idum
  integer,dimension(n) :: iloc
  complex(kind=kind(1.0d0)):: adum

  isa(1:N+1) = 0
  !find how many elements in row
  do  k=1, nnz
     isa(ic(k)) = isa(ic(k))+1
  end do

  !build isa
  k = 1
  do  i=1,N+1
     k1 = isa(i)
     isa(i) = k
     k = k+k1
  end do

  iloc(1:n)=isa(1:n)
  !Build jsa, sa - increment local row counter
  do  k=1, nnz
     sa(iloc(ic(k))) =  c(k)
     jsa(iloc(ic(k))) = jc(k)
     iloc(ic(k)) = iloc(ic(k))+1
  end do
  ! Reorder by increasing column
  do i=1,n
     do k=isa(i),isa(i+1)-1
        do k1=k,isa(i+1)-1
           if (jsa(k1)<jsa(k)) then
              idum=jsa(k)
              jsa(k)=jsa(k1)
              jsa(k1)=idum
              adum=sa(k)
              sa(k)=sa(k1)
              sa(k1)=adum
           endif
        enddo
     enddo
  enddo

end subroutine zcoo2csr

subroutine scoo2csr(n,nnz,ic,jc,c,isa,jsa,sa)
  implicit none
  integer :: n,nnz
  integer,dimension(*) :: ic,jc,isa,jsa
  real,dimension(*) :: c,sa
!!!
  integer :: k,k1,i,j,idum
  integer,dimension(n) :: iloc
  real :: adum

  isa(1:N+1) = 0
  !find how many elements in row
  do  k=1, nnz
     isa(ic(k)) = isa(ic(k))+1
  end do

  !build isa
  k = 1
  do  i=1,N+1
     k1 = isa(i)
     isa(i) = k
     k = k+k1
  end do

  iloc(1:n)=isa(1:n)
  !Build jsa, sa - increment local row counter
  do  k=1, nnz
     sa(iloc(ic(k))) =  c(k)
     jsa(iloc(ic(k))) = jc(k)
     iloc(ic(k)) = iloc(ic(k))+1
  end do
  ! Reorder by increasing column
  do i=1,n
     do k=isa(i),isa(i+1)-1
        do k1=k,isa(i+1)-1
           if (jsa(k1)<jsa(k)) then
              idum=jsa(k)
              jsa(k)=jsa(k1)
              jsa(k1)=idum
              adum=sa(k)
              sa(k)=sa(k1)
              sa(k1)=adum
           endif
        enddo
     enddo
  enddo

end subroutine scoo2csr

subroutine ccoo2csr(n,nnz,ic,jc,c,isa,jsa,sa)
  implicit none
  integer :: n,nnz
  integer,dimension(*) :: ic,jc,isa,jsa
  complex,dimension(*) :: c,sa
!!!
  integer :: k,k1,i,j,idum
  integer,dimension(n) :: iloc
  complex:: adum

  isa(1:N+1) = 0
  !find how many elements in row
  do  k=1, nnz
     isa(ic(k)) = isa(ic(k))+1
  end do

  !build isa
  k = 1
  do  i=1,N+1
     k1 = isa(i)
     isa(i) = k
     k = k+k1
  end do

  iloc(1:n)=isa(1:n)
  !Build jsa, sa - increment local row counter
  do  k=1, nnz
     sa(iloc(ic(k))) =  c(k)
     jsa(iloc(ic(k))) = jc(k)
     iloc(ic(k)) = iloc(ic(k))+1
  end do
  ! Reorder by increasing column
  do i=1,n
     do k=isa(i),isa(i+1)-1
        do k1=k,isa(i+1)-1
           if (jsa(k1)<jsa(k)) then
              idum=jsa(k)
              jsa(k)=jsa(k1)
              jsa(k1)=idum
              adum=sa(k)
              sa(k)=sa(k1)
              sa(k1)=adum
           endif
        enddo
     enddo
  enddo

end subroutine ccoo2csr


      SUBROUTINE constants
      USE global
      IMPLICIT NONE

!C --- Constants for Kappa function ------------------------------------

      P = -K + 0.50      ! constant at power in Kappa
      B = 1.0/(K - 1.50) ! constant at dinominator in Kappa

!-------------- For Cairns distribution ------------------------
      BT = 4*ALP/(3*ALP + 1)

      END SUBROUTINE constants


!* Copyright (c) 1997, 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.
!
!   Derived types

program p
type test
 integer,dimension(:,:),pointer:: mem
end type
integer results(9), expect(9)
data expect /4,5,6,7,99,9,10,99,12/

type(test)::a

allocate(a%mem(1:3,1:3))

do i = 1,3
 do j = 1,3
  a%mem(i,j) = i+j*3
 enddo
enddo

where(a%mem(1,:).gt.5)
 a%mem(2,:) = 99
endwhere

do i = 1,3
 do j = 1,3
  k = i+(j-1)*3
  results(k) = a%mem(i,j)
 enddo
enddo
call check( results, expect, 9)
end


! { dg-do run }
! Test the boz handling
program boz

   implicit none

   integer(1), parameter :: b1 = b'00000001'
   integer(2), parameter :: b2 = b'0101010110101010'
   integer(4), parameter :: b4 = b'01110000111100001111000011110000'
   integer(8), parameter :: &
   &  b8 = b'0111000011110000111100001111000011110000111100001111000011110000'

   integer(1), parameter :: o1 = o'12'
   integer(2), parameter :: o2 = o'4321'
   integer(4), parameter :: o4 = o'43210765'
   integer(8), parameter :: o8 = o'1234567076543210'

   integer(1), parameter :: z1 = z'a'
   integer(2), parameter :: z2 = z'ab'
   integer(4), parameter :: z4 = z'dead'
   integer(8), parameter :: z8 = z'deadbeef'

   if (z1 /= 10_1) call abort
   if (z2 /= 171_2) call abort
   if (z4 /= 57005_4) call abort
   if (z8 /= 3735928559_8) call abort

   if (b1 /= 1_1) call abort
   if (b2 /= 21930_2) call abort
   if (b4 /= 1894838512_4) call abort
   if (b8 /= 8138269444283625712_8) call abort

   if (o1 /= 10_1) call abort
   if (o2 /= 2257_2) call abort
   if (o4 /= 9245173_4) call abort
   if (o8 /= 45954958542472_8) call abort

end program boz


program test_sort
use iso_fortran_env,only:int8,int16,int32,int64,real32,real64,real128
use mod_testing,only:assert,initialize_tests,report_tests
use mod_functional

implicit none

logical,dimension(:),allocatable :: tests
logical :: test_failed
integer :: n,norder,ntests
integer,parameter :: stdout = 6
real(kind=real32),dimension(1000) :: x

n = 1
ntests = 12
call initialize_tests(tests,ntests)

tests(n) = assert(all(sort([3_int8,2_int8,1_int8]) == [1,2,3]),&
                  'sort, int8')
n = n + 1

tests(n) = assert(all(sort([3_int16,2_int16,1_int16]) == [1,2,3]),&
                  'sort, int16')
n = n + 1

tests(n) = assert(all(sort([3_int32,2_int32,1_int32]) == [1,2,3]),&
                  'sort, int32')
n = n + 1

tests(n) = assert(all(sort([3_int64,2_int64,1_int64]) == [1,2,3]),&
                  'sort, int8')
n = n + 1

tests(n) = assert(all(sort([3._real32,2._real32,1._real32]) == [1,2,3]),&
                  'sort, real32')
n = n + 1

tests(n) = assert(all(sort([3._real64,2._real64,1._real64]) == [1,2,3]),&
                  'sort, real64')
n = n + 1

tests(n) = assert(all(sort([3._real128,2._real128,1._real128]) == [1,2,3]),&
                  'sort, real128')
n = n + 1

tests(n) = assert(all(sort(arange(cmplx(3._real32,0._real32),&
                                  cmplx(1._real32,0._real32),&
                                  cmplx(-1._real32,0._real32)))&
                        == arange(cmplx(1._real32,0._real32),&
                                  cmplx(3._real32,0._real32))),&
                  'sort, complex real32')
n = n + 1

tests(n) = assert(all(sort(arange(cmplx(3._real64,0._real64),&
                                  cmplx(1._real64,0._real64),&
                                  cmplx(-1._real64,0._real64)))&
                        == arange(cmplx(1._real64,0._real64),&
                                  cmplx(3._real64,0._real64))),&
                  'sort, complex real64')
n = n + 1

tests(n) = assert(all(sort(arange(cmplx(3._real128,0._real128),&
                                  cmplx(1._real128,0._real128),&
                                  cmplx(-1._real128,0._real128)))&
                        == arange(cmplx(1._real128,0._real128),&
                                  cmplx(3._real128,0._real128))),&
                  'sort, complex real128')
n = n + 1

call random_number(x)
tests(n) = assert(all(tail(sort(x)) >= init(sort(x))),&
                  'all(tail(sort(x)) >= init(sort(x))')
n = n + 1

tests(n) = assert(all(sort(x) == .sort.x),&
                  'sort operator, .sort.x')
n = n + 1

test_failed = .false.
call report_tests(tests,test_failed)
if(test_failed)stop 1

endprogram test_sort


: TEST
  [ DECIMAL 123 ] LITERAL DECIMAL . CR
  [ HEX -7F ] LITERAL DECIMAL     . CR
  [ HEX 7FF7 ] LITERAL HEX        . CR
  [ HEX -7FF7 ] LITERAL 2 BASE !  . CR
;

TEST


c---------------------------------------------------------------------
c---------------------------------------------------------------------

       subroutine lhsy(c)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c This function computes the left hand side for the three y-factors
c---------------------------------------------------------------------

       include 'header.h'

       double precision ru1
       integer          i, j, k, c

c---------------------------------------------------------------------
c      treat only cell c
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c      first fill the lhs for the u-eigenvalue
c---------------------------------------------------------------------
       do  k = start(3,c), cell_size(3,c)-end(3,c)-1
          do  i = start(1,c), cell_size(1,c)-end(1,c)-1

             do  j = start(2,c)-1, cell_size(2,c)-end(2,c)
                ru1 = c3c4*rho_i(i,j,k,c)
                cv(j) = vs(i,j,k,c)
                rhoq(j) = dmax1( dy3 + con43 * ru1,
     >                           dy5 + c1c5*ru1,
     >                           dymax + ru1,
     >                           dy1)
             end do

             do  j = start(2,c), cell_size(2,c)-end(2,c)-1
                lhs(i,j,k,1,c) =  0.0d0
                lhs(i,j,k,2,c) = -dtty2 * cv(j-1) - dtty1 * rhoq(j-1)
                lhs(i,j,k,3,c) =  1.0 + c2dtty1 * rhoq(j)
                lhs(i,j,k,4,c) =  dtty2 * cv(j+1) - dtty1 * rhoq(j+1)
                lhs(i,j,k,5,c) =  0.0d0
             end do
          end do
       end do

c---------------------------------------------------------------------
c      add fourth order dissipation
c---------------------------------------------------------------------
       if (start(2,c) .gt. 0) then
          j = 1
          do   k = start(3,c), cell_size(3,c)-end(3,c)-1
             do   i = start(1,c), cell_size(1,c)-end(1,c)-1

                lhs(i,j,k,3,c) = lhs(i,j,k,3,c) + comz5
                lhs(i,j,k,4,c) = lhs(i,j,k,4,c) - comz4
                lhs(i,j,k,5,c) = lhs(i,j,k,5,c) + comz1

                lhs(i,j+1,k,2,c) = lhs(i,j+1,k,2,c) - comz4
                lhs(i,j+1,k,3,c) = lhs(i,j+1,k,3,c) + comz6
                lhs(i,j+1,k,4,c) = lhs(i,j+1,k,4,c) - comz4
                lhs(i,j+1,k,5,c) = lhs(i,j+1,k,5,c) + comz1
             end do
          end do
       endif

       do   k = start(3,c), cell_size(3,c)-end(3,c)-1
          do   j=3*start(2,c), cell_size(2,c)-3*end(2,c)-1
             do   i = start(1,c), cell_size(1,c)-end(1,c)-1

                lhs(i,j,k,1,c) = lhs(i,j,k,1,c) + comz1
                lhs(i,j,k,2,c) = lhs(i,j,k,2,c) - comz4
                lhs(i,j,k,3,c) = lhs(i,j,k,3,c) + comz6
                lhs(i,j,k,4,c) = lhs(i,j,k,4,c) - comz4
                lhs(i,j,k,5,c) = lhs(i,j,k,5,c) + comz1
             end do
          end do
       end do

       if (end(2,c) .gt. 0) then
          j = cell_size(2,c)-3
          do   k = start(3,c), cell_size(3,c)-end(3,c)-1
             do   i = start(1,c), cell_size(1,c)-end(1,c)-1
                lhs(i,j,k,1,c) = lhs(i,j,k,1,c) + comz1
                lhs(i,j,k,2,c) = lhs(i,j,k,2,c) - comz4
                lhs(i,j,k,3,c) = lhs(i,j,k,3,c) + comz6
                lhs(i,j,k,4,c) = lhs(i,j,k,4,c) - comz4

                lhs(i,j+1,k,1,c) = lhs(i,j+1,k,1,c) + comz1
                lhs(i,j+1,k,2,c) = lhs(i,j+1,k,2,c) - comz4
                lhs(i,j+1,k,3,c) = lhs(i,j+1,k,3,c) + comz5
             end do
          end do
       endif

c---------------------------------------------------------------------
c      subsequently, do the other two factors
c---------------------------------------------------------------------
       do    k = start(3,c), cell_size(3,c)-end(3,c)-1
          do    j = start(2,c), cell_size(2,c)-end(2,c)-1
             do    i = start(1,c), cell_size(1,c)-end(1,c)-1
                lhs(i,j,k,1+5,c)  = lhs(i,j,k,1,c)
                lhs(i,j,k,2+5,c)  = lhs(i,j,k,2,c) -
     >                            dtty2 * speed(i,j-1,k,c)
                lhs(i,j,k,3+5,c)  = lhs(i,j,k,3,c)
                lhs(i,j,k,4+5,c)  = lhs(i,j,k,4,c) +
     >                            dtty2 * speed(i,j+1,k,c)
                lhs(i,j,k,5+5,c) = lhs(i,j,k,5,c)
                lhs(i,j,k,1+10,c) = lhs(i,j,k,1,c)
                lhs(i,j,k,2+10,c) = lhs(i,j,k,2,c) +
     >                            dtty2 * speed(i,j-1,k,c)
                lhs(i,j,k,3+10,c) = lhs(i,j,k,3,c)
                lhs(i,j,k,4+10,c) = lhs(i,j,k,4,c) -
     >                            dtty2 * speed(i,j+1,k,c)
                lhs(i,j,k,5+10,c) = lhs(i,j,k,5,c)
             end do
          end do
       end do

       return
       end


      SUBROUTINE MFFTDS(C,IMSX,IVSX,IESX,NMX,NVX,NEX,TABLES,IERR)

*   PURPOSE:
*       THE SAME AS MFFTDM.    IT IS A VARIANT OF MFFTDM
*       AIMED AT OPTIMAL PERFORMANCE ON MATRICES HAVING THE
*       FIRST DIMENSION SMALLER THAN 64. IT REQUIRES THAT MFFTP HAS
*       BEEN CALLED WITH ID .NE. 0
*  IMPLEMENTATION:
*       THE TRANSFORMATION IS IMPLEMENTED THROUGH REPEATED CALLS TO THE
*       "BUTTERFLY" TRANSFORMATION MFFT?8; PARAMETERS OF THE "BUTTERFLY"
*       ARE COMMUNICATED THROUGH THE COMMON BLOCK MFFTPA.
*  ARGUMENTS:
*    INPUT  :
*       C : ARRAY TO BE TRANSFORMED.
*       IMSX,IVSX,IESX,NMX,NVX,NEX: THESE ARGUMENTS DEFINE THE STRUCTURE
*           OF C ACCORDING TO THE DEFINITIONS ABOVE. THEY ARE UNCHANGED
*           ON OUTPUT
*       TABLES : ARRAY PREPARED BY MFFTP. IT  IS NOT CHANGED ON OUTPUT.
*                IT SHOULD BE DECLARED INTEGER TABLES(4*NM+14);
*                IT MUST BE INITIALIZED BY MFFTP BEFORE USAGE.
*    OUTPUT:
*       C : TRANSFORM OF THE ORIGINAL ARRAY; "BIT REVERSED" ORDER
*       IERR : ERROR CODE : =0 : SUCCESSFUL
*                         : =3 :  'TABLES' NOT CORRECTLY INITIALIZED
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE COMPLEX C(*)
      INTEGER TABLES(-14:*)
      INTEGER IDERR,FACERR,TBERR
      PARAMETER (IDERR=1,FACERR=2,TBERR=3)
      COMMON /MFFTPA/  IMS,IVS,IES,NM,NV,NE,MX,LX,MLIM,MSTEP,LLIM,LSTEP,
     $ NUSTEP,IVLIM,ILIM,MD2LIM,LD2LIM
      SAVE IBASE
*  LOADING THE COMMON BLOCK : CONSTANTS
      IMS=IMSX
      IVS=IVSX
      NM=NMX
      NV=NVX
      NE=NEX
      IVLIM=(NV-1)*IVS
      MSTEP=IMS
*  LOADING THE COMMON BLOCK : ITERATION-DEPENDENT QUANTITIES: INITIALIZA
      LX=1
      MX=NM

      IBASE=2*NM
*  SELECT THE HIGHEST FACTOR OF NM
      IFAC=TABLES(-1)
      GOTO(200,300,500)IFAC
      IERR=TBERR
      RETURN
*...  RADIX 5 LOOP
500   CONTINUE
      DO 510 IM=1,TABLES(-12)
        MX=MX/5
        NUSTEP=MX*MSTEP
        ILIM=NUSTEP-1
        LSTEP=NUSTEP*5
        LLIM=NM*MSTEP-LSTEP
        CALL MFFTC8(C,TABLES(2*IBASE))
        LX=LX*5
        IBASE=IBASE+NUSTEP*4
510   CONTINUE
*..  RADIX 3 LOOP
300   CONTINUE
      DO 310 IM=1,TABLES(-13)
        MX=MX/3
        NUSTEP=MX*MSTEP
        ILIM=NUSTEP-1
        LSTEP=NUSTEP*3
        LLIM=NM*MSTEP-LSTEP
        CALL MFFTB8(C,TABLES(2*IBASE))
        LX=LX*3
        IBASE=IBASE+NUSTEP*2
310   CONTINUE
*..  RADIX 2 LOOP
200   CONTINUE
      DO 210 IM=1,TABLES(-14)
        MX=MX/2
        NUSTEP=MX*MSTEP
        ILIM=NUSTEP-1
        MD2LIM=NUSTEP/2-MSTEP
        LSTEP=NUSTEP*2
        LLIM=NM*MSTEP-LSTEP
        CALL MFFTA8(C,TABLES(2*IBASE))
        LX=LX+LX
        IBASE=IBASE+NUSTEP
210   CONTINUE

      END


C  %Z%SCCS: %G%  FILE: %M% (%I%)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
!ROUTINE NAME: shval3
!CALL INTERFACE:
        SUBROUTINE shval3 (flat, flon, elevkm,
     1                     nmax, gh, iext, ext, x, y, z)
c ================================================================
!F77  LANGUAGE-  FORTRAN 77
c
!ABSTRACT: calculates field components from spherical harmonic (sh)
c       models.
c
!ROUTINE HISTORY:
c       version 1.03
c       based on subroutine 'igrf' by d. r. barraclough and
c       s. r. c. malin
c
c       norman w. peddie, u.s. geological survey, mail stop 964,
c       federal center, box 25046, denver, colorado 80225
c
c       minor changes to argument list- p. rosenkranz, 5/21/93
c       fixed sqrt neg argument trap -   " 11/9/93
c
C  ! Log for /home/jsg/airs_level2_f77/src/mit/shval3.F[1.0]:
!   Initial version
!  Apr. 25, 1997 PWR - internal double precision version
c
c
!ARGUMENTS:
c specifications-
      IMPLICIT NONE
      real flat,flon,elevkm,gh(*),ext(3),x,y,z
      integer nmax,iext
c       input:
c           flat  - north latitude, in degrees (- for south)
c           flon  - east longitude, in degrees (- for west)
c           elevkm  - elevation in km
c                   if elevkm < 6000., flat,flon and elevkm
c                   are interpreted as geodetic coordinates
c                   (i.e., measured from mean sea level).
c                   if elevkm > 6000., they are interpreted
c                   as geocentric coordinates (i.e., from
c                   earth's center).
c           nmax  - maximum degree and order of coefficients
c           gh    - schmidt quasi-normal internal spherical
c                   harmonic coefficients (nanotesla).
c                   number of coeff = nmax*(nmax+2)
c           iext  - external field coefficients flag (= 0 if none)
c           ext   - the three 1st-degree external coefficients
c                   (not used if iext = 0)
c
c       output:
c           x     -  northward component (nanotesla)
c           y     -  eastward component (nanotesla)
c           z     -  vertically-downward component (nanotesla)
c
!ROUTINES CALLED: none
!PARENT: general purpose
!RETURN VALUES:
!FILES ACCESSED:
!DESCRIPTION: d. r. barraclough and s. r. c. malin, report no. 71/1,
c  institute of geological sciences, u.k.
c
!KNOWN BUGS AND LIMITATIONS:
c       The required sizes of the local arrays used in this subroutine
c       depend on the value of nmax. This version is dimensioned for
c       nmax of 14 or less. The minimum dimensions
c       needed are indicated below.
c
c --------------------------
c      minimum dimension nmax
        double precision  sl(14), cl(14)
c      minimum dimension (nmax * (nmax + 3)) / 2
        double precision  p(119), q(119)
!END HEADER*************************************************************
      double precision erad,a2,b2,dtr,r,slat,aa,clat,sd,cd,bb,cc,dd,
     & ratio,rr,fn,fm,argb
      integer n,l,m,npq,j,k,i
c**** CONSTANTS
      parameter (erad = 6371.2d0)
      parameter (a2 = 40680925.d0)
      parameter (b2 = 40408588.d0)
c           erad  - value of earth's radius associated with the sh
c                   coefficients, in km
c           a2,b2 - squares of semi-major and semi-minor axes of
c                   the reference spheroid used for transforming
c                   between geodetic and geocentric coordinates or
c                   components
c
c ================================================================
        dtr = 3.1415926536D0/180.D0
        r = elevkm
        if (90. - flat .lt. .001) then
            aa = 89.999d0
c           300 ft from n. pole
        else if (90. + flat .lt. .001) then
            aa = -89.999d0
c           300 ft from s. pole
        else
            aa = flat
        endif
        slat = dsin (aa * dtr)
        clat = dcos (aa * dtr)
        sl(1) = dsin (dble(flon) * dtr)
        cl(1) = dcos (dble(flon) * dtr)
        x = 0.
        y = 0.
        z = 0.
        sd = 0.d0
        cd = 1.d0
        n = 0
        l = 1
        m = 1
        npq = (nmax * (nmax + 3)) / 2
        if (elevkm.lt.6000.) then
            aa = a2 * clat * clat
            bb = b2 * slat * slat
            cc = aa + bb
            dd = sqrt (cc)
            r = dsqrt (dble(elevkm) * (dble(elevkm) + 2.d0 * dd)
     1                   + (a2 * aa + b2 * bb) / cc)
            cd = (dble(elevkm) + dd) / r
            sd = (a2 - b2) / dd * slat * clat / r
            aa = slat
            slat = slat * cd - clat * sd
            clat = clat * cd + aa * sd
        endif
        ratio = erad / r
        aa = dsqrt (3.d0)
        p(1) = 2.d0 * slat
        p(2) = 2.d0 * clat
        p(3) = 4.5d0 * slat * slat - 1.5d0
        p(4) = 3.d0 * aa * clat * slat
        q(1) = -clat
        q(2) = slat
        q(3) = -3.d0 * clat * slat
        q(4) = aa * (slat * slat - clat * clat)
        do 10  k = 1, npq
            if (n .lt. m) then
                m = 0
                n = n + 1
                rr = ratio**(n + 2)
                fn = n
            endif
            fm = m
            if (k .ge. 5) then
                if (m .eq. n) then
                    aa = dsqrt (1.d0 - .5d0 / fm)
                    j = k - n - 1
                    p(k) = (1.d0 + 1.d0 / fm) * aa * clat * p(j)
                    q(k) = aa * (clat * q(j) + slat / fm * p(j))
                    sl(m) = sl(m-1) * cl(1) + cl(m-1) * sl(1)
                    cl(m) = cl(m-1) * cl(1) - sl(m-1) * sl(1)
                else
                    aa = dsqrt (fn * fn - fm * fm)
                    ARGB = (fn - 1.d0)**2 - fm * fm
                    bb = dsqrt (dmax1(ARGB,0.d0)) / aa
                    cc = (2.d0 * fn - 1.d0) / aa
                    i = k - n
                    j = k - 2 * n + 1
                    p(k) = (fn + 1.d0) * (cc * slat / fn * p(i) - bb
     1                     / (fn - 1.d0) * p(j))
                    q(k) = cc * (slat * q(i) - clat / fn * p(i))
     1                     - bb * q(j)
                endif
            endif
            aa = rr * gh(l)
            if (m .eq. 0) then
                x = x + aa * q(k)
                z = z - aa * p(k)
                l = l + 1
            else
                bb = rr * gh(l+1)
                cc = aa * cl(m) + bb * sl(m)
                x = x + cc * q(k)
                z = z - cc * p(k)
                if (clat .gt. 0.d0) then
                    y = y + (aa * sl(m) - bb * cl(m)) * fm * p(k)
     1                  / ((fn + 1.d0) * clat)
                else
                    y = y + (aa * sl(m) - bb * cl(m)) * q(k)
     1              * slat
                endif
                l = l + 2
            endif
            m = m + 1
   10   continue
        if (iext .ne. 0) then
            aa = dble(ext(2)) * cl(1) + dble(ext(3)) * sl(1)
            x = dble(x) - dble(ext(1)) * clat + aa * slat
            y = dble(y) + dble(ext(2)) * sl(1) - dble(ext(3)) * cl(1)
            z = dble(z) + dble(ext(1)) * slat + aa * clat
        endif
        aa = x
        x = dble(x) * cd + dble(z) * sd
        z = dble(z) * cd - aa * sd
        return
        end


      Bzero5(z5(1,1,1,1,1),ep) =  - Bv(bb11111 + B23,ep) - 5*Bv(bb1111
     &  + B23,ep) - 10*Bv(bb111 + B23,ep) - 10*Bv(bb11 + B23,ep) - 5*
     & Bv(bb1 + B23,ep) - Bv(bb0 + B23,ep)

      Bzero5(z5(1,1,1,1,2),ep) = Bv(bb11111 + B23,ep) + 4*Bv(bb1111 +
     & B23,ep) + 6*Bv(bb111 + B23,ep) + 4*Bv(bb11 + B23,ep) + Bv(bb1 +
     & B23,ep)

      Bzero5(z5(1,1,1,2,2),ep) =  - Bv(bb11111 + B23,ep) - 3*Bv(bb1111
     &  + B23,ep) - 3*Bv(bb111 + B23,ep) - Bv(bb11 + B23,ep)

      Bzero5(z5(1,1,2,2,2),ep) = Bv(bb11111 + B23,ep) + 2*Bv(bb1111 +
     & B23,ep) + Bv(bb111 + B23,ep)

      Bzero5(z5(1,2,2,2,2),ep) =  - Bv(bb11111 + B23,ep) - Bv(bb1111 +
     & B23,ep)

      Bzero5(z5(2,2,2,2,2),ep) = Bv(bb11111 + B23,ep)

      Bzero4(z4(1,1,1,1),ep) = Bv(bb1111 + B23,ep) + 4*Bv(bb111 + B23,
     & ep) + 6*Bv(bb11 + B23,ep) + 4*Bv(bb1 + B23,ep) + Bv(bb0 + B23,ep
     & )

      Bzero4(z4(1,1,1,2),ep) =  - Bv(bb1111 + B23,ep) - 3*Bv(bb111 +
     & B23,ep) - 3*Bv(bb11 + B23,ep) - Bv(bb1 + B23,ep)

      Bzero4(z4(1,1,2,2),ep) = Bv(bb1111 + B23,ep) + 2*Bv(bb111 + B23,
     & ep) + Bv(bb11 + B23,ep)

      Bzero4(z4(1,2,2,2),ep) =  - Bv(bb1111 + B23,ep) - Bv(bb111 + B23,
     & ep)

      Bzero4(z4(2,2,2,2),ep) = Bv(bb1111 + B23,ep)

      Bzero3(z3(1,1,1),ep) =  - Bv(bb111 + B23,ep) - 3*Bv(bb11 + B23,ep
     & ) - 3*Bv(bb1 + B23,ep) - Bv(bb0 + B23,ep)

      Bzero3(z3(1,1,2),ep) = Bv(bb111 + B23,ep) + 2*Bv(bb11 + B23,ep)
     &  + Bv(bb1 + B23,ep)

      Bzero3(z3(1,2,2),ep) =  - Bv(bb111 + B23,ep) - Bv(bb11 + B23,ep)

      Bzero3(z3(2,2,2),ep) = Bv(bb111 + B23,ep)

      Bzero2(z2(1,1),ep) = Bv(bb11 + B23,ep) + 2*Bv(bb1 + B23,ep) + Bv(
     & bb0 + B23,ep)

      Bzero2(z2(1,2),ep) =  - Bv(bb11 + B23,ep) - Bv(bb1 + B23,ep)

      Bzero2(z2(2,2),ep) = Bv(bb11 + B23,ep)

      Bzero1(z1(1),ep) =  - Bv(bb1 + B23,ep) - Bv(bb0 + B23,ep)

      Bzero1(z1(2),ep) = Bv(bb1 + B23,ep)

      Bzero0(ep) = Bv(bb0 + B23,ep)


c.... *****************************************************************<-70
      subroutine ELMT02(d,ul,xl,ix,tl,s,r,ndf,ndm,nst,isw)
c .....................................................................
c     elmt02 - Two dimensional truss element
c
c     written:  fmk
c     created:  03/99
c     revision: A
c .....................................................................
c     element data:
c       d(1) = Crss Sectional Area, A
c       d(2) = Youngs Modulus, E
c       d(3) = Mass per unit volume, rho
c .....................................................................

      implicit none

c.... common declarations
      character*4 o,head
      common /bdata/ o,head(20)

      integer         numnp,numel,nummat,nen,neq,ipr
      common /cdata/  numnp,numel,nummat,nen,neq,ipr

      real*8          dm
      integer            n,ma,mct,iel,nel
      common /eldata/ dm,n,ma,mct,iel,nel

      real *8         bpr, ctan
      common /eltran/ bpr(3), ctan(3)

      integer         ior,iow
      common /iofile/ ior,iow

      integer         nh1,nh2,nh3
      common /hdata/  nh1,nh2,nh3

      real*8  h
      common  h(1000)

c ... subroutine arguments
      integer ix(*)
      integer ndf,ndm,nst,isw
      real*8  d(*),ul(ndf,nen,*),xl(ndm,*),tl(*),s(nst,*),r(*)

c ... local variables
      integer  i,j
      real*8  cs, sn, L, dx, dy, k, m, A, E, rho, tran(4), eps, force

      if(isw.eq.0) then
c     output element type
         if(iow.lt.0) then
            write(*,*) '   Elmt02: 2d Truss Element.'
         else
            write(iow,*) '   Elmt02: 2d Truss Element.'
         endif

      elseif(isw.eq.1) then
c     input material properties & set nh1(=nh2), nh3
c     d(1) = A, d(2)=E, d(3) = rho, nh1 = 0, nh2 = 0
         call dinput(d,3)
         write(iow,2000) d(1),d(2),d(3)
         if (ior.lt.0) then
            write(*,2000) d(1),d(2),d(3)
         endif
         nh1 = 0
         nh3 = 0
      elseif(isw.eq.2) then
c     check of mesh if desired (chec)

      elseif(isw.eq.3) then
c     compute element residual and tangent matrix

c ...... compute element length

         dx = xl(1,2) - xl(1,1)
         dy = xl(2,2) - xl(2,1)
         L = sqrt(dx*dx + dy*dy)

         cs = dx/L
         sn = dy/L
         tran(1) = cs
         tran(2) = sn
         tran(3) = -cs
         tran(4) = -sn

c ...... add stiffness portion to matrix
         A = d(1)
         E = d(2)

         if(ctan(1).ne.0.0d0) then
            k = ctan(1)*A*E/L
            do i = 1,4
               do j = 1,4
                  s(i,j) = s(i,j) + k*tran(i)*tran(j)
               enddo
            enddo
         endif

c ...... add mass portion to matrix
         rho = d(3)
         if (ctan(3).ne.0.0d0) then
            m = ctan(3)*rho*A*L/2
            do i = 1,4
               s(i,i) = s(i,i) + m
            enddo
         endif

c ...... compute the strain
         eps = cs*(ul(1,2,1)-ul(1,1,1))
         eps = eps + sn*ul(2,2,1)-ul(2,1,1)
         eps = eps/L

c .....  compute the residual
         force = E*A*eps
         r(1) = cs*force
         r(2) = sn*force
         r(3) = -r(1)
         r(4) = -r(2)

c .....  add the inertia effects
         m = rho*A*L/2
         r(1) = r(1) - m*ul(1,1,5)
         r(2) = r(2) - m*ul(1,2,5)
         r(3) = r(3) - m*ul(2,1,5)
         r(4) = r(4) - m*ul(2,2,5)

      elseif(isw.eq.5) then
c     compute element mass matrix

c        compute element length
         dx = xl(1,2) - xl(1,1)
         dy = xl(2,2) - xl(2,1)
         L = sqrt(dx*dx + dy*dy)

c ...... compute mass matrix
         A = d(1)
         rho = d(3)
         m = ctan(3)*rho*A*L/2
         do i = 1,4
            s(i,i) = m
         enddo

         r(1) = m
         r(2) = m
         r(3) = m
         r(4) = m

      elseif(isw.eq.4 .or. isw.eq.6) then
c     compute element residual

c ...... compute element length

         dx = xl(1,2) - xl(1,1)
         dy = xl(2,2) - xl(2,1)
         L = sqrt(dx*dx + dy*dy)

         cs = dx/L
         sn = dy/L

c ...... compute the strain
         eps = cs*(ul(1,2,1)-ul(1,1,1))
         eps = eps + sn*(ul(2,2,1)-ul(2,1,1))
         eps = eps/L

c .....  compute the residual
         A = d(1)
         E = d(2)
         force = E*A*eps

         r(1) = cs*force
         r(2) = sn*force
         r(3) = -cs*force
         r(4) = -sn*force

c .....  add the inertia effects
         m = rho*A*L/2
         r(1) = r(1) - m*ul(1,1,5)
         r(2) = r(2) - m*ul(1,2,5)
         r(3) = r(3) - m*ul(2,1,5)
         r(4) = r(4) - m*ul(2,2,5)

c     output element quantities
         if (isw.eq.4) then
            write(iow,2002) n,ix(1),ix(2),d(1),d(2),d(3),eps,force
            if (ior.lt.0) then
               write(*,2002) n,ix(1),ix(2),d(1),d(2),d(3),eps,force
            endif
         endif

      elseif(isw.eq.7) then
c     output surface loading

      elseif(isw.eq.8) then
c     compute stress projections at nodes

      endif

 2000 format(2x,'Element type: elmt02 ',
     1  'Area: ',e8.3, ' Youngs Modulus: ',e8.3,
     2  ' Rho: ',e8.3)

 2002    format(2x,'Element:',i5,' type: elmt02   iNode: ',i5,
     1  ' jNode: ',i5/16x,'Area: ',e8.3, ' Youngs Modulus: ',e8.3,
     2  ' Rho: ',e8.3/16x,'strain: ',e12.5,5x,'axial force: ',e12.5)

      end


MODULE m_process_lattice_namelist
  use m_juDFT
  implicit none
  !---------------------------------------------------------------------!
  ! eventually easy input of all 14 Bravais lattices in agreement with  !
  ! 'International Tables of Crystallography'                           !
  ! table 2.1.1, ( page13 in 3rd Ed. )                                  !
  !---------------------------------------------------------------------!
CONTAINS
  SUBROUTINE process_lattice(line,a1,a2,a3,aa,scale,mat)

    USE m_constants
    IMPLICIT NONE

    !==> Arguments
    CHARACTER(len=*),INTENT(INOUT)::line
    REAL,    INTENT (OUT) :: a1(3),a2(3),a3(3)
    REAL,    INTENT (OUT) :: aa                ! overall scaling constant
    REAL,    INTENT (OUT) :: scale(3),mat(3,3) ! for trigonal lattices

    !==> Local Variables
    CHARACTER(len=40) :: latsys
    REAL    :: a0,a_rho
    REAL    :: a,b,c
    REAL    :: alpha,beta,gamma
    REAL    :: c1(3),c2(3),c3(3)
    REAL    :: ar,br,cr,b1,b2,am(3,3)
    REAL    :: ca,cb,at
    INTEGER :: i,j,err,i1,i2,i_c,ios
    LOGICAL :: noangles

    REAL, PARAMETER :: eps = 1.0e-7, sqrt2  =  1.4142135623730950, &
         sqrt3  =  1.7320508075688773, sqrt32 =  0.86602540378444, msqrt32 = -0.86602540378444

    REAL :: lmat(3,3,8)
    DATA  lmat /  1.0,  0.0,  0.0,  &   ! 1: primitive     : P
         0.0,  1.0,  0.0,&
         0.0,  0.0,  1.0, &
         0.0,  0.5,  0.5,  &   ! 2: face-centered : F
         0.5,  0.0,  0.5,&
         0.5,  0.5,  0.0,&
         -0.5,  0.5,  0.5,  &   ! 3: body-centered : I
         0.5, -0.5,  0.5,&
         0.5,  0.5, -0.5,&
         0.5, msqrt32, 0.0,  &   ! 4: hexagonal-P   : hP, hcp
         0.5,  sqrt32, 0.0,&
         0.0,     0.0, 1.0, &
         0.0, -1.0,  1.0,  &   ! 5: hexagonal-R   : hR, trigonal
         sqrt32,  0.5,  1.0,&
         msqrt32,  0.5,  1.0, &
         0.5, -0.5,  0.0,  &   ! 6: base-centered: S (C)
         0.5,  0.5,  0.0,&
         0.0,  0.0,  1.0,&
         0.5,  0.0, -0.5,  &   ! 7: base-centered: B
         0.0,  1.0,  0.0,&
         0.5,  0.0,  0.5,&
         1.0,  0.0,  0.0,  &   ! 8: base-centered: A
         0.0,  0.5,  0.5,&
         0.0, -0.5,  0.5/

    !===> namelists
    NAMELIST /lattice/ latsys,a0,a,b,c,alpha,beta,gamma

    noangles = .false.
    latsys = ' ' ; a0 = 0.0
    a = 0.0      ; b = 0.0    ; c = 0.0
    alpha = 0.0  ; beta = 0.0 ; gamma = 0.0
    scale = 0.0  ; mat = 0.0

    READ (line,lattice,iostat=ios)
    if (ios.ne.0) call judft_error(("Error reading lattice:"//trim(line)))

    IF ( abs(a0) < eps ) a0 = 1.0
    IF ( abs(a)  < eps ) a  = 1.0
    IF ( abs(b)  < eps ) b  = a
    IF ( abs(c)  < eps ) c  = a
    IF ( abs(alpha)  < eps ) alpha  = 90.0
    IF ( abs(beta)   < eps ) beta   = 90.0
    IF ( abs(gamma)  < eps ) gamma  = 90.0

    IF ( alpha > pi_const ) THEN     ! deg
       ar = alpha * pi_const / 180.0
       br = beta  * pi_const / 180.0
       cr = gamma * pi_const / 180.0
    ELSE                       ! radians
       ar = alpha
       br = beta
       cr = gamma
    ENDIF

    scale(1) = a
    scale(2) = b
    scale(3) = c

    latsys = ADJUSTL(latsys)

    !===>  1: cubic-P          (cP) sc

    IF ( latsys =='cubic-P'.OR.latsys =='cP'.OR.latsys =='sc'.OR.&
         latsys =='simple-cubic' ) THEN

       noangles=.true.
       i_c = 1
       a1 = lmat(:,1,i_c) * scale(:)
       a2 = lmat(:,2,i_c) * scale(:)
       a3 = lmat(:,3,i_c) * scale(:)
       scale = 1.0

       IF ( a.NE.b .OR. a.NE.c ) err = 11
       IF ( ar.NE.br .OR. ar.NE.cr .OR. ar.NE.(pi_const/2.0) ) err = 12

       !===>  2: cubic-F          (cF) fcc

    ELSEIF ( latsys =='cubic-F'.OR.latsys =='cF'.OR.latsys =='fcc'.OR.&
         latsys =='face-centered-cubic' ) THEN

       noangles=.true.
       i_c = 2
       a1 = lmat(:,1,i_c) * scale(:)
       a2 = lmat(:,2,i_c) * scale(:)
       a3 = lmat(:,3,i_c) * scale(:)
       scale = 1.0

       IF ( a.NE.b .OR. a.NE.c ) err = 21

       !===>  3: cubic-I          (cI) bcc

    ELSEIF ( latsys =='cubic-I'.OR.latsys =='cI'.OR.latsys =='bcc'.OR.&
         latsys =='body-centered-cubic' ) THEN

       noangles=.true.
       i_c = 3
       a1 = lmat(:,1,i_c) * scale(:)
       a2 = lmat(:,2,i_c) * scale(:)
       a3 = lmat(:,3,i_c) * scale(:)
       scale = 1.0

       IF ( a.NE.b .OR. a.NE.c ) err = 31

       !===>  4: hexagonal-P      (hP) hcp

    ELSEIF ( latsys =='hexagonal-P'.OR.latsys =='hP'.OR.latsys =='hcp'&
         .OR.latsys =='hexagonal' ) THEN

       noangles=.true.
       i_c = 4
       a1 = lmat(:,1,i_c) * scale(:)
       a2 = lmat(:,2,i_c) * scale(:)
       a3 = lmat(:,3,i_c) * scale(:)
       scale = 1.0

       IF ( a.NE.b ) err = 41

       !===>  4.1 : hexagonal-P   60 degrees variant

    ELSEIF ( latsys =='hdp' ) THEN

       noangles=.true.
       i_c = 4
       a1 =  lmat((/2,1,3/),1,i_c) * scale(:)
       a2 = -lmat((/2,1,3/),2,i_c) * scale(:)
       a3 = lmat(:,3,i_c) * scale(:)
       scale = 1.0
       i_c = 9

       IF ( a.NE.b ) err = 41

       !===>  5.1: hexagonal-R      (hR) trigonal,( rhombohedral )

    ELSEIF ( latsys =='hexagonal-R'.OR.latsys =='hR'.OR.latsys =='r'&
         .OR.latsys =='R'.OR.latsys =='rhombohedral'.OR.&
         latsys =='rho'.OR.latsys =='trigonal' ) THEN

       noangles=.false.
       i_c = 5
       a1 = lmat(:,1,i_c)
       a2 = lmat(:,2,i_c)
       a3 = lmat(:,3,i_c)

       IF ( a.NE.b ) err = 51
       IF ( b.NE.c ) err = 51
       IF ( alpha.EQ.0.0  .OR. alpha.NE.beta .OR. alpha.NE.gamma ) err = 52

       at = sqrt( 2.0 / 3.0 * ( 1 - cos(ar) ) )
       am(:,1) = a1 ; am(:,2) = a2 ; am(:,3) = a3
       am(1,:) = at * am(1,:)
       am(2,:) = at * am(2,:)
       am(3,:) = cos(asin(at)) * am(3,:)
       a1 = am(:,1)*a ; a2 = am(:,2)*b ; a3 = am(:,3)*c
       scale = 1.0

       CALL angles( am )

       !===>  5.2: hexagonal-R      (hR) trigonal,( rhombohedral )

    ELSEIF (latsys =='hexagonal-R2'.OR.latsys =='hR2'.OR.latsys =='r2'&
         .OR.latsys =='R2'.OR.latsys =='rhombohedral2'.OR. latsys =='trigonal2' ) THEN

       noangles=.false.
       i_c = 5
       a1 = lmat(:,1,i_c)
       a2 = lmat(:,2,i_c)
       a3 = lmat(:,3,i_c)

       IF ( a.NE.b ) err = 53
       IF ( alpha.NE.90 ) err = 54
       IF ( alpha.NE.beta .OR. gamma.NE.120 ) err = 54

       mat(:,1) = a*lmat(:,1,4) ! to transfer atom
       mat(:,2) = a*lmat(:,2,4) ! positions hex -> trig
       mat(:,3) = c*lmat(:,3,4) ! in struct_inp.f

       ! transform hex -> rho
       a_rho = sqrt( 3*a*a + c*c)/3.0
       ar = acos( 1. - 9./(6.+2*(c/a)**2) )
       at = sqrt( 2.0 / 3.0 * ( 1 - cos(ar) ) )

       a = a_rho * at
       b = a_rho * at
       c = a_rho * cos( asin(at) )

       am(:,1) = a1 ; am(:,2) = a2 ; am(:,3) = a3
       am(1,:) = a*am(1,:)
       am(2,:) = b*am(2,:)
       am(3,:) = c*am(3,:)
       a1 = am(:,1) ; a2 = am(:,2) ; a3 = am(:,3)
       scale = 1.0

       CALL angles( am )

       !===>  6: tetragonal-P     (tP) st

    ELSEIF ( latsys =='tetragonal-P'.OR.latsys =='st'.OR.latsys =='tP'&
         .OR.latsys =='simple-tetragonal' ) THEN

       noangles=.true.
       i_c = 1
       a1 = lmat(:,1,i_c) * scale(:)
       a2 = lmat(:,2,i_c) * scale(:)
       a3 = lmat(:,3,i_c) * scale(:)
       scale = 1.0

       IF ( a.NE.b ) err = 61
       IF ( ar.NE.br .OR. ar.NE.cr .OR. ar.NE.(pi_const/2.0)  ) err= 62

       !===>  7: tetragonal-I     (tI) bct

    ELSEIF (latsys =='tetragonal-I'.OR.latsys =='tI'.OR.latsys =='bct'&
         .OR.latsys =='body-centered-tetragonal' ) THEN

       noangles=.true.
       i_c = 3
       a1 = lmat(:,1,i_c) * scale(:)
       a2 = lmat(:,2,i_c) * scale(:)
       a3 = lmat(:,3,i_c) * scale(:)
       scale = 1.0

       IF ( a.NE.b ) err = 61

       !===>  8: orthorhombic-P   (oP)

    ELSEIF ( latsys =='orthorhombic-P'.OR.latsys =='oP'.OR.&
         latsys =='simple-orthorhombic' ) THEN

       noangles=.true.
       i_c = 1
       a1 = lmat(:,1,i_c) * scale(:)
       a2 = lmat(:,2,i_c) * scale(:)
       a3 = lmat(:,3,i_c) * scale(:)
       scale = 1.0

       !===>  9: orthorhombic-F   (oF)

    ELSEIF ( latsys =='orthorhombic-F'.OR.latsys =='oF'.OR.&
         latsys =='orF'.OR. latsys =='face-centered-orthorhombic' ) THEN

       noangles=.true.
       i_c = 2
       a1 = lmat(:,1,i_c) * scale(:)
       a2 = lmat(:,2,i_c) * scale(:)
       a3 = lmat(:,3,i_c) * scale(:)
       scale = 1.0

       !===> 10: orthorhombic-I   (oI)

    ELSEIF ( latsys =='orthorhombic-I'.OR.latsys =='oI'.OR.&
         latsys =='orI'.OR. latsys =='body-centered-orthorhombic' ) THEN

       noangles=.true.
       i_c = 3
       a1 = lmat(:,1,i_c) * scale(:)
       a2 = lmat(:,2,i_c) * scale(:)
       a3 = lmat(:,3,i_c) * scale(:)
       scale = 1.0

       !===> 11: orthorhombic-S   (oS) (oC)

    ELSEIF ( latsys =='orthorhombic-S'.OR.latsys =='orthorhombic-C'.OR.&
         latsys =='oS'.OR.latsys =='oC'.OR.latsys =='orC'.OR.&
         latsys =='base-centered-orthorhombic' ) THEN

       noangles=.true.
       i_c = 6
       a1 = lmat(:,1,i_c) * scale(:)
       a2 = lmat(:,2,i_c) * scale(:)
       a3 = lmat(:,3,i_c) * scale(:)
       scale = 1.0

       !===> 11a: orthorhombic-A   (oA)

    ELSEIF ( latsys =='orthorhombic-A'.OR.latsys =='oA'.OR.&
         latsys =='orA'.OR. latsys =='base-centered-orthorhombic2' ) THEN

       noangles=.true.
       i_c = 8
       a1 = lmat(:,1,i_c) * scale(:)
       a2 = lmat(:,2,i_c) * scale(:)
       a3 = lmat(:,3,i_c) * scale(:)
       scale = 1.0

       !===> 11b: orthorhombic-B   (oB)

    ELSEIF ( latsys =='orthorhombic-B'.OR.latsys =='oB'.OR.&
         latsys =='orB'.OR. latsys =='base-centered-orthorhombic3' ) THEN

       noangles=.true.
       i_c = 7
       a1 = lmat(:,1,i_c) * scale(:)
       a2 = lmat(:,2,i_c) * scale(:)
       a3 = lmat(:,3,i_c) * scale(:)
       scale = 1.0

       !===> 12: monoclinic-P     (mP)
    ELSEIF ( latsys =='monoclinic-P'.OR.latsys =='mP'.OR.&
         latsys =='moP'.OR. latsys =='simple-monoclinic' ) THEN

       noangles=.false.
       i_c = 1

       IF ( (abs(alpha-90.0)<eps).AND.(abs(beta-90.0)<eps) ) THEN
          IF ( ABS(gamma - 90.0) <eps )  CALL juDFT_error("no monoclinic angle!",calledby ="lattice2")
       ELSE
          CALL juDFT_error("lattice2: Please take gamma as monoclinic angle!")
       ENDIF
       CALL brvmat ( alpha, beta, gamma, am )
       a1 = a*am(:,1)
       a2 = b*am(:,2)
       a3 = c*am(:,3)
       scale = 1.0

       CALL angles( am )

       !===> 13: monoclinic-C (mC)
    ELSEIF ( latsys =='monoclinic-C'.OR.latsys =='mC'.OR.latsys =='moC'.OR.&
         latsys =='centered-monoclinic' ) THEN

       CALL juDFT_error("Monoclinic setup",hint="Please use gamma as monoclinic angle"//&
            " and center on A or B !")

       !===> 13a monoclinic-A (mA)
    ELSEIF ( latsys =='monoclinic-A'.OR.latsys =='mA'.OR.latsys =='moA'.OR.&
         latsys =='centered-monoclinic2' ) THEN

       noangles=.false.
       IF ( (abs(alpha-90.0)<eps).AND.(abs(beta-90.0)<eps) ) THEN
          IF ( abs(gamma - 90.0) <eps )  CALL juDFT_error("no monoclinic angle!",calledby ="lattice2")
       ELSE
          CALL juDFT_error("Please take gamma as monoclinic angle!",calledby ="lattice2")
       ENDIF
       CALL brvmat ( alpha, beta, gamma, am )
       am(:,1) = a * am(:,1)
       am(:,2) = b * am(:,2)
       am(:,3) = c * am(:,3)
       i_c = 8
       am = matmul ( am, lmat(:,:,i_c) )
       a1 = am(:,1)
       a2 = am(:,2)
       a3 = am(:,3)
       CALL angles( am )
       scale = 1.0

       !===> 13b monoclinic-B (mB)
    ELSEIF ( latsys =='monoclinic-B'.OR.latsys =='mB'.OR.latsys =='moB'.OR.&
         latsys =='centered-monoclinic3' ) THEN

       noangles=.false.
       IF ( (abs(alpha-90.0)<eps).AND.(abs(beta-90.0)<eps) ) THEN
          IF ( ABS(gamma - 90.0) <eps )  CALL juDFT_error("no monoclinic angle!",calledby ="lattice2")
       ELSE
          CALL juDFT_error("Please take gamma as monoclinic angle!")
       ENDIF
       CALL brvmat ( alpha, beta, gamma, am )
       am(:,1) = a * am(:,1)
       am(:,2) = b * am(:,2)
       am(:,3) = c * am(:,3)
       i_c = 7
       am = matmul ( am, lmat(:,:,i_c) )
       a1 = am(:,1)
       a2 = am(:,2)
       a3 = am(:,3)
       CALL angles( am )
       scale = 1.0

       !===> 13c monoclinic-I (mI)
    ELSEIF ( latsys =='monoclinic-I'.OR.latsys =='mI'.OR.latsys =='moI' ) THEN

       noangles=.false.
       IF ( (abs(alpha-90.0)<eps).AND.(abs(beta-90.0)<eps) ) THEN
          IF ( ABS(gamma - 90.0) <eps )  CALL juDFT_error("no monoclinic angle!")
       ELSE
          CALL juDFT_error("Please take gamma as monoclinic angle!",calledby ="lattice2")
       ENDIF
       CALL brvmat ( alpha, beta, gamma, am )
       am(:,1) = a * am(:,1)
       am(:,2) = b * am(:,2)
       am(:,3) = c * am(:,3)
       i_c = 3
       am = matmul ( am, lmat(:,:,i_c) )
       a1 = am(:,1)
       a2 = am(:,2)
       a3 = am(:,3)
       CALL angles( am )
       scale = 1.0

       !===> 14: triclinic        (aP)

    ELSEIF ( latsys =='aP' .OR. latsys =='triclinic' .OR. latsys =='tcl' )  THEN

       noangles=.false.
       i_c = 1
       CALL brvmat ( alpha, beta, gamma, am )
       a1 = a*am(:,1)
       a2 = b*am(:,2)
       a3 = c*am(:,3)
       CALL angles( am )
       scale = 1.0

    ELSE
       call judft_error(("unknown lattice system latsys="//latsys))
    ENDIF

    IF ( noangles .AND. ( abs(alpha - 90.0 ) > eps .OR.&
         abs(beta  - 90.0 ) > eps .OR. abs(gamma - 90.0 ) > eps )    ) THEN
       call judft_error("ERROR in &lattice ... For the given lattice system all angles should be 90deg.")
    ENDIF

    IF (abs(scale(1)) < eps) THEN
       CALL juDFT_error("Illegal program section ")
    ENDIF
    aa = a0

911 CONTINUE

    RETURN
  END SUBROUTINE process_lattice
  !
  !**********************************************************************!
  !
  SUBROUTINE angles( am )
    !----------------------------------------------------------------------!
    !     given an bravais matrix (am), calculate length of basis vectors  !
    !     and angles beween them ; write results to standard output        !
    !----------------------------------------------------------------------!

    USE m_constants
    IMPLICIT NONE

    REAL, INTENT(IN) :: am(3,3)

    REAL     ca,al(3)
    INTEGER  i,j,i1,i2

    al = 0.0
    DO j = 1, 3
       DO i = 1, 3
          al(j) = al(j) + am(i,j)*am(i,j)
       ENDDO
       al(j) = sqrt(al(j))
    ENDDO

    DO j = 1, 3
       WRITE (oUnit,'("vector ",i1," : ",3f9.5,5x," length : ",f9.5)') j,am(:,j),al(j)
    ENDDO

    DO i1 = 1, 2
       DO i2 = i1+1, 3
          ca = 0.0
          DO i = 1, 3
             ca = ca + am(i,i1)*am(i,i2)
          ENDDO
          ca  = ca/(al(i1)*al(i2))
          ca = acos(ca)*180/pi_const

          WRITE (oUnit,'("angle between vectors (",i1,",",i1,") =",f9.5)') i1,i2,ca
       ENDDO
    ENDDO

  END SUBROUTINE angles
  !
  !**********************************************************************!
  !
  SUBROUTINE brvmat ( alpha, beta, gamma, am )
    !----------------------------------------------------------------------!
    !     given the angles alpha, beta and gamma, set up an matrix 'am'    !
    !     with 3 unit vectors and these angles between them. The first     !
    !     unit vector poins in (1,0,0) direction                gb`05      !
    !----------------------------------------------------------------------!

    USE m_constants
    IMPLICIT NONE

    REAL, INTENT (IN)  :: alpha, beta, gamma
    REAL, INTENT (OUT) :: am(3,3)

    REAL ca,cb,cg,sg,c1,c2

    ca = cos(alpha*pi_const/180); cb = cos(beta*pi_const/180)
    cg = cos(gamma*pi_const/180); sg = sin(gamma*pi_const/180)
    c1 = (ca - cg*cb ) / sg
    c2 = sqrt( 1 - cb**2 - c1**2 )

    am(1,1) = 1.0 ; am(2,1) = 0.0 ; am(3,1) = 0.0
    am(1,2) = cg  ; am(2,2) = sg  ; am(3,2) = 0.0
    am(1,3) = cb  ; am(2,3) = c1  ; am(3,3) = c2

  END SUBROUTINE brvmat

END MODULE m_process_lattice_namelist