      module mtrx
        ! Matrix operation utilities.
!$      use omp_lib
        implicit none
        private
        real(8),parameter::TOL_=1d-10
        !---------------------------------------------------------------
        public::
     &      mtrx_xcanon,
     &      mtrx_uc,
     &      mtrx_utau,
     &      mtrx_utaup,
     &      mtrx_utau2,
     &      mtrx_utau2p,
     &      mtrx_utau2u,
     &      mtrx_eigsp,
     &      mtrx_expv,
     &      mtrx_expv2
        !---------------------------------------------------------------

      contains

        subroutine mtrx_xcanon(sb,val)
          ! Canonical transformation matrix X in AO basis.
          implicit none
          real(8),intent(in)::sb(:)
          real(8),intent(out)::val(:,:)
          integer::i,nb
          real(8),allocatable::e(:),sbt(:)
          nb=SIZE(val(:,1))
          allocate(e(nb))
          allocate(sbt(SIZE(sb)))
          sbt(:)=sb(:)
          e(:)=0d0
          call mtrx_eigsp(sbt,e,val)
          do i=1,nb
            val(:,i)=val(:,i)*e(i)**(-0.5d0)
          end do
        end subroutine

        subroutine mtrx_utau(u,a)
          ! Unitary transformation of a 1e matrix (distructive).
          implicit none
          real(8),intent(in)::u(:,:)
          real(8),intent(inout)::a(:)
          real(8),allocatable::b(:)
          call mtrx_utaup(u,a,b)
          a(:)=b(:)
        end subroutine

        subroutine mtrx_utaup(u,a,b)
          ! Unitary transformation of a 1e matrix (2-index).
          implicit none
          real(8),intent(in)::u(:,:)
          real(8),intent(in)::a(:)
          real(8),intent(out),allocatable::b(:)
          integer::i,j,k,ij,n,m,m2
          real(8),allocatable::vt(:,:)
          n=SIZE(u(:,1))
          m=SIZE(u(1,:))
          m2=ip_(m,m)
          allocate(vt(n,m))
          allocate(b(m2))
          vt(:,:)=0d0
          do i=1,n
            do j=1,m
              do k=1,n
                vt(i,j)=vt(i,j)+a(ip_(i,k))*u(k,j)
              end do
            end do
          end do
          b(:)=0d0
          do i=1,m
            do j=1,i
              ij=ip_(i,j)
              do k=1,n
                b(ij)=b(ij)+u(k,i)*vt(k,j)
              end do
            end do
          end do
        end subroutine

        subroutine mtrx_utau2(u,a)
          ! Unitary transformation of a 2e matrix (distructive).
          implicit none
          real(8),intent(in)::u(:,:)
          real(8),intent(inout)::a(:)
          real(8),allocatable::b(:)
          call mtrx_utau2p(u,a,b)
          a(:)=b(:)
        end subroutine

        subroutine mtrx_utau2p(u,a,b)
          ! Unitary transformation of a 2e matrix (4-index).
          implicit none
          real(8),intent(in)::u(:,:)
          real(8),intent(in)::a(:)
          real(8),intent(out),allocatable::b(:)
          integer::n,n3,m,m3,i,j,k,l,ijkl,im,jm,km,lm,ijklm
          real(8),allocatable::wk1(:,:,:,:),wk2(:,:,:,:)
          ! Get memory.
          n=SIZE(u(:,1))
          m=SIZE(u(1,:))
          n3=SIZE(a)
          m3=ip2_(m,m,m,m)
          allocate(wk1(n,n,n,n))
          allocate(wk2(n,n,n,n))
          allocate(b(m3))
          wk1(:,:,:,:)=0d0
          ! Transf.: a(i,j,k,l) -> a(i,j,k,lm)
!$omp     parallel private(i,j,k,l,lm,ijkl)
!$omp     do reduction(+:wk1)
          do i=1,n
            do j=1,n
              do k=1,n
                do lm=1,m
                  do l=1,n
                    ijkl=ip2_(i,j,k,l)
                    wk1(i,j,k,lm)=wk1(i,j,k,lm)+u(l,lm)*a(ijkl)
                  end do
                end do
              end do
            end do
          end do
!$omp     end do
!$omp     end parallel
          wk2(:,:,:,:)=0d0
          ! Transf.: a(i,j,k,lm) -> a(i,j,km,lm)
!$omp     parallel private(i,j,km,lm,k)
!$omp     do reduction(+:wk2)
          do i=1,n
            do j=1,n
              do km=1,m
                do lm=1,m
                  do k=1,n
                    wk2(i,j,km,lm)=wk2(i,j,km,lm)+u(k,km)*wk1(i,j,k,lm)
                  end do
                end do
              end do
            end do
          end do
!$omp     end do
!$omp     end parallel
          wk1(:,:,:,:)=wk2(:,:,:,:)
          wk2(:,:,:,:)=0d0
          ! Transf.:(i,j,km,lm) -> (i,jm,km,lm)
!$omp     parallel private(i,jm,km,lm,j)
!$omp     do reduction(+:wk2)
          do i=1,n
            do jm=1,m
              do km=1,m
                do lm=1,m
                  do j=1,n
                    wk2(i,jm,km,lm)=wk2(i,jm,km,lm)
     &                +u(j,jm)*wk1(i,j,km,lm)
                  end do
                end do
              end do
            end do
          end do
!$omp     end do
!$omp     end parallel
          ! Transf.:(i,jm,km,lm) -> (im,jm,km,lm)
          b(:)=0d0
          do ijklm=1,m3
            call iup2_(ijklm,im,jm,km,lm)
            do i=1,n
              b(ijklm)=b(ijklm)+u(i,im)*wk2(i,jm,km,lm)
            end do
          end do
        end subroutine

        subroutine mtrx_utau2u(cma,cmb,ab)
          ! Unitary transformation of a 2e matrix (4-index).
          implicit none
          real(8),intent(in)::cma(:,:),cmb(:,:)
          real(8),intent(inout)::ab(:,:)
          integer::n,n2,i,j,k,l,ij,kl,im,jm,km,lm,ijm,klm
          real(8),allocatable::wk1(:,:,:,:),wk2(:,:,:,:)
          ! Get memory.
          n=SIZE(cma(:,1))
          n2=SIZE(ab(:,1))
          allocate(wk1(n,n,n,n))
          allocate(wk2(n,n,n,n))
          wk1(:,:,:,:)=0d0
          ! Transf.: a(i,j,k,l) -> a(i,j,k,lm)
!$omp     parallel private(i,j,k,l,lm)
!$omp     do reduction(+:wk1)
          do i=1,n
            do j=1,n
              ij=ip_(i,j)
              do k=1,n
                do lm=1,n
                  do l=1,n
                    kl=ip_(k,l)
                    wk1(i,j,k,lm)=wk1(i,j,k,lm)
     &                +cmb(l,lm)*ab(ij,kl)
                  end do
                end do
              end do
            end do
          end do
!$omp     end do
!$omp     end parallel
          wk2(:,:,:,:)=0d0
          ! Transf.: a(i,j,k,lm) -> a(i,j,km,lm)
!$omp     parallel private(i,j,km,lm,k)
!$omp     do reduction(+:wk2)
          do i=1,n
            do j=1,n
              do km=1,n
                do lm=1,n
                  do k=1,n
                    wk2(i,j,km,lm)=wk2(i,j,km,lm)
     &                +cmb(k,km)*wk1(i,j,k,lm)
                  end do
                end do
              end do
            end do
          end do
!$omp     end do
!$omp     end parallel
          wk1(:,:,:,:)=wk2(:,:,:,:)
          wk2(:,:,:,:)=0d0
          ! Transf.:(i,j,km,lm) -> (i,jm,km,lm)
!$omp     parallel private(i,jm,km,lm,j)
!$omp     do reduction(+:wk2)
          do i=1,n
            do jm=1,n
              do km=1,n
                do lm=1,n
                  do j=1,n
                    wk2(i,jm,km,lm)=wk2(i,jm,km,lm)
     &                +cma(j,jm)*wk1(i,j,km,lm)
                  end do
                end do
              end do
            end do
          end do
!$omp     end do
!$omp     end parallel
          ! Transf.:(i,jm,km,lm) -> (im,jm,km,lm)
          ab(:,:)=0d0
          do ijm=1,n2
            call iup_(ijm,im,jm)
            do klm=1,n2
              call iup_(klm,km,lm)
              do i=1,n
                ab(ijm,klm)=ab(ijm,klm)+cma(i,im)*wk2(i,jm,km,lm)
              end do
            end do
          end do
        end subroutine

        subroutine mtrx_eigsp(ap,e,c)
          ! Real symmetric matrix diagonalization (packed strage).
          implicit none
          real(8),intent(inout)::ap(:)
          real(8),intent(out)::e(:),c(:,:)
          integer::n,lwork,liwork,info
          integer,allocatable::iwork(:)
          real(8),allocatable::work(:)
          n=size(e)
          lwork=1+6*n+n**2
          liwork=3+5*n
          allocate(work(lwork),iwork(liwork))
          call DSPEVD('V','U',n,ap,e,c,n,work,lwork,iwork,liwork,info)
        end subroutine

        subroutine mtrx_uc(u,c)
          ! Unitary transformation of orbitals.
          implicit none
          real(8),intent(in)::u(:,:)
          real(8),intent(inout)::c(:,:)
          real(8),allocatable::vt(:,:)
          integer::n
          n=SIZE(c(:,1))
          allocate(vt(n,n))
          vt=MATMUL(u,c)
          c(:,:)=vt(:,:)
        end subroutine

        subroutine mtrx_expv(pb,hb,val)
          ! Expectation value of the 1e operator.
          implicit none
          real(8),intent(in)::pb(:),hb(:)
          real(8),intent(out)::val
          integer::i,j,ij,nb2
          real(8),allocatable::vt(:)
          nb2=SIZE(pb)
          allocate(vt(nb2))
          do ij=1,nb2
            vt(ij)=pb(ij)*2d0
            call iup_(ij,i,j)
            if (i==j) vt(ij)=vt(ij)/2d0
          end do
          val=SUM(vt(:)*hb(:))
        end subroutine

        subroutine mtrx_expv2(pb,tb,val)
          ! Expectation value of the 2e operator.
          implicit none
          real(8),intent(in)::pb(:),tb(:)
          real(8),intent(out)::val
          integer::i,j,k,l,ij,kl,ijkl,nb3
          real(8),allocatable::vt(:)
          nb3=SIZE(tb)
          allocate(vt(nb3))
          do ijkl=1,nb3
            vt(ijkl)=pb(ijkl)*8d0
            call iup_(ijkl,ij,kl)
            call iup_(ij,i,j)
            call iup_(kl,k,l)
            if (i==j) vt(ijkl)=vt(ijkl)/2d0
            if (k==l) vt(ijkl)=vt(ijkl)/2d0
            if (ij==kl) vt(ijkl)=vt(ijkl)/2d0
          end do
          val=SUM(vt(:)*tb(:))
        end subroutine

        integer function ip_(i,j) result(ij)
          ! Canonical index packing for a symmetric matrix (1e).
          implicit none
          integer,intent(in)::i,j
          integer::ii,jj
          ii=max(i,j)
          jj=min(i,j)
          ij=(ii-1)*ii/2+jj
        end function

        integer function ip2_(i,j,k,l) result(ijkl)
          ! Canonical index packing for a symmetric matrix (2e).
          implicit none
          integer,intent(in)::i,j,k,l
          integer::ij,kl
          ij=ip_(i,j)
          kl=ip_(k,l)
          ijkl=ip_(ij,kl)
        end function

        subroutine iup_(ij,i,j)
          ! Unpack the canonical index for a symmetric matrix (1e).
          implicit none
          integer,intent(in)::ij
          integer,intent(out)::i,j
          real(8)::vt
          vt=0.5d0*(-1d0+SQRT(1d0+8*ij))
          i=CEILING(vt)
          j=ij-(i-1)*i/2
        end subroutine

        subroutine iup2_(ijkl,i,j,k,l)
          ! Unpack the canonical index for a symmetric matrix (2e).
          implicit none
          integer,intent(in)::ijkl
          integer,intent(out)::i,j,k,l
          integer::ij,kl
          call iup_(ijkl,ij,kl)
          call iup_(ij,i,j)
          call iup_(kl,k,l)
        end subroutine

      end module


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c 18/09/08
c Calculates the magnetic footprints by following the field lines
c until they hit the divertor target.
c In this version of the program, the starting points are given as
c a set of points on a (R, Z, phi) grid.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

	MODULE globals
	 IMPLICIT REAL*8 (A-H,O-Z)

	 REAL*8, POINTER :: R_poinc_plus(:,:,:)
	 REAL*8, POINTER :: Z_poinc_plus(:,:,:)

	 REAL*8, POINTER :: R_poinc_minus(:,:,:)
	 REAL*8, POINTER :: Z_poinc_minus(:,:,:)

	 REAL*8, POINTER :: phi_poinc_start(:,:,:)

	 REAL*8, POINTER :: dont_poinc(:,:,:)
	 REAL*8, POINTER :: R_old_poinc(:,:,:)
	 REAL*8, POINTER :: Z_old_poinc(:,:,:)
	 REAL*8, POINTER :: phi_old_poinc(:,:,:)

	 REAL*8, POINTER :: R_interm(:), Z_interm(:),
     *   phi_interm(:),
     *   R_start(:), Z_start(:), phi_start(:), S_start(:),
     *   BR(:,:), BZ(:,:), Bt(:,:), psi_norm(:,:)

	 REAL*8, POINTER :: dont(:),
     *   R_old(:), Z_old(:), phi_old(:)

	 REAL*8, POINTER :: BR_pert(:), BZ_pert(:),
     *   Bphi_pert(:)

	 REAL*8, POINTER :: BR3D_pert(:,:,:), BZ3D_pert(:,:,:),
     *   Bphi3D_pert(:,:,:)

	 REAL*8, POINTER :: BR2D_screen(:,:), BZ2D_screen(:,:),
     *   Bphi2D_screen(:,:)

	 REAL*8, POINTER :: R_div(:,:), Z_div(:,:)
	 INTEGER :: n_segments

	 REAL*8 :: R_min, R_max, Z_min, Z_max
	 REAL*8 :: R_min_pert, R_max_pert, Z_min_pert, Z_max_pert
	 REAL*8 :: R_min_screen, R_max_screen, Z_min_screen,
     *   Z_max_screen
	 REAL*8 :: R_min_0, R_max_0, Z_min_0, Z_max_0
	 REAL*8 :: psi_min, dphi0, psi_sep, psi_maxis

	 REAL*8 :: l_temp
	 REAL*8 :: l_plus
	 REAL*8 :: l_minus

	 REAL*8 :: Bt_factor
	 REAL*8 :: Ip_factor

	 REAL*8 :: phase_screen
	 INTEGER :: n_screen

         INTEGER :: N_R, N_Z, N_phi

         INTEGER :: N_R_screen, N_Z_screen, N_phi_screen
	 INTEGER :: N_2D_mesh

         INTEGER :: N_R_pert, N_Z_pert, N_phi_pert
	 INTEGER :: N_3D_mesh

	 PARAMETER (pi = 3.141592653589793)

	END MODULE globals

	PROGRAM poincare_footprint

	USE globals
	IMPLICIT REAL*8 (A-H,O-Z)

c Open input parameters file
	open(32,file='flt_in.dat',status='old',action='read')

c Open equilibrium files
	open(20,file='BR.dat',status='old',action='read')
	open(21,file='BZ.dat',status='old',action='read')
	open(22,file='Bt.dat',status='old',action='read')
	open(23,file='nR_nZ.dat',status='old',action='read')
	open(24,file='R_Z_min_max.dat',status='old',action='read')
	open(25,file='psi_norm.dat',status='old',action='read')
	open(26,file='psi_sep_maxis.dat',status='old',action='read')

c Open magnetic perturbations files
	open(33,file='nR_nZ_nphi_pert.dat',status='old',action='read')
	open(34,file='R_Z_min_max_pert.dat',status='old',action='read')
	open(35,file='Br3D_pert.dat',status='old',action='read')
	open(36,file='Bz3D_pert.dat',status='old',action='read')
	open(37,file='Bphi3D_pert.dat',status='old',action='read')

c Open magnetic screening files
	open(93,file='nR_nZ_screen.dat',status='old',action='read')
	open(94,file='R_Z_min_max_screen.dat',status='old',
     *  action='read')
	open(95,file='Br2D_screen.dat',status='old',action='read')
	open(96,file='Bz2D_screen.dat',status='old',action='read')
	open(97,file='Bphi2D_screen.dat',status='old',action='read')
	open(98,file='n_screen.dat',status='old',action='read')

c Open starting points specification files
	open(59,file='reg_grid.dat',status='old',action='read')
	open(60,file='n_R_Z_phi_start.dat',status='old',action='read')
	open(61,file='R_start.dat',status='old',action='read')
	open(62,file='Z_start.dat',status='old',action='read')
	open(63,file='phi_start.dat',status='old',action='read')

	open(75,file='dont.dat',status='old',action='read')
	open(76,file='R_old.dat',status='old',action='read')
	open(77,file='Z_old.dat',status='old',action='read')
	open(78,file='phi_old.dat',status='old',action='read')

c Open output files
	open(64,file='connection_length_start.dat',status='replace',
     *  action='write')
	open(65,file='connection_length_start_plus.dat',status='replace',
     *  action='write')
	open(66,file='connection_length_start_minus.dat',status='replace',
     *  action='write')
	open(67,file='psi_min_start.dat',status='replace',
     *  action='write')
	open(68,file='connection_length_start_plus_turns.dat',
     *  status='replace',action='write')
	open(69,file='connection_length_start_minus_turns.dat',
     *  status='replace',action='write')

	open(51,file='R_footprint_plus.dat',status='replace',
     *  action='write')
	open(52,file='Z_footprint_plus.dat',status='replace',
     *  action='write')
	open(53,file='phi_footprint_plus.dat',status='replace',
     *  action='write')
	open(54,file='n_seg_strike_plus.dat',status='replace',
     *  action='write')
	open(55,file='connection_length_plus.dat',status='replace',
     *  action='write')
	open(57,file='psi_min_plus.dat',status='replace',
     *  action='write')

	open(81,file='R_footprint_minus.dat',status='replace',
     *  action='write')
	open(82,file='Z_footprint_minus.dat',status='replace',
     *  action='write')
	open(83,file='phi_footprint_minus.dat',status='replace',
     *  action='write')
	open(84,file='n_seg_strike_minus.dat',status='replace',
     *  action='write')
	open(85,file='connection_length_minus.dat',status='replace',
     *  action='write')
	open(87,file='psi_min_minus.dat',status='replace',
     *  action='write')

	open(72,file='R_poincare.dat',status='replace',action='write')
	open(73,file='Z_poincare.dat',status='replace',action='write')
	open(74,file='psi_poincare.dat',status='replace',
     *  action='write')

	open(102,file='R_test.dat',status='replace',action='write')
	open(103,file='Z_test.dat',status='replace',action='write')
	open(104,file='phi_test.dat',status='replace',action='write')
        open(105,file='fl_num.dat',status='replace',action='write')
	open(106,file='turns_or_metres.txt',status='replace',action='write')
	open(107,file='lost_plus.dat',status='replace',action='write')
	open(108,file='lost_minus.dat',status='replace',action='write')
	open(109,file='lost_either.dat',status='replace',action='write')

	call cpu_time(time_begin)
	write(*,*) 'Starting program'

	deux_pi = 2*pi

c Read input parameters
	read(32,*) N_phi
	read(32,*) l_fl
	read(32,*) current_pert
	read(32,*) current_screen
	read(32,*) phase_screen
	read(32,*) i_divertor
	read(32,*) plot_fl
	read(32,*) Bt_factor
	read(32,*) Ip_factor

	write(106,*) l_fl,'m'

c Read starting points specification
	read(59,*) reg_grid
	read(60,*) n_R_start
	read(60,*) n_Z_start
	read(60,*) n_phi_start
	n_start = n_R_start * n_Z_start * n_phi_start

	ALLOCATE(R_start(n_start), Z_start(n_start),
     *  phi_start(n_start), dont(n_start),
     *  R_old(n_start), Z_old(n_start), phi_old(n_start))

	if (reg_grid.eq.0) then

	 do i=1,n_R_start*n_Z_start
	  read(61,*) R_start(i)
	 enddo

	 do i=1,n_R_start*n_Z_start
	  read(62,*) Z_start(i)
	 enddo

	elseif (reg_grid.eq.1) then

	 do i=1,n_R_start
	  read(61,*) R_start(i)
	 enddo

	 do i=1,n_Z_start
	  read(62,*) Z_start(i)
	 enddo

	elseif (reg_grid.eq.2) then

	 do i=1,n_start
	  read(61,*) R_start(i)
	 enddo

	 do i=1,n_start
	  read(62,*) Z_start(i)
	 enddo

	 do i=1,n_start
	  read(75,*) dont(i)
	 enddo

	 do i=1,n_start
	  read(76,*) R_old(i)
	 enddo

	 do i=1,n_start
	  read(77,*) Z_old(i)
	 enddo

	 do i=1,n_start
	  read(78,*) phi_old(i)
	 enddo

	else

	 write(*,*) 'reg_grid must equal 0, 1 or 2'
	 stop

	endif

	if ((reg_grid.eq.0).or.(reg_grid.eq.1)) then

	 do i=1,n_phi_start
	  read(63,*) phi_start(i)
	 enddo

	elseif (reg_grid.eq.2) then

	 do i=1,n_start
	  read(63,*) phi_start(i)
	 enddo

	else

	 write(*,*) 'reg_grid must equal 0, 1 or 2'
	 stop

	endif

	ALLOCATE(R_poinc_plus(n_R_start, n_Z_start, n_phi_start))
        ALLOCATE(Z_poinc_plus(n_R_start, n_Z_start, n_phi_start))

	ALLOCATE(R_poinc_minus(n_R_start, n_Z_start, n_phi_start))
        ALLOCATE(Z_poinc_minus(n_R_start, n_Z_start, n_phi_start))

        ALLOCATE(phi_poinc_start(n_R_start, n_Z_start, n_phi_start))

	ALLOCATE(dont_poinc(n_R_start, n_Z_start, n_phi_start))
	ALLOCATE(R_old_poinc(n_R_start, n_Z_start, n_phi_start))
	ALLOCATE(Z_old_poinc(n_R_start, n_Z_start, n_phi_start))
	ALLOCATE(phi_old_poinc(n_R_start, n_Z_start, n_phi_start))

c Initialising
	if (reg_grid.eq.0) then

	 do k=1,n_R_start
	 do l=1,n_Z_start
	 do m=1,n_phi_start

	 R_poinc_plus(k,l,m) = R_start(n_Z_start*(k-1)+l)
	 Z_poinc_plus(k,l,m) = Z_start(n_Z_start*(k-1)+l)

	 R_poinc_minus(k,l,m) = R_start(n_Z_start*(k-1)+l)
	 Z_poinc_minus(k,l,m) = Z_start(n_Z_start*(k-1)+l)

	 phi_poinc_start(k,l,m) = phi_start(m)

	 enddo
	 enddo
	 enddo

	elseif (reg_grid.eq.1) then

	 do k=1,n_R_start
	 do l=1,n_Z_start
	 do m=1,n_phi_start

	 R_poinc_plus(k,l,m) = R_start(k)
	 Z_poinc_plus(k,l,m) = Z_start(l)

	 R_poinc_minus(k,l,m) = R_start(k)
	 Z_poinc_minus(k,l,m) = Z_start(l)

	 phi_poinc_start(k,l,m) = phi_start(m)

	 enddo
	 enddo
	 enddo

	elseif (reg_grid.eq.2) then

	 do k=1,n_R_start
	 do l=1,n_Z_start
	 do m=1,n_phi_start

	 R_poinc_plus(k,l,m) =
     *   R_start(n_Z_start*n_phi_start*(k-1)+n_phi_start*(l-1)+m)

	 Z_poinc_plus(k,l,m) =
     *   Z_start(n_Z_start*n_phi_start*(k-1)+n_phi_start*(l-1)+m)

	 R_poinc_minus(k,l,m) =
     *   R_start(n_Z_start*n_phi_start*(k-1)+n_phi_start*(l-1)+m)

	 Z_poinc_minus(k,l,m) =
     *   Z_start(n_Z_start*n_phi_start*(k-1)+n_phi_start*(l-1)+m)

	 phi_poinc_start(k,l,m) =
     *   phi_start(n_Z_start*n_phi_start*(k-1)+n_phi_start*(l-1)+m)

	 dont_poinc(k,l,m) =
     *   dont(n_Z_start*n_phi_start*(k-1)+n_phi_start*(l-1)+m)

	 R_old_poinc(k,l,m) =
     *   R_old(n_Z_start*n_phi_start*(k-1)+n_phi_start*(l-1)+m)

	 Z_old_poinc(k,l,m) =
     *   Z_old(n_Z_start*n_phi_start*(k-1)+n_phi_start*(l-1)+m)

	 phi_old_poinc(k,l,m) =
     *   phi_old(n_Z_start*n_phi_start*(k-1)+n_phi_start*(l-1)+m)

	 enddo
	 enddo
	 enddo

	else

	 write(*,*) 'reg_grid must equal 0, 1 or 2'
	 stop

	endif

        ALLOCATE(R_interm(N_phi+1), Z_interm(N_phi+1),
     *  phi_interm(N_phi+1))

c Read equilibrium data
	write(*,*) 'Begin reading equilibrium data'
	read(23,*) N_R
	read(23,*) N_Z

        ALLOCATE(BR(N_R+1,N_Z+1), BZ(N_R+1,N_Z+1),
     *  Bt(N_R+1,N_Z+1), psi_norm(N_R+1,N_Z+1))

	read(24,*) R_min
	read(24,*) R_max
	read(24,*) Z_min
	read(24,*) Z_max

	write(*,*) 'Reading BR'
	do j=1,N_Z
	 read(20,*) (BR(i,j), i=1,N_R)
	enddo

	write(*,*) 'Reading BZ'
	do j=1,N_Z
	 read(21,*) (BZ(i,j), i=1,N_R)
	enddo

	write(*,*) 'Reading Bt'
	do j=1,N_Z
	 read(22,*) (Bt(i,j), i=1,N_R)
	enddo

	write(*,*) 'Reading psi_norm'
	do j=1,N_Z
	 read(25,*) (psi_norm(i,j), i=1,N_R)
	enddo

	BR = BR*Ip_factor
	BZ = BZ*Ip_factor
	Bt = Bt*Bt_factor

	read(26,*) psi_sep
	read(26,*) psi_maxis

	write(*,*) 'psi_sep',psi_sep
	write(*,*) 'psi_maxis',psi_maxis

	write(*,*) 'End of reading equilibrium data'

c Read magnetic perturbations data
	read(33,*) N_R_pert
	read(33,*) N_Z_pert
	read(33,*) N_phi_pert

	ALLOCATE(BR3D_pert(N_R_pert,N_Z_pert,N_phi_pert),
     *  BZ3D_pert(N_R_pert,N_Z_pert,N_phi_pert),
     *  Bphi3D_pert(N_R_pert,N_Z_pert,N_phi_pert))

	N_3D_mesh = N_R_pert * N_Z_pert * N_phi_pert

	ALLOCATE(BR_pert(N_3D_mesh), BZ_pert(N_3D_mesh),
     *  Bphi_pert(N_3D_mesh))

	do i=1,N_3D_mesh
	  read(35,*) BR_pert(i)
	enddo
	do i=1,N_3D_mesh
	  read(36,*) BZ_pert(i)
	enddo
	do i=1,N_3D_mesh
	  read(37,*) Bphi_pert(i)
	enddo

	do i=1,N_3D_mesh
	  BR_pert(i) = current_pert * BR_pert(i)
	  BZ_pert(i) = current_pert * BZ_pert(i)
	  Bphi_pert(i) = current_pert * Bphi_pert(i)
	enddo

	do i=1,N_R_pert
	 do j=1,N_Z_pert
	  do k=1,N_phi_pert
c For a field from Eric:
	   BR3D_pert(i,j,k) =
     *     BR_pert(k+(j-1)*N_phi_pert+(i-1)*N_Z_pert*N_phi_pert)
	   BZ3D_pert(i,j,k) =
     *     BZ_pert(k+(j-1)*N_phi_pert+(i-1)*N_Z_pert*N_phi_pert)
	   Bphi3D_pert(i,j,k) =
     *     Bphi_pert(k+(j-1)*N_phi_pert+(i-1)*N_Z_pert*N_phi_pert)

c For a field from Pavel, the field is in a different order:
c	   BR3D_pert(i,j,k) =
c     *     BR_pert(i+(j-1)*N_R_pert+(k-1)*N_Z_pert*N_R_pert)
c	   BZ3D_pert(i,j,k) =
c     *     BZ_pert(i+(j-1)*N_R_pert+(k-1)*N_Z_pert*N_R_pert)
c	   Bphi3D_pert(i,j,k) =
c     *     Bphi_pert(i+(j-1)*N_R_pert+(k-1)*N_Z_pert*N_R_pert)
	  enddo
	 enddo
	enddo

	read(34,*) R_min_pert
	read(34,*) R_max_pert
	read(34,*) Z_min_pert
	read(34,*) Z_max_pert

c Read screening field data
	read(93,*) N_R_screen
	read(93,*) N_Z_screen

	N_2D_mesh = N_R_screen * N_Z_screen

	ALLOCATE(BR2D_screen(N_2D_mesh,2),
     *  BZ2D_screen(N_2D_mesh,2),Bphi2D_screen(N_2D_mesh,2))

	do i=1,N_2D_mesh
	  read(95,*) BR2D_screen(i,1), BR2D_screen(i,2)
	enddo
	do i=1,N_2D_mesh
	  read(96,*) BZ2D_screen(i,1), BZ2D_screen(i,2)
	enddo
	do i=1,N_2D_mesh
	  read(97,*) Bphi2D_screen(i,1), Bphi2D_screen(i,2)
	enddo

	do i=1,N_2D_mesh
	  BR2D_screen(i,1) = current_screen * BR2D_screen(i,1)
	  BZ2D_screen(i,1) = current_screen * BZ2D_screen(i,1)
	  Bphi2D_screen(i,1) = current_screen * Bphi2D_screen(i,1)
	  BR2D_screen(i,2) = current_screen * BR2D_screen(i,2)
	  BZ2D_screen(i,2) = current_screen * BZ2D_screen(i,2)
	  Bphi2D_screen(i,2) = current_screen * Bphi2D_screen(i,2)
	enddo

	read(98,*) n_screen

	read(94,*) R_min_screen
	read(94,*) R_max_screen
	read(94,*) Z_min_screen
	read(94,*) Z_max_screen

	R_min_1 = max(R_min,R_min_pert)
	R_max_1 = min(R_max,R_max_pert)
	Z_min_1 = max(Z_min,Z_min_pert)
	Z_max_1 = min(Z_max,Z_max_pert)

	R_min_0 = max(R_min_1,R_min_screen)
	R_max_0 = min(R_max_1,R_max_screen)
	Z_min_0 = max(Z_min_1,Z_min_screen)
	Z_max_0 = min(Z_max_1,Z_max_screen)

c Read divertor data
c Open divertor shape specification files
	if (i_divertor.eq.1) then
	 open(100,file='JET_divertor.dat',status='old',action='read')
	elseif (i_divertor.eq.2) then
	 open(100,file='MAST_divertor.dat',status='old',action='read')
	elseif (i_divertor.eq.3) then
	 open(100,file='MAST-U_divertor.dat',status='old',action='read')
	elseif (i_divertor.eq.4) then
	 open(100,file='JET_divertor_simple.dat',status='old',action='read')
	else
	 write(*,*) 'Wrong divertor number'
	endif

	read(100,*) n_segments

	ALLOCATE(R_div(n_segments,2), Z_div(n_segments,2))

	do i_seg=1,n_segments
	 read(100,*) R_div(i_seg,1), R_div(i_seg,2),
     *   Z_div(i_seg,1), Z_div(i_seg,2)
	enddo

c Define toroidal step for advancing the field lines
	dphi0 = 2*pi/(N_phi-1)

c------------------------------------------------------------
c Begin field line tracing
	n = 0

	do k=1,n_R_start
	write(*,*)'k',k

	do l=1,n_Z_start
	write(*,*)'l',l

	m = 0

	do while(m.lt.n_phi_start)

   1    m = m + 1
	n = n + 1

	if (dont_poinc(k,l,m).eq.1) then
	 write(102,*) R_old_poinc(k,l,m)
	 write(103,*) Z_old_poinc(k,l,m)
	 write(104,*) phi_old_poinc(k,l,m)
	 write(105,*) n
	elseif (dont_poinc(k,l,m).eq.0) then

c Initialisation of psi_min
	psi_min = 100000.

c Start turning in the increasing phi direction
	l_follow = l_fl/2
	N_tot_turns = 0
	l_plus = 0.
	l_temp = 0.

c Loop on toroidal rotations.
c Continue unless the field line has travelled a length equal to l_follow,
c reached the divertor target (or the wall), or reached the boundary of
c the computation domain
	in_wall_plus = 0
	in_bounds_plus = 1

	do while ((l_temp.lt.l_follow)
     *            .and.(in_wall_plus.eq.0)
     *            .and.(in_bounds_plus.eq.1))

	N_tot_turns = N_tot_turns + 1

c Write position for Poincare plot
	write(72,*) R_poinc_plus(k,l,m)
	write(73,*) Z_poinc_plus(k,l,m)

c Also find the local psi_norm and write it for Poincare plot
	R_loc = R_poinc_plus(k,l,m)
	Z_loc = Z_poinc_plus(k,l,m)
	call index_interp_eq(R_loc, Z_loc, i_interp, j_interp,
     *  coef1, coef2)
	psi_norm_loc = B_interp_eq(psi_norm, i_interp, j_interp,
     *  coef1, coef2)
	write(74,*) psi_norm_loc

	call one_turn(R_poinc_plus(k,l,m), Z_poinc_plus(k,l,m),
     *  phi_poinc_start(k,l,m), in_wall_plus, in_bounds_plus, 1, n)

	enddo

	N_plus = N_tot_turns
	l_plus = l_temp

c Now turn in the decreasing phi direction
	l_follow = 0. ! l_fl - l_plus
	l_minus = 0.
	l_temp = 0.

c Loop on toroidal rotations.
c Continue unless the field line has travelled a length equal to l_follow,
c reached the divertor target (or the wall), or reached the boundary of
c the computation domain
	in_wall_minus = 0
	in_bounds_minus = 1

	do while ((l_temp.lt.l_follow)
     *            .and.(in_wall_minus.eq.0)
     *            .and.(in_bounds_minus.eq.1))

	N_tot_turns = N_tot_turns + 1

c Write position for Poincare plot
	write(72,*) R_poinc_minus(k,l,m)
	write(73,*) Z_poinc_minus(k,l,m)

c Also find the local psi_norm and write it for Poincare plot
	R_loc = R_poinc_minus(k,l,m)
	Z_loc = Z_poinc_minus(k,l,m)
	call index_interp_eq(R_loc, Z_loc, i_interp, j_interp,
     *  coef1, coef2)
	psi_norm_loc = B_interp_eq(psi_norm, i_interp, j_interp,
     *  coef1, coef2)
	write(74,*) psi_norm_loc

	call one_turn(R_poinc_minus(k,l,m), Z_poinc_minus(k,l,m),
     *  phi_poinc_start(k,l,m), in_wall_minus, in_bounds_minus, -1, n)

	enddo

	N_minus = N_tot_turns - N_plus
	l_minus = l_temp

c If there remains turns to do, turn
c in the increasing phi direction again
	l_follow = l_fl - l_minus
	l_temp = l_plus

c Loop on toroidal rotations.
c Continue unless the field line has travelled a length equal to l_follow,
c reached the divertor target (or the wall), or reached the boundary of
c the computation domain

	do while ((l_temp.lt.l_follow)
     *            .and.(in_wall_plus.eq.0)
     *            .and.(in_bounds_plus.eq.1))

	N_tot_turns = N_tot_turns + 1

c Write position for Poincare plot
	write(72,*) R_poinc_plus(k,l,m)
	write(73,*) Z_poinc_plus(k,l,m)

c Also find the local psi_norm and write it for Poincare plot
	R_loc = R_poinc_plus(k,l,m)
	Z_loc = Z_poinc_plus(k,l,m)
	call index_interp_eq(R_loc, Z_loc, i_interp, j_interp,
     *  coef1, coef2)
	psi_norm_loc = B_interp_eq(psi_norm, i_interp, j_interp,
     *  coef1, coef2)
	write(74,*) psi_norm_loc

	call one_turn(R_poinc_plus(k,l,m), Z_poinc_plus(k,l,m),
     *  phi_poinc_start(k,l,m), in_wall_plus, in_bounds_plus, 1, n)

	enddo

	N_plus = N_tot_turns - N_minus
	l_plus = l_temp

	write(102,*) R2
	write(103,*) Z2
	write(104,*) phi_bis
	write(105,*) n

	else
	 write(*,*) 'lost_plus.dat should only contain values equal to 0 or 1'
	 stop
	endif

	if ((in_wall_plus.eq.1).or.(in_bounds_plus.eq.0)) then
	 write(107,*) 1
	else
	 write(107,*) 0
	endif

	if ((in_wall_minus.eq.1).or.(in_bounds_minus.eq.0)) then
	 write(108,*) 1
	else
	 write(108,*) 0
	endif

	if ((in_wall_plus.eq.1).or.(in_bounds_plus.eq.0)
     *  .or.(in_wall_minus.eq.1).or.(in_bounds_minus.eq.0)) then
	 write(109,*) 1
	else
	 write(109,*) 0
	endif

c Write connection length (N_tot_turns) and deepest position reached in the plasma
c (psi_min)
	if (in_wall_plus.eq.1) then
	 write(55,*) N_tot_turns
c	 write(55,*) l_plus
	 write(57,*) psi_min
	endif

	if (in_wall_minus.eq.1) then
	 write(85,*) N_tot_turns
c	 write(85,*) l_minus
	 write(87,*) psi_min
	endif

	write(67,*) psi_min

	write(64,*) N_tot_turns

! 	if (in_wall_plus.eq.0) then
! 	 l_plus = NaN
! 	endif
	write(65,*) l_plus

! 	if (in_wall_minus.eq.0) then
! 	 l_minus = NaN
! 	endif
	write(66,*) l_minus

	write(68,*) N_plus

	write(69,*) N_minus

	enddo
	enddo
	enddo

	DEALLOCATE(R_poinc_plus, Z_poinc_plus)
	DEALLOCATE(R_poinc_minus, Z_poinc_minus)
	DEALLOCATE(phi_poinc_start)
	DEALLOCATE(R_interm, Z_interm, phi_interm)
	DEALLOCATE(R_start, Z_start, phi_start)
	DEALLOCATE(BR, BZ, Bt, psi_norm)
	DEALLOCATE(BR_pert, BZ_pert, Bphi_pert)
	DEALLOCATE(BR3D_pert, BZ3D_pert, Bphi3D_pert)
	DEALLOCATE(BR2D_screen, BZ2D_screen, Bphi2D_screen)
	DEALLOCATE(R_div, Z_div)
	DEALLOCATE(dont, R_old, Z_old, phi_old)
	DEALLOCATE(dont_poinc, R_old_poinc, Z_old_poinc, phi_old_poinc)

	write(*,*)'END'

	call cpu_time(time_end)
	exec_time = time_end - time_begin
	write(*,*)'Execution time in seconds:',exec_time

	CONTAINS
c------------------------------------------------------------------------------------

	SUBROUTINE runge_kutta(R, Z, phi, dphi, R2, Z2, phi2, in_bounds)

c	write(*,*) 'Hello'

	phi = dmod_phi(phi)

	call advance_field_line(R, Z, phi, dR1, dZ1, dphi)

	phi_interm0 = dmod_phi(phi+dphi/2)

	in_bounds = i_still_in_bounds(R+dR1/2, Z+dZ1/2)
	if (in_bounds.eq.0) goto 10

	call advance_field_line(R+dR1/2, Z+dZ1/2, phi_interm0,
     *  dR2, dZ2, dphi)

	in_bounds = i_still_in_bounds(R+dR2/2, Z+dZ2/2)
	if (in_bounds.eq.0) goto 10

	call advance_field_line(R+dR2/2, Z+dZ2/2, phi_interm0,
     *	dR3, dZ3, dphi)

	phi_interm0 = dmod_phi(phi_interm0+dphi/2)

	in_bounds = i_still_in_bounds(R+dR3, Z+dZ3)
	if (in_bounds.eq.0) goto 10

	call advance_field_line(R+dR3, Z+dZ3, phi_interm0,
     *	dR4, dZ4, dphi)

	R2 = R + dR1/6 + dR2/3 + dR3/3 + dR4/6

	Z2 = Z + dZ1/6 + dZ2/3 + dZ3/3 + dZ4/6

	phi2 = dmod_phi(phi+dphi)

	dl_temp = ((R2-R)**2.+(Z2-Z)**2.+(R*dphi)**2.)**0.5
	l_temp = l_temp + dl_temp

   10	RETURN
	END SUBROUTINE runge_kutta
c-----------------------------------------------------------------------------------

	SUBROUTINE advance_field_line(R, Z, phi, dR, dZ, dphi)

	call index_interp_eq(R, Z, i_interp, j_interp, coef1, coef2)
c	write(*,*)'i_interp',i_interp
c	write(*,*)'j_interp',j_interp
	call field_interp_eq(R, BR_interp, BZ_interp,
     *  i_interp, j_interp, coef1, coef2)
c	write(*,*)'BR_interp_psi',BR_interp
c	write(*,*)'BZ_interp_psi',BZ_interp
c	BR_interp = B_interp_eq(BR, i_interp, j_interp, coef1, coef2)
c	BZ_interp = B_interp_eq(BZ, i_interp, j_interp, coef1, coef2)
c	write(*,*)'BR_interp',BR_interp
c	write(*,*)'BZ_interp',BZ_interp
c	BR_interp = BR_interp/100
c	BZ_interp = BZ_interp/100

	Bphi_interp = B_interp_eq(Bt, i_interp, j_interp, coef1, coef2)
	psi_norm_test = B_interp_eq(psi_norm, i_interp, j_interp,
     *  coef1, coef2)
	if(psi_norm_test.lt.psi_min) then
	 psi_min = psi_norm_test
	endif

	BR_interp_pert = B_interp_pert(R, Z, phi, BR3D_pert)
	BZ_interp_pert = B_interp_pert(R, Z, phi, BZ3D_pert)
	Bphi_interp_pert = B_interp_pert(R, Z, phi, Bphi3D_pert)

c 	write(*,*)'BR_interp_pert',BR_interp_pert
c 	write(*,*)'BZ_interp_pert',BZ_interp_pert
c 	write(*,*)'Bphi_interp_pert',Bphi_interp_pert

	index_screen = index_interp_screen(R, Z)
	BR_interp_screen = B_interp_screen(index_screen,
     *  BR2D_screen, phi)
	BZ_interp_screen = B_interp_screen(index_screen,
     *  BZ2D_screen, phi)
	Bphi_interp_screen = B_interp_screen(index_screen,
     *  Bphi2D_screen, phi)

	dR = ((BR_interp + BR_interp_pert + BR_interp_screen)/
     *       (Bphi_interp + Bphi_interp_pert + Bphi_interp_screen))
     *       * dphi * R

	dZ = ((BZ_interp + BZ_interp_pert + BZ_interp_screen)
     *       /(Bphi_interp + Bphi_interp_pert + Bphi_interp_screen))
     *       * dphi * R

	RETURN
	END SUBROUTINE advance_field_line

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

	SUBROUTINE index_interp_eq(R, Z, i_interp, j_interp,
     *  coef1, coef2)
c 	Interpolate the magnetic field in the poloidal plane

	i_interp = 1 + int(N_R*(R-R_min)
     *             /(R_max-R_min))

	j_interp = 1 + int(N_Z*(Z-Z_min)
     *             /(Z_max-Z_min))

	R_up = R_min
     *         + ((1.*i_interp)/(1.*N_R))*(R_max-R_min)

	R_down = R_min
     *           + ((1.*(i_interp-1))/(1.*N_R))
     *             *(R_max-R_min)

	Z_up = Z_min
     *         + ((1.*j_interp)/(1.*N_Z))*(Z_max-Z_min)

	Z_down = Z_min
     *           + ((1.*(j_interp-1))/(1.*N_Z))
     *             *(Z_max-Z_min)

	coef1 = (R-R_down)/(R_up-R_down)
	coef2 = (Z-Z_down)/(Z_up-Z_down)

	END SUBROUTINE index_interp_eq

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

	REAL*8 FUNCTION B_interp_eq(Bfield, i_interp, j_interp,
     *  coef1, coef2)
c 	Interpolate the magnetic field in the poloidal plane

	REAL*8 :: Bfield(:,:)

	psi11 = Bfield(i_interp,j_interp)
	psi12 = Bfield(i_interp+1,j_interp)
	psi21 = Bfield(i_interp,j_interp+1)
	psi22 = Bfield(i_interp+1,j_interp+1)

	B_interp_eq = (1.-coef1)*(1.-coef2)*psi11
     *  + coef1*coef2*psi22 + (1.-coef1)*coef2*psi21
     *  + coef1*(1.-coef2)*psi12

	END FUNCTION B_interp_eq

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

	SUBROUTINE field_interp_eq(R, BR_interp, BZ_interp, i_interp,
     *  j_interp, coef1, coef2)
c 	Interpolate the magnetic field in the poloidal plane

	psi11 = psi_norm(i_interp,j_interp)
	psi12 = psi_norm(i_interp+1,j_interp)
	psi21 = psi_norm(i_interp,j_interp+1)
	psi22 = psi_norm(i_interp+1,j_interp+1)

	BR_interp = -(1./R)*(N_Z/(Z_max-Z_min))
     *  *((1.-coef1)*(psi21-psi11)+coef1*(psi22-psi12))

	BR_interp = BR_interp*(psi_sep-psi_maxis)*Ip_factor

	BZ_interp = (1./R)*(N_R/(R_max-R_min))
     *  *((1.-coef2)*(psi12-psi11)+coef2*(psi22-psi21))

	BZ_interp = BZ_interp*(psi_sep-psi_maxis)*Ip_factor

	psi_norm_before = (1.-coef1)*(1.-coef2)*psi11
     *  + coef1*coef2*psi22 + (1.-coef1)*coef2*psi21
     *  + coef1*(1.-coef2)*psi12

	END SUBROUTINE field_interp_eq

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

	FUNCTION B_interp_pert(R, Z, phi, Bfield)
c 	Interpolate the magnetic field in the poloidal plane

	REAL*8 :: Bfield(:,:,:)
	REAL*8 :: Bcorner(8)

	iloc = 1 + int((N_R_pert-1.)*(R-R_min_pert)
     *             /(R_max_pert-R_min_pert))

	jloc = 1 + int((N_Z_pert-1.)*(Z-Z_min_pert)
     *             /(Z_max_pert-Z_min_pert))

	kloc1 = 1 + int(phi*N_phi_pert/(2.*pi))

	if (kloc1+1.le.N_phi_pert) then
	 kloc2 = kloc1+1
	else
	 kloc2 = 1
	endif

	Bcorner(1) = Bfield(iloc,jloc,kloc1)
	Bcorner(2) = Bfield(iloc+1,jloc,kloc1)
	Bcorner(3) = Bfield(iloc+1,jloc,kloc2)
	Bcorner(4) = Bfield(iloc,jloc,kloc2)
	Bcorner(5) = Bfield(iloc,jloc+1,kloc1)
	Bcorner(6) = Bfield(iloc+1,jloc+1,kloc1)
	Bcorner(7) = Bfield(iloc+1,jloc+1,kloc2)
	Bcorner(8) = Bfield(iloc,jloc+1,kloc2)

	R1 = R_min_pert + (iloc-1.)*(R_max_pert-R_min_pert)
     *  /(N_R_pert-1.)
	R2 = R_min_pert + iloc*(R_max_pert-R_min_pert)
     *  /(N_R_pert-1.)

	Z1 = Z_min_pert + (jloc-1.)*(Z_max_pert-Z_min_pert)
     *  /(N_Z_pert-1.)
	Z2 = Z_min_pert + jloc*(Z_max_pert-Z_min_pert)
     *  /(N_Z_pert-1.)

	phi1 = (kloc1-1.)*2.*pi/N_phi_pert
	phi2 = kloc1*2.*pi/N_phi_pert

	c1 = (R2-R)/(R2-R1)
	c2 = (Z2-Z)/(Z2-Z1)
	c3 = (phi2-phi)/(phi2-phi1)

	B_interp_pert = 0.

	do icorn=1,8
	 if ((icorn.eq.1).or.(icorn.eq.4).or.(icorn.eq.5).or.(icorn.eq.8)) then
	  a1 = c1
	 else
	  a1 = 1.-c1
	 endif
	 if ((icorn.eq.1).or.(icorn.eq.2).or.(icorn.eq.3).or.(icorn.eq.4)) then
	  a2 = c2
	 else
	  a2 = 1.-c2
	 endif
	 if ((icorn.eq.1).or.(icorn.eq.2).or.(icorn.eq.5).or.(icorn.eq.6)) then
	  a3 = c3
	 else
	  a3 = 1.-c3
	 endif

	 Bincr = Bcorner(icorn)*a1*a2*a3

	 B_interp_pert = B_interp_pert + Bincr
	enddo

	END FUNCTION B_interp_pert

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

	FUNCTION index_interp_screen(R, Z)
c 	Interpolate the magnetic field in the poloidal plane

	i_interp = 1 + int((N_R_screen-1)*(R-R_min_screen)
     *             /(R_max_screen-R_min_screen))

	j_interp = 1 + int((N_Z_screen-1)*(Z-Z_min_screen)
     *             /(Z_max_screen-Z_min_screen))

	index_interp_screen = (i_interp-1)*N_Z_screen + j_interp

	END FUNCTION index_interp_screen

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

	FUNCTION B_interp_screen(index_interp_screen, Bfield, phi)
c 	Interpolate the magnetic field in the poloidal plane

	REAL*8 :: Bfield(:,:)

	B_interp_screen = Bfield(index_interp_screen,1)
     *                    * cos((phi+phase_screen)*n_screen)
     *                    - Bfield(index_interp_screen,2)
     *                    * sin((phi+phase_screen)*n_screen)

	END FUNCTION B_interp_screen

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

	FUNCTION i_still_in_bounds(R, Z)

	REAL*8 :: R, Z

	if((R.lt.R_max_0).and.(R.gt.R_min_0)
     *  .and.(Z.lt.Z_max_0).and.(Z.gt.Z_min_0)) then
	 i_still_in_bounds = 1
	else
	 i_still_in_bounds = 0
	endif

c	WRITE(*,*)'i_still_in_bounds',i_still_in_bounds

	END FUNCTION i_still_in_bounds

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

	FUNCTION dmod_phi(phi)

	REAL*8 :: phi, dmod_phi

	deux_pi = 2*pi

	dmod_phi = dmod(phi, deux_pi)
	if (dmod_phi.lt.0.) then
	 dmod_phi = dmod_phi + deux_pi
	endif

	END FUNCTION dmod_phi

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

	SUBROUTINE one_turn(R, Z, phi, in_wall, in_bounds,
     *  i_direction, n_fl)

        REAL*8 :: R_int(N_phi+1), Z_int(N_phi+1), phi_int(N_phi+1)

c Position of the field line at the beginning of toroidal rotation
c number j
	R_int(1) = R
	Z_int(1) = Z
	phi_int(1) = phi

c i := index of the number of elementary steps
	i = 0

c Loop on elementary toroidal steps.
c Continue unless the field line has made a full toroidal rotation,
c reached the divertor target (or the wall), or reached the boundary of
c the computation domain
	do while (i.le.N_phi-1
     *            .and.(in_wall.eq.0)
     *            .and.(in_bounds.eq.1))

	i = i + 1

	R = R_int(i)
	Z = Z_int(i)
	phi_bis = phi_int(i)

	dphi = i_direction * dphi0

C Advance field line using 4th order Runge-Kutta algorithm
	call runge_kutta(R, Z, phi_bis, dphi, R2, Z2, phi2, in_bounds)

	R_bis = R
	Z_bis = Z

	if (plot_fl.eq.1) then
	 write(102,*) R
	 write(103,*) Z
	 write(104,*) phi_bis
	 write(105,*) n_fl
	endif

	if(in_bounds.eq.0) goto 10

	R_int(i+1) = R2
	Z_int(i+1) = Z2
	phi_int(i+1) = phi2

	call striked_wall(in_wall, R_int(i), Z_int(i),
     *  R2, Z2, phi_int(i), phi2, R_strike, Z_strike,
     *  phi_strike, n_seg_strike)

	in_bounds = i_still_in_bounds(R_int(i+1), Z_int(i+1))
	enddo

c Position of the field line after toroidal rotation number j
	R = R_int(i+1)
	Z = Z_int(i+1)

c If the field line has reached the divertor target (or the wall),
c write its position for magnetic footprint plot
	if (in_wall.eq.1) then
	 if (i_direction.eq.1) then
	  write(51,*) R_strike
	  write(52,*) Z_strike
	  write(53,*) phi_strike
	  write(54,*) n_seg_strike
	 elseif (i_direction.eq.-1) then
	  write(81,*) R_strike
	  write(82,*) Z_strike
	  write(83,*) phi_strike
	  write(84,*) n_seg_strike
	 endif
	endif

   10	RETURN
	END SUBROUTINE one_turn

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

	SUBROUTINE striked_wall(in_wall, R1, Z1, R2, Z2,
     *  phi1, phi2, R_strike, Z_strike, phi_strike, n_seg_strike)

	in_wall = 0

	do i_seg=1,n_segments
	 a = -(Z_div(i_seg,1)-Z_div(i_seg,2))
	 b = (R_div(i_seg,1)-R_div(i_seg,2))
	 c = -(Z1-Z2)
	 d = (R1-R2)
	 e = b*Z_div(i_seg,2) + a*R_div(i_seg,2)
	 f = d*Z2 + c*R2
	 det = a*d - b*c

	 if (det.ne.0.) then
	  R_strike = (1./det)*(e*d-b*f)
	  Z_strike = (1./det)*(a*f-c*e)

	  a2 = (R_strike-R_div(i_seg,1))
     *    *(R_div(i_seg,2)-R_div(i_seg,1))
	  b2 = (Z_strike-Z_div(i_seg,1))
     *    *(Z_div(i_seg,2)-Z_div(i_seg,1))

	  scalar_test1 = a2 + b2
	  scalar_ref1 = (R_div(i_seg,2)-R_div(i_seg,1))**2.
     *    + (Z_div(i_seg,2)-Z_div(i_seg,1))**2.

	  scalar_test2 = (R_strike-R1)*(R2-R1)
     *    + (Z_strike-Z1)*(Z2-Z1)
	  scalar_ref2 = (R2-R1)**2. + (Z2-Z1)**2.

	  if ((0..le.scalar_test1).and.
     *    (scalar_test1.le.scalar_ref1)
     *    .and.(scalar_test2.ge.0.).and.
     *    (scalar_test2.le.scalar_ref2)) then
	    in_wall = 1
	    n_seg_strike = i_seg
c To adapt to cases where phi2 and phi1 are separated by almost 2pi.
c This is not rigorously coded but it should work.
	  dphi_loc = phi2 - phi1
	  if (abs(dphi_loc).gt.1.) then
	   if (dphi_loc.gt.0.) then
	    dphi_loc = dphi_loc - 2*pi
	   else
	    dphi_loc = dphi_loc + 2*pi
	   endif
	  endif
	    phi_strike = phi1 + dphi_loc*(Z_strike-Z1)/(Z2-Z1)
c	    phi_strike = phi1 + (phi2-phi1)*(Z_strike-Z1)/(Z2-Z1)
	    goto 10
	  endif
	 endif

	enddo

   10	RETURN
	END SUBROUTINE striked_wall

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

	END PROGRAM poincare_footprint


program hmipt_matsuara_dmft_g0
  USE DMFT_IPT
  USE IOTOOLS
  USE ERROR
  implicit none
  logical                :: converged,check
  real(8)                :: n,z
  integer                :: i,iloop
  complex(8)             :: zeta
  complex(8),allocatable :: fg(:),fg0(:),sigma(:),GFold(:)
  real(8),allocatable    :: wm(:),sigt(:)
  real(8) :: C0,C1,n0

  call read_input("inputIPT.in")

  !allocate functions:
  allocate(fg(L))
  allocate(sigma(L))
  allocate(fg0(L))
  allocate(sigt(0:L))

  !build freq. array
  allocate(wm(L))
  wm(:)  = pi/beta*real(2*arange(1,L)-1,8)

  !set the energy scale:
  D=2.d0*ts

  !get or read first sigma
  call  get_initial_weiss_field(fg0,"g0.restart")
  call splot("guessG0_iw.ipt",wm,fg0)

  !dmft loop:
  iloop=0 ; converged=.false.
  do while(.not.converged.AND.iloop<nloop)
     iloop=iloop+1
     write(*,"(A,i5)",advance="no")"DMFT-loop",iloop
     !IMPURITY SOLVER
     sigma= solve_ipt_matsubara(fg0)
     !
     sigma=xi*dimag(sigma)!ACTHUNG
     !
     !SELF-CONSISTENCY:
     do i=1,L
        zeta  = xi*wm(i) - sigma(i)
        fg(i) = gfbethe(wm(i),zeta,D)
     enddo
     n   = get_local_density(fg,beta)
     !update weiss-field:
     fg0 = one/(one/fg + sigma)
     !if(iloop>1)fg0 = weight*fg0 + (1.d0-weight)*GFold
     !
     converged=check_convergence(fg0,dmft_error,nsuccess,nloop)
     !GET OBSERVABLES
     z=1.d0 - dimag(sigma(1))/wm(1);z=1.d0/z
     call splot("observables_all.ipt",iloop,beta,xmu,u,z,n,append=.true.)
  enddo
  call splot("G_iw.ipt",wm,fg)
  call splot("G0_iw.ipt",wm,fg0)
  call splot("Sigma_iw.ipt",wm,sigma)
  call splot("observables.ipt",iloop,u,beta,xmu,z,n)

  n0=n/2.d0
  C0=U*(n0-0.5d0)
  C1=U**2*n0*(1.d0-n0)
  print*,n0,C0,C1
  sigma=sigma- C0 - C1/(xi*wm)
  call fftgf_iw2tau(sigma,sigt(0:),beta,notail=.true.)
  sigt=sigt-C1*0.5d0
  open(100,file="fft_sigma_iw.ipt")
  do i=0,L
     write(100,*)i*beta/dble(L),sigt(i)
  enddo
  close(100)

contains

  subroutine get_initial_weiss_field(self,file)
    complex(8),dimension(:)       :: self
    real(8),dimension(size(self)) :: wm_
    character(len=*)              :: file
    logical                       :: check
    inquire(file=file,exist=check)
    if(check)then
       print*,'Reading G0'
       call sread(file,wm_,self)
    else
       print*,"Using non-interacting GF as guess:"
       call bethe_guess_g0(self,D,beta,0.d0)
    endif
  end subroutine get_initial_weiss_field

end program hmipt_matsuara_dmft_g0


*> \brief \b SLAR2V applies a vector of plane rotations with real cosines and real sines from both sides to a sequence of 2-by-2 symmetric/Hermitian matrices.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLAR2V + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SLAR2V( N, X, Y, Z, INCX, C, S, INCC )
*
*       .. Scalar Arguments ..
*       INTEGER            INCC, INCX, N
*       ..
*       .. Array Arguments ..
*       REAL               C( * ), S( * ), X( * ), Y( * ), Z( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SLAR2V applies a vector of real plane rotations from both sides to
*> a sequence of 2-by-2 real symmetric matrices, defined by the elements
*> of the vectors x, y and z. For i = 1,2,...,n
*>
*>    ( x(i)  z(i) ) := (  c(i)  s(i) ) ( x(i)  z(i) ) ( c(i) -s(i) )
*>    ( z(i)  y(i) )    ( -s(i)  c(i) ) ( z(i)  y(i) ) ( s(i)  c(i) )
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of plane rotations to be applied.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*>          X is REAL array,
*>                         dimension (1+(N-1)*INCX)
*>          The vector x.
*> \endverbatim
*>
*> \param[in,out] Y
*> \verbatim
*>          Y is REAL array,
*>                         dimension (1+(N-1)*INCX)
*>          The vector y.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*>          Z is REAL array,
*>                         dimension (1+(N-1)*INCX)
*>          The vector z.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*>          INCX is INTEGER
*>          The increment between elements of X, Y and Z. INCX > 0.
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*>          C is REAL array, dimension (1+(N-1)*INCC)
*>          The cosines of the plane rotations.
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*>          S is REAL array, dimension (1+(N-1)*INCC)
*>          The sines of the plane rotations.
*> \endverbatim
*>
*> \param[in] INCC
*> \verbatim
*>          INCC is INTEGER
*>          The increment between elements of C and S. INCC > 0.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup realOTHERauxiliary
*
*  =====================================================================
      SUBROUTINE SLAR2V( N, X, Y, Z, INCX, C, S, INCC )
*
*  -- LAPACK auxiliary routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. Scalar Arguments ..
      INTEGER            INCC, INCX, N
*     ..
*     .. Array Arguments ..
      REAL               C( * ), S( * ), X( * ), Y( * ), Z( * )
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, IC, IX
      REAL               CI, SI, T1, T2, T3, T4, T5, T6, XI, YI, ZI
*     ..
*     .. Executable Statements ..
*
      IX = 1
      IC = 1
      DO 10 I = 1, N
         XI = X( IX )
         YI = Y( IX )
         ZI = Z( IX )
         CI = C( IC )
         SI = S( IC )
         T1 = SI*ZI
         T2 = CI*ZI
         T3 = T2 - SI*XI
         T4 = T2 + SI*YI
         T5 = CI*XI + T1
         T6 = CI*YI - T1
         X( IX ) = CI*T5 + SI*T4
         Y( IX ) = CI*T6 - SI*T3
         Z( IX ) = CI*T4 - SI*T5
         IX = IX + INCX
         IC = IC + INCC
   10 CONTINUE
*
*     End of SLAR2V
*
      RETURN
      END


SUBROUTINE BlochMessiah(dim,U,V,u_can,v_can,D,C,V_new, STAT)
  USE PRECISION
  IMPLICIT NONE

  ! dim should be an even number

  INTEGER,                             INTENT(IN)  :: dim
  COMPLEX(DP), DIMENSION(1:dim,1:dim), INTENT(IN)  :: U, V
  REAL(DP),    DIMENSION(1:dim/2),     INTENT(OUT) :: u_can, v_can
  COMPLEX(DP), DIMENSION(1:dim,1:dim), INTENT(OUT) :: D, C, V_new

  INTEGER,                             INTENT(OUT) :: STAT

  COMPLEX(DP), DIMENSION(1:dim,1:dim) :: Ud, UUd, UUdvec, UdU, UdUvec, Ubarinv, Vbarinv
  REAL(DP), DIMENSION(1:dim) :: UUdEV, UdUEV
  REAL(DP),    DIMENSION(1:dim,1:dim)  :: Ubar, Vbar
  COMPLEX(DP), DIMENSION(1:dim,1:dim) :: U_check, V_check, Check, D2

  INTEGER :: i, j,k

  REAL(DP) :: eps = 1.0D-8

  STOP "BLOCH MESSIAH under construction"

  ! dimension check
  IF( MOD(dim,2) .NE. 0 ) THEN
     WRITE(0,*) "BlochMessiah: dimension not 2M. exiting"
     STAT = -2
     RETURN
  END IF

  U_can(1:dim/2) = 0.0D0
  V_can(1:dim/2) = 0.0D0
  D(1:dim,1:dim) = (0.0D0,0.0D0)
  D2(1:dim,1:dim) = (0.0D0,0.0D0)
  C(1:dim,1:dim) = (0.0D0,0.0D0)
  UUdEV(1:dim)   = 0.0D0

  Ubar(1:dim,1:dim) = 0.0D0
  Vbar(1:dim,1:dim) = 0.0D0
  U_check(1:dim,1:dim) = 0.0D0
  V_check(1:dim,1:dim) = 0.0D0

  CALL UVUnitarityCheck(dim, U, V, STAT)
  IF (STAT .NE. 0) THEN
!     WRITE(0,*) "BlochMessiah: UV unitarity bad!"
!     RETURN
  END IF

  Ud (1:dim,1:dim) = TRANSPOSE(CONJG(U(1:dim,1:dim)))        ! U^+
  UUd(1:dim,1:dim) = MATMUL(U(1:dim,1:dim), Ud(1:dim,1:dim)) ! U U^+ = D Ubar^2 D^+
  UdU(1:dim,1:dim) = MATMUL(Ud(1:dim,1:dim), U(1:dim,1:dim)) ! U^+ U = C^+ Ubar^2 C

  CALL HermiteCheck(dim, UUd, STAT)
  IF (STAT .NE. 0) THEN
     WRITE(0,*) "BlochMessiah: UU+ not hermite"
  END IF
  CALL HermiteCheck(dim, UdU, STAT)
  IF (STAT .NE. 0) THEN
     WRITE(0,*) "BlochMessiah: U+U not hermite"
  END IF

  CALL EIGEN_ZHEEV(dim, UUd, UUdvec, UUdEV, STAT) ! UUdvec = D !
  IF (STAT .NE. 0) THEN
     WRITE(0,*) "BlochMessiah: UU+ diagonalization failed"
  END IF
  CALL EIGEN_ZHEEV(dim, UdU, UdUvec, UdUEV, STAT)
  IF (STAT .NE. 0) THEN
     WRITE(0,*) "BlochMessiah: U+U diagonalization failed"
  END IF

  ! CHECK diagonalization is performed correctly
  CHECK(1:dim,1:dim) = 0.0D0
  DO i = 1, dim
  DO j = 1, dim
  DO k = 1, dim
     CHECK(i,j) = CHECK(i,j) + UUdvec(i,k)*UUdEV(k)*CONJG(UUdvec(j,k))  !+ CONJG(UUdvec(k,i))*UUdEV(k)*UUdvec(k,j)
  END DO
  END DO
  END DO

  DO i = 1, dim
  DO j = 1, dim
     IF( ABS(CHECK(i,j) - UUd(i,j)) .GT. 1.0D-8) THEN
        PRINT *, i, j, UUd(i,j), CHECK(i,j)
     END IF
  END DO
  END DO
!  STOP "DEBUG"
  DO i = 1, dim/2
     ! All eigenvalue must be paired
     IF(ABS(UUdEV(2*i-1)-UUdEV(2*i)) .GT. 1.0D-10) THEN
        WRITE(0,*) "BlochMessiah: Ubar from UU+ wrong"
        WRITE(0,*) "u_i", UUdEV(2*i-1), UUdEV(2*i)
        STAT = -10
        RETURN
     END IF

     IF(ABS(UdUEV(2*i-1)-UdUEV(2*i)) .GT. 1.0D-10) THEN
        WRITE(0,*) "BlochMessiah: Ubar from U+U wrong"
        WRITE(0,*) "u_i", UdUEV(2*i-1), UdUEV(2*i)
        STAT = -20
        RETURN
     END IF

     ! And the eigenvalue from UU+ and U+U should be the same
     IF(ABS(UUdEV(2*i-1)-UdUEV(2*i-1)) .GT. 1.0D-10) THEN
        WRITE(0,*) "BlochMessiah: Ubar from U+U and UU+ do not agree"
        WRITE(0,*) "u_i", UUdEV(2*i-1), UdUEV(2*i-1)
        STAT = -25
        RETURN
     END IF

     ! eigenvalue range u_i =< 1
     IF( UUdEV(2*i-1) .GT. 1.0D0+1.0D-8) THEN
        WRITE(0,*) "BlochMessiah: u_i from UU+ larger than 1"
        WRITE(0,*) "u_i", UUdEV(2*i-1)
        STAT = -30
        RETURN
     END IF
     IF( UdUEV(2*i-1) .GT. 1.0D0+1.0D-8) THEN
        WRITE(0,*) "BlochMessiah: u_i from U+U larger than 1"
        WRITE(0,*) "u_i", UdUEV(2*i-1)
        STAT = -40
        RETURN
     END IF

     ! remove numerical error
     IF( UUdEV(2*i-1) .GT. 1.0D0 - eps .OR. UUdEV(2*i) .GT. 1.0D0 - eps) THEN
        UUdEV(2*i-1) = 1.0D0 - eps**2
        UUdEV(2*i)   = 1.0D0 - eps**2
     END IF
     IF( UdUEV(2*i-1) .GT. 1.0D0 - eps .OR. UdUEV(2*i) .GT. 1.0D0 - eps ) THEN
        UdUEV(2*i-1) = 1.0D0 - eps**2
        UdUEV(2*i)   = 1.0D0 - eps**2
     END IF

     ! eigenvalue range u_i >= 0
     IF( UUdEV(2*i-1) .LT. -1.0D-8) THEN
        WRITE(0,*) "BlochMessiah: u_i from UU+ smaller than 0"
        WRITE(0,*) "u_i", UUdEV(2*i-1)
        STAT = -50
        RETURN
     END IF
     IF( UdUEV(2*i-1) .LT. -1.0D-8) THEN
        WRITE(0,*) "BlochMessiah: u_i from U+U smaller than 0"
        WRITE(0,*) "u_i", UdUEV(2*i-1)
        STAT = -60
        RETURN
     END IF

     ! remove numerical error
     IF( UUdEV(2*i-1) .LT. eps .OR. UUdEV(2*i) .LT. eps ) THEN
        UUdEV(2*i-1) = eps**2
        UUdEV(2*i)   = eps**2
     END IF
     IF( UdUEV(2*i-1) .LT. eps .OR. UdUEV(2*i) .LT. eps ) THEN
        UdUEV(2*i-1) = eps**2
        UdUEV(2*i)   = eps**2
     END IF

     u_can(i) = SQRT(UUdEV(2*i))
     v_can(i) = SQRT(1.0D0 - UUdEV(2*i))
     PRINT *, "i = ", i, u_can(i), v_can(i)

     Ubar(2*i-1,2*i-1) =  SQRT(UUdEV(2*i))
     Ubar(2*i,2*i)     =  SQRT(UUdEV(2*i))
     Vbar(2*i-1,2*i)   =  SQRT(1.0D0-UUdEV(2*i))
     Vbar(2*i,2*i-1)   = -SQRT(1.0D0-UUdEV(2*i))

  END DO

  PRINT *, "summation over the states"
  PRINT *, " u_i^2      : ", SUM(u_can(1:dim/2)**2)
  PRINT *, " v_i^2      : ", SUM(v_can(1:dim/2)**2)
  PRINT *, " u_i^2+v_i^2: ", SUM(u_can(1:dim/2)**2+v_can(1:dim/2)**2)

  D2(1:dim,1:dim) = UUdvec(1:dim,1:dim)
  !  C(1:dim,1:dim) = UdUvec(1:dim,1:dim)

  Ubarinv(1:dim,1:dim) = 0.0D0
  DO i = 1, dim
     PRINT *, "u_can ", i, Ubar(i,i), Vbar(i,i+1)
     Ubarinv(i,i) = Ubar(i,i)**(-1)
  END DO

  C(1:dim,1:dim) = MATMUL( Ubarinv(1:dim,1:dim), MATMUL( CONJG(TRANSPOSE(D2(1:dim,1:dim))), U(1:dim,1:dim)))

  ! Unitarity check
  Check(1:dim,1:dim) = MATMUL( TRANSPOSE(CONJG(C(1:dim,1:dim))), C(1:dim,1:dim))
  PRINT *, "Unitarity check of C"
  DO i = 1, dim
  DO j = 1, dim
     IF( i .EQ. j .AND. ABS(Check(i,j)-1.0D0) .GT. 1.0D-7) THEN
        PRINT *, i, j, Check(i,j)
     END IF
     IF( i .NE. j .AND. ABS(Check(i,j)) .GT. 1.0D-7) THEN
        PRINT *, i, j, Check(i,j)
     END IF
  END DO
  END DO

  Check(1:dim,1:dim) = MATMUL( TRANSPOSE(CONJG(D2(1:dim,1:dim))), D2(1:dim,1:dim))
  PRINT *, "Unitarity check of D"
  DO i = 1, dim
  DO j = 1, dim
     IF( i .EQ. j .AND. ABS(Check(i,j)-1.0D0) .GT. 1.0D-8) THEN
        PRINT *, i, j, Check(i,j)
     END IF
     IF( i .NE. j .AND. ABS(Check(i,j)) .GT. 1.0D-8) THEN
        PRINT *, i, j, Check(i,j)
     END IF
  END DO
  END DO

!  Vbarinv(1:dim,1:dim) = 0.0D0
!  DO i = 1, dim/2
!     Vbarinv(2*i-1,2*i) =  Vbar(2*i,2*i-1)**(-1)
!     Vbarinv(2*i,2*i-1) =  Vbar(2*i-1,2*i)**(-1)
!  END DO

  ! calc V part

  Vbar(1:dim,1:dim) = 0.0D0

  Vbar(1:dim,1:dim) = MATMUL( TRANSPOSE(D2(1:dim,1:dim)), MATMUL( V(1:dim,1:dim), CONJG(TRANSPOSE(C(1:dim,1:dim)))))

  !CHECK Vbarinv
  PRINT *, "Vbar from D and C of U"

  DO i = 1, dim
  DO j = 1, dim
     IF( ABS(Vbar(i,j)) .GT. 1.0D-10) PRINT *, i, j, Vbar(i,j)
  END DO
END DO

  Check(1:dim,1:dim) = MATMUL( Vbar(1:dim,1:dim), Vbarinv(1:dim,1:dim))
  PRINT *, "Orthogonality check of Vbar Vbar^{-1}"
  DO i = 1, dim
  DO j = 1, dim
     IF( i .EQ. j .AND. ABS(Check(i,j)-1.0D0) .GT. 1.0D-8) THEN
        PRINT *, i, j, Check(i,j)
     END IF
     IF( i .NE. j .AND. ABS(Check(i,j)) .GT. 1.0D-8) THEN
        PRINT *, i, j, Check(i,j)
     END IF
  END DO
  END DO

!  D(1:dim,1:dim) = CONJG( MATMUL( V(1:dim,1:dim), &
!       & MATMUL( CONJG(TRANSPOSE(C(1:dim,1:dim))), Vbarinv(1:dim,1:dim))))
  D = D2
  Check(1:dim,1:dim) = MATMUL( TRANSPOSE(CONJG(D(1:dim,1:dim))), D(1:dim,1:dim))
  PRINT *, "Unitarity check of D new"
  DO i = 1, dim
  DO j = 1, dim
     IF( i .EQ. j .AND. ABS(Check(i,j)-1.0D0) .GT. 1.0D-8) THEN
        PRINT *, i, j, Check(i,j)
     END IF
     IF( i .NE. j .AND. ABS(Check(i,j)) .GT. 1.0D-8) THEN
        PRINT *, i, j, Check(i,j)
     END IF
  END DO
  END DO

!  PRINT *, "Dmat"
!  DO i = 1, 8
!     WRITE(*,'(8ES15.5)') (ABS(D(i,j)), j = 1, 8)
!  END DO
!  PRINT *, "D2mat"
!  DO i = 1, 8
!     WRITE(*,'(8ES15.5)') (ABS(D2(i,j)), j = 1, 8)
!  END DO
  !  PRINT *, "Cmat"
!  DO i = 1, 4
!     WRITE(*,'(8ES15.5)') (C(i,j), j = 1, 4)
!  END DO
!  PRINT *, "Ubar"
!  DO i = 1, 8
!     WRITE(*,'(8ES15.5)') (Ubar(i,j), j = 1, 8)
!  END DO
!  PRINT *, "Vbar"
!  DO i = 1, 8
!     WRITE(*,'(8ES15.5)') (Vbar(i,j), j = 1, 8)
!  END DO
!  PRINT *, "U"
!  DO i = 1, 8
!     WRITE(*,'(8ES15.5)') (U(i,j), j = 1, 8)
!  END DO
!  PRINT *, "V"
!  DO i = 1, 8
!     WRITE(*,'(8ES15.5)') (V(i,j), j = 1, 8)
!  END DO

  ! check U and V from the Bloch-Messiah decomposition

  U_check(1:dim,1:dim) = MATMUL(       D(1:dim,1:dim),  MATMUL( Ubar(1:dim,1:dim), C(1:dim,1:dim)) )
  V_check(1:dim,1:dim) = MATMUL( CONJG(D(1:dim,1:dim)), MATMUL( Vbar(1:dim,1:dim), C(1:dim,1:dim)) )
  V_new(1:dim,1:dim) = V_check(1:dim,1:dim)

  PRINT *, "CHECKING U matrix from Bloch-Messiah"
  DO i = 1, dim
  DO j = 1, dim
     IF( ABS(U_check(i,j)  - U(i,j)) .GT. 1.0D-10) THEN
        PRINT *, i, j, U(i,j), U_check(i,j)
     END IF
  END DO
  END DO
  PRINT *, "CHECKING V matrix from Bloch-Messiah -always failed"
  DO i = 1, dim
  DO j = 1, dim
     IF( ABS(V_check(i,j)  - V(i,j)) .GT. 1.0D-8) THEN
        PRINT *, i, j, V(i,j), V_check(i,j)
     END IF
  END DO
  END DO

!  PRINT *, "UV unitarity check1"
!  CALL UVUnitarityCheck(dim, U, V, STAT)
!  PRINT *, "UV unitarity check2"
!  CALL UVUnitarityCheck(dim, U, V_check, STAT)
!  PRINT *, "UV unitarity check3"
!  CALL UVUnitarityCheck(dim, U_check, V, STAT)
  PRINT *, "UV unitarity check4"
  CALL UVUnitarityCheck(dim, U_check, V_check, STAT)
  PRINT *, "Check done: STAT = ", STAT

  PRINT *, "END SUBROUTINE Bloch-Messiah"
  RETURN

END SUBROUTINE BlochMessiah


*> \brief \b SLAVSY
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SLAVSY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
*                          LDB, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          DIAG, TRANS, UPLO
*       INTEGER            INFO, LDA, LDB, N, NRHS
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * )
*       REAL               A( LDA, * ), B( LDB, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SLAVSY  performs one of the matrix-vector operations
*>    x := A*x  or  x := A'*x,
*> where x is an N element vector and A is one of the factors
*> from the block U*D*U' or L*D*L' factorization computed by SSYTRF.
*>
*> If TRANS = 'N', multiplies by U  or U * D  (or L  or L * D)
*> If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L')
*> If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L')
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          Specifies whether the factor stored in A is upper or lower
*>          triangular.
*>          = 'U':  Upper triangular
*>          = 'L':  Lower triangular
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*>          TRANS is CHARACTER*1
*>          Specifies the operation to be performed:
*>          = 'N':  x := A*x
*>          = 'T':  x := A'*x
*>          = 'C':  x := A'*x
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*>          DIAG is CHARACTER*1
*>          Specifies whether or not the diagonal blocks are unit
*>          matrices.  If the diagonal blocks are assumed to be unit,
*>          then A = U or A = L, otherwise A = U*D or A = L*D.
*>          = 'U':  Diagonal blocks are assumed to be unit matrices.
*>          = 'N':  Diagonal blocks are assumed to be non-unit matrices.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of rows and columns of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of vectors
*>          x to be multiplied by A.  NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          The block diagonal matrix D and the multipliers used to
*>          obtain the factor U or L as computed by SSYTRF.
*>          Stored as a 2-D triangular matrix.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (N)
*>          Details of the interchanges and the block structure of D,
*>          as determined by SSYTRF.
*>
*>          If UPLO = 'U':
*>               If IPIV(k) > 0, then rows and columns k and IPIV(k)
*>               were interchanged and D(k,k) is a 1-by-1 diagonal block.
*>               (If IPIV( k ) = k, no interchange was done).
*>
*>               If IPIV(k) = IPIV(k-1) < 0, then rows and
*>               columns k-1 and -IPIV(k) were interchanged,
*>               D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
*>
*>          If UPLO = 'L':
*>               If IPIV(k) > 0, then rows and columns k and IPIV(k)
*>               were interchanged and D(k,k) is a 1-by-1 diagonal block.
*>               (If IPIV( k ) = k, no interchange was done).
*>
*>               If IPIV(k) = IPIV(k+1) < 0, then rows and
*>               columns k+1 and -IPIV(k) were interchanged,
*>               D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is REAL array, dimension (LDB,NRHS)
*>          On entry, B contains NRHS vectors of length N.
*>          On exit, B is overwritten with the product A * B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0: successful exit
*>          < 0: if INFO = -k, the k-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2013
*
*> \ingroup single_lin
*
*  =====================================================================
      SUBROUTINE SLAVSY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
     $                   LDB, INFO )
*
*  -- LAPACK test routine (version 3.5.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2013
*
*     .. Scalar Arguments ..
      CHARACTER          DIAG, TRANS, UPLO
      INTEGER            INFO, LDA, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      REAL               A( LDA, * ), B( LDB, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE
      PARAMETER          ( ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOUNIT
      INTEGER            J, K, KP
      REAL               D11, D12, D21, D22, T1, T2
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           SGEMV, SGER, SSCAL, SSWAP, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
     $         LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.LSAME( DIAG, 'U' ) .AND. .NOT.LSAME( DIAG, 'N' ) )
     $          THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SLAVSY ', -INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( N.EQ.0 )
     $   RETURN
*
      NOUNIT = LSAME( DIAG, 'N' )
*------------------------------------------
*
*     Compute  B := A * B  (No transpose)
*
*------------------------------------------
      IF( LSAME( TRANS, 'N' ) ) THEN
*
*        Compute  B := U*B
*        where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
*
         IF( LSAME( UPLO, 'U' ) ) THEN
*
*        Loop forward applying the transformations.
*
            K = 1
   10       CONTINUE
            IF( K.GT.N )
     $         GO TO 30
            IF( IPIV( K ).GT.0 ) THEN
*
*              1 x 1 pivot block
*
*              Multiply by the diagonal element if forming U * D.
*
               IF( NOUNIT )
     $            CALL SSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
*
*              Multiply by  P(K) * inv(U(K))  if K > 1.
*
               IF( K.GT.1 ) THEN
*
*                 Apply the transformation.
*
                  CALL SGER( K-1, NRHS, ONE, A( 1, K ), 1, B( K, 1 ),
     $                       LDB, B( 1, 1 ), LDB )
*
*                 Interchange if P(K) .ne. I.
*
                  KP = IPIV( K )
                  IF( KP.NE.K )
     $               CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
               END IF
               K = K + 1
            ELSE
*
*              2 x 2 pivot block
*
*              Multiply by the diagonal block if forming U * D.
*
               IF( NOUNIT ) THEN
                  D11 = A( K, K )
                  D22 = A( K+1, K+1 )
                  D12 = A( K, K+1 )
                  D21 = D12
                  DO 20 J = 1, NRHS
                     T1 = B( K, J )
                     T2 = B( K+1, J )
                     B( K, J ) = D11*T1 + D12*T2
                     B( K+1, J ) = D21*T1 + D22*T2
   20             CONTINUE
               END IF
*
*              Multiply by  P(K) * inv(U(K))  if K > 1.
*
               IF( K.GT.1 ) THEN
*
*                 Apply the transformations.
*
                  CALL SGER( K-1, NRHS, ONE, A( 1, K ), 1, B( K, 1 ),
     $                       LDB, B( 1, 1 ), LDB )
                  CALL SGER( K-1, NRHS, ONE, A( 1, K+1 ), 1,
     $                       B( K+1, 1 ), LDB, B( 1, 1 ), LDB )
*
*                 Interchange if P(K) .ne. I.
*
                  KP = ABS( IPIV( K ) )
                  IF( KP.NE.K )
     $               CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
               END IF
               K = K + 2
            END IF
            GO TO 10
   30       CONTINUE
*
*        Compute  B := L*B
*        where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) .
*
         ELSE
*
*           Loop backward applying the transformations to B.
*
            K = N
   40       CONTINUE
            IF( K.LT.1 )
     $         GO TO 60
*
*           Test the pivot index.  If greater than zero, a 1 x 1
*           pivot was used, otherwise a 2 x 2 pivot was used.
*
            IF( IPIV( K ).GT.0 ) THEN
*
*              1 x 1 pivot block:
*
*              Multiply by the diagonal element if forming L * D.
*
               IF( NOUNIT )
     $            CALL SSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
*
*              Multiply by  P(K) * inv(L(K))  if K < N.
*
               IF( K.NE.N ) THEN
                  KP = IPIV( K )
*
*                 Apply the transformation.
*
                  CALL SGER( N-K, NRHS, ONE, A( K+1, K ), 1, B( K, 1 ),
     $                       LDB, B( K+1, 1 ), LDB )
*
*                 Interchange if a permutation was applied at the
*                 K-th step of the factorization.
*
                  IF( KP.NE.K )
     $               CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
               END IF
               K = K - 1
*
            ELSE
*
*              2 x 2 pivot block:
*
*              Multiply by the diagonal block if forming L * D.
*
               IF( NOUNIT ) THEN
                  D11 = A( K-1, K-1 )
                  D22 = A( K, K )
                  D21 = A( K, K-1 )
                  D12 = D21
                  DO 50 J = 1, NRHS
                     T1 = B( K-1, J )
                     T2 = B( K, J )
                     B( K-1, J ) = D11*T1 + D12*T2
                     B( K, J ) = D21*T1 + D22*T2
   50             CONTINUE
               END IF
*
*              Multiply by  P(K) * inv(L(K))  if K < N.
*
               IF( K.NE.N ) THEN
*
*                 Apply the transformation.
*
                  CALL SGER( N-K, NRHS, ONE, A( K+1, K ), 1, B( K, 1 ),
     $                       LDB, B( K+1, 1 ), LDB )
                  CALL SGER( N-K, NRHS, ONE, A( K+1, K-1 ), 1,
     $                       B( K-1, 1 ), LDB, B( K+1, 1 ), LDB )
*
*                 Interchange if a permutation was applied at the
*                 K-th step of the factorization.
*
                  KP = ABS( IPIV( K ) )
                  IF( KP.NE.K )
     $               CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
               END IF
               K = K - 2
            END IF
            GO TO 40
   60       CONTINUE
         END IF
*----------------------------------------
*
*     Compute  B := A' * B  (transpose)
*
*----------------------------------------
      ELSE
*
*        Form  B := U'*B
*        where U  = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
*        and   U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m)
*
         IF( LSAME( UPLO, 'U' ) ) THEN
*
*           Loop backward applying the transformations.
*
            K = N
   70       CONTINUE
            IF( K.LT.1 )
     $         GO TO 90
*
*           1 x 1 pivot block.
*
            IF( IPIV( K ).GT.0 ) THEN
               IF( K.GT.1 ) THEN
*
*                 Interchange if P(K) .ne. I.
*
                  KP = IPIV( K )
                  IF( KP.NE.K )
     $               CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
*                 Apply the transformation
*
                  CALL SGEMV( 'Transpose', K-1, NRHS, ONE, B, LDB,
     $                        A( 1, K ), 1, ONE, B( K, 1 ), LDB )
               END IF
               IF( NOUNIT )
     $            CALL SSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
               K = K - 1
*
*           2 x 2 pivot block.
*
            ELSE
               IF( K.GT.2 ) THEN
*
*                 Interchange if P(K) .ne. I.
*
                  KP = ABS( IPIV( K ) )
                  IF( KP.NE.K-1 )
     $               CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ),
     $                           LDB )
*
*                 Apply the transformations
*
                  CALL SGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB,
     $                        A( 1, K ), 1, ONE, B( K, 1 ), LDB )
                  CALL SGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB,
     $                        A( 1, K-1 ), 1, ONE, B( K-1, 1 ), LDB )
               END IF
*
*              Multiply by the diagonal block if non-unit.
*
               IF( NOUNIT ) THEN
                  D11 = A( K-1, K-1 )
                  D22 = A( K, K )
                  D12 = A( K-1, K )
                  D21 = D12
                  DO 80 J = 1, NRHS
                     T1 = B( K-1, J )
                     T2 = B( K, J )
                     B( K-1, J ) = D11*T1 + D12*T2
                     B( K, J ) = D21*T1 + D22*T2
   80             CONTINUE
               END IF
               K = K - 2
            END IF
            GO TO 70
   90       CONTINUE
*
*        Form  B := L'*B
*        where L  = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
*        and   L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1)
*
         ELSE
*
*           Loop forward applying the L-transformations.
*
            K = 1
  100       CONTINUE
            IF( K.GT.N )
     $         GO TO 120
*
*           1 x 1 pivot block
*
            IF( IPIV( K ).GT.0 ) THEN
               IF( K.LT.N ) THEN
*
*                 Interchange if P(K) .ne. I.
*
                  KP = IPIV( K )
                  IF( KP.NE.K )
     $               CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
*                 Apply the transformation
*
                  CALL SGEMV( 'Transpose', N-K, NRHS, ONE, B( K+1, 1 ),
     $                        LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
               END IF
               IF( NOUNIT )
     $            CALL SSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
               K = K + 1
*
*           2 x 2 pivot block.
*
            ELSE
               IF( K.LT.N-1 ) THEN
*
*              Interchange if P(K) .ne. I.
*
                  KP = ABS( IPIV( K ) )
                  IF( KP.NE.K+1 )
     $               CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ),
     $                           LDB )
*
*                 Apply the transformation
*
                  CALL SGEMV( 'Transpose', N-K-1, NRHS, ONE,
     $                        B( K+2, 1 ), LDB, A( K+2, K+1 ), 1, ONE,
     $                        B( K+1, 1 ), LDB )
                  CALL SGEMV( 'Transpose', N-K-1, NRHS, ONE,
     $                        B( K+2, 1 ), LDB, A( K+2, K ), 1, ONE,
     $                        B( K, 1 ), LDB )
               END IF
*
*              Multiply by the diagonal block if non-unit.
*
               IF( NOUNIT ) THEN
                  D11 = A( K, K )
                  D22 = A( K+1, K+1 )
                  D21 = A( K+1, K )
                  D12 = D21
                  DO 110 J = 1, NRHS
                     T1 = B( K, J )
                     T2 = B( K+1, J )
                     B( K, J ) = D11*T1 + D12*T2
                     B( K+1, J ) = D21*T1 + D22*T2
  110             CONTINUE
               END IF
               K = K + 2
            END IF
            GO TO 100
  120       CONTINUE
         END IF
*
      END IF
      RETURN
*
*     End of SLAVSY
*
      END


      INTEGER FUNCTION CEILNG (X)

C  CEILNG returns the integer ceiling for x, i.e. the lowest
C  integer .ge. x

      INTEGER    IX
      REAL       X

      IX = INT(X)
      IF (REAL(IX).EQ.X .OR. X.LE.0) THEN
         CEILNG = IX
      ELSE
         CEILNG = IX + 1
      ENDIF

      END


      program prog
      do i=-1,1
        do j=-1,1
          write(6, *) i, j, sign(i, j)
        enddo
      enddo
      write(6, *) dsign(-1.d0, 1.d0)
      end


program life

  ! Game of life program using MPI and a one-dimensional domain
  ! decomposition in the x-direction.

  ! The program checks that a decomposition is possible on the
  ! current number of MPI tasks as a first step.

  use mpi
  implicit none

  ! imtot and jmtot are the global system size in each direction
  ! im and jm are the local system size per MPI rank

  integer, parameter :: imtot = 16
  integer, parameter :: jmtot = 16
  integer, parameter :: nsteps = 12

  integer :: im, jm
  integer :: imp1, jmp1
  integer :: i, j
  integer :: n
  integer :: nc, np, tmp
  integer :: live, lcount, ncount

  ! System state

  logical, parameter :: periodic = .true.
  logical, allocatable, dimension(:, :, :) :: state

  ! send buffers for x-direction (left and right going) messages
  ! recv buffers for x-direction (lelft and right) messages

  logical, allocatable, dimension(:) :: sxl, sxr
  logical, allocatable, dimension(:) :: rxl, rxr

  ! MPI variables

  integer :: ifail
  integer :: rank, size

  integer :: comm
  integer :: my_left, my_right

  ! For 1-dimensional decomposition:

  integer, parameter :: ndims = 1
  integer, dimension(ndims) :: dims
  integer, dimension(ndims) :: mycoords
  logical, dimension(ndims) :: periods

  ! MPI messages
  integer, parameter :: my_tagl = 9999
  integer, parameter :: my_tagr = 9998
  integer, dimension(4) :: req
  integer, dimension(MPI_STATUS_SIZE, 4) :: status

  call mpi_init(ifail)
  call mpi_comm_rank(MPI_COMM_WORLD, rank, ifail)
  call mpi_comm_size(MPI_COMM_WORLD, size, ifail)

  ! If a decomposition is possible, use a Cartesian communicator,
  ! and work out relevant ranks in the new communicator

  if (mod(imtot, size) /= 0) then
     write (unit = *, fmt = *) &
     'Number of points not exactly divisible by number of MPI tasks'
     call mpi_abort(MPI_COMM_WORLD, -1, ifail)
  end if

  periods(:) = periodic

  call mpi_dims_create(size, ndims, dims, ifail)
  call mpi_cart_create(MPI_COMM_WORLD, ndims, dims, periods, .true., comm, ifail)

  call mpi_comm_rank(comm, rank, ifail)
  call mpi_cart_shift(comm, 0, 1, my_left, my_right, ifail)
  call mpi_cart_coords(comm, rank, ndims, mycoords, ifail)

  ! Commpute the number of points held locally on each rank
  ! Add one point at each end to hold the halo region
  ! Allocate message buffers for transfers in the x direction

  im = imtot/size
  jm = jmtot
  imp1 = im + 1
  jmp1 = jm + 1

  allocate(state(0:imp1, 0:jmp1, 2), stat = ifail)
  allocate(sxl(1:jm), stat = ifail)
  allocate(sxr(1:jm), stat = ifail)
  allocate(rxl(1:jm), stat = ifail)
  allocate(rxr(1:jm), stat = ifail)

  ! initial state

  nc = 1 ! pointer to current time level
  np = 2 ! pointer to forward time level

  state(:,:,:) = .false.

  ! Every rank must test to see if the relevant points are local...
  !    the points in the global system are:
  !    state(2, 6) state(3, 5:6) state(4, 4) state(5, 5:6) state(6,6)
  ! ...so subtract the starting x coordinate for this rank

  i = 2 - mycoords(1)*im
  if (i >= 1 .and. i <= im) state(i, 6, nc) = .true.

  i = 3 - mycoords(1)*im
  if (i >= 1 .and. i <= im) state(i, 5:6, nc) = .true.

  i = 4 - mycoords(1)*im
  if (i >= 1 .and. i <= im) state(i, 4, nc) = .true.

  i = 5 - mycoords(1)*im
  if (i >= 1 .and. i <= im) state(i, 5:6, nc) = .true.

  i = 6 - mycoords(1)*im
  if (i >= 1 .and. i <= im) state(i, 6, nc) = .true.

  do n = 1, nsteps

     ! halo regions

     ! x-direction

     sxl(1:jm) = state(1,  1:jm, nc)
     sxr(1:jm) = state(im, 1:jm, nc)

     call mpi_irecv(rxr, jm, MPI_LOGICAL, my_right, my_tagl, comm, req(1), ifail)
     call mpi_irecv(rxl, jm, MPI_LOGICAL, my_left, my_tagr, comm, req(2), ifail)

     call mpi_issend(sxl, jm, MPI_LOGICAL, my_left, my_tagl, comm, req(3), ifail)
     call mpi_issend(sxr, jm, MPI_LOGICAL, my_right, my_tagr, comm, req(4), ifail)
     call mpi_waitall(4, req, status, ifail)

     state(0,    1:jm, nc) = rxl(1:jm)
     state(imp1, 1:jm, nc) = rxr(1:jm)

     ! y-direction
     state(0:imp1, 0,    nc) = state(0:imp1, jm, nc)
     state(0:imp1, jmp1, nc) = state(0:imp1,  1, nc)

     ! update

     lcount = 0

     do j = 1, jm
        do i = 1, im
           if (state(i,j,nc)) lcount = lcount + 1
           state(i,j,np) = state(i,j,nc)
           ! count the neighbours (including self)
           live = count(state(i-1:i+1, j-1:j+1, nc))
           if (state(i,j,nc)) then
              ! currently alive
              if (live == 3 .or. live == 4) then
                 ! remains alive
              else
                 ! dies
                 state(i,j,np) = .false.
              end if
           else
              ! currently dead
              if (live == 3) then
                 ! new cell
                 state(i,j,np) = .true.
              end if
           end if
           ! next cell
        end do
     end do

     ! output

     call mpi_reduce(lcount, ncount, 1, MPI_INTEGER, MPI_SUM, 0, comm, ifail)

     if (rank == 0) then
        write (unit = *, fmt = '(a,i3,i3)') "Step, count: ", n, ncount
     end if

     ! swap time level pointers
     tmp = nc
     nc = np
     np = tmp

  end do

  deallocate(rxr, rxl, sxr, sxl)
  deallocate(state)

  call mpi_finalize(ifail)

end program life


! { dg-do run }
! Tests the fix for PR35759 and PR35756 in which the dependencies
! led to an incorrect use of the "simple where", gfc_trans_where_3.
!
! Contributed by Dick Hendrickson <dick.hendrickson@gmail.com>
!
  logical :: la(6) = (/(2*(i/2) /= i, i = 1, 6)/), lb(6)
  CALL PR35759
  CALL PR35756
!
! The first version of the fix caused this to regress as pointed
! out by Dominique d'Humieres
!
  lb = la
  where(la)
    la = .false.
  elsewhere
    la = .true.
  end where
  if (any(la .eqv. lb)) STOP 1
CONTAINS
  subroutine PR35759
    integer UDA1L(6)
    integer ::  UDA1R(6), expected(6) = (/2,0,5,0,3,0/)
    LOGICAL LDA(5)
    UDA1L(1:6) = 0
    uda1r = (/1,2,3,4,5,6/)
    lda = (/ (i/2*2 .ne. I, i=1,5) /)
    WHERE (LDA)
      UDA1L(1:5) = UDA1R(2:6)
    ELSEWHERE
      UDA1L(2:6) = UDA1R(6:2:-1)
    ENDWHERE
    if (any (expected /= uda1l)) STOP 1
  END subroutine

  SUBROUTINE PR35756
    INTEGER  ILA(10), CLA(10)
    LOGICAL  LDA(10)
    ILA = (/ (I, i=1,10) /)
    LDA = (/ (i/2*2 .ne. I, i=1,10) /)
    WHERE(LDA)
      CLA = 10
    ELSEWHERE
      CLA = 2
    ENDWHERE
    WHERE(LDA)
      ILA = R_MY_MAX_I(ILA)
    ELSEWHERE
      ILA = R_MY_MIN_I(ILA)
    ENDWHERE
    IF (any (CLA /= ILA)) STOP 2
  end subroutine

  INTEGER FUNCTION R_MY_MAX_I(A)
    INTEGER  ::  A(:)
    R_MY_MAX_I = MAXVAL(A)
  END FUNCTION R_MY_MAX_I

  INTEGER FUNCTION R_MY_MIN_I(A)
    INTEGER  ::  A(:)
    R_MY_MIN_I = MINVAL(A)
  END FUNCTION R_MY_MIN_I
END


program vin
  integer :: numbers(9)
  numbers = 3
  print *,count(numbers /= 0)
  print *,count(numbers + numbers == 6)
end program vin


      subroutine ct4h_d(c1,h2,t5,dect4h)

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

      dimension h2(3,3,3,3),t5(3,3,3,3,3),dect4h(3)

c  this subroutine evaluates the quadrupole-quadrupole
c  electrostatic interaction

      dimension a(3,15),b(15)

      a(1,1)=t5(1,1,1,1,1)*h2(1,1,1,1)
      a(1,2)=t5(1,1,1,1,2)*h2(1,1,1,2)*4.d0
      a(1,3)=t5(1,1,1,1,3)*h2(1,1,1,3)*4.d0
      a(1,4)=t5(1,1,1,2,2)*h2(1,1,2,2)*6.d0
      a(1,5)=t5(1,1,1,2,3)*h2(1,1,2,3)*12.d0
      a(1,6)=t5(1,1,1,3,3)*h2(1,1,3,3)*6.d0
      a(1,7)=t5(1,1,2,2,2)*h2(1,2,2,2)*4.d0
      a(1,8)=t5(1,1,2,2,3)*h2(1,2,2,3)*12.d0
      a(1,9)=t5(1,1,2,3,3)*h2(1,2,3,3)*12.d0
      a(1,10)=t5(1,1,3,3,3)*h2(1,3,3,3)*4.d0
      a(1,11)=t5(1,2,2,2,2)*h2(2,2,2,2)
      a(1,12)=t5(1,2,2,2,3)*h2(2,2,2,3)*4.d0
      a(1,13)=t5(1,2,2,3,3)*h2(2,2,3,3)*6.d0
      a(1,14)=t5(1,2,3,3,3)*h2(2,3,3,3)*4.d0
      a(1,15)=t5(1,3,3,3,3)*h2(3,3,3,3)

      a(2,1)=t5(1,1,1,1,2)*h2(1,1,1,1)
      a(2,2)=t5(1,1,1,2,2)*h2(1,1,1,2)*4.d0
      a(2,3)=t5(1,1,1,2,3)*h2(1,1,1,3)*4.d0
      a(2,4)=t5(1,1,2,2,2)*h2(1,1,2,2)*6.d0
      a(2,5)=t5(1,1,2,2,3)*h2(1,1,2,3)*12.d0
      a(2,6)=t5(1,1,2,3,3)*h2(1,1,3,3)*6.d0
      a(2,7)=t5(1,2,2,2,2)*h2(1,2,2,2)*4.d0
      a(2,8)=t5(1,2,2,2,3)*h2(1,2,2,3)*12.d0
      a(2,9)=t5(1,2,2,3,3)*h2(1,2,3,3)*12.d0
      a(2,10)=t5(1,2,3,3,3)*h2(1,3,3,3)*4.d0
      a(2,11)=t5(2,2,2,2,2)*h2(2,2,2,2)
      a(2,12)=t5(2,2,2,2,3)*h2(2,2,2,3)*4.d0
      a(2,13)=t5(2,2,2,3,3)*h2(2,2,3,3)*6.d0
      a(2,14)=t5(2,2,3,3,3)*h2(2,3,3,3)*4.d0
      a(2,15)=t5(2,3,3,3,3)*h2(3,3,3,3)

      a(3,1)=t5(1,1,1,1,3)*h2(1,1,1,1)
      a(3,2)=t5(1,1,1,2,3)*h2(1,1,1,2)*4.d0
      a(3,3)=t5(1,1,1,3,3)*h2(1,1,1,3)*4.d0
      a(3,4)=t5(1,1,2,2,3)*h2(1,1,2,2)*6.d0
      a(3,5)=t5(1,1,2,3,3)*h2(1,1,2,3)*12.d0
      a(3,6)=t5(1,1,3,3,3)*h2(1,1,3,3)*6.d0
      a(3,7)=t5(1,2,2,2,3)*h2(1,2,2,2)*4.d0
      a(3,8)=t5(1,2,2,3,3)*h2(1,2,2,3)*12.d0
      a(3,9)=t5(1,2,3,3,3)*h2(1,2,3,3)*12.d0
      a(3,10)=t5(1,3,3,3,3)*h2(1,3,3,3)*4.d0
      a(3,11)=t5(2,2,2,2,3)*h2(2,2,2,2)
      a(3,12)=t5(2,2,2,3,3)*h2(2,2,2,3)*4.d0
      a(3,13)=t5(2,2,3,3,3)*h2(2,2,3,3)*6.d0
      a(3,14)=t5(2,3,3,3,3)*h2(2,3,3,3)*4.d0
      a(3,15)=t5(3,3,3,3,3)*h2(3,3,3,3)

      dect4h(1)=c1*(a(1,1)+a(1,2)+a(1,3)+a(1,4)+a(1,5)+a(1,6)+
     .          a(1,7)+a(1,8)+a(1,9)+a(1,10)+a(1,11)+a(1,12)+
     .          a(1,13)+a(1,14)+a(1,15))

      dect4h(2)=c1*(a(2,1)+a(2,2)+a(2,3)+a(2,4)+a(2,5)+a(2,6)+
     .          a(2,7)+a(2,8)+a(2,9)+a(2,10)+a(2,11)+a(2,12)+
     .          a(2,13)+a(2,14)+a(2,15))

      dect4h(3)=c1*(a(3,1)+a(3,2)+a(3,3)+a(3,4)+a(3,5)+a(3,6)+
     .          a(3,7)+a(3,8)+a(3,9)+a(3,10)+a(3,11)+a(3,12)+
     .          a(3,13)+a(3,14)+a(3,15))

      return
      end


module constantes
implicit none

! *********************************************************
! *********************************************************
! GLOBAL VARIABLES
! *********************************************************
! *********************************************************

! ---------------------------------------------------------
! PHYSICAL CONSTANTS AND RELATIONS AMONG THEM (ALL IN CGS)
! Taken from NIST (data from 1998)
!  http://physics.nist.gov/cuu/Constants/index.html
! ---------------------------------------------------------
! PI : pi
! PME : electron mass
! PK : Boltmann's constant
! PH : Planck's constant
! PC : speed of light
! UMA : atomic mass unit
! A0 : Bohr radius
! PION : hydrogen ionization potential
! ONETHIRD : 1/3
! FOURSQRTTWO : 1/(4*sqrt(2))
! CI : 1/2 * (h^2/(2*pi*me*k))^(3/2)  Constant for the Saha equation
! PI8C2 : 8 * pi / c^2
! PI4H : 4 * pi / h
! PHK : h / k
! PKUMA : k / amu
! PHC : 2 * h / c^2
! FOURSQRTTWO : 1/(4*sqrt(2))
! SQRTPI : sqrt(PI)
! FWHM : sqrt(8*ln(2))
! ---------------------------------------------------------
	real(kind=8), parameter :: PI = 3.14159265359d0, PME = 9.10938188d-28, PK = 1.3806503d-16
	real(kind=8), parameter :: PH = 6.62606876d-27, PC = 2.99792458d10, UMA = 1.66053873d-24, CI = 2.0706d-16
	real(kind=8), parameter :: A0 = 5.291772083d-9, PION = 2.17987190d-11, PEC = 4.803d-10
	real(kind=8), parameter :: PI8C2 = 8.d0 * PI / (PC**2), PI4H = 4.d0 * PI / PH, PHK = PH / PK
	real(kind=8), parameter :: PKUMA = PK / UMA, ONETHIRD = 1.d0 / 3.d0
	real(kind=8), parameter :: PHC = 2.d0 * PH / PC**2, FOURSQRTTWO = 0.176776695297d0
	real(kind=8), parameter :: SQRTPI = 1.77245385091d0, PARSEC = 3.085678d18
	real(kind=8), parameter :: FWHM = 2.35482004503d0
	real(kind=8), parameter :: C_graf = -25.16d0, C_sil = -25.11d0

! ---------------------------------------------------------
! CONSTANTS FOR LIMITS
! ---------------------------------------------------------
! nordm : maximum order of Ng acceleration
! n_ptos : maximum number of shells
! ---------------------------------------------------------

	integer, parameter :: nordm = 4
   integer, parameter :: n_ptos = 801

end module constantes

module variables
use constantes

! ---------------------------------------------------------
! GENERAL GLOBAL VARIABLES
! ---------------------------------------------------------
!       REAL*8
! tauip1 : it is used to indicate the minimum optical depth to be considered as thin and so not
!        make formal solution
! distancia : distance to the source (pc)
! ang_size : angular size of the source (arcsec)
! tel_fwhm : full width at half maximum of the telescope (FWHM)
! omega_sor : omega parameter in SOR iterative scheme
! star_radius: radius of the central star if present
! gaussq_n : number of points in the gaussian quadrature used in LVG
!
!       INTEGER
! n_radios : number of shells
! nfrq : number of frequency points in each profile
! n_freq_ud_doppler : number of frequency points in each Doppler width of the profile
! n_freq_perfil : number of Doppler width which cover the profile
! nord : Ng acceleration order
! itracc : number of iterations to accelerate
! nintracc : number of iterations after accelerating to re-accelerate
! iacel : type of acceleration ( 1 -> Ng, otherwise -> no acceleration)
! iter : current iterative step
! cortes : number of intersections between a shell and the characteristics
! n_caract : total number of characteristics used
! caract_core : number of characteristics crossing the core
! iter_max : maximum number of iterations
! output_spectrum : flag to write the emerging spectrum or not
! impact_star_radius : number of impact parameters which cross the central star if present
!
!       CHARACTER*30
! nombre_salida : output file
! nombre_iteration : iteration file
! nombre_modelo : atomic/molecular model file
! nombre_atmosf : atmosphere file
! nombre_emerging : emerging spectrum output file
! nombre_atmosf_out : atmosphere output file
! nombre_flux : emerging flux output file
! nombre_background_out : background opacity output file
! nombre_radrates : radiative rates output file
! tipo_iteracion : type of iterative scheme to use
! cortes : n. cortes entre una caracteristica y una capa!
! hor_axis : horizontal axis of the ellipse (vertical axis is equivalent to radius)
! geometry_type : type of geometry we are using
! ---------------------------------------------------------

	real(kind=8) :: tauip1, distancia, ang_size, omega_sor, maj_axis, tel_fwhm, tel_fwhm_cut, star_radius
	integer :: n_radios, nfrq, n_freq_ud_doppler, n_freq_perfil, nord, itracc, nintracc, iacel, iter
	integer :: cortes, n_caract, caract_core, iter_max, output_spectrum, impact_star_radius
	integer :: angleset_pp, gaussq_n
	character*60 :: nombre_salida, nombre_modelo, nombre_atmosf, nombre_iteration
	integer :: tipo_iteracion
	character*60 :: nombre_emerging, nombre_atmosf_out, nombre_flux, geometry_type
	character*60 :: nombre_background_out, nombre_radrates, nombre_collisrates
   character*10 :: observing_instrument, central_source_type

! ---------------------------------------------------------
! DEPTH VARYING VARIABLES
! ---------------------------------------------------------
! tau(transition,shell) : optical depth of each transition at each shell
! B(shell) : continuum source function (Planck's function at kinetic temperature)
! chil(shell) : line opacity
! kappa(shell) : continuum opacity
! chie(shell) : electron scattering opacity
! Sl(shell) : line source function
! Lstar(shell) : Lambda operator's diagonal
! Jbar(shell) : frequency and angle averaged intensity
! Jbar20(transition, shell) : frequency and angle averaged with (3*mu^2-1) intensity (for polarization)
! p(shell) : position of each characteristic
! r(shell) : shell grid
! B_dust(shell) : dust source function (Planck's function at dust temperature)
! kappa_dust(shell) : dust opacity
! ---------------------------------------------------------

	real(kind=8), allocatable :: tau(:,:), B(:), chil(:), chic(:,:), Sc(:,:), chie(:), Sl(:), Lstar(:)
	real(kind=8), allocatable :: Jbar(:), p(:), r(:), B_dust(:), kappa_dust(:), Jbar20(:,:), chic_bf(:,:,:), Sc_bf(:,:,:)
	real(kind=8), allocatable :: kappa(:), wtmu(:), mu_pp(:)
	real(kind=8), allocatable :: Jbarb(:), Lstarb(:), Lstarc(:), Ibf(:)

! ---------------------------------------------------------
! FREQUENCY VARYING VARIABLES
! ---------------------------------------------------------
! perfil(frq) : line profile
! profile(frq,caract,shell,in/out) : line profile in each point
! frqwt(frq,caract,shell,in/out) : frequency integration weights
! overl_lim(shell,caract,inout,transition_i,transition_j,begin/end) : indicates the begining
!		and the end of the overlapping between transition i and j
! In(charact,frq) : specific intensity for each characteristic and frequency
! wtnu(frq) : frequency integration weights
! eps_graphite_par(2,lambda) : graphite complex parallel dielectric function
! eps_graphite_per(2,lambda) : graphite complex perpendicular dielectric function
! eps_silicate(2,lambda) : silicate complex dielectric function
! graphite_lambda(lambda) : wavelengths where graphite's dielectric function is tabulated
! silicate_lambda(lambda) : wavelengths where silicate's dielectric function is tabulated
! ---------------------------------------------------------

	real(kind=8), allocatable :: perfil(:), In(:,:), wtnu(:), profile(:,:,:,:), frqwt(:,:,:,:)
	real(kind=8), allocatable :: eps_graphite_par(:,:), eps_graphite_per(:,:), eps_silicate(:,:)
	real(kind=8), allocatable :: graphite_lambda(:), silicate_lambda(:)
	integer, allocatable :: overl(:,:,:)

! ---------------------------------------------------------
! ANGULAR VARYING VARIABLES
! ---------------------------------------------------------
! mu(shell,charact) : angle between the shell and the characteristic for each intersection
! ---------------------------------------------------------

	real(kind=8), allocatable :: mu(:,:)

! ---------------------------------------------------------
! GLOBAL JBAR AND LSTAR MATRICES
! ---------------------------------------------------------
! Jbar_total(shell*level) : total Jbar matrix for all levels and shells
! Lstar_total(shell*level) : total Lambda operator diagonal for all levels and shells
! ---------------------------------------------------------

   real(kind=8), allocatable :: Jbar_total(:), lstar_total(:)
	real(kind=8), allocatable :: Jbar_total_bf_a(:), Jbar_total_bf_b(:), I_total_bf(:)
	real(kind=8), allocatable :: lstar_total_bf_a(:), lstar_total_bf_b(:), lstar_total_bf_c(:)

! ---------------------------------------------------------
! OTHER VARIABLES
! ---------------------------------------------------------
! scratch(level*shells,nord) : Ng temporal storage
! precision : final maximum relative change to reach
! relat_error : current iteration maximum relative change
! relat_error_p : last iteration maximum relative change
! trick : threshold value to turn on exponential series expansion
! repeat : variable to say if we have an empty core or an absorbing/source one
! ---------------------------------------------------------

   real(kind=8), allocatable ::  scratch(:,:)
	real(kind=8) :: precision, relat_error, trick, relat_error_p, repeat, true_error

! ---------------------------------------------------------
! ATOMIC MODEL
! ---------------------------------------------------------
!       INTEGER
! nl : number of levels
! ni : number of ion
! nt : number of transitions
! nr : number of radiative transitions
! nact : number of active transitions
! nli(nlm) : ion to which the level belongs to
! itran(2,ntm) : upper and lower levels of each transition
! n_partition : number of coefficients in the partition function fit
!
!       REAL*8
! dlevel(1,nlm) : level energy in frequency units
! dlevel(2,nlm) : statistical weight of each level
! dion(1,ni) : ionization potential in frequency units
! dtran(1,nt) : effective cross-section of the transition = fij * pi * e^2 / (me * c)
!					It is converted to h*nu/(4*pi)*Blu
! dtran(2,nt) : transition frequency (Hz)
! dtran(3,nt) : collisional cross-section (only used for reading from file, see collision(:,:))
! dtran(4,nt) : Doppler width or radiation temperature
! doppler_width(shell,transition) : doppler width for each transition and point in the atmosphere
! collision(shell,transition) : collisional rates for each transition and shell
! partition(n_partition) : coefficients of the partition function
! mass : mass of the atom or molecule
!
!       CHARACTER*20
! tipo_colision : type of collisions (FIXED, FIXED_H, INTERPOL_H, etc)
! tipo_modelo : indicates if the model is an atom or a molecule
! atom_mol_nombre : indicates the model name
! ---------------------------------------------------------

	integer :: nl, ni, nact, nt, nr, n_partition, nbf, nfrq_bf, include_bound_free
	integer, allocatable :: nli(:), itran(:,:)
	real(kind=8), allocatable :: dlevel(:,:), dion(:,:), dtran(:,:), doppler_width(:,:)
	real(kind=8), allocatable :: partition(:), collision(:,:), threshold_bf(:), bf_cross_section(:,:,:)
	character*40, allocatable :: label(:)
	real(kind=8) :: mass
	character*20 :: tipo_colision, tipo_modelo, atom_mol_nombre

! ---------------------------------------------------------
! ATMOSPHERE MODEL
! ---------------------------------------------------------
!       REAL*8
! datph(1,shell) : kinetic temperature in each shell
! datph(2,shell) : electron density
! datph(3,shell) : atom/molecule abundance
! datph(4,shell) : microturbulence velocity
! datph(5,shell) : visual absorption A_v
! datph(6,shell) : dust temperature
! datph(7,shell) : macroscopic velocity
! datph(8,shell) : gas pressure
! dentro(nfrq) : inner shell boundary condition
! fuera(nfrq) : outer shell boundary condition
! tback : microwave background temperature
! tcentral : central source temperature
! lambda_ref : dust reference wavelength
! expav : dust opacity exponent chi_dust = A_v * (lambda/lambda_ref)**(-expav)
! xhel : helium abundance referring to H2
! xhid : atomic hydrogen abundance referring to H2
!       INTEGER
! background_flag : include background radiation or not
! central_flag : include central source or not
! dust_flag : include dust or not
! back_opac_flag : include or not background opacity
! radrates_flag : write or not radiative rates
! iterat_improv : do iterative improvement of the solution to the linearized system
! V_max : maximum velocity in the atmosphere
! lvg_flag : maximum relative change of the LVG solution (if 0, then use LTE)
! SNTB_flag : maximum relative change to turn on Socas Navarro-Trujillo Bueno acceleration
!       If 0, then don't use it
! ---------------------------------------------------------
	real(kind=8), allocatable :: datph(:,:), dentro(:), fuera(:), thermal_v(:), dentro_bf(:), fuera_bf(:)
	real(kind=8) :: tback, tcentral, lambda_ref, expav, xhel, xhid, V_max, lvg_flag, SNTB_flag
	real(kind=8) :: ref_wavelength, ref_opacity, spectral_index
	integer :: background_flag, dust_flag, central_flag, iterat_improv, back_opac_flag
	integer :: radrates_flag, converge_flag, overlap_flag, error_flag
	integer :: zeeman_line, include_collis, linear_solver_algorithm, verbose_flag
	integer :: level_highest_change, interpolate_atmosphere, n_radios_old, n_caract_old

! ---------------------------------------------------------
! POPULATION
! ---------------------------------------------------------
! nh(shell) : atomic hydrogen (atom model) or molecular hydrogen (molecular model) density
! popl(shell*nl) : LTE population in each shell for all levels
! pop(shell*nl) : population of all levels in each shell
! pop(shell*nl) : initial population (LVG or LTE)
! ---------------------------------------------------------

	real(kind=8), allocatable :: nh(:), popl(:), pop(:), popi(:), pop_final(:)

! ---------------------------------------------------------
! CEP method
! ---------------------------------------------------------
! ---------------------------------------------------------
	integer :: n_quadr_beta
	real(kind=8), allocatable :: dSldn(:,:), dJbar_totaldn(:,:), dJbardn(:,:), x_e3(:), w_e3(:)

end module variables