  subroutine landau_level_k
     !> calculate landau levels in 3D system in special k line
     !> fix B field
     !
     !> the magnetic field is in the a1 a2 plane
     !
     !> B= (B cos\theta, B sin\theta, 0)
     !
     !> construct on Dec 8 2015
     !
     !> By QuanSheng Wu at ETH Zurich Honggerberg
     !
     ! Copyright (c) 2010 QuanSheng Wu. All rights reserved.
     use para
     implicit none

     !> magnetic supercell size, perpendicular to the magnetic field
     integer :: Nq
     integer :: ik
     integer :: ia1
     integer :: ia2
     integer :: i, j

     !> Ndimq= Nq* Num_wann
     integer :: Ndimq

     integer :: nlines

     integer :: ierr

     real(dp) :: B0
     real(dp) :: theta

     real(dp) :: t1, temp, dis, dis1
     ! wave vector
     real(dp) :: k3(3)

     !> dim= Ndimq, knv3
     real(dp), allocatable :: W(:)
     real(dp), allocatable :: eigv(:, :)
     real(dp), allocatable :: eigv_mpi(:, :)

     !> dim= Ndimq*Ndimq
     complex(dp), allocatable :: ham_landau(:, :)

     Nq= nslab
     Ndimq= Num_wann* Nq
     allocate( ham_landau(Ndimq, Ndimq))
     allocate( W( Ndimq))
     allocate( eigv( Ndimq, knv2))
     allocate( eigv_mpi( Ndimq, knv2))
     eigv_mpi= 0d0
     eigv    = 0d0
     ham_landau= 0d0

     !> deal with the magnetic field
     !> first transform the Bx By into B*Cos\theta, B*Sin\theta
     if (abs(By)<1e-8) then
        theta= 0d0
     elseif (By>0) then
        theta = atan(Bx/By)
     else
        theta = atan(Bx/By)+ pi
     endif
     if (abs(theta)<1e-8 .and. Bx<0 ) theta= theta+ pi

     !> get the shortest bond in the home unit cell
     dis1= sqrt(sum((Rua_new)**2))
     do ia1=1, Num_atoms
        do ia2=ia1+1, Num_atoms
           dis = (Rua_new(2))*Cos(theta)- (Rua_new(1))*Sin(theta)
           if (abs(dis)< abs(dis1) .and. abs(dis)>1e-5) dis1= abs(dis)
           dis = (Rub_new(2))*Cos(theta)- (Rub_new(1))*Sin(theta)
           if (abs(dis)< abs(dis1) .and. abs(dis)>1e-5) dis1= abs(dis)
        enddo
     enddo

     !> The flux in the supercell should be 2*pi
     if (dis1< 1e-9) stop 'something wrong with the atom position'
     B0= 2d0*pi/ (dis1* Ruc_new(3)*Nq)
     B0= abs(B0)
     Bx= B0* Cos(theta)
     By= B0* Sin(theta)

     if (cpuid==0) then
        write(stdout, '(a, 2f18.8)')' Bx, By= ', Bx, By
     endif

     !> calculate the landau levels along special k line
     k3= 0
     do ik=1+ cpuid, knv2, num_cpu

        if (cpuid==0) print *, ik, knv2
        k3(1:2) = k2_path(ik, :)
        call ham_3Dlandau2(Ndimq, Nq, k3, ham_landau)

        !> diagonalization by call zheev in lapack
        W= 0d0
        call eigensystem_c( 'N', 'U', Ndimq ,ham_landau, W)

        eigv(:, ik)= W
     enddo !ik

#if defined (MPI)
     call mpi_allreduce(eigv,eigv_mpi,size(eigv),&
                       mpi_dp,mpi_sum,mpi_cmw,ierr)
#else
     eigv_mpi= eigv
#endif

     if (cpuid.eq.0) then
        open(unit=100, file='landaulevel_k.dat')
        do j=1, Ndimq
           do i=1, knv2
              write(100,'(2f15.7, i8)')k2len(i), eigv_mpi(j, i)
           enddo
           write(100 , *)''
        enddo
        close(100)
        write(stdout,*) 'calculate landau level done'
     endif

     return
  end subroutine landau_level_k

  subroutine landau_level_B
     !> calculate landau levels in 3D system for different B
     !> fix k point, usually Gamma point
     use para
     implicit none

     !> magnetic supercell size, perpendicular to the magnetic field
     integer :: Nq
     integer :: ia1
     integer :: ia2
     integer :: ib
     integer :: i, j

     !> Ndimq= Nq* Num_wann
     integer :: Ndimq

     integer :: Nmag

     integer :: ierr

     real(dp) :: B0
     real(dp) :: theta

     real(dp) :: dis, dis1
     ! wave vector
     real(dp) :: k3(3)

     !> dim= Ndimq, knv3
     real(dp), allocatable :: mag(:)
     real(dp), allocatable :: W(:)
     real(dp), allocatable :: eigv(:, :)
     real(dp), allocatable :: eigv_mpi(:, :)

     !> dim= Ndimq*Ndimq
     complex(dp), allocatable :: ham_landau(:, :)

     Nq= nslab
     Nmag= Nq
     Ndimq= Num_wann* Nq
     allocate( ham_landau(Ndimq, Ndimq))
     allocate( W( Ndimq))
     allocate( eigv( Ndimq, Nmag))
     allocate( eigv_mpi( Ndimq, Nmag))
     allocate( mag(Nq))
     mag= 0d0
     eigv_mpi= 0d0
     eigv    = 0d0
     ham_landau= 0d0

     !> deal with the magnetic field
     !> first transform the Bx By into B*Cos\theta, B*Sin\theta
     if (abs(By)<1e-8) then
        theta= 0d0
     elseif (By>0) then
        theta = atan(Bx/By)
     else
        theta = atan(Bx/By)+ pi
     endif
     if (abs(theta)<1e-8 .and. Bx<0 ) theta= theta+ pi

     !> get the shortest bond in the home unit cell
     dis1= sqrt(sum((Rua_new)**2))
     do ia1=1, Num_atoms
        do ia2=ia1+1, Num_atoms
           dis= (Rua_new(2))*Cos(theta)- (Rua_new(1))*Sin(theta)
           if (abs(dis)< abs(dis1) .and. abs(dis)>1e-5) dis1= abs(dis)
           dis= (Rub_new(2))*Cos(theta)- (Rub_new(1))*Sin(theta)
           if (abs(dis)< abs(dis1) .and. abs(dis)>1e-5) dis1= abs(dis)
        enddo
     enddo

     !> The flux in the supercell should be 2*pi
     if (dis1< 1e-9) stop 'something wrong with the atom position'
     B0= 2d0*pi/ (dis1* Ruc_new(3)*Nq)
     B0= abs(B0)

     do ib=1, Nmag
        mag(ib)= B0* ib
     enddo

     k3= 0d0
     !> calculate the landau levels along special k line
     do ib=1+ cpuid, Nmag, num_cpu

        Bx= mag(ib)* Cos(theta)
        By= mag(ib)* Sin(theta)

        if (cpuid==0) print *, ib, Nmag
        call ham_3Dlandau2(Ndimq, Nq, k3, ham_landau)

        !> diagonalization by call zheev in lapack
        W= 0d0
        call eigensystem_c( 'N', 'U', Ndimq ,ham_landau, W)

        eigv(:, ib)= W
     enddo !ik

#if defined (MPI)
     call mpi_allreduce(eigv,eigv_mpi,size(eigv),&
                       mpi_dp,mpi_sum,mpi_cmw,ierr)
#else
     eigv_mpi= eigv
#endif

     if (cpuid.eq.0) then
        open(unit=101, file='landaulevel_B.dat')
        do j=1, Ndimq
           do i=1, Nmag
              write(101,'(2f15.7, i8)')mag(i), eigv_mpi(j, i)
           enddo
           write(101 , *)''
        enddo
        close(101)
        write(stdout,*) 'calculate landau level done'
     endif

     return

  end subroutine landau_level_B

  subroutine ham_3Dlandau(Ndimq, Nq, k, ham_landau)
     !> calculate hamiltonian for landau levels
     !> consider the internal atom's position
     use para
     implicit none

     integer, intent(in) :: Ndimq
     integer, intent(in) :: Nq
     real(dp), intent(in) :: k(3)
     complex(dp), intent(out) :: ham_landau(Ndimq, Ndimq)

     !> inta-hopping for the supercell
     complex(dp), allocatable :: H00(:, :)

     !> inter-hopping for the supercell
     complex(dp), allocatable :: H01(:, :)

     ! loop index
     integer :: i1, i2

     ! loop index
     integer :: iR

     ! index used to sign irvec
     integer :: ia,ib,ic
     integer :: ia1, ia2

     integer :: istart1, istart2
     integer :: iend1, iend2

     integer :: inew_ic

     !> nwann= Num_wann/2
     integer :: nwann

     integer, allocatable :: orbital_start(:)

     ! new index used to sign irvec
     real(dp) :: new_ia,new_ib,new_ic

     ! wave vector k times lattice vector R
     real(Dp) :: kdotr
     real(dp) :: phase
     complex(dp) :: ratio
     complex(dp) :: fac

     real(dp) :: Rp1(3)
     real(dp) :: Rp2(3)
     real(dp) :: R1(3)
     real(dp) :: R2(3)
     real(dp) :: Ri(3)
     real(dp) :: Rj(3)
     real(dp) :: tau1(3)
     real(dp) :: tau2(3)

     allocate( H00( Ndimq, Ndimq))
     allocate( H01( Ndimq, Ndimq))

     nwann= Num_wann/2
     allocate( orbital_start(Num_atoms+ 1))
     orbital_start= 0
     orbital_start(1)= 1
     do ia=1, Num_atoms
        orbital_start(ia+1)= orbital_start(ia)+ nprojs(ia)
     enddo

     !> calculate intra-hopping
     H00=0.0d0
     ! i1 column index
     do i1=1, Nq
        ! i2 row index
        do i2=1, Nq
           if (abs(i2-i1)> ijmax) cycle
           !> sum over R points to get H(k1, k2)
           do iR=1, Nrpts
              ia=irvec(1,iR)
              ib=irvec(2,iR)
              ic=irvec(3,iR)

              !> new lattice
              call latticetransform(ia, ib, ic, new_ia, new_ib, new_ic)

              inew_ic= int(new_ic)
              if (inew_ic /= (i2-i1)) cycle

              !> exp(i k.R)
              kdotr= k(1)*new_ia+ k(2)*new_ib
              ratio= cos(2d0*pi*kdotr)+ zi*sin(2d0*pi*kdotr)

              R1= (i1-1)*Ruc_new
              R2= new_ia*Rua_new+ new_ib*Rub_new+ (i2-1)*Ruc_new
              Rp1= R1
              Rp2= R2

              do ia1=1, Num_atoms
              do ia2=1, Num_atoms
                 R1= Atom_position(:, ia1)
                 R2= Atom_position(:, ia2)
                 call rotate(R1, tau1)
                 call rotate(R2, tau2)

                 Ri= Rp1+ tau1
                 Rj= Rp2+ tau2

                !write(*, '(3i3, 3(2x, 3f7.3))')ia, ib, ic, Ri, &
                !Rj-Ri, Ri+Rj
                !write(*, '(3i3, 3(2x, 3f7.3))')ia, ib, ic, Rp2, tau2, Rj

                 phase= By*(Rj(3)+Ri(3))*(Rj(1)-Ri(1))  &
                      - Bx*(Rj(3)+Ri(3))*(Rj(2)-Ri(2))
                 fac= cos(phase)+ zi*sin(phase)

                !write(*, '(a, 4i5   )') 'iR, ia ib ic', ir, ia, ib, ic
                !write(*, '(a, 4f10.5)') '            ', new_ia, new_ib, new_ic
                !write(*, '(a, 3f10.5)') 'Ri', Ri
                !write(*, '(a, 3f10.5)') 'Rj', Rj
                !write(*, '(a, 3f10.5)') 'phase', phase

                 istart1= (i2-1)*Num_wann+ orbital_start(ia1)
                 iend1= (i2-1)*Num_wann+ orbital_start(ia1+1)- 1
                 istart2= (i1-1)*Num_wann+ orbital_start(ia2)
                 iend2= (i1-1)*Num_wann+ orbital_start(ia2+1)- 1

                 H00( istart1:iend1, istart2:iend2) &
                 = H00( istart1:iend1, istart2:iend2) &
                 + HmnR( istart1- (i2-1)*Num_wann:iend1- (i2-1)*Num_wann, &
                 istart2- (i1-1)*Num_wann:iend2- (i1-1)*Num_wann, iR)*ratio/ndegen(iR)* fac

                 !> there is soc term in the hr file
                 if (soc>0) then
                    istart1= (i2-1)*Num_wann+ orbital_start(ia1) + Nwann
                    iend1= (i2-1)*Num_wann+ orbital_start(ia1+1)- 1 + Nwann
                    istart2= (i1-1)*Num_wann+ orbital_start(ia2)
                    iend2= (i1-1)*Num_wann+ orbital_start(ia2+1)- 1

                    H00( istart1:iend1, istart2:iend2) &
                    = H00( istart1:iend1, istart2:iend2) &
                    + HmnR( istart1- (i2-1)*Num_wann:iend1- (i2-1)*Num_wann, &
                    istart2- (i1-1)*Num_wann:iend2- (i1-1)*Num_wann, iR)*ratio/ndegen(iR)* fac

                    istart1= (i2-1)*Num_wann+ orbital_start(ia1)
                    iend1= (i2-1)*Num_wann+ orbital_start(ia1+1)- 1
                    istart2= (i1-1)*Num_wann+ orbital_start(ia2) + Nwann
                    iend2= (i1-1)*Num_wann+ orbital_start(ia2+1)- 1 + Nwann

                    H00( istart1:iend1, istart2:iend2) &
                    = H00( istart1:iend1, istart2:iend2) &
                    + HmnR( istart1- (i2-1)*Num_wann:iend1- (i2-1)*Num_wann, &
                    istart2- (i1-1)*Num_wann:iend2- (i1-1)*Num_wann, iR)*ratio/ndegen(iR)* fac

                    istart1= (i2-1)*Num_wann+ orbital_start(ia1) + Nwann
                    iend1= (i2-1)*Num_wann+ orbital_start(ia1+1)- 1 + Nwann
                    istart2= (i1-1)*Num_wann+ orbital_start(ia2) + Nwann
                    iend2= (i1-1)*Num_wann+ orbital_start(ia2+1)- 1 + Nwann

                    H00( istart1:iend1, istart2:iend2) &
                    = H00( istart1:iend1, istart2:iend2) &
                    + HmnR( istart1- (i2-1)*Num_wann:iend1- (i2-1)*Num_wann, &
                    istart2- (i1-1)*Num_wann:iend2- (i1-1)*Num_wann, iR)*ratio/ndegen(iR)* fac
                 endif ! soc
              enddo ! ia2
              enddo ! ia1
           enddo ! iR
        enddo ! i2
     enddo ! i1

     !> check hermitcity
     do i1=1,Nq*Num_wann
     do i2=1,Nq*Num_wann
       !if(abs(H00(i1,i2)-conjg(H00(i2,i1))).ge.1e-6)then
       !  write(stdout,*)'there are something wrong with H00'
       !  print *, i1, i2, H00(i1, i2)
       !  stop
       !endif
     enddo
     enddo

     !>> calculate inter-hopping
     H01=0.0d0
     ! i1 column index
     do i1=1, Nq
        ! i2 row index
        do i2=1, Nq
           !> sum over R points to get H(k1, k2)
           do iR=1, Nrpts
              ia=irvec(1,iR)
              ib=irvec(2,iR)
              ic=irvec(3,iR)

              !> new lattice
              call latticetransform(ia, ib, ic, new_ia, new_ib, new_ic)

              inew_ic= int(new_ic)
              if (inew_ic /= (i2+ Nq -i1)) cycle

              !> exp(i k.R)
              kdotr= k(1)*new_ia+ k(2)*new_ib
              ratio= cos(2d0*pi*kdotr)+ zi*sin(2d0*pi*kdotr)

              R1= (i1-1)*Ruc_new
              R2= new_ia*Rua_new+ new_ib*Rub_new+ (i2-1+ Nq)*Ruc_new
              Rp1= R1
              Rp2= R2
             !call rotate(R1, Rp1)
             !call rotate(R2, Rp2)

              do ia1=1, Num_atoms
              do ia2=1, Num_atoms
                 R1= Atom_position(:, ia1)
                 R2= Atom_position(:, ia2)
                 call rotate(R1, tau1)
                 call rotate(R2, tau2)

                 Ri= Rp1+ tau1
                 Rj= Rp2+ tau2

                 phase= alpha*By*(Rj(3)+Ri(3))*(Rj(1)-Ri(1))  &
                      - alpha*Bx*(Rj(3)+Ri(3))*(Rj(2)-Ri(2))
                 fac= cos(phase)+ zi*sin(phase)

                !write(*, '(a, 4i5   )') 'iR, ia ib ic', ir, ia, ib, ic
                !write(*, '(a, 4f10.5)') '            ', new_ia, new_ib, new_ic
                !write(*, '(a, 3f10.5)') 'Ri', Ri
                !write(*, '(a, 3f10.5)') 'Rj', Rj
                !write(*, '(a, 3f10.5)') 'phase', phase

                 istart1= (i2-1)*Num_wann+ orbital_start(ia1)
                 iend1= (i2-1)*Num_wann+ orbital_start(ia1+1)- 1
                 istart2= (i1-1)*Num_wann+ orbital_start(ia2)
                 iend2= (i1-1)*Num_wann+ orbital_start(ia2+1)- 1

                 H01( istart1:iend1, istart2:iend2) &
                 = H01( istart1:iend1, istart2:iend2) &
                 + HmnR( istart1- (i2-1)*Num_wann:iend1- (i2-1)*Num_wann, &
                 istart2- (i1-1)*Num_wann:iend2- (i1-1)*Num_wann, iR)*ratio/ndegen(iR)* fac

                 !> there is soc term in the hr file
                 if (soc>0) then
                    istart1= (i2-1)*Num_wann+ orbital_start(ia1) + Nwann
                    iend1= (i2-1)*Num_wann+ orbital_start(ia1+1)- 1 + Nwann
                    istart2= (i1-1)*Num_wann+ orbital_start(ia2)
                    iend2= (i1-1)*Num_wann+ orbital_start(ia2+1)- 1

                    H01( istart1:iend1, istart2:iend2) &
                    = H01( istart1:iend1, istart2:iend2) &
                    + HmnR( istart1- (i2-1)*Num_wann:iend1- (i2-1)*Num_wann, &
                    istart2- (i1-1)*Num_wann:iend2- (i1-1)*Num_wann, iR)*ratio/ndegen(iR)* fac

                    istart1= (i2-1)*Num_wann+ orbital_start(ia1)
                    iend1= (i2-1)*Num_wann+ orbital_start(ia1+1)- 1
                    istart2= (i1-1)*Num_wann+ orbital_start(ia2) + Nwann
                    iend2= (i1-1)*Num_wann+ orbital_start(ia2+1)- 1 + Nwann

                    H01( istart1:iend1, istart2:iend2) &
                    = H01( istart1:iend1, istart2:iend2) &
                    + HmnR( istart1- (i2-1)*Num_wann:iend1- (i2-1)*Num_wann, &
                    istart2- (i1-1)*Num_wann:iend2- (i1-1)*Num_wann, iR)*ratio/ndegen(iR)* fac

                    istart1= (i2-1)*Num_wann+ orbital_start(ia1) + Nwann
                    iend1= (i2-1)*Num_wann+ orbital_start(ia1+1)- 1 + Nwann
                    istart2= (i1-1)*Num_wann+ orbital_start(ia2) + Nwann
                    iend2= (i1-1)*Num_wann+ orbital_start(ia2+1)- 1 + Nwann

                    H01( istart1:iend1, istart2:iend2) &
                    = H01( istart1:iend1, istart2:iend2) &
                    + HmnR( istart1- (i2-1)*Num_wann:iend1- (i2-1)*Num_wann, &
                    istart2- (i1-1)*Num_wann:iend2- (i1-1)*Num_wann, iR)*ratio/ndegen(iR)* fac
                 endif ! soc
              enddo ! ia2
              enddo ! ia1
           enddo ! iR
        enddo ! i2
     enddo ! i1

     !> periodic boundary
     ham_landau= H00+ H01* exp(zi*k(3)) + conjg(transpose(H01))* exp(-zi*k(3))

     !> check hermitcity
     do i1=1,Nq*Num_wann
     do i2=1,Nq*Num_wann
       !if(abs(H00(i1,i2)-conjg(H00(i2,i1))).ge.1e-6)then
       !  write(stdout,*)'there are something wrong with ham_landau'
       !  stop
       !endif
     enddo
     enddo

     return
  end subroutine ham_3Dlandau

  subroutine ham_3Dlandau2(Ndimq, Nq, k, ham_landau)
     !> calculate hamiltonian for landau levels
     !> don't consider the internal atom's position
     use para
     implicit none

     integer, intent(in) :: Ndimq
     integer, intent(in) :: Nq
     real(dp), intent(in) :: k(3)
     complex(dp), intent(out) :: ham_landau(Ndimq, Ndimq)

     !> inta-hopping for the supercell
     complex(dp), allocatable :: H00(:, :)

     !> inter-hopping for the supercell
     complex(dp), allocatable :: H01(:, :)

     ! loop index
     integer :: i1, i2

     ! loop index
     integer :: iR

     ! index used to sign irvec
     integer :: ia,ib,ic

     integer :: istart1, istart2
     integer :: iend1, iend2

     integer :: inew_ic

     !> nwann= Num_wann/2
     integer :: nwann

     integer, allocatable :: orbital_start(:)

     ! new index used to sign irvec
     real(dp) :: new_ia,new_ib,new_ic

     ! wave vector k times lattice vector R
     real(Dp) :: kdotr
     real(dp) :: phase
     complex(dp) :: ratio
     complex(dp) :: fac

     real(dp) :: Ri(3)
     real(dp) :: Rj(3)

     allocate( H00( Ndimq, Ndimq))
     allocate( H01( Ndimq, Ndimq))

     nwann= Num_wann/2
     allocate( orbital_start(Num_atoms+ 1))
     orbital_start= 0
     orbital_start(1)= 1
     do ia=1, Num_atoms
        orbital_start(ia+1)= orbital_start(ia)+ nprojs(ia)
     enddo

     !> calculate intra-hopping
     H00=0.0d0
     ! i1 column index
     do i1=1, Nq
        ! i2 row index
        do i2=1, Nq
           if (abs(i2-i1)> ijmax) cycle
           !> sum over R points to get H(k1, k2)
           do iR=1, Nrpts
              ia=irvec(1,iR)
              ib=irvec(2,iR)
              ic=irvec(3,iR)

              !> new lattice
              call latticetransform(ia, ib, ic, new_ia, new_ib, new_ic)

              inew_ic= int(new_ic)
              if (inew_ic /= (i2-i1)) cycle

              !> exp(i k.R)
              kdotr= k(1)*new_ia+ k(2)*new_ib
              ratio= cos(2d0*pi*kdotr)+ zi*sin(2d0*pi*kdotr)

              Ri= (i1-1)*Ruc_new
              Rj= new_ia*Rua_new+ new_ib*Rub_new+ (i2-1)*Ruc_new

              phase= By*(Rj(3)+Ri(3))*(Rj(1)-Ri(1))  &
                   - Bx*(Rj(3)+Ri(3))*(Rj(2)-Ri(2))
              fac= cos(phase)+ zi*sin(phase)

              istart1= (i2-1)*Num_wann+ 1
              iend1= (i2-1)*Num_wann+ Num_wann
              istart2= (i1-1)*Num_wann+ 1
              iend2= (i1-1)*Num_wann+ Num_wann

              H00(istart1:iend1, istart2:iend2)= &
              H00(istart1:iend1, istart2:iend2)+ &
              HmnR(:, :, iR)/dble(ndegen(iR))* ratio*fac

           enddo ! iR
          !pause
        enddo ! i2
     enddo ! i1

     !> check hermitcity
     do i1=1,Nq*Num_wann
     do i2=1,Nq*Num_wann
        if(abs(H00(i1,i2)-conjg(H00(i2,i1))).ge.1e-6)then
          write(stdout,*)'there are something wrong with H00'
          write(*,*)'there are something wrong with H00'
          print *, i1, i2, H00(i1, i2)
          stop
        endif
     enddo
     enddo

     !> calculate inter-hopping
     H01=0.0d0
     ! i1 column index
     do i1=1, Nq
        ! i2 row index
        do i2=1, Nq
           if (abs(i2+Nq-i1)> ijmax) cycle
           !> sum over R points to get H(k1, k2)
           do iR=1, Nrpts
              ia=irvec(1,iR)
              ib=irvec(2,iR)
              ic=irvec(3,iR)

              !> new lattice
              call latticetransform(ia, ib, ic, new_ia, new_ib, new_ic)

              inew_ic= int(new_ic)
              if (inew_ic /= (i2+Nq-i1)) cycle

              !> exp(i k.R)
              kdotr= k(1)*new_ia+ k(2)*new_ib
              ratio= cos(2d0*pi*kdotr)+ zi*sin(2d0*pi*kdotr)

              Ri= (i1-1)*Ruc_new
              Rj= new_ia*Rua_new+ new_ib*Rub_new+ (i2+Nq-1)*Ruc_new

              phase= By*(Rj(3)+Ri(3))*(Rj(1)-Ri(1))  &
                   - Bx*(Rj(3)+Ri(3))*(Rj(2)-Ri(2))
              fac= cos(phase)+ zi*sin(phase)

              istart1= (i2-1)*Num_wann+ 1
              iend1= (i2-1)*Num_wann+ Num_wann
              istart2= (i1-1)*Num_wann+ 1
              iend2= (i1-1)*Num_wann+ Num_wann

              H01(istart1:iend1, istart2:iend2)= &
              H01(istart1:iend1, istart2:iend2)+ &
              HmnR(:, :, iR)/dble(ndegen(ir))* ratio*fac

           enddo ! iR
        enddo ! i2
     enddo ! i1

     !> periodic boundary
     ham_landau= H00 + H01* exp(zi*k(3)) + conjg(transpose(H01))* exp(-zi*k(3))

     !> check hermitcity
     do i1=1,Nq*Num_wann
     do i2=1,Nq*Num_wann
       !if(abs(H00(i1,i2)-conjg(H00(i2,i1))).ge.1e-6)then
       !  write(stdout,*)'there are something wrong with ham_landau'
       !  stop
       !endif
     enddo
     enddo

     return
  end subroutine ham_3Dlandau2


      program sblas
      use timers
      type(TimerType) :: vecaddTime,vecsumTime,trimvTime,totalTime

      integer i,j,n,m,k,nsteps
      parameter (n=1024*60,m=512)
      parameter (nsteps=1000)
      real*8 a(n),b(n),x(n),y(8,m),l(m,m)
      common /heap/ a,b,x,y,l
      real*8 res
C
      call TimerCreate(vecaddTime,"vecadd")
      call TimerCreate(vecsumTime,"vecsum")
      call TimerCreate(trimvTime,"trimv")
      call TimerCreate(totalTime,"total")
c
c Loop over whole program to get reasonable execution time
c (simulates a time-steping code)
c
      call TimerOn(totalTime)
c
      do k=1,nsteps
c
c 'Update' vector data
c
      call vector_update(n,x,a,b)
c
c vector addition operation
c
      call TimerOn(vecaddTime)
      call vecadd(n,x,a,b)
      call TimerOff(vecaddTime)
c
c sum operation
c
      call TimerOn(vecsumTime)
      call vecsum (n,res,x)
      call TimerOff(vecsumTime)
c
c 'Update' lower triangular matrix and y vector
c
      call matrix_update(m,y,l)
c
c triangular matrix times vector operation
c
      call TimerOn(trimvTime)
      call trimv(m,y,l,a)
      call TimerOff(trimvTime)
c
c end time-step loop
	end do
c
      call TimerOff(totalTime)
c
c print out some results
c
      print *,'x(1) = ',x(1),'x(n) = ', x(n)
      print *,'Sum of x() = ',res
      print *,'y(1,1) = ',y(1,1),'y(1,m) = ', y(1,m)
C
C  OUTPUT TIMING DATA
C
      call TimerPrint(vecaddTime)
      call TimerPrint(vecsumTime)
      call TimerPrint(trimvTime)
      call TimerPrint(totalTime)
c
      end
c
c Subroutines
c
      subroutine vector_update (n,x,a,b)
c
c .. Scalar arguments
      integer n
c
c .. Array arguments
      real*8 x(n),a(n),b(n)
c
c .. Local scalars
      integer i
c
c .. External functions
c
      do i=1,n
         x(i) = 0.
         a(i) = 3.142
         b(i) = 3.142
      end do
c
      return
      end
c
      subroutine matrix_update (m,y,l)
c
c .. Scalar arguments
      integer m
c
c .. Array arguments
      real*8 y(8,m),l(m,m)
c
c .. Local scalars
      integer i,j
c
c .. External functions
c
      do i=1,m
         y(1,i) = 0.
         do j=1,i
            l(j,i) = 2.
         end do
      end do
c
      return
      end
c
      subroutine vecadd (n,x,a,b)
c
c .. Scalar arguments
      integer n
c
c .. Array arguments
      real*8 x(n),a(n),b(n)
c
c .. Local scalars
      integer i
c
c .. External functions
c
!$omp parallel do schedule(static)
      do i=1,n
         x(i) = a(i) + b(i)
      end do
      return
      end
c
      subroutine vecsum (n,sum,a)
c
c .. Scalar arguments
      integer n
      real*8 sum
c
c .. Array arguments
      real*8 a(n)
c
c .. Local scalars
      integer i
c
      sum = 0.0
!$omp parallel do schedule(static) reduction(+:sum)
      do i=1,n
        sum = sum +a(i)
      end do
      return
      end
c
      subroutine trimv (m,y,l,a)
c
c .. Scalar arguments
      integer m
c
c .. Array arguments
      real*8 y(8,m),l(m,m),a(m)
c
c .. Local scalars
      integer i,j
c
c .. External functions
c
!$omp parallel do schedule(static)
      do i=1,m
        do j=1,i
          y(1,i) = y(1,i) + l(j,i)*a(j)
        end do
      end do
      return
      end


	subroutine covar(maxev0, v, n, q, cvm)

	implicit none

c	Parameters:
	integer	maxev0
	doubleprecision	v(maxev0*4, maxev0*4)
	integer	n
	doubleprecision	q(maxev0*4)
	real	cvm(maxev0*4, maxev0*4)

c	Local variables:
	integer	i, j, k		! Dummy loop indices
	real	sum

      do i=1,n
         do j=1,i
           sum= 0
           do k=1,n
              if(q(k).ne.0) sum= sum + v(i,k)*v(j,k) * (1/(q(k)*q(k)))
           enddo
           cvm(i,j)= sum
           cvm(j,i)= sum
         enddo
      enddo
      return
      end


module local_functions
implicit none
contains

  subroutine mult_noise(x,ampl)
  !
    real,intent(out):: x
    real,intent(in):: ampl
    real:: logampl
  !
    logampl = log(ampl)
    call random_number(x)
    x = (2*x - 1)  *  logampl
    x = exp(x)
  !
  end subroutine mult_noise

  subroutine init_random_seed()
  !
    integer :: i, n, clock
    integer, dimension(:), allocatable :: seed
  !
    call random_seed(size = n)
    allocate(seed(n))
  !
    call system_clock(count=clock)
  !
    seed = clock + 37 * (/ (i - 1, i = 1, n) /)
    call random_seed(put = seed)
  !
    deallocate(seed)
  !
  end subroutine init_random_seed

  subroutine check(ierr)
    use netcdf
    integer, intent(in):: ierr
    if (ierr/=NF90_NOERR) then
      print *, nf90_strerror(ierr)
      !stop
    end if
  end subroutine

end module

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

program create_slope
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! create a random slope matching geographic forcings from the variable       !!
!! "area" in a "geographic" storing netCDF file                               !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

use netcdf
use local_functions, only: mult_noise, init_random_seed, check
implicit none

  character(len=*), parameter::geofile='../INPUT/FOAM/CTRL_48x40/FOAM_Aire_CtrlR.nc'
  character(len=*), parameter::fileout='../INPUT/FOAM/CTRL_48x40/slope_random_FOAMctrl48x40.nc'
  integer, parameter:: nx=48, ny=40
! ============================================================================================
  real, parameter:: NOISE_AMPLITUDE = 100.
  real, parameter:: MEANSLOPE = 0.03354 & ! 0.03354 is present-day Earth mean slope
                               *  2.*log(NOISE_AMPLITUDE)/(NOISE_AMPLITUDE-1./NOISE_AMPLITUDE)
! ============================================================================================

  integer:: i,j, ierr, gfid,ofid,gdimid(2),odimid(2),gvarid(3),ovarid(3)
  real:: lon(nx), lat(ny)
  real, dimension(nx,ny):: area, slope
  real:: noise, missval

  character(len=*), parameter:: missvalname='_FillValue'

  ierr = nf90_open(   geofile , NF90_NOWRITE , gfid )  ;  call check(ierr)
  ierr = nf90_create( fileout , NF90_CLOBBER , ofid )  ;  call check(ierr)

  ierr = nf90_inq_varid( gfid , 'lon'  , gvarid(1) )  ;  call check(ierr)
  ierr = nf90_inq_varid( gfid , 'lat'  , gvarid(2) )  ;  call check(ierr)
  ierr = nf90_inq_varid( gfid , 'area' , gvarid(3) )  ;  call check(ierr)

  ierr = nf90_get_var( gfid , gvarid(1) , lon )   ;  call check(ierr)
  ierr = nf90_get_var( gfid , gvarid(2) , lat )   ;  call check(ierr)
  ierr = nf90_get_var( gfid , gvarid(3) , area )  ;  call check(ierr)
  !
  ! Default missing-value:
  missval = 9.96921e+36
  ierr = nf90_get_att( gfid , gvarid(3) , missvalname  , missval )  ;  call check(ierr)

  !---!

  ierr = nf90_def_dim( ofid , 'lon' , nx , odimid(1) )  ;  call check(ierr)
  ierr = nf90_def_dim( ofid , 'lat' , ny , odimid(2) )  ;  call check(ierr)

  ierr = nf90_def_var( ofid , 'lon' , NF90_REAL , odimid(1) , ovarid(1) )       ;  call check(ierr)
  ierr = nf90_copy_att( gfid , gvarid(1) , 'axis'       , ofid , ovarid(1) )    ;  call check(ierr)
  ierr = nf90_copy_att( gfid , gvarid(1) , 'nav_model'  , ofid , ovarid(1) )    ;  call check(ierr)
  ierr = nf90_copy_att( gfid , gvarid(1) , 'name'       , ofid , ovarid(1) )    ;  call check(ierr)
  ierr = nf90_copy_att( gfid , gvarid(1) , 'units'      , ofid , ovarid(1) )    ;  call check(ierr)
  !
  ierr = nf90_def_var( ofid , 'lat' , NF90_REAL , odimid(2) , ovarid(2) )       ;  call check(ierr)
  ierr = nf90_copy_att( gfid , gvarid(2) , 'axis'       , ofid , ovarid(2) )    ;  call check(ierr)
  ierr = nf90_copy_att( gfid , gvarid(2) , 'nav_model'  , ofid , ovarid(2) )    ;  call check(ierr)
  ierr = nf90_copy_att( gfid , gvarid(2) , 'name'       , ofid , ovarid(2) )    ;  call check(ierr)
  ierr = nf90_copy_att( gfid , gvarid(2) , 'units'      , ofid , ovarid(2) )    ;  call check(ierr)
  !
  ierr = nf90_def_var( ofid , 'slope' , NF90_REAL , odimid  , ovarid(3) )       ;  call check(ierr)
  ierr = nf90_put_att( gfid , ovarid(3) , 'name'  , 'slope' )                   ;  call check(ierr)
  ierr = nf90_put_att( ofid , ovarid(3) , 'units' , 'm/m' )                     ;  call check(ierr)
  ierr = nf90_put_att( ofid , ovarid(3) , missvalname  , missval )              ;  call check(ierr)

  ierr = nf90_close( gfid )

  ierr = nf90_enddef( ofid )

  ierr = nf90_put_var( ofid , ovarid(1) , lon )   ;  call check(ierr)
  ierr = nf90_put_var( ofid , ovarid(2) , lat )   ;  call check(ierr)

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

  call init_random_seed()

  do j = 1,ny
    do i = 1,nx

      if (area(i,j)/=missval .and. area(i,j)/=0.) then
         call mult_noise(noise,NOISE_AMPLITUDE)
!        ******************************
         slope(i,j) = MEANSLOPE * noise
!        ******************************
      else
        slope(i,j) = missval
      end if

    end do
  end do

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

  ierr = nf90_put_var( ofid , ovarid(3) , slope )  ;  call check(ierr)

  ierr = nf90_close( ofid )  ;  call check(ierr)

end program


Program Binario

integer a(32),x,n

read*, x

a(1) = mod(x,3)

10 continue

n = n+1

x = x/3

a(n+1) = mod(x,3)

if(x==0)goto 20

goto 10

20 continue

write(*,"(32I1)")(a(i),i=n,1,-1)

stop

end


module model_stokes_hypothesis
#include <messenger.h>
    use mod_kinds,          only: rk
    use mod_constants,      only: THREE, TWO
    use type_model,         only: model_t
    use type_chidg_worker,  only: chidg_worker_t
    use DNAD_D
    implicit none

    !>  Stokes' Hypothesis for computing the second coefficient of viscosity.
    !!
    !!  Model Fields:
    !!      - Second Coefficient of Viscosity
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/3/2016
    !!
    !---------------------------------------------------------------------------------------
    type, extends(model_t)  :: stokes_hypothesis_t

    contains

        procedure   :: init
        procedure   :: compute

    end type stokes_hypothesis_t
    !***************************************************************************************

contains

    !>  Initialize the model with a name and the model fields it is contributing to.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/1/2016
    !!
    !---------------------------------------------------------------------------------------
    subroutine init(self)
        class(stokes_hypothesis_t), intent(inout)   :: self

        call self%set_name('Stokes Hypothesis')
        call self%set_dependency('f(Q-)')

        call self%add_model_field('Second Coefficient of Laminar Viscosity')

    end subroutine init
    !***************************************************************************************

    !>  Routine for computing a viscosity contribution from Sutherland's Law.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/1/2016
    !!
    !--------------------------------------------------------------------------------------
    subroutine compute(self,worker)
        class(stokes_hypothesis_t), intent(in)      :: self
        type(chidg_worker_t),       intent(inout)   :: worker

        type(AD_D), dimension(:),   allocatable :: viscosity, second_viscosity

        !
        ! Interpolate solution to quadrature nodes
        !
        viscosity = worker%get_field('Laminar Viscosity','value')

        !
        ! Stokes' Hypothesis for the second coefficient of viscosity
        !
        second_viscosity = -(TWO/THREE)*viscosity

        !
        ! Contribute second coefficient of viscosity
        !
        call worker%store_model_field('Second Coefficient of Laminar Viscosity', 'value', second_viscosity)

    end subroutine compute
    !***************************************************************************************

end module model_stokes_hypothesis


SUBROUTINE make_grid_sphdata(hmean)
  !*****************************************************
  ! Written 17/2/15 by dh4gan
  ! This subroutine makes a regular grid in x,y,z and
  ! bins the particles accordingly

  ! x face = -xmax +(i-1)*dgrid and so on for y,z
  ! x centre = -xmax +(i-1)*dgrid +0.5*dgrid and so on for y,z

  ! Finding a particle's cell, location (xi,yi,zi):

  ! icell = int((xi-xmin)/dgrid +1) = int((xi+xmax)/dgrid +1)
  ! (and so on for jcell, kcell (y,z)
  !******************************************************

  use sphdata
  use sphneighbourdata
  use tachedata,only:nelement

  implicit none

  integer :: ielement, icell,jcell,kcell
  integer :: thiscell, celltot, neigen

  real,intent(in) :: hmean
  real :: dmax

  ! Set up uniform grid in x,y,z

  dmax = maxval(rmax)

  dgridmin = 2.0*dmax/real(ngridmax)
  print*, 'Minimum grid spacing: ', dgridmin,dmax,ngridmax

  ! Grid spacing
  dgrid = 2.0*hmean

  if(dgrid< dgridmin) then
     print*, 'Calculated dgrid too small: ', hmean, dgrid
     dgrid = dgridmin
  endif

  ngridx = int(2.0*xmax/dgrid +1)
  ngridy = int(2.0*ymax/dgrid +1)
  ngridz = int(2.0*zmax/dgrid +1)

  ncells = ngridx*ngridy*ngridz

  print*, 'xmax, ymax, zmax: ', xmax, ymax, zmax
  print*, 'Setting up regular grid, spacing: ',dgrid
  print*, 'Grid dimensions:'
  print*, 'nx = ',ngridx
  print*, 'ny = ', ngridy
  print*, 'nz = ', ngridz
  print*, 'Total cell no.: ',ncells

  ! Set up grid variables

  allocate(n_occ(ncells))

  print*, 'Cell IDs and occupancy set up'

  n_occ(:) = 0

  ! Bin particles in grid
  !$OMP PARALLEL &
  !$OMP shared(nelement,iphase,xyzmh,cellID,n_occ,occ) &
  !$OMP private(ielement,icell,jcell,kcell,thiscell)
  !$OMP DO SCHEDULE(runtime)
  do ielement=1,nelement

     if(iphase(ielement)/=0) cycle

     icell = int((xyzmh(1,ielement)+xmax)/dgrid +1)
     jcell = int((xyzmh(2,ielement)+ymax)/dgrid +1)
     kcell = int((xyzmh(3,ielement)+zmax)/dgrid +1)

     if(icell*jcell*kcell==0) print*, xyzmh(1:3,ielement), icell, jcell, kcell
     !thiscell = cellID(icell,jcell,kcell)

     call get_cellID(thiscell,icell,jcell,kcell,ngridx,ngridy,ngridz)

     if(thiscell>ncells) then
        print*, 'Error: cellID exceeds cell total'
        print*, thiscell, ncells, icell,jcell,kcell
     endif

     !$OMP CRITICAL
     n_occ(thiscell) = n_occ(thiscell)+1
     !$OMP END CRITICAL

  enddo
  !$OMP END DO
  !$OMP END PARALLEL

  cellmax = maxval(n_occ)

  ! Sum n occ to confirm that all particles are binned

  celltot = sum(n_occ)

  print*, 'Maximum cell occupancy: ',cellmax

  if(celltot.ne.nelement) then
     print*, "WARNING: Binned total doesn't match particle total: ", celltot, nelement
  endif

  !allocate(occ(ncells,cellmax))
  allocate(member(nelement))

  print*, 'Cell occupancy allocation complete'
  n_occ(:) = 0
  !occ(:,:) = 0

  ! Bin particles in grid
  !$OMP PARALLEL &
  !$OMP shared(nelement,iphase,xyzmh,cellID,n_occ,occ) &
  !$OMP private(ielement,icell,jcell,kcell,thiscell)
  !$OMP DO SCHEDULE(runtime)
  do ielement=1,nelement

     if(iphase(ielement)/=0) cycle

     neigen = neigen +1
     icell = int((xyzmh(1,ielement)+xmax)/dgrid +1)
     jcell = int((xyzmh(2,ielement)+ymax)/dgrid +1)
     kcell = int((xyzmh(3,ielement)+zmax)/dgrid +1)

     if(icell*jcell*kcell==0) print*, xyzmh(1:3,ielement), icell, jcell, kcell
!     thiscell = cellID(icell,jcell,kcell)

     call get_cellID(thiscell,icell,jcell,kcell,ngridx,ngridy,ngridz)

     if(ielement==1) print*, 'particle ',ielement, ' in cell ', thiscell
     !$OMP CRITICAL
     n_occ(thiscell) = n_occ(thiscell)+1
!     occ(thiscell,n_occ(thiscell)) = ielement
     member(ielement) = thiscell
     !$OMP END CRITICAL
     if(ielement==1) print*, 'membership: ', member(ielement)

  enddo
  !$OMP END DO
  !$OMP END PARALLEL

! Finally, create a sorted list of particle IDs so that we can access lists of
! cell members in cell order

print*, 'Sorting so that membership can be accessed in cell order'
allocate(isortcellpart(nelement))

do ielement=1,nelement
   isortcellpart(ielement) = ielement
   if(iphase(ielement)/=0)   isortcellpart(ielement) = -10
enddo

call sort2(nelement,member,isortcellpart,nelement)

print*, 'Sort complete'

return
end subroutine make_grid_sphdata


C-----------------------------------------------------------------------
      SUBROUTINE SPTGPT(IROMB,MAXWV,KMAX,NMAX,
     &                  KWSKIP,KGSKIP,NRSKIP,NGSKIP,
     &                  RLAT,RLON,WAVE,GP)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:  SPTGPT     TRANSFORM SPECTRAL SCALAR TO STATION POINTS
C   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-02-29
C
C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM
C           FROM SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES
C           TO SPECIFIED SETS OF STATION POINTS ON THE GLOBE.
C           THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL.
C           THE WAVE AND POINT FIELDS MAY HAVE GENERAL INDEXING,
C           BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER',
C           I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX.
C           THE TRANSFORMS ARE ALL MULTIPROCESSED OVER STATIONS.
C           TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION.
C           SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
C
C PROGRAM HISTORY LOG:
C   96-02-29  IREDELL
C 1998-12-15  IREDELL  OPENMP DIRECTIVES INSERTED
C
C USAGE:    CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX,
C    &                  KWSKIP,KGSKIP,NRSKIP,NGSKIP,
C    &                  RLAT,RLON,WAVE,GP)
C   INPUT ARGUMENTS:
C     IROMB    - INTEGER SPECTRAL DOMAIN SHAPE
C                (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
C     MAXWV    - INTEGER SPECTRAL TRUNCATION
C     KMAX     - INTEGER NUMBER OF FIELDS TO TRANSFORM.
C     NMAX     - INTEGER NUMBER OF STATION POINTS TO RETURN
C     KWSKIP   - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS
C                (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0)
C     KGSKIP   - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS
C                (DEFAULTS TO NMAX IF KGSKIP=0)
C     NRSKIP   - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS
C                (DEFAULTS TO 1 IF NRSKIP=0)
C     NGSKIP   - INTEGER SKIP NUMBER BETWEEN STATION POINTS
C                (DEFAULTS TO 1 IF NGSKIP=0)
C     RLAT     - REAL (*) STATION LATITUDES IN DEGREES
C     RLON     - REAL (*) STATION LONGITUDES IN DEGREES
C     WAVE     - REAL (*) WAVE FIELDS
C   OUTPUT ARGUMENTS:
C     GP       - REAL (*) STATION POINT SETS
C
C SUBPROGRAMS CALLED:
C   SPWGET       GET WAVE-SPACE CONSTANTS
C   SPLEGEND     COMPUTE LEGENDRE POLYNOMIALS
C   SPSYNTH      SYNTHESIZE FOURIER FROM SPECTRAL
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C
C$$$
      REAL RLAT(*),RLON(*),WAVE(*),GP(*)
      REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
      REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
      REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
      REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
      INTEGER MP(KMAX)
      REAL SLON(MAXWV),CLON(MAXWV)
      REAL WTOP(2*(MAXWV+1),KMAX)
      REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1)
      REAL F(2*MAXWV+3,2,KMAX)
      PARAMETER(PI=3.14159265358979)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  CALCULATE PRELIMINARY CONSTANTS
      CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
      MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
      MXTOP=MAXWV+1
      IDIM=2*MAXWV+3
      KW=KWSKIP
      KG=KGSKIP
      NR=NRSKIP
      NG=NGSKIP
      IF(KW.EQ.0) KW=2*MX
      IF(KG.EQ.0) KG=NMAX
      IF(NR.EQ.0) NR=1
      IF(NG.EQ.0) NG=1
      MP=0
C$OMP PARALLEL DO
      DO K=1,KMAX
        WTOP(1:2*MXTOP,K)=0
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  CALCULATE STATION FIELDS
C$OMP PARALLEL DO PRIVATE(RADLAT,RADLON,SLAT1,CLAT1)
C$OMP&       PRIVATE(PLN,PLNTOP,F,SLON,CLON,NK)
      DO N=1,NMAX
        RADLAT=PI/180*RLAT((N-1)*NR+1)
        RADLON=PI/180*RLON((N-1)*NR+1)
        IF(RLAT((N-1)*NR+1).GE.89.9995) THEN
          SLAT1=1.
          CLAT1=0.
        ELSEIF(RLAT((N-1)*NR+1).LE.-89.9995) THEN
          SLAT1=-1.
          CLAT1=0.
        ELSE
          SLAT1=SIN(RADLAT)
          CLAT1=COS(RADLAT)
        ENDIF
        CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP,
     &                PLN,PLNTOP)
        CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,KW,2*MXTOP,KMAX,
     &               CLAT1,PLN,PLNTOP,MP,WAVE,WTOP,F)
        DO L=1,MAXWV
          SLON(L)=SIN(L*RADLON)
          CLON(L)=COS(L*RADLON)
        ENDDO
        DO K=1,KMAX
          NK=(N-1)*NG+(K-1)*KG+1
          GP(NK)=F(1,1,K)
        ENDDO
        IF(KMAX.EQ.1) THEN
          NK=(N-1)*NG+1
          DO L=1,MAXWV
            GP(NK)=GP(NK)+2.*(F(2*L+1,1,1)*CLON(L)
     &                       -F(2*L+2,1,1)*SLON(L))
          ENDDO
        ELSE
          DO L=1,MAXWV
            DO K=1,KMAX
              NK=(N-1)*NG+(K-1)*KG+1
              GP(NK)=GP(NK)+2.*(F(2*L+1,1,K)*CLON(L)
     &                         -F(2*L+2,1,K)*SLON(L))
            ENDDO
          ENDDO
        ENDIF
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END


      SUBROUTINE TBMX(TBRC,TBLC,TBLIN,H,TAV,AL,GP,GM,GPI,CBTH)
C
C  LANGUAGE- FORTRAN 77
C
C  VERSION- 1    DATE- 11/28/87    PROGRAMMER- P. ROSENKRANZ
C
C  FUNCTION-
C  COMPUTES MATRIX RADIATIVE TRANSFER THROUGH A HOMOGENEOUS LAYER
C
C  ARGUMENT SPECIFICATIONS-
      REAL TBRC,TBLC,H,TAV,AL,CBTH
      COMPLEX GP,GM,GPI,TBLIN
C
C  NAME    IN/OUT  UNITS    DESCRIPTON
C
C  TBRC     I,O    KELVIN   RIGHT-CIRCULARLY POLARIZED BRIGHTNESS TEMPERATURE
C  TBLC     I,O    KELVIN   LEFT-CIRCULARLY POLARIZED BRIGHTNESS TEMPERATURE.
C  TBLIN    I,O    KELVIN   COMPLEX OFF-DIAGONAL TERM OF TB COHERENCY MATRIX;
C                           IN TERMS OF STOKES PARAMETERS, Q=2*REAL(TBLIN),
C                           U=2*AIMAG(TBLIN).
C                           ON INPUT, TBRC, TBLC AND TBLIN SHOULD HAVE INITIAL
C                           VALUES AT ONE SIDE OF THE LAYER. ON OUTPUT,
C                           THEY HAVE BEEN COMPUTED FOR THE OTHER SIDE OF THE LAYER.
C  H         I     KM       PATH LENGTH THROUGH LAYER
C  TAV       I     KELVIN   TEMPERATURE
C  AL        I     1/KM     POWER ABSORPTION COEFF NOT DEPENDING ON POLARIZATION;
C                           I.E., FROM DISTANT LINES.
C  GP        I     1/KM     COMPLEX AMPLITUDE PROPAGATION COEFFICIENT OF
C                           ZEEMAN-SPLIT LINE, FOR DELTA M = +1.
C  GM        I     1/KM     COMPLEX AMPLITUDE PROPAGATION COEFFICIENT OF
C                           ZEEMAN-SPLIT LINE, FOR DELTA M = -1.
C  GPI       I     1/KM     COMPLEX AMPLITUDE PROPAGATION COEFFICIENT OF
C                           ZEEMAN-SPLIT LINE, FOR DELTA M = 0.
C  CBTH      I              COSINE(ANGLE BETWEEN MAGNETIC FIELD AND PROPAGATION
C                           DIRECTION)
C********************************************************************************
C
C  LOCAL VARIABLES-
      COMPLEX C11,C12,C22,CP,CM,CPI,DELTA,
     &  E11,E22,E12,C2,DUM,EL1,EL2,D,C212,AB,BB,CB
      SQMAG(DUM) = REAL(DUM)**2 + AIMAG(DUM)**2
C
      PB = AL*.5*H
      CP = GP*H
      CM = GM*H
      CPI = GPI*H
      SIN2 = .5*(1.-CBTH**2)
      OPC = .5*(1.+CBTH)**2
      OMC = .5*(1.-CBTH)**2
      C11 = OPC*CP + OMC*CM + SIN2*CPI +CMPLX(PB,0.)
      C22 = OMC*CP + OPC*CM + SIN2*CPI + CMPLX(PB,0.)
      C12 = SIN2*(CP+CM-CPI)
      IF(ABS(REAL(C12))+ABS(AIMAG(C12))) 9,9,10
C      MATRIX IS DIAGONAL
9      E11 = CEXP(-C11)
      E22 = CEXP(-C22)
      E12 = CMPLX(0.,0.)
      GOTO 20
10      C2 = C22 - C11
      DELTA = CSQRT(C2*C2 + 4.*C12*C12)
      IF(REAL(C2)*REAL(DELTA).LT.0.) DELTA = -DELTA
      C2 = .5*(C2+DELTA)
      EL2 = CEXP(-C2-C11)
      EL1 = EL2*CEXP(DELTA)
      C212 = C2*C12
      C2 = C2*C2
      C12 = C12*C12
      D = C2 + C12
      E11 = (C2*EL1+C12*EL2)/D
      E22 = (C12*EL1+C2*EL2)/D
      E12 = C212*(EL2-EL1)/D
20      TBR = TBRC - TAV
      TBL = TBLC - TAV
      AA = SQMAG(E11)
      AB = E11*CONJG(E12)
      AC = SQMAG(E12)
      TBRC = TAV + TBR*AA + 2.*REAL(TBLIN*AB) + TBL*AC
      CB = E12*CONJG(E22)
      CC = SQMAG(E22)
      TBLC = TAV + TBR*AC + 2.*REAL(TBLIN*CB) + TBL*CC
      BB = E11*CONJG(E22)
      TBLIN = TBR*AB + TBLIN*BB + CONJG(TBLIN)*AC + TBL*CB
      RETURN
      END


	FUNCTION TDSCAL(CHANNEL,SPEED,TM)
C
C	this function converts the telemetry number TM from the TDS of
C	Wind-Waves to volts--voltage output from the preamplifiers.
C	If voltage input, i.e. voltage on the antenna, is desired, some
C	further calculation to correct for preamp gain as a function of
C	frequency is required.
C		As there are 5 different A/D converters,
C	it is necessary to specify the channel  (1 to 6, ITEM = 'CHANNEL')
C	For channels 1 and 2, the fast channels, it is also necessary to
C	specify the speed, i.e. the sample rate (ITEM = "RX_SPEED")
C
	INCLUDE 	'TDS_CALDATA.FOR'
C
C	COMMON /TCALDATA/ A(6),B(6),POFFS(6),NOFFS(6)
C	INTEGER*4 CHANNEL,SPEED,TM,INDEX
C	REAL TDSCAL,A,B,POFFS,NOFFS
C	DATA B /.08316,.08151,.08099,.08212,.08293,.08293/
C	DATA A /3.19E-4,2.14E-4,3.89E-4,2.40E-4,1.75E-4,1.94E-4/
C	DATA POFFS /4.01,6.31,4*0./
C	DATA NOFFS /1.59,1.79,4*0./
C
	INDEX = MIN0(2*CHANNEL + MIN0(SPEED,1) - 1, 5)
	TMNB = TM - 128
	IF(INDEX.EQ.5.AND.ABS(TMNB).LT.78.) INDEX = 6
C
C	INDEX = 1 IS CHANNEL 1, FASTEST, 2 IS CHANNEL 1, SLOWER, 3 IS
C	CHANNEL 2 FASTEST, 4 IS CHANNEL 2 SLOWER, 5,6 ARE CHANNELS 3-6,
C	5 FOR TM GT. 78, 6 FOR TM LT 78
C
	IF(TMNB.GT.0.) THEN
	  TDSCAL = A(INDEX)*(EXP(B(INDEX)*TMNB) - POFFS(INDEX))
	ELSE
	  TDSCAL = -A(INDEX)*(EXP(-B(INDEX)*TMNB) - NOFFS(INDEX))
	ENDIF
	RETURN
	END


      SUBROUTINE IPPCOV(RLAT,RLON,Z,X,A,RS,OM,E,CL,CS,FLAG)
C
C
C        FUNCTION -
C
C          CALCULATES LATITUDE AND LONGITUDE FOR SPECIFIED DATA
C          POINT ON AN INVERSE PERSPECTIVE PROJECTION
C
C        PARAMETERS -
C
C          RLAT = CALCULATED LATITUDE(RADIANS)
C          RLON = CALCULATED LONGITUDE (E. RADIANS)
C          Z = LINE VALUE OF INPUT POINT
C          X = SAMPLE VALUE OF INPUT POINT
C          A = DESCRIPTIVE ARRAY
C              A(1) = EQUATORIAL RADIUS
C              A(2) = CAMERA FOCAL LENGTH
C              A(3) = DISTANCE PLANET TO SPACECRAFT
C
C        OTHER VARIABLES -
C
C          OM = ROTATION MATRIX PLANET TO CAMERA - om matrix
C          E = ECCENTRICITY MATRIX (1.,0.,0.,0.,1.,0.,0.,0.,re/rp)
C          RS = POSITION OF SPACECRAFT IN PLANET COORDINATES-rs vector
C
C
      REAL A(3)
      DOUBLE PRECISION RS(3), OM(3,3),E(3,3),T(3),U(3),V(3),AA,BB,CC,
     * DENOM,D,XX,ZZ
      DATA TWOPI/6.283185308/
C
C        INITIALIZATION
C
      AA = 0.
      BB = 0.
      CC = 0.
      DO 20 I = 1,3
         T(I) = 0.
         U(I) = 0.
   20 CONTINUE
      XX=X-CS
      ZZ=Z-CL
C
C        CALCULATE QUADRATIC COEFFICIENTS
C          AA = (NORM(U))**2
C          BB = 2 * DOT(U,V)
C          CC = (NORM(V))**2 - R**2
C              WHERE
C          T = R * (XX,ZZ,A(2))
C          U = E * T
C          V = E * RS
C
C        NOTE -- R IS ROTATION FROM PLANET TO CAMERA COORDINATES,
C          SO MULTIPLY IN TRANSPOSE SENSE
C
      DO 40 I = 1,3
   40 T(I) = OM(1,I)*XX + OM(2,I)*ZZ + OM(3,I)*A(2)
      DO 50 I = 1,3
      U(I) = E(I,1)*T(1) + E(I,2)*T(2) + E(I,3)*T(3)
   50 V(I) = E(I,1)*RS(1) + E(I,2)*RS(2) + E(I,3)*RS(3)
C
      AA = U(1)*U(1) + U(2)*U(2) + U(3)*U(3)
      BB = U(1)*V(1) + U(2)*V(2) + U(3)*V(3)
      CC = V(1)*V(1) + V(2)*V(2) + V(3)*V(3)
      BB = 2. * BB
      CC = CC - A(1)*A(1)
C
C        CALCULATE DEPTH FACTOR 'D'.  NEGATIVE DISCRIMINANT MEANS
C        POINT OFF PLANET.  USE -SQRT TO INSURE VISIBLE SIDE OF
C        PLANET.
C
      D = BB*BB - 4.*AA*CC
      IF (D .GE. 0.) GO TO 70
      RLAT=FLAG
      RLON=FLAG
      RETURN
   70 D = (-BB - DSQRT(D))/(2.*AA)
C
C        FIND RLAT AND RLON
C
      DO 80 I = 1,3
   80 T(I) = D * T(I) + RS(I)
      DENOM = DSQRT(T(1)*T(1) + T(2)*T(2))
      RLAT = DATAN(T(3)/DENOM)
      RLON = DATAN2(T(2),T(1)) + TWOPI
      RLON = AMOD(RLON,TWOPI)
      RETURN
      END


CS    REAL FUNCTION BESJ0(X)
      DOUBLE PRECISION FUNCTION BESJ0(X)
C--------------------------------------------------------------------
C
C This subprogram computes approximate values for Bessel functions
C   of the first kind of order zero for arguments  |X| <= XMAX
C   (see comments heading CALJY0).
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL  X, RESULT
      DOUBLE PRECISION  X, RESULT
C--------------------------------------------------------------------
      JINT=0
      CALL CALJY0(X,RESULT,JINT)
      BESJ0 = RESULT
      RETURN
C---------- Last line of BESJ0 ----------
      END


program vin
  real :: numbers(9)=(/  5,  6,  3,  8,  9,  1,  7,  4,  2 /)
  print *, (numbers)
end program vin


program scatter
   use mpi_f08

   integer, parameter :: nsize = 8
   integer :: numtasks, rank, sendcount, recvcount, source, ierr
   real, allocatable ::  sendbuf(:, :), recvbuf(:)

   call MPI_INIT(ierr)
   call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr)
   call MPI_COMM_size(MPI_COMM_WORLD, numtasks, ierr)

   allocate (sendbuf(nsize, numtasks))
   allocate (recvbuf(nsize))
   sendbuf = reshape([(i, i=1, nsize*numtasks)], [nsize, numtasks])

   if (rank == 0) then
      print *, ''
      print *, 'Original array to be distributed:'
      do i = 1, numtasks
         print *, sendbuf(:, i)
      end do
      print *, ''
   end if

   call MPI_BARRIER(MPI_COMM_WORLD)

   source = 1
   sendcount = nsize
   recvcount = nsize
   call MPI_SCATTER(sendbuf, sendcount, MPI_REAL, recvbuf, recvcount, MPI_REAL, &
                    source, MPI_COMM_WORLD, ierr)

   print *, 'rank= ', rank, ' recvbuf: ', recvbuf

   call MPI_FINALIZE(ierr)

   deallocate (sendbuf, recvbuf)

end program


      MODULE LIB_LINPACK_BLAS
      !!#PURPOSE
      !! The LINPACK BLAS in a module.

      !!#DEFAULT ACCESS
	PUBLIC

      CONTAINS
      subroutine saxpy(n,sa,sx,incx,sy,incy)
c
c     constant times a vector plus a vector.
c     uses unrolled loop for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c     modified 12/3/93, array(1) declarations changed to array(*)
c
      real sx(*),sy(*),sa
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if (sa .eq. 0.0) return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        sy(iy) = sy(iy) + sa*sx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,4)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        sy(i) = sy(i) + sa*sx(i)
   30 continue
      if( n .lt. 4 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,4
        sy(i) = sy(i) + sa*sx(i)
        sy(i + 1) = sy(i + 1) + sa*sx(i + 1)
        sy(i + 2) = sy(i + 2) + sa*sx(i + 2)
        sy(i + 3) = sy(i + 3) + sa*sx(i + 3)
   50 continue
      return
      end subroutine

      integer function isamax(n,sx,incx)
c
c     finds the index of element having max. absolute value.
c     jack dongarra, linpack, 3/11/78.
c     modified 3/93 to return if incx .le. 0.
c     modified 12/3/93, array(1) declarations changed to array(*)
c
      real sx(*),smax
      integer i,incx,ix,n
c
      isamax = 0
      if( n.lt.1 .or. incx.le.0 ) return
      isamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      smax = abs(sx(1))
      ix = ix + incx
      do 10 i = 2,n
         if(abs(sx(ix)).le.smax) go to 5
         isamax = i
         smax = abs(sx(ix))
    5    ix = ix + incx
   10 continue
      return
c
c        code for increment equal to 1
c
   20 smax = abs(sx(1))
      do 30 i = 2,n
         if(abs(sx(i)).le.smax) go to 30
         isamax = i
         smax = abs(sx(i))
   30 continue
      return
      end function

      integer function idamax(n,dx,incx)
c
c     finds the index of element having max. absolute value.
c     jack dongarra, linpack, 3/11/78.
c     modified 3/93 to return if incx .le. 0.
c     modified 12/3/93, array(1) declarations changed to array(*)
c
      double precision dx(*),dmax
      integer i,incx,ix,n
c
      idamax = 0
      if( n.lt.1 .or. incx.le.0 ) return
      idamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      dmax = dabs(dx(1))
      ix = ix + incx
      do 10 i = 2,n
         if(dabs(dx(ix)).le.dmax) go to 5
         idamax = i
         dmax = dabs(dx(ix))
    5    ix = ix + incx
   10 continue
      return
c
c        code for increment equal to 1
c
   20 dmax = dabs(dx(1))
      do 30 i = 2,n
         if(dabs(dx(i)).le.dmax) go to 30
         idamax = i
         dmax = dabs(dx(i))
   30 continue
      return
      end function

      subroutine  dscal(n,da,dx,incx)
c
c     scales a vector by a constant.
c     uses unrolled loops for increment equal to one.
c     jack dongarra, linpack, 3/11/78.
c     modified 3/93 to return if incx .le. 0.
c     modified 12/3/93, array(1) declarations changed to array(*)
c
      double precision da,dx(*)
      integer i,incx,m,mp1,n,nincx
c
      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      nincx = n*incx
      do 10 i = 1,nincx,incx
        dx(i) = da*dx(i)
   10 continue
      return
c
c        code for increment equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dx(i) = da*dx(i)
   30 continue
      if( n .lt. 5 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dx(i) = da*dx(i)
        dx(i + 1) = da*dx(i + 1)
        dx(i + 2) = da*dx(i + 2)
        dx(i + 3) = da*dx(i + 3)
        dx(i + 4) = da*dx(i + 4)
   50 continue
      return
      end subroutine

      subroutine daxpy(n,da,dx,incx,dy,incy)
c
c     constant times a vector plus a vector.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c     modified 12/3/93, array(1) declarations changed to array(*)
c
      double precision dx(*),dy(*),da
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if (da .eq. 0.0d0) return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dy(iy) = dy(iy) + da*dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,4)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dy(i) = dy(i) + da*dx(i)
   30 continue
      if( n .lt. 4 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,4
        dy(i) = dy(i) + da*dx(i)
        dy(i + 1) = dy(i + 1) + da*dx(i + 1)
        dy(i + 2) = dy(i + 2) + da*dx(i + 2)
        dy(i + 3) = dy(i + 3) + da*dx(i + 3)
   50 continue
      return
      end subroutine

      subroutine sscal(n,sa,sx,incx)
c
c     scales a vector by a constant.
c     uses unrolled loops for increment equal to 1.
c     jack dongarra, linpack, 3/11/78.
c     modified 3/93 to return if incx .le. 0.
c     modified 12/3/93, array(1) declarations changed to array(*)
c
      real sa,sx(*)
      integer i,incx,m,mp1,n,nincx
c
      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      nincx = n*incx
      do 10 i = 1,nincx,incx
        sx(i) = sa*sx(i)
   10 continue
      return
c
c        code for increment equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        sx(i) = sa*sx(i)
   30 continue
      if( n .lt. 5 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        sx(i) = sa*sx(i)
        sx(i + 1) = sa*sx(i + 1)
        sx(i + 2) = sa*sx(i + 2)
        sx(i + 3) = sa*sx(i + 3)
        sx(i + 4) = sa*sx(i + 4)
   50 continue
      return
      end subroutine

      real function sdot(n,sx,incx,sy,incy)
c
c     forms the dot product of two vectors.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c     modified 12/3/93, array(1) declarations changed to array(*)
c
      real sx(*),sy(*),stemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      stemp = 0.0e0
      sdot = 0.0e0
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        stemp = stemp + sx(ix)*sy(iy)
        ix = ix + incx
        iy = iy + incy
   10 continue
      sdot = stemp
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        stemp = stemp + sx(i)*sy(i)
   30 continue
      if( n .lt. 5 ) go to 60
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        stemp = stemp + sx(i)*sy(i) + sx(i + 1)*sy(i + 1) +
     *   sx(i + 2)*sy(i + 2) + sx(i + 3)*sy(i + 3) + sx(i + 4)*sy(i + 4)
   50 continue
   60 sdot = stemp
      return
      end function

      double precision function ddot(n,dx,incx,dy,incy)
c
c     forms the dot product of two vectors.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c     modified 12/3/93, array(1) declarations changed to array(*)
c
      double precision dx(*),dy(*),dtemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      ddot = 0.0d0
      dtemp = 0.0d0
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = dtemp + dx(ix)*dy(iy)
        ix = ix + incx
        iy = iy + incy
   10 continue
      ddot = dtemp
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dtemp + dx(i)*dy(i)
   30 continue
      if( n .lt. 5 ) go to 60
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) +
     *   dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4)
   50 continue
   60 ddot = dtemp
      return
      end function

      END MODULE


.( Demo program to show you how to use do-loop )   \  <========== '.(' is compile time message. Print this message when compiling.

\ Demo how to use do-loop
: test1      ( --  )
    5 0 do
    	i . cr            \ i is inner loop's count
    loop
    cr
    10 0 do
    	i . cr            \ i is inner loop's count
    2 +loop
;
test1 cr

: test2  ( -- )
    10 2 do                                           \ loop 2,3,4 ... 9
    	10 2 do                                       \ loop 2,3,4 ... 9
    		j . ." x" i . ." =" i j * . ."   "        \ i is inner loop's count, j is outter loop's count. They are both forth standard command words.
    	loop
    	cr
    loop
;
test2

\  'break' and '?break' are supposed to break do-loop as C Language. But they are not stable so far on WF06.EXE hcchen5600 2010/06/07 09:40:53
\  use if .... else .... then when you need to break a do-loop. A safe trick to terminate do-loop is shown below ...

: test3      ( --  )
    10 0 do
    	i . cr            \ i is inner loop's count
    	i 7 = if          \ when reached 7 then terminate the loop, how?
    	    cr ." %%%%%%%%%% See the original return stack %%%%%%%%%%%" cr
    	    .ss           \ view the return stack, see the 7 and 10 ?
    		r> r> drop dup >r >r     \ <==================================== this is the trick
    	    cr ." %%%%%%%%%%% After the trick %%%%%%%%%%%%%%%% " cr
    		.ss           \ view again the return stack. We have made original 7 and 10 become two 7s. That terminates the loop when do the 'then'.
    	then
    loop
;
test3

bye


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

! CHECK-LABEL: ishft_test
function ishft_test(i, j)
    ! CHECK-DAG: %[[result:.*]] = fir.alloca i32 {bindc_name = "ishft_test"
    ! CHECK-DAG:  %[[i:.*]] = fir.load %arg0 : !fir.ref<i32>
    ! CHECK-DAG:  %[[j:.*]] = fir.load %arg1 : !fir.ref<i32>
    ! CHECK-DAG:  %[[VAL_5:.*]] = arith.constant 32 : i32
    ! CHECK-DAG:  %[[VAL_6:.*]] = arith.constant 0 : i32
    ! CHECK-DAG:  %[[VAL_7:.*]] = arith.constant 31 : i32
    ! CHECK:  %[[VAL_8:.*]] = arith.shrsi %[[j]], %[[VAL_7]] : i32
    ! CHECK:  %[[VAL_9:.*]] = arith.xori %[[j]], %[[VAL_8]] : i32
    ! CHECK:  %[[VAL_10:.*]] = arith.subi %[[VAL_9]], %[[VAL_8]] : i32
    ! CHECK:  %[[VAL_11:.*]] = arith.shli %[[i]], %[[VAL_10]] : i32
    ! CHECK:  %[[VAL_12:.*]] = arith.shrui %[[i]], %[[VAL_10]] : i32
    ! CHECK:  %[[VAL_13:.*]] = arith.cmpi sge, %[[VAL_10]], %[[VAL_5]] : i32
    ! CHECK:  %[[VAL_14:.*]] = arith.cmpi slt, %[[j]], %[[VAL_6]] : i32
    ! CHECK:  %[[VAL_15:.*]] = arith.select %[[VAL_14]], %[[VAL_12]], %[[VAL_11]] : i32
    ! CHECK:  %[[VAL_16:.*]] = arith.select %[[VAL_13]], %[[VAL_6]], %[[VAL_15]] : i32
    ! CHECK:  fir.store %[[VAL_16]] to %[[result]] : !fir.ref<i32>
    ! CHECK:  %[[VAL_17:.*]] = fir.load %[[result]] : !fir.ref<i32>
    ! CHECK:  return %[[VAL_17]] : i32
    ishft_test = ishft(i, j)
  end


program test_psoil
  use simsphere_mod, only: dzeta, dual_ti, lambda, kappa, cg, tp, tt, del,  &
                           delta, btemp, otemp, nlvls, tt, z, xfun, w2g,    &
                           wgg, wmax, fsub, f, ti_a, ti_b, eq
  use mod_testing, only: assert, initialize_tests, report_tests
  implicit none

  ! mod_testing setup
  logical, dimension(:), allocatable :: tests
  logical :: test_failed
  integer :: n, ntests

  ! kappa, lambda, cg, tp, w2g, wgg, tt, xfun, z
  ! Expected results
  real, parameter :: lambda_exp = 2.42532587
  real, parameter :: kappa_exp = 1.18045705e-06
  real, parameter :: cg_exp = 1943522.50
  real, parameter :: tp_exp = 5.04350513e-02
  real, parameter :: w2g_exp = 0.75
  real, parameter :: wgg_exp = 0.5
  real, parameter, dimension(9) :: tt_exp = (/265.0,265.399994,265.799988,  &
                                              266.199982,266.599976,267.0,  &
                                              0.0,0.0,0.0/)
  real, parameter, dimension(9) :: xfun_exp = (/                            &
                                      1.0,2.71828175,7.38905668,20.0855370, &
                                      54.5981445,148.413162,0.0,0.0,0.0/)
  real, parameter, dimension(9) :: z_exp = (/                               &
                                      0.0,2.06146669e-02,7.66511485e-02,    &
                                      0.228974074,0.643030703,1.7685535,    &
                                      0.0,0.0,0.0/)

  real, parameter :: lambda_N_exp = 1.29497826
  real, parameter :: kappa_N_exp = 7.57211808e-07
  real, parameter :: cg_N_exp = 1617762.38
  real, parameter :: tp_N_exp = 3.36233675e-02
  real, parameter :: w2g_N_exp = 0.75
  real, parameter :: wgg_N_exp = 0.5
  real, parameter, dimension(9) :: tt_N_exp = (/265.0,265.399994,265.799988,&
                                                266.199982,266.599976,267.0,&
                                                0.0,0.0,0.0/)
  real, parameter, dimension(9) :: xfun_N_exp = (/                          &
                                      1.0,2.71828175,7.38905621,20.085537,  &
                                      54.5981522,148.413162,0.0,0.0,0.0/)
  real, parameter, dimension(9) :: z_N_exp = (/                             &
                                      0.0,1.65104885e-02,6.13906533e-02,    &
                                      0.183387592,0.515009642,1.41645181,   &
                                      0.0,0.0,0.0/)

  ! Check value with dual_ti set to each of 'Y' and 'N'

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

  ! Case I: dual_ti = 'Y'
  call psoil_init
  dual_ti = 'Y'
  call psoil
  tests(n) = assert(eq(lambda,lambda_exp), 'psoil lambda')
  n = n + 1
  tests(n) = assert(eq(kappa,kappa_exp), 'psoil kappa')
  n = n + 1
  tests(n) = assert(eq(cg,cg_exp), 'psoil cg')
  n = n + 1
  tests(n) = assert(eq(tp,tp_exp), 'psoil tp')
  n = n + 1
  tests(n) = assert(eq(w2g,w2g_exp), 'psoil w2g')
  n = n + 1
  tests(n) = assert(eq(wgg,wgg_exp), 'psoil wgg')
  n = n + 1
  tests(n) = assert(eq(tt,tt_exp), 'psoil tt')
  n = n + 1
  tests(n) = assert(eq(xfun,xfun_exp), 'psoil xfun')
  n = n + 1
  tests(n) = assert(eq(z,z_exp), 'psoil z')
  n = n + 1

  ! Case II: dual_ti = 'N'
  call psoil_init
  dual_ti = 'N'
  call psoil
  tests(n) = assert(eq(lambda,lambda_N_exp), 'psoil not dual lambda')
  n = n + 1
  tests(n) = assert(eq(kappa,kappa_N_exp), 'psoil not dual kappa')
  n = n + 1
  tests(n) = assert(eq(cg,cg_N_exp), 'psoil not dual cg')
  n = n + 1
  tests(n) = assert(eq(tp,tp_N_exp), 'psoil not dual tp')
  n = n + 1
  tests(n) = assert(eq(w2g,w2g_N_exp), 'psoil not dual w2g')
  n = n + 1
  tests(n) = assert(eq(wgg,wgg_N_exp), 'psoil not dual wgg')
  n = n + 1
  tests(n) = assert(eq(tt,tt_N_exp), 'psoil not dual tt')
  n = n + 1
  tests(n) = assert(eq(xfun,xfun_N_exp), 'psoil not dual xfun')
  n = n + 1
  tests(n) = assert(eq(z,z_N_exp), 'psoil not dual z')
  n = n + 1

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

contains
  subroutine psoil_init
    btemp = 267.0
    cg = 0.0
    del = 0.0
    f = 0.5
    fsub = 0.75
    kappa = 0.0
    lambda = 0.0
    nlvls = 5
    otemp = 265.0
    ti_a = 12.0
    ti_b = 12.0
    tp = 12.0
    tt = 0.0
    w2g = 1.0
    wgg = 1.0
    wmax = 1.0
    xfun = 0.0
    z = 0.0
    return
  end subroutine psoil_init

end program test_psoil


c
c**********************************************************************
      subroutine l2d_directcp_vec(nd,sources,ns,charge,
     $           targ,pot,thresh)
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT
c     at the target point TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c     pot(ii)  = \sum_j log(|targ-source(*,j)|)*charge(ii,j)
c
c     The potential is not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     targ          :   location of the target
c     thresh        :   threshold for computing potential
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd)   (complex *16)      : potential is incremented
c---------------------------------------------------------------------
      integer i,ns,ii,nd
      real *8 sources(2,ns),targ(2),xdiff,ydiff,rr,r
      real *8 thresh,rtmp,thresh2
      complex *16 pot(nd),z,ima4inv,ztmp
      complex *16 charge(nd,ns)

      thresh2 = thresh*thresh
c
      do i = 1,ns
         xdiff=targ(1)-sources(1,i)
         ydiff=targ(2)-sources(2,i)
         rr=xdiff*xdiff+ydiff*ydiff
         if(rr.le.thresh2) goto 1000

         rtmp = log(rr)/2
         do ii=1,nd
            pot(ii) = pot(ii) + rtmp*charge(ii,i)
         enddo
 1000    continue
      enddo
      return
      end
c
c
c
c
c
c**********************************************************************
      subroutine l2d_directcg_vec(nd,sources,ns,charge,targ,pot,
     1             grad,thresh)
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT and gradients GRAD
c     at the target point TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c
c     pot(ii)  = \sum_j log(|targ-source(*,j)|)*charge(ii,j)
c
c     grad  = d/dz(pot)
c
c     The potential and gradient are not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     targ          :   location of the target
c     thresh        :   threshold for computing potential and gradient
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd)     (complex *16)      : potential is incremented
c     grad(nd)  (complex *16)      : gradient is incremented
c---------------------------------------------------------------------
      integer i,ns,ii,nd
      real *8 sources(2,ns),targ(2)
      real *8 xdiff,ydiff,rr,r,thresh,rtmp,thresh2
      complex *16 pot(nd),grad(nd)
      complex *16 z,ztmp,zinv
      complex *16 charge(nd,ns)

      thresh2 = thresh*thresh
c
      do i = 1,ns
         xdiff=targ(1)-sources(1,i)
         ydiff=targ(2)-sources(2,i)
         rr=xdiff*xdiff+ydiff*ydiff
         if(rr.lt.thresh2) goto 1000
         rtmp = log(rr)/2
         z=dcmplx(xdiff,ydiff)
         zinv = 1/z
c
         do ii = 1,nd
            pot(ii) = pot(ii) + rtmp*charge(ii,i)
            grad(ii) = grad(ii) + zinv*charge(ii,i)
         enddo
 1000 continue
      enddo

      return
      end
c
c
c
c
c
c
c
c
c**********************************************************************
      subroutine l2d_directch_vec(nd,sources,ns,charge,targ,
     1           pot,grad,hess,thresh)
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT, gradients GRAD
c     and Hessians at the target point TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c
c     pot(ii)  = \sum_j log(|targ-source(*,j)|)*charge(ii,j)
c
c     grad  = d/dz(pot)
c     hess = d^2/dz^2(pot)
c
c     The potential and gradient are not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     targ          :   location of the target
c     thresh        :   threshold for computing potential,gradient,and
c                       hessian
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd)     (complex *16)      : potential is incremented
c     grad(nd)  (complex *16)      : gradient is incremented
c     hess(nd)  (complex *16)      : Hessian is incremented
c---------------------------------------------------------------------
      integer i,ns,ifexpon,ii,nd
      real *8 sources(2,ns),targ(2)
      real *8 xdiff,ydiff,rr,r,thresh,thresh2
      complex *16 pot(nd),grad(nd),hess(nd)
      real *8 rtmp
      complex *16 z,zinv,ztmp
      complex *16 charge(nd,ns)

      thresh2 = thresh*thresh

c
      do i = 1,ns
         xdiff=targ(1)-sources(1,i)
         ydiff=targ(2)-sources(2,i)
         rr=xdiff*xdiff+ydiff*ydiff
         if(rr.lt.thresh2) goto 1000
         rtmp = log(rr)/2
         z=dcmplx(xdiff,ydiff)
         zinv = 1/z
         ztmp = -zinv*zinv
c
         do ii = 1,nd
            pot(ii) = pot(ii) + rtmp*charge(ii,i)
            grad(ii) = grad(ii) + zinv*charge(ii,i)
            hess(ii) = hess(ii) + ztmp*charge(ii,i)
         enddo
 1000 continue
      enddo

      return
      end
c
c
c
c
c
c**********************************************************************
      subroutine l2d_directdp_vec(nd,sources,ns,dipstr,
     $           targ,pot,thresh)
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT
c     at the target point TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c      z_j = cmplx(targ - source(:,j))
c
c     pot(ii)  = \sum_j dipstr(ii,j)/z_j
c
c     The potential is not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     dipstr(nd,ns) :   dipole strengths
c     targ          :   location of the target
c     thresh        :   threshold for computing potential
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd)   (complex *16)      : potential is incremented
c---------------------------------------------------------------------
      integer i,ns,ii,nd
      real *8 sources(2,ns),targ(2),xdiff,ydiff,rr,r
      real *8 thresh,rtmp
      complex *16 pot(nd),z,zinv
      complex *16 dipstr(nd,ns)
c
      do i = 1,ns
         xdiff=targ(1)-sources(1,i)
         ydiff=targ(2)-sources(2,i)
         z = dcmplx(xdiff,ydiff)
         if(abs(z).le.thresh) goto 1000

         zinv = 1/z
         do ii=1,nd
            pot(ii) = pot(ii) + zinv*dipstr(ii,i)
         enddo
 1000    continue
      enddo
      return
      end
c
c
c
c
c
c**********************************************************************
      subroutine l2d_directdg_vec(nd,sources,ns,dipstr,targ,pot,
     1             grad,thresh)
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT and gradients GRAD
c     at the target point TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c      z_j = cmplx(targ - source(:,j))
c
c     pot(ii)  = \sum_j dipstr(ii,j)/z_j
c
c     grad  = d/dz(pot)
c
c     The potential and gradient are not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     dipstr(nd,ns) :   charge strengths
c     targ          :   location of the target
c     thresh        :   threshold for computing potential and gradient
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd)     (complex *16)    : potential is incremented
c     grad(nd)  (complex *16)      : gradient is incremented
c---------------------------------------------------------------------
      integer i,ns,ii,nd
      real *8 sources(2,ns),targ(2)
      real *8 xdiff,ydiff,rr,r,thresh,rtmp
      complex *16 pot(nd),grad(nd)
      complex *16 z,zinv,ztmp2
      complex *16 dipstr(nd,ns)
c
      do i = 1,ns
         xdiff=targ(1)-sources(1,i)
         ydiff=targ(2)-sources(2,i)
         z=dcmplx(xdiff,ydiff)
         if(abs(z).lt.thresh) goto 1000
         zinv = 1/z
         ztmp2 = -zinv*zinv
c
         do ii = 1,nd
            pot(ii) = pot(ii) + zinv*dipstr(ii,i)
            grad(ii) = grad(ii) + ztmp2*dipstr(ii,i)
         enddo
 1000 continue
      enddo

      return
      end
c
c
c
c
c
c
c
c
c**********************************************************************
      subroutine l2d_directdh_vec(nd,sources,ns,dipstr,targ,
     1           pot,grad,hess,thresh)
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT, gradients GRAD
c     and Hessians at the target point TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c      z_j = cmplx(targ - source(:,j))
c
c     pot(ii)  = \sum_j dipstr(ii,j)/z_j
c
c     grad  = d/dz(pot)
c     hess = d^2/dz^2(pot)
c
c     The potential and gradient are not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     dipstr(nd,ns) :   charge strengths
c     targ          :   location of the target
c     thresh        :   threshold for computing potential,gradient,and
c                       hessian
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd)     (complex *16)      : potential is incremented
c     grad(nd)  (complex *16)      : gradient is incremented
c     hess(nd)  (complex *16)      : Hessian is incremented
c---------------------------------------------------------------------
      integer i,ns,ifexpon,ii,nd
      real *8 sources(2,ns),targ(2)
      real *8 xdiff,ydiff,rr,r,thresh
      complex *16 pot(nd),grad(nd),hess(nd)
      real *8 rtmp
      complex *16 z,zinv,ztmp2,ztmp3
      complex *16 dipstr(nd,ns)

c
      do i = 1,ns
         xdiff=targ(1)-sources(1,i)
         ydiff=targ(2)-sources(2,i)
         z = dcmplx(xdiff,ydiff)
         if(abs(z).lt.thresh) goto 1000
         zinv = 1/z
         ztmp2 = -zinv*zinv
         ztmp3 = -2*ztmp2*zinv
c
         do ii = 1,nd
            pot(ii) = pot(ii) + zinv*dipstr(ii,i)
            grad(ii) = grad(ii) + ztmp2*dipstr(ii,i)
            hess(ii) = hess(ii) + ztmp3*dipstr(ii,i)
         enddo
 1000 continue
      enddo

      return
      end
c
c
c
c
c
c**********************************************************************
      subroutine l2d_directcdp_vec(nd,sources,ns,charge,
     $           dipstr,targ,pot,thresh)
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT
c     at the target point TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c     z_j = cmplx(targ - source(:,j))
c     pot(ii)  = \sum_j log(|z_{j}|)*charge(ii,j)+
c           dipstr(ii,j)/z_{j}
c
c     The potential is not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     dipstr(nd,ns) :   dipole strengths
c     targ          :   location of the target
c     thresh        :   threshold for computing potential
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd)   (complex *16)      : potential is incremented
c---------------------------------------------------------------------
      integer i,ns,ii,nd
      real *8 sources(2,ns),targ(2),xdiff,ydiff,rr,r
      real *8 thresh,rtmp,thresh2
      complex *16 pot(nd),z,ztmp,zinv
      complex *16 charge(nd,ns),dipstr(nd,ns)

      thresh2 = thresh*thresh
c
      do i = 1,ns
         xdiff=targ(1)-sources(1,i)
         ydiff=targ(2)-sources(2,i)
         rr=xdiff*xdiff+ydiff*ydiff
         if(rr.le.thresh2) goto 1000

         rtmp = log(rr)/2.0d0
         z = dcmplx(xdiff,ydiff)
         zinv = 1/z
         do ii=1,nd
            pot(ii) = pot(ii) + rtmp*charge(ii,i)+zinv*dipstr(ii,i)
         enddo
 1000    continue
      enddo
      return
      end
c
c
c
c
c
c**********************************************************************
      subroutine l2d_directcdg_vec(nd,sources,ns,charge,dipstr,targ,pot,
     1             grad,thresh)
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT and gradients GRAD
c     at the target point TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c     pot(ii)  = \sum_j log(|z_{j}|)*charge(ii,j)+
c           dipstr(ii,j)/z_{j}
c
c     grad  = d/dz(pot)
c
c     The potential and gradient are not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     dipstr(nd,ns) :   charge strengths
c     targ          :   location of the target
c     thresh        :   threshold for computing potential and gradient
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd)     (complex *16)      : potential is incremented
c     grad(nd)  (complex *16)      : gradient is incremented
c---------------------------------------------------------------------
      integer i,ns,ii,nd
      real *8 sources(2,ns),targ(2)
      real *8 xdiff,ydiff,rr,r,thresh,rtmp,thresh2
      complex *16 pot(nd),grad(nd)
      complex *16 z,ztmp,zinv,ztmp2
      complex *16 charge(nd,ns),dipstr(nd,ns)

      thresh2 = thresh*thresh
c
      do i = 1,ns
         xdiff=targ(1)-sources(1,i)
         ydiff=targ(2)-sources(2,i)
         rr=xdiff*xdiff+ydiff*ydiff
         if(rr.lt.thresh2) goto 1000
         rtmp = log(rr)/2
         z=dcmplx(xdiff,ydiff)
         zinv = 1/z
         ztmp2 = -zinv*zinv
c
         do ii = 1,nd
            pot(ii) = pot(ii) + rtmp*charge(ii,i)+zinv*dipstr(ii,i)
            grad(ii) = grad(ii) + zinv*charge(ii,i)+ztmp2*dipstr(ii,i)
         enddo
 1000 continue
      enddo

      return
      end
c
c
c
c
c
c
c
c
c**********************************************************************
      subroutine l2d_directcdh_vec(nd,sources,ns,charge,dipstr,targ,
     1           pot,grad,hess,thresh)
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT, gradients GRAD
c     and Hessians at the target point TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c
c     pot(ii)  = \sum_j log(|z_{j}|)*charge(ii,j)+
c           dipstr(ii,j)/z_{j}
c
c     grad  = d/dz(pot)
c     hess = d^2/dz^2(pot)
c
c     The potential and gradient are not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     dipstr(nd,ns) :   dipole strengths
c     targ          :   location of the target
c     thresh        :   threshold for computing potential,gradient,and
c                       hessian
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd)     (complex *16)      : potential is incremented
c     grad(nd)  (complex *16)      : gradient is incremented
c     hess(nd)  (complex *16)      : Hessian is incremented
c---------------------------------------------------------------------
      integer i,ns,ifexpon,ii,nd
      real *8 sources(2,ns),targ(2)
      real *8 xdiff,ydiff,rr,r,thresh,thresh2
      complex *16 pot(nd),grad(nd),hess(nd)
      real *8 rtmp
      complex *16 z,zinv,ztmp2,ztmp3
      complex *16 charge(nd,ns),dipstr(nd,ns)

      thresh2 = thresh*thresh

c
      do i = 1,ns
         xdiff=targ(1)-sources(1,i)
         ydiff=targ(2)-sources(2,i)
         rr=xdiff*xdiff+ydiff*ydiff
         if(rr.lt.thresh2) goto 1000
         rtmp = log(rr)/2
         z=dcmplx(xdiff,ydiff)
         zinv = 1/z
         ztmp2 = -zinv*zinv
         ztmp3 = -2*ztmp2*zinv
c
         do ii = 1,nd
            pot(ii) = pot(ii) + rtmp*charge(ii,i)+zinv*dipstr(ii,i)
            grad(ii) = grad(ii) + zinv*charge(ii,i)+ztmp2*dipstr(ii,i)
            hess(ii) = hess(ii) + ztmp2*charge(ii,i)+ztmp3*dipstr(ii,i)
         enddo
 1000 continue
      enddo

      return
      end
c
c
c


Subroutine dreson(i1, i2)
  Parameter (maxstr=150001, maxr=1, amn=0.939457, amp=0.93828, ap1=0.13496, ap2=0.13957, am0=1.232, pi=3.1415926)
  Double Precision e10, e20, scheck, p1, p2, p3
  Common /aa/r(3, maxstr)
  Common /bb/p(3, maxstr)
  Common /cc/e(maxstr)
  Common /ee/id(maxstr), lb(maxstr)
  Common /run/num
  Common /pa/rpion(3, maxstr, maxr)
  Common /pb/ppion(3, maxstr, maxr)
  Common /pc/epion(maxstr, maxr)
  Common /pd/lpion(maxstr, maxr)
  Save
  e10 = dsqrt(dble(e(i1))**2+dble(p(1,i1))**2+dble(p(2,i1))**2+dble(p(3,i1))**2)
  e20 = dsqrt(dble(e(i2))**2+dble(p(1,i2))**2+dble(p(2,i2))**2+dble(p(3,i2))**2)
  p1 = dble(p(1,i1)) + dble(p(1,i2))
  p2 = dble(p(2,i1)) + dble(p(2,i2))
  p3 = dble(p(3,i1)) + dble(p(3,i2))
  If (iabs(lb(i2))==1 .Or. iabs(lb(i2))==2 .Or. (iabs(lb(i2))>=6 .And. iabs(lb(i2))<=17)) Then
     e(i1) = 0.
     i = i2
  Else
     e(i2) = 0.
     i = i1
  End If
  p(1, i) = p(1, i1) + p(1, i2)
  p(2, i) = p(2, i1) + p(2, i2)
  p(3, i) = p(3, i1) + p(3, i2)
  scheck = (e10+e20)**2 - p1**2 - p2**2 - p3**2
  If (scheck<0) Then
     Write (99, *) 'scheck17: ', scheck
     Write (99, *) 'scheck17', scheck, e10, e20, p(1, i), p(2, i), p(3, i)
     Write (99, *) 'scheck17-1', e(i1), p(1, i1), p(2, i1), p(3, i1)
     Write (99, *) 'scheck17-2', e(i2), p(1, i2), p(2, i2), p(3, i2)
     scheck = 0.D0
  End If
  dm = sqrt(sngl(scheck))
  e(i) = dm
  Return
End Subroutine dreson


!===== T. Dennen, May 2014
!===== Initialise array of bubble integral values.
!===== For use with qqb->4gamma and qqb->2j2gamma
!===== coefficients by same author.
      subroutine Bubint_init(i1,i2,i3,i4,i5,i6,
     & Bubint,ord)
      implicit none
      include 'constants.f'
      include 'sprods_com.f'
      include 'scale.f'
      integer i1,i2,i3,i4,i5,i6
      integer ord
      double complex Bubint(25), qlI2
      double precision t

      t(i1,i2,i3) = s(i1,i2) + s(i2,i3) + s(i3,i1)

      Bubint(:) = czip

      Bubint(1) = qlI2(t(i1,i2,i3),0d0,0d0,musq,ord)
      Bubint(2) = qlI2(t(i1,i2,i4),0d0,0d0,musq,ord)
      Bubint(3) = qlI2(t(i1,i2,i5),0d0,0d0,musq,ord)
      Bubint(4) = qlI2(t(i1,i2,i6),0d0,0d0,musq,ord)
      Bubint(5) = qlI2(t(i1,i3,i4),0d0,0d0,musq,ord)
      Bubint(6) = qlI2(t(i1,i3,i5),0d0,0d0,musq,ord)
      Bubint(7) = qlI2(t(i1,i3,i6),0d0,0d0,musq,ord)
      Bubint(8) = qlI2(t(i1,i4,i5),0d0,0d0,musq,ord)
      Bubint(9) = qlI2(t(i1,i4,i6),0d0,0d0,musq,ord)
      Bubint(10) = qlI2(t(i1,i5,i6),0d0,0d0,musq,ord)
      Bubint(11) = qlI2(s(i1,i2),0d0,0d0,musq,ord)
      Bubint(12) = qlI2(s(i5,i6),0d0,0d0,musq,ord)
      Bubint(13) = qlI2(s(i4,i6),0d0,0d0,musq,ord)
      Bubint(14) = qlI2(s(i4,i5),0d0,0d0,musq,ord)
      Bubint(15) = qlI2(s(i3,i6),0d0,0d0,musq,ord)
      Bubint(16) = qlI2(s(i3,i5),0d0,0d0,musq,ord)
      Bubint(17) = qlI2(s(i3,i4),0d0,0d0,musq,ord)
      Bubint(18) = qlI2(s(i1,i3),0d0,0d0,musq,ord)
      Bubint(19) = qlI2(s(i2,i6),0d0,0d0,musq,ord)
      Bubint(20) = qlI2(s(i2,i5),0d0,0d0,musq,ord)
      Bubint(21) = qlI2(s(i2,i4),0d0,0d0,musq,ord)
      Bubint(22) = qlI2(s(i1,i4),0d0,0d0,musq,ord)
      Bubint(23) = qlI2(s(i2,i3),0d0,0d0,musq,ord)
      Bubint(24) = qlI2(s(i1,i5),0d0,0d0,musq,ord)
      Bubint(25) = qlI2(s(i1,i6),0d0,0d0,musq,ord)

      return
      end


      program fizzbuzz
        character(len=8) :: fizz_str
        do i = 1, 100
          fizz_str = ''
          if (mod(i, 15) == 0) then
            fizz_str = 'fizzbuzz'
          else if (mod(i, 3) == 0) then
            fizz_str = 'fizz'
          else if (mod(i, 5) == 0) then
            fizz_str = 'buzz'
          endif
          print '(i3, a9)', i, fizz_str
        enddo
      end program fizzbuzz


program P12015
    implicit none
    integer :: length
    integer, dimension(1000000) :: sequence, rearranged
    integer :: i
    integer :: size
    integer :: low, mid, high
    read (*, *) length
    read (*, *) (sequence(i), i = 1, length)
    size = 1
    rearranged(1) = sequence(1)
    do i = 2, length
        if (rearranged(size) < sequence(i)) then
            size = size + 1
            rearranged(size) = sequence(i)
        else if (rearranged(size) > sequence(i)) then
            low = 1
            high = size
            do while (low < high)
                mid = (low + high) / 2
                if (rearranged(mid) < sequence(i)) then
                    low = mid + 1
                else
                    high = mid
                end if
            end do
            mid = (low + high) / 2
            rearranged(mid) = sequence(i)
        end if
    end do
    write (*, '(I0)') size
end program P12015


      program DRSEI
c>> 1996-05-28 DRSEI    Krogh Added external statement.
c>> 1994-10-19 DRSEI    Krogh  Changes to use M77CON
c>> 1992-03-16 DRSEI    CLL
c>> 1990-11-29 CLL
c>> 1987-12-09 DRSEI    Lawson  Initial Code.
c     ------------------------------------------------------------------
c--S replaces "?": DR?EI, ?EI, ?E1
c     ------------------------------------------------------------------
      integer J
      external SEI, SE1
      real             X(14), Y, Z, SEI, SE1
c     ------------------------------------------------------------------
      data X / -80.E0, -20.E0, -5.E0, -1.E0, -.4E0, -.3E0, -.001E0,
     *         .001E0, .3E0, .4E0, 1.E0, 5.E0, 20.E0, 80.E0 /
c
      print '(1x,3X,A1,13X,A6,14X,A6/)','X','SEI(X)','SE1(X)'
c
      do 10 J = 1, 14
        Y = SEI(X(J))
        Z = SE1(X(J))
        print '(1x,F7.3,5X,2(G15.8,5X))',X(J),Y,Z
   10 continue
      end


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

!* Tests for runtime library MATMUL routines

program p

  parameter(NbrTests=128)
  parameter(n_extent=6)
  parameter(m_extent=4)
  parameter(k_extent=8)

  real*4, dimension(n_extent,m_extent) :: arr1
  real*4, dimension(n_extent,k_extent) :: arr2
  real*4, dimension(m_extent,k_extent) :: arr3

  REAL*4 :: expect(NbrTests)
  REAL*4 :: results(NbrTests)

  integer:: i,j

  data arr1 /0,1,2,3,4,5,6,7,8,9,10,11,                 &
             12,13,14,15,16,17,18,19,20,22,22,23/
  data arr2 /0,1,2,3,4,5,6,7,8,9,10,11,                         &
             12,13,14,15,16,17,18,19,20,21,22,23,               &
             24,25,26,27,28,29,30,31,32,33,34,35,               &
             36,37,38,39,40,41,42,43,44,45,46,47/
  data arr3 /0,1,2,3,4,5,6,7,8,9,10,11,                 &
             12,13,14,15,16,17,18,19,20,21,22,23,               &
             24,25,26,27,28,29,30,31/

  data expect / &
 ! test 1-32
    55.0, 145.0, 235.0, 328.0, 145.0, 451.0, &
    757.0, 1072.0, 235.0, 757.0, 1279.0, 1816.0, &
    325.0, 1063.0, 1801.0, 2560.0, 415.0, 1369.0, &
    2323.0, 3304.0, 505.0, 1675.0, 2845.0, 4048.0, &
    595.0, 1981.0, 3367.0, 4792.0, 685.0, 2287.0, &
    3889.0, 5536.0, &
 ! test 43-64
    55.0, 145.0, 235.0, 328.0, 145.0, 415.0, &
    685.0, 964.0, 235.0, 685.0, 1135.0, 1600.0, &
    325.0, 955.0, 1585.0, 2236.0, 415.0, 1225.0, &
    2035.0, 2872.0, 505.0, 1495.0, 2485.0, 3508.0, &
    595.0, 1765.0, 2935.0, 4144.0, 685.0, 2035.0, &
    3385.0, 4780.0, &
 ! test 65-96
    30.0, 90.0, 150.0, 213.0, 90.0, 330.0, &
    570.0, 819.0, 150.0, 570.0, 990.0, 1425.0, &
    210.0, 810.0, 1410.0, 2031.0, 270.0, 1050.0, &
    1830.0, 2637.0, 330.0, 1290.0, 2250.0, 3243.0, &
    390.0, 1530.0, 2670.0, 3849.0, 450.0, 1770.0, &
    3090.0, 4455.0, &
 ! test 97-128
    0.0, 145.0, 235.0, 328.0, 0.0, 451.0, &
    757.0, 1072.0, 0.0, 757.0, 1279.0, 1816.0, &
    0.0, 1063.0, 1801.0, 2560.0, 0.0, 1369.0, &
    2323.0, 3304.0, 0.0, 1675.0, 2845.0, 4048.0, &
    0.0, 1981.0, 3367.0, 4792.0, 0.0, 2287.0, &
    3889.0, 5536.0/

  !print *,"test 1-32"
  arr3=0
  arr3 = matmul(transpose(arr1),arr2)
  call assign_result(1,32,arr3,results)
  !print *,arr3

  !print *,"test 33-64"
  arr3=0
  arr3 = matmul(transpose(arr1(2:n_extent,:)),arr2(2:n_extent,:))
  call assign_result(33,64,arr3,results)
  !print *,arr3

  !print *,"test 65-96 "
  arr3=0
  arr3 = matmul(transpose(arr1(1:n_extent-1,:)),arr2(1:n_extent-1,:))
  call assign_result(65,96,arr3,results)
  !print *,arr3

  !print *,"test 97-128"
  arr3=0
  arr3(2:m_extent,:) = matmul(transpose(arr1(:,2:m_extent)),arr2)
  call assign_result(97,128,arr3,results)
  !print *,arr3

  call check(results, expect, NbrTests)

end program

subroutine assign_result(s_idx, e_idx , arr, rslt)
  REAL*4, dimension(1:e_idx-s_idx+1) :: arr
  REAL*4, dimension(e_idx) :: rslt
  integer:: s_idx, e_idx

  rslt(s_idx:e_idx) = arr

end subroutine