!***********************************************************************************
    SUBROUTINE Simulation (imult)
    !c----------------------------------------------------------------------
    !c
    !c----------------------------------------------------------------------
    use varmod
    use ran_mod
    implicit none
    ! Declare dummy arguments
    INTEGER, INTENT(IN) :: imult

    ! Declare local variables
    INTEGER :: ingd,ic,ix,iy,iz,ixr,iyr,izr
    INTEGER :: jx, jy, jz
    real::pptmp
    integer::pptmpi
    real,dimension(nz)::rangz,rangtm
    real , DIMENSION  (MAXXYZ) :: c,d,e,f,g,h
    integer::i,NcoarseNz
    integer :: kz
    real :: TsnyccBMcMCIte,AverageCCBMcMCIte

    ! Main loop over all simulation grid nodes:
    DO ingd=1, nxycoarse
        ! Figure out the location of this point and make sure it has
        ! not been assigned a value already:
        jz=1
        jy=1+int((order(ingd)-(jz-1)*nxycoarse-1)/nxcoarse)
        jx=order(ingd)-(jz-1)*nxycoarse-(jy-1)*nxcoarse
        ix=(jx-1)*ncoarse+1
        iy=(jy-1)*ncoarse+1
        iz=(jz-1)*ncoarse+1

        rangtm(1:nz)=2
        rangz(1:nz)=UNEST
        do i=1,(nz-1)/ncoarse+1
            rangz((i-1)*ncoarse+1)=(i-1)*ncoarse+1
            call RANDOM_NUMBER(pptmp)
            rangtm((i-1)*ncoarse+1)=pptmp
        end do
        CALL sortem(1,nz,rangtm,1,rangz,c,d,e,f,g,h)
        do i=1,(nz-1)/ncoarse+1
            iz=rangz(i)

            IF(simim(ix, iy, iz)<0) THEN

                ! First, get close conditioning data:
                CALL SearchClosestNodes(ix,iy,iz)

                ! If no conditioning data were found, use the marginal pdf as
                ! local cpdf, otherwise infer the local cpdf from the training image:
                IF(ncnode==0) THEN
                    IF(WCY.GT.1)THEN
                        simim(ix,iy,iz)=FaciesSimTmp(ix,iy,iz)
                        DenSim(ix,iy,iz)=DenSimtmp(ix,iy,iz)
                        VpSim(ix,iy,iz)=VpSimtmp(ix,iy,iz)
                    ELSE
                        numcd(ix,iy,iz)=0
                        call RANDOM_NUMBER(pptmp)
                        do pptmpi=1,ncut
                            if(pptmp.le.real(pptmpi)/real(ncut)) exit
                        end do
                        simim(ix,iy,iz)=pptmpi
                        DenSim(ix,iy,iz)=normal(EDen(simim(ix,iy,iz)),VDen(simim(ix,iy,iz)))
                        VpSim(ix,iy,iz)=slopeVp(simim(ix,iy,iz))*DenSim(ix,iy,iz)+interceptVp(simim(ix,iy,iz))+normal(ResMeanVp(simim(ix,iy,iz)),RMSEVp(simim(ix,iy,iz)))
                    end if
                ELSE
                    if (ObjectiveFuction==1) then
                        CALL InferCpdfRMSE(ix,iy,iz,imult)

!                        do ixr=1,nx
!                            do iyr=1,ny
!                                call convolution(nz,ixr,iyr,1,DenSim(ixr,iyr,1:nz),VpSim(ixr,iyr,1:nz),SnySim(ixr,iyr,1:nz))
!                            end do
!                        end do
!                        seisRMS=0.0
!                        do izr=nz, 1,-1
!                            do iyr=1, ny
!                                do ixr=1, nx
!                                    seisRMS=seisRMS+ABS(SnySim(ixr,iyr,izr)-ActualSeismic(ixr,iyr,izr))
!                                end do
!                            end do
!                        end do
!                        write(ObFunpar,1004) itera,seisRMS
!1004                    format(I14,F16.3)
                    else
                        itera=itera+1
                        CALL InferCpdfCC(ix,iy,iz,imult)

!                        ESnySimBMcMCIte(1:nx,1:ny) = 0.0
!                        CovSnyBMcMCIte(1:nx,1:ny) = 0.0
!                        VarSnySimBMcMCIte(1:nx,1:ny) = 0.0
!                        RsnyBMcMCIte(1:nx,1:ny) = 0.0
!                        AverageCCBMcMCIte=0.0
!                        do ixr=1,nx
!                            do iyr=1,ny
!                                call convolution(nz,ixr,iyr,1,DenSim(ixr,iyr,1:nz),VpSim(ixr,iyr,1:nz),SnySim(ixr,iyr,1:nz))
!                            end do
!                        end do
!                        do izr = nz, 1,-1
!                            do iyr = 1, ny
!                                do ixr = 1, nx
!                                    write(2, *) SnySim(ixr,iyr,izr)
!                                    TsnyccBMcMCIte = TsnyccBMcMCIte+ABS(SnySim(ixr,iyr,izr)-ActualSeismic(ixr,iyr,izr))
!                                end do
!                            end do
!                        end do
!                        do ixr = 1,nx
!                            do iyr = 1,ny
!                                do izr = nz, 1,-1
!                                    ESnySimBMcMCIte(ixr,iyr)=ESnySimBMcMCIte(ixr,iyr)+SnySim(ixr,iyr,izr)
!                                    CovSnyBMcMCIte(ixr,iyr)=CovSnyBMcMCIte(ixr,iyr)+SnySim(ixr,iyr,izr)*ActualSeismic(ixr,iyr,izr)
!                                end do
!                                ESnySimBMcMCIte(ixr,iyr)=real(ESnySimBMcMCIte(ixr,iyr)/nz)
!                                CovSnyBMcMCIte(ixr,iyr)=real(CovSnyBMcMCIte(ixr,iyr)/nz)
!                                do izr=1,nz
!                                    VarSnySimBMcMCIte(ixr,iyr)=VarSnySimBMcMCIte(ixr,iyr)+(SnySim(ixr,iyr,izr)-ESnySimBMcMCIte(ixr,iyr))**2
!                                end do
!                                VarSnySimBMcMCIte(ixr,iyr)=real(VarSnySimBMcMCIte(ixr,iyr)/nz)
!                                if(VarSnySimBMcMCIte(ixr,iyr)/=0.0) RsnyBMcMCIte(ixr,iyr)=(CovSnyBMcMCIte(ixr,iyr)-ESnySimBMcMCIte(ixr,iyr)*EActualSeismic(ixr,iyr))/((VarSnySimBMcMCIte(ixr,iyr)*VarActualSeismic(ixr,iyr))**0.5)
!                                AverageCCBMcMCIte = AverageCCBMcMCIte+RsnyBMcMCIte(ixr,iyr)
!                            end do
!                        end do
!                        AverageCCBMcMCIte = AverageCCBMcMCIte/nx/ny
!                        write(ObFunpar,1005) itera,AverageCCBMcMCIte
!1005                    format(I14,F16.3)
                    end if
                END IF
            END IF
        end do
    END DO

    END SUBROUTINE Simulation
    !***********************************************************************************


      subroutine induc02(a, n)

C     Example submitted by Nga. You want to prove that ij is greater
C     than 1 in the second loop. a new property was added to semantics
C     to recompute the loop fixpoints with precondition information.

      real a(n)

      do ix = 1, nx2
         ij = ix
         do iy = 1, ny2
            if(nx2.gt.0) then
               a(ij) = 0.
               ij = ij + nx2
            endif
         enddo
      enddo

      do ix = 1, nx2
         ij = ix
         do iy = 1, ny2
               a(ij) = 0.
               ij = ij + nx2
         enddo
      enddo

      end


	PROGRAM TESTCV
C************************************************************************
C* TESTCV								*
C*									*
C* This program tests the CURVE library subroutines.			*
C*									*
C**									*
C* Log:									*
C* S. Jacobs/NCEP	 8/98						*
C* S. Jacobs/NCEP	 8/98	Changed call to CV_PRMT			*
C* S. Jacobs/NCEP	 4/99	Added CV_RDUC				*
C* J. Wu/GSC	   	 8/00	Added CV_MDFY				*
C************************************************************************
	INCLUDE         'GEMPRM.PRM'
C*
	REAL		xpt (LLMXPT), ypt (LLMXPT),
     +			xcl (LLMXPT), ycl (LLMXPT),
     +			xcv (LLMXPT), ycv (LLMXPT)
        CHARACTER*20	filename
C------------------------------------------------------------------------
	CALL IN_BDTA  ( ier )
	iostat = 0
	DO WHILE  ( iostat .eq. 0 )
	    WRITE  ( 6, 20 )
20	    FORMAT (' 1 = CV_PRMT   2 = CV_RDUC   3 = CV_MDFY')
	    CALL TM_INT ( 'Select a subroutine number', .false.,
     +                     .false., 1, numsub, n, ier )
	    IF  ( ier .eq. 2 )  THEN
		iostat = -1
		numsub = -1
	    END IF
C------------------------------------------------------------------------
	    IF  ( numsub .eq. 1 )  THEN
		WRITE (6,*) ' Enter number of original points: '
		READ  (5,*) np
		WRITE (6,*) ' Enter ', np, ' value pairs: '
		READ  (5,*) ( xpt (i), ypt (i), i = 1, np )
		WRITE (6,*) ' Enter the smoothing density: '
		READ  (5,*) dens
		WRITE (6,*) ' Enter the curve scaling factor: '
		READ  (5,*) crvscl
		WRITE (6,*) ' Enter the start point of the segment: '
		READ  (5,*) istrt
		WRITE (6,*) ' Enter the end point of the segment: '
		READ  (5,*) iend
		CALL CV_PRMT  ( np, xpt, ypt, dens, LLMXPT, crvscl,
     +				istrt, iend, nout, xcv, ycv, iret )
		WRITE (6,*) 'nout, iret = ', nout, iret
		DO  i = 1, nout
		    WRITE (6,*) xcv (i), ycv (i)
		END DO
		CALL ER_WMSG ( 'CV',  iret, ' ', ierr)
C------------------------------------------------------------------------
	      ELSE IF  ( numsub .eq. 2 )  THEN
		WRITE (6,*) ' Enter number of original points: '
		READ  (5,*) np
		WRITE (6,*) ' Enter ', np, ' value pairs: '
		READ  (5,*) ( xpt (i), ypt (i), i = 1, np )
		WRITE (6,*) ' Enter the tolerance: '
		READ  (5,*) eps
		CALL CV_RDUC  ( np, xpt, ypt, eps,
     +				nout, xcv, ycv, iret )
		WRITE (6,*) 'nout, iret = ', nout, iret
		DO  i = 1, nout
		    WRITE (6,*) xcv (i), ycv (i)
		END DO
		CALL ER_WMSG ( 'CV',  iret, ' ', ierr)
C------------------------------------------------------------------------
	      ELSE IF  ( numsub .eq. 3 )  THEN
		WRITE (6,*) ' Enter your data source: '
	        WRITE (6,40)
40	        FORMAT (' 1 = Type in    2 = Read from file')
		READ  (5,*) choice

		IF  ( choice .eq. 2 )  THEN
		  WRITE (6,*) ' Enter file name ( sample.dat? ): '
		  READ  (5,'(A20)') filename
		  WRITE (6,*) ' Enter type of line [0-open 1-close]: '
		  READ  (5,*) nline
		  WRITE (6,*) ' Enter smoothing level [0, 1, 2]: '
		  READ  (5,*) nsm_lvl
		  OPEN (20, FILE = filename, STATUS = 'old', IOSTAT = iv)
                  IF ( iv .GT. 0 ) THEN
		    WRITE (6,*) ' Cannot open your file, please type in: '
		    choice = 1
		  ELSE
		    REWIND(20)
		    READ  (20,*) npo, ( xpt( i ), i = 1, npo )
		    READ  (20, *)  ( ypt( i ), i = 1, npo )
		    READ  (20, *) npc, ( xcl( i ), i = 1, npc )
		    READ  (20, *)  ( ycl( i ), i = 1, npc )
		    CLOSE (20)
		  END IF
		END IF

		IF  ( choice .eq. 1 )  THEN
		  WRITE (6,*) ' Enter number of original points: '
		  READ  (5,*) npo
		  WRITE (6,*) ' Enter ', npo, ' value pairs: '
		  READ  (5,*) ( xpt( i ), ypt( i ), i = 1, npo )
		  WRITE (6,*) ' Enter number of clicked points: '
		  READ  (5,*) npc
		  WRITE (6,*) ' Enter ', npc, ' value pairs: '
		  READ  (5,*) ( xcl( i ), ycl( i ), i = 1, npc )
		  WRITE (6,*) ' Enter smoothing level [0, 1, 2]: '
		  READ  (5,*) nsm_lvl
		  WRITE (6,*) ' Enter type of line [0-open 1-close]: '
		  READ  (5,*) nline
                ENDIF

		IF ( ( choice .eq. 1 ) .or. ( choice .eq. 2 ) ) THEN
		  CALL CV_MDFY  ( npo, xpt, ypt, npc, xcl, ycl, nsm_lvl, nline,
     +				  LLMXPT, nout, xcv, ycv, is, ie, iret )
		  WRITE (6,*) 'nout, is, ie, iret = ', nout, is, ie, iret
		  DO  i = 1, nout
		    WRITE (6,*) xcv (i), ycv (i)
		  END DO
		ENDIF
		CALL ER_WMSG ( 'CV',  iret, ' ', ierr)
C------------------------------------------------------------------------
	    END IF
	END DO
C*
	END


PROGRAM sortdriver
  ! Test program for gf_qsort.f90
  USE mod_gf_qsort
  IMPLICIT NONE
  INTEGER, PARAMETER :: ki=SELECTED_REAL_KIND(p = 15, r = 30)
  INTEGER, PARAMETER :: r = 10
  INTEGER :: i
  REAL(ki), DIMENSION(1:r) :: myarray = &
      (/0, 50, 20, 25, 90, 10, 5, 99, 99, 99/)
  INTEGER, DIMENSION(1:r) :: myindex = (/ (i,i=1,r) /)
  PRINT *, "Original array is ", myarray
  CALL QsortC(myarray,myindex)
  PRINT *, "Sorted array is ", myarray
  PRINT *, "Sorted index is ", myindex
END PROGRAM sortdriver


!--------+--------+--------+--------+--------+--------+--------+------!
!> Subroutine for calculating Berry phase for a giving path
! Comments:
!          At present, you have to define the k path that you want
!          in kpoints
! Author : QuanSheng Wu (wuquansheng@gmail.com)
! 31 Mar 2016
!--------+--------+--------+--------+--------+--------+--------+------!

   subroutine  berryphase
      use para
      use mpi
      implicit none

      integer :: i
      integer :: j
      integer :: nfill

      integer :: ik

      !> k points in kx-ky plane
      real(dp), allocatable :: kpoints(:, :)

      !> hamiltonian for each k point
      !> and also the eigenvector of hamiltonian after eigensystem_c
      complex(dp), allocatable :: Hamk(:, :)
      complex(dp), allocatable :: Hamk_dag(:, :)

      !> eigenvector for each kx
      complex(dp), allocatable :: Eigenvector(:, :, :)

      !> Mmnkb=<u_n(k)|u_m(k+b)>
      !> |u_n(k)> is the periodic part of wave function
      complex(dp), allocatable :: Mmnkb(:, :)
      complex(dp), allocatable :: Mmnkb_com(:, :)
      complex(dp), allocatable :: Mmnkb_full(:, :)

      !>
      complex(dp), allocatable :: Lambda_eig(:)
      complex(dp), allocatable :: Lambda(:, :)
      complex(dp), allocatable :: Lambda0(:, :)

      !> three matrix for SVD
      !> M= U.Sigma.V^\dag
      !> VT= V^\dag
      complex(dp), allocatable :: U(:, :)
      real   (dp), allocatable :: Sigma(:, :)
      complex(dp), allocatable :: VT(:, :)

      complex(dp), allocatable :: phase(:)
      !> eigenvalue
      real(dp), allocatable :: eigenvalue(:)

      real(dp) :: kx
      real(dp) :: ky
      real(dp) :: kz
      real(dp) :: k(3)
      real(dp) :: k1(3)
      real(dp) :: phi
      complex(dp) :: overlap

      nfill= Numoccupied

      allocate(kpoints(3, Nk))
      kpoints= 0d0

      allocate(Lambda_eig(nfill))
      allocate(Lambda(nfill, nfill))
      allocate(Lambda0(nfill, nfill))
      allocate(Mmnkb(nfill, nfill))
      allocate(Mmnkb_com(nfill, nfill))
      allocate(Mmnkb_full(Num_wann, Num_wann))
      allocate(hamk(Num_wann, Num_wann))
      allocate(hamk_dag(Num_wann, Num_wann))
      allocate(Eigenvector(Num_wann, Num_wann, Nk))
      allocate(eigenvalue(Num_wann))
      allocate(U(nfill, nfill))
      allocate(Sigma(nfill, nfill))
      allocate(VT(nfill, nfill))
      allocate(phase(Num_wann))
      hamk=0d0
      eigenvalue=0d0
      Eigenvector=0d0
      Mmnkb_full=0d0
      Mmnkb=0d0
      Mmnkb_com=0d0
      Lambda =0d0
      Lambda0=0d0
      U= 0d0
      Sigma= 0d0
      VT= 0d0

      !> define a k path
      do ik=1, Nk
         phi= (ik-1d0)*2d0*pi/dble(Nk)
         kx= 0.00d0+ cos(phi)*0.100d0!pi
         ky= 0.20d0+ sin(phi)*0.100d0!pi
         kz= 0.00d0
         kpoints(1, ik)= kx
         kpoints(2, ik)= ky
         kpoints(3, ik)= kz
      enddo

      !> for each ky, we can get wanniercenter
      do ik=1, Nk
         k(1)= kpoints(1, ik)
         k(2)= kpoints(2, ik)
         k(3)= kpoints(3, ik)

         call cart_direct(k, k1)
         write(*, '(a, 3f7.3, a, 3f7.3)')'k',k,'  k1', k1

         call ham_bulk(k1,hamk)

         !> diagonal hamk
         call eigensystem_c('V', 'U', Num_wann, hamk, eigenvalue)

         Eigenvector(:, :, ik)= hamk
      enddo

      !> sum over k to get berry phase
      phase= 1d0
      do ik= 1, Nk
         hamk= Eigenvector(:, :, ik)
         hamk_dag= conjg(transpose(hamk))
         if (ik==nk) then
            hamk= Eigenvector(:, :, 1)
         else
            hamk= Eigenvector(:, :, ik+ 1)
         endif

         !> <u_k|u_k+1>
         do i=1, Num_wann
            overlap= 0d0
            do j=1, Num_wann
               overlap= overlap+ hamk_dag(i, j)* hamk(j, i)
            enddo
           !phase(i)= phase(i)- aimag(log(overlap))/pi
            phase(i)= phase(i)*overlap
         enddo
      enddo  !< ik
      print *, 'berry phase'
      do i=1, Num_wann
         write(*, '(10f10.5)')aimag(log(phase(i)))/pi
      enddo

      return
   end subroutine berryphase


      subroutine gtemp(afcnst,al10,iopt,jtemp,noptmx,noutpt,nttkmx,
     $ nttyo,rconst,rtcnst,tempc,tempcb,tempk,time1,ttk,xi1)
c
c     This subroutine computes the temperature (tempc) as a function of
c     reaction progress (xi1) or time (time1).
c
c     This subroutine is called by:
c
c       EQ6/eq6.f
c       EQ6/tpadv.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       jtemp  = temperature tracking flag
c       ttk    = temperature tracking coefficients
c       time1  = time variable
c       xi1    = reaction progress variable
c
c     Principal output:
c
c       tempc  = temperature, C
c       tempk  = temperature, K
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer noptmx,nttkmx
c
      integer iopt(noptmx)
      integer jtemp,noutpt,nttyo
c
      real(8) ttk(nttkmx)
      real(8) afcnst,al10,rconst,rtcnst,tempc,tempcb,tempk,time1,xi1
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      real(8) tmpmin,tmpmax
c
c-----------------------------------------------------------------------
c
c     Allowed range of the temperature (C):
c
      data tmpmin,tmpmax /-273.15,1400./
c
c-----------------------------------------------------------------------
c
      if (jtemp .eq. 0) then
c
c       Constant temperature.
c
        tempc = tempcb
      elseif (jtemp .eq. 1) then
c
c       Linear tracking in Xi.
c
        tempc = tempcb + ttk(1)*xi1
      elseif (jtemp .eq. 2) then
c
c       Linear tracking in time.
c
        tempc = tempcb + ttk(1)*time1
      elseif (jtemp .eq. 3) then
c
c       Fluid mixing tracking.
c
        tempc = ( tempcb*ttk(1) + xi1*ttk(2) )/( xi1 + ttk(1) )
      endif
c
      tempk = tempc + 273.15
      rtcnst = 0.001*rconst*tempk
      afcnst = al10*rtcnst
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Stop if tempc is less than tmpmin or greater than tmpmax.
c
      if (tempc.lt.tmpmin .or. tempc.gt.tmpmax) then
        write (noutpt,1010) tempc,tmpmin,tmpmax,xi1
        write (nttyo,1010) tempc,tmpmin,tmpmax,xi1
 1010   format(/' * Error - (EQ6/gtemp) The calculated temperature',
     $  /7x,'is ',g10.3," C, outside the code's built-in allowed",
     $  /7x,'range of ',g10.3,'-',g10.3,' C. Other limits associated',
     $  /7x,'with the supporting data file may also apply.',
     $  /7x,'The current value of reaction progress is ',
     $  g12.5,' moles.')
        if (iopt(2) .gt. 0) then
          write (noutpt,1020) time1
          write (nttyo,1020) time1
 1020     format(7x,'The current time value is ',g10.3,' seconds.')
        endif
        stop
      endif
c
  999 continue
      end


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

MODULE m_setabc1lo
!*********************************************************************
! calculates the (lower case) a, b and c coefficients for the local
! orbitals. The radial function of the local orbital is a linear
! combination of the apw radial function and its derivative and the
! extra radial funtion (a*u + b*udot + c*ulo). This function is zero
! and has zero derivative at the muffin tin boundary.
! Philipp Kurz 99/04
!*********************************************************************
      CONTAINS
      SUBROUTINE setabc1lo(atoms, ntyp,ud,usp, alo1,blo1,clo1)
      USE m_types
      IMPLICIT NONE

      TYPE(t_atoms),INTENT(IN)   :: atoms
!     ..
!     .. Scalar Arguments ..
      INTEGER, INTENT (IN)  :: ntyp,usp
!     ..
!     .. Array Arguments ..
      TYPE(t_usdus),INTENT(IN):: ud
      REAL,    INTENT (OUT) :: alo1(:,:),blo1(:,:),clo1(:,:)
!     ..
!     .. Local Scalars ..
      REAL ka,kb,ws
      INTEGER l,lo
      LOGICAL apw_at
!     ..
!     ..
! look, whether 'ntyp' is a APW atom; then set apw_at=.true.
      !
      apw_at=ANY(atoms%l_dulo(:atoms%nlo(ntyp),ntyp))

      DO lo = 1,atoms%nlo(ntyp)
         l = atoms%llo(lo,ntyp)
         IF (apw_at) THEN
           IF (atoms%l_dulo(lo,ntyp)) THEN
! udot lo
             ka=sqrt(1+(ud%us(l,ntyp,usp)/ud%uds(l,ntyp,usp))**2* ud%ddn(l,ntyp,usp))
             alo1(lo,usp)=1.00 / ka
             blo1(lo,usp)=-ud%us(l,ntyp,usp)/ (ud%uds(l,ntyp,usp) * ka )
             clo1(lo,usp)=0.00
           ELSE
! u2 lo
             alo1(lo,usp)=1.00
             blo1(lo,usp)=0.00
             clo1(lo,usp)=-ud%us(l,ntyp,usp)/ud%ulos(lo,ntyp,usp)
           ENDIF
         ELSE
           ws = ud%uds(l,ntyp,usp)*ud%dus(l,ntyp,usp) - ud%us(l,ntyp,usp)*ud%duds(l,ntyp,usp)
           ka = 1.0/ws*(ud%duds(l,ntyp,usp)*ud%ulos(lo,ntyp,usp)- ud%uds(l,ntyp,usp)*ud%dulos(lo,ntyp,usp))
           kb = 1.0/ws* (ud%us(l,ntyp,usp)*ud%dulos(lo,ntyp,usp)- ud%dus(l,ntyp,usp)*ud%ulos(lo,ntyp,usp))
           clo1(lo,usp) = 1.0/sqrt(ka**2+ (kb**2)*ud%ddn(l,ntyp,usp)+1.0+ 2.0*ka*ud%uulon(lo,ntyp,usp)+&
                2.0*kb*ud%dulon(lo,ntyp,usp))
           alo1(lo,usp) = ka*clo1(lo,usp)
           blo1(lo,usp) = kb*clo1(lo,usp)
         ENDIF
      END DO

      END SUBROUTINE setabc1lo
      END MODULE m_setabc1lo
!
!         flo = alo1(lo,usp)*us(l,ntyp) + blo1(lo,usp)*uds(l,ntyp) +
!     +         clo1(lo,usp)*ulos(lo,ntyp)
!         dflo = alo1(lo,usp)*dus(l,ntyp) + blo1(lo,usp)*duds(l,ntyp) +
!     +          clo1(lo,usp)*dulos(lo,ntyp)
!         nflo = alo1(lo,usp)**2 + (blo1(lo,usp)**2)*ddn(l,ntyp) + clo1(lo,usp)**2 +
!     +          2*alo1(lo,usp)*clo1(lo,usp)*uulon(lo,ntyp) +
!     +          2*blo1(lo,usp)*clo1(lo,usp)*dulon(lo,ntyp)


      subroutine mkintrp3d(x,nx,y,ny,z,nz,jspline,
     >     f,icoeff,ixdim,iydim,izdim,
     >     ibcxmin,bcxmin,ibcxmax,bcxmax,
     >     ibcymin,bcymin,ibcymax,bcymax,
     >     ibczmin,bczmin,ibczmax,bczmax,
     >     ier)
c
c  setup a tricubic spline, or tricubic Hermite, or hybrid linear/zonal 2d or
c  1d with 1d or 2d cubic or Hermite spline interpolation
c
      implicit NONE
C
C  input:
      integer nx                        ! length of x vector
      integer ny                        ! length of y vector
      integer nz                        ! length of z vector
      real x(nx)                        ! x vector, strict ascending
      real y(ny)                        ! y vector, strict ascending
      real z(nz)                        ! z vector, strict ascending
c
      integer :: jspline(3)             ! interpolation method control
C        (1) -- 1st dimension: -1: zone, 0: pclin, 1: Hermite, 2: spline
C        (2) -- 2nd dimension: -1: zone, 0: pclin, 1: Hermite, 2: spline
C        (3) -- 3rd dimension: -1: zone, 0: pclin, 1: Hermite, 2: spline
C
C    Standard interpolation-- all jspline values match
C      e.g. jspline(1)=jspline(2)=jspline(3)=2 for tricubic spline
C
C    Hybrid interpolation-- not all jspline values are the same.
C
C    RESTRICTION: if any jspline(...) element has value 1, none can have
C    value 2.  I.e. Spline and Hermite interpolation cannot currently be mixed.
C    This restriction exists because of technical issues in the
C    implementation (it could be removed in principle but the work to do
C    this has not been scheduled).
c
c  coefficient buffer dimensions
      integer :: icoeff                 ! #coefficients per data point
      integer :: ixdim                  ! nx; nx-1 if jspline(1)==-1
      integer :: iydim                  ! ny; ny-1 if jspline(2)==-1
      integer :: izdim                  ! nz; nz-1 if jspline(3)==-1
c  input/output:
      real f(icoeff,ixdim,iydim,izdim)  ! data and spline coefficients
c
C  boundary condition data
C    Contiguous storage is assumed-- 1st dimension size must match
C      actual use
C
C
      integer ibcxmin,ibcxmax           ! BC type flag @xmin, xmax
      integer ibcymin,ibcymax           ! BC type flag @ymin, ymax
      integer ibczmin,ibczmax           ! BC type flag @zmin, zmax
C
      real bcxmin(iydim,izdim),bcxmax(iydim,izdim) ! xmin & xmax BC data
      real bcymin(ixdim,izdim),bcymax(ixdim,izdim) ! ymin & ymax BC data
      real bczmin(ixdim,iydim),bczmax(ixdim,iydim) ! zmin & zmax BC data
c
c  where BC data is not required, dummy scalars may be passed.
C  the ibc* flags determine whether BC data isneeded.
c
c  BC data not required for zonal or piecewise linear interpolation
c  for Hermite interpolation ibc* values from set {-1,0,1} are accepted.
c
c  BC data:  bcxmin & bcxmax:  BC vs. y,z @xmin,xmax
C            bcymin & bcymax:  BC vs. x,z @ymin,ymax
C            bczmin & bczmax:  BC vs. x,y @zmin,zmax
C
c   ibcxmin -- indicator for boundary condition at xmin=x(1):
c    bcxmin(...) -- boundary condition data
c     =-1 -- use periodic boundary condition
c     =0 -- use "not a knot"
c     =1 -- match slope, specified at x(1),y(iy),z(iz) by bcxmin(iy,iz)
c     =2 -- match 2nd derivative, specified at x(1),y(iy),z(iz)
c           by bcxmin(iy,iz
c     =3 -- boundary condition is slope=0 (df/dx=0) at x(1), all y(j)
c     =4 -- boundary condition is d2f/dx2=0 at x(1), all y(j)
c     =5 -- df/dx BC from 1st divided difference
c     =6 -- d2f/dx2 BC from 2nd divided difference (parabolic fit)
c     =7 -- d3f/dx3 BC from 3rd divided difference (cubic fit)
c   ***NOTE bcxmin(...) referenced ONLY if ibcxmin=1 or ibcxmin=2
c
c   ibcxmax -- indicator for boundary condition at x(nx):
c    bcxmax(...) -- boundary condition data
c     (interpretation as with ibcxmin, bcxmin)
c     NOTE:  if ibcxmin=-1 then the periodic BC applies on both sides
c            and ibcxmax, bcxmax are ignored.
c
c   interpretation of ibcymin,bcymin,ibcymax,bcymax
c     is same as with ibcxmin,...
c
c   interpretation of ibczmin,bczmin,ibczmax,bczmax
c     is same as with ibcxmin,...
c
c   the explicit bdy condition arrays are referenced only if the
c     corresponding "ibc" flag values are set > 0.
c
      integer ier                       ! exit code
c   ier -- completion code, 0 for normal
c
C-----------------------
      integer :: kspline
      integer :: ii,jj,imul,imin,imax,ickx,icky,ickz,inum
      integer :: idum1,idum2,idum3,idimcu
      integer :: ipx,ipy,ipz
      real :: ztol = 0.0001
      logical :: ifound(-1:2)

      real, dimension(:,:), allocatable :: wk2
      real, dimension(:,:,:), allocatable :: wk3
C-----------------------
c
      ier=0
c
      imin=3
      imax=-2
      imul=1
      inum=0
      idimcu=0
      ifound = .FALSE.

      do ii=1,3
         imin=min(imin,jspline(ii))
         imax=max(imax,jspline(ii))
         if(jspline(ii).gt.0) then
            idimcu=idimcu+1
            imul=imul*2
         endif
         if(.not.ifound(jspline(ii))) then
            ifound(jspline(ii)) = .TRUE.
            inum = inum+1
         endif
      enddo

      if((imin.lt.-1).or.(imax.gt.2)) then
         ier = 1
         write(6,*)
     >        ' ?mkintrp3d: spline type control out of range -1 to 2: ',
     >        jspline
      endif
      if(ier.ne.0) return

      if(inum.eq.1) then
         kspline=imin   ! same interp type on all dimensions
      else
         kspline=-99    ! hybrid
         if(ifound(1).and.ifound(2)) then
            ier = 1
            write(6,*)
     >           ' ?mkintrp3d: spline/Hermite hybrid not supported (',
     >           jspline,')'
         endif
      endif
      if(ier.ne.0) return
c
      if(imul.ne.icoeff) then
         write(6,*)
     >        ' ?coeff dimension inconsistency for spline type codes ',
     >        jspline
         write(6,*) ' in mkintrp3d: expected: ',imul,' got: ',icoeff
         ier=1
         return
      endif
c
c
c  check dimensioning consistency
c
      if(jspline(1).eq.-1) then
         ickx=nx-1
      else
         ickx=nx
      endif
c
      if(jspline(2).eq.-1) then
         icky=ny-1
      else
         icky=ny
      endif
c
      if(jspline(3).eq.-1) then
         ickz=nz-1
      else
         ickz=nz
      endif
c
      if((ickx.ne.ixdim).or.(icky.ne.iydim).or.(ickz.ne.izdim)) then
         write(6,*)
     >        ' ?mkintrp2d: dimensioning inconsistent with '//
     >        'interpolation controls: ',jspline
         write(6,*) '  expected: ',ickx,icky,ickz,
     >        '; got: ',ixdim,iydim,izdim
         ier=1
         return
      endif
c
      if(jspline(1).le.0) then
         call splinck(x,nx,idum1,ztol,ier)
         if(ier.ne.0) then
            write(6,*) ' ?mkintrp2d: x axis not strict ascending.'
            return
         endif
      endif
c
      if(jspline(2).le.0) then
         call splinck(y,ny,idum1,ztol,ier)
         if(ier.ne.0) then
            write(6,*) ' ?mkintrp2d: y axis not strict ascending.'
            return
         endif
      endif
c
      if(jspline(3).le.0) then
         call splinck(z,nz,idum1,ztol,ier)
         if(ier.ne.0) then
            write(6,*) ' ?mkintrp2d: z axis not strict ascending.'
            return
         endif
      endif
c
c  if no work to be done: exit now
      if(imul.eq.1) return
c
c  check Hermite BCs if necessary
c
      if(jspline(1).eq.1) then
         if((min(ibcxmin,ibcxmax).lt.-1).or.
     >        (max(ibcxmin,ibcxmax).gt.1)) then
            write(6,*) ' ?mkintrp2d: Bdy Cond code out of range for'
            write(6,*) '  Hermite interpolation; (-1:1) allowed, '//
     >           'found: ',ibcxmin,ibcxmax
            ier=1
            return
         endif
         ipx=0
         if(ibcxmin.eq.-1) then
            ipx=1
         else if((ibcxmin.eq.1).or.(ibcxmax.eq.1)) then
            ipx=2
         endif
      endif
c
      if(jspline(2).eq.1) then
         if((min(ibcymin,ibcymax).lt.-1).or.
     >        (max(ibcymin,ibcymax).gt.1)) then
            write(6,*) ' ?mkintrp2d: Bdy Cond code out of range for'
            write(6,*) '  Hermite interpolation; (-1:1) allowed, '//
     >           'found: ',ibcymin,ibcymax
            ier=1
            return
         endif
         ipy=0
         if(ibcymin.eq.-1) then
            ipy=1
         else if((ibcymin.eq.1).or.(ibcymax.eq.1)) then
            ipy=2
         endif
      endif
c
      if(jspline(3).eq.1) then
         if((min(ibczmin,ibczmax).lt.-1).or.
     >        (max(ibczmin,ibczmax).gt.1)) then
            write(6,*) ' ?mkintrp2d: Bdy Cond code out of range for'
            write(6,*) '  Hermite interpolation; (-1:1) allowed, '//
     >           'found: ',ibczmin,ibczmax
            ier=1
            return
         endif
         ipz=0
         if(ibczmin.eq.-1) then
            ipz=1
         else if((ibczmin.eq.1).or.(ibczmax.eq.1)) then
            ipz=2
         endif
      endif
c
      if(kspline.eq.1) then
         ! tricubic Hermite

         ! put the BCs inside the function data at the right locations...
         call util_bcherm3(f, ixdim, iydim, izdim,
     >        ibcxmin,ibcxmax, ibcymin,ibcymax, ibczmin,ibczmax,
     >        bcxmin, bcxmax,  bcymin, bcymax,  bczmin, bczmax,
     >        x, y, z)

         call akherm3p(x,ixdim, y,iydim, z,izdim, f,ixdim,iydim,
     >        idum1,idum2,idum3, ipx,ipy,ipz, ier)

      else if(kspline.eq.2) then
         ! tricubic Spline

         call mktricub(x,nx,y,ny,z,nz,
     >     f,ixdim,iydim,
     >     ibcxmin,bcxmin,ibcxmax,bcxmax,iydim,
     >     ibcymin,bcymin,ibcymax,bcymax,ixdim,
     >     ibczmin,bczmin,ibczmax,bczmax,ixdim,
     >     idum1,idum2,idum3, ier)

      else
         ! Hybrid
         if(idimcu.eq.1) then
            ! cubic along 1 dimension; other dims are step or pclin

            if(jspline(1).gt.0) then
                                ! cubic in x direction
               do jj=1,izdim
                  do ii=1,iydim
                     if(jspline(1).eq.1) then
                        call util_bcherm1(f(1,1,ii,jj), ixdim,
     >                       ibcxmin, ibcxmax,
     >                       bcxmin(ii,jj), bcxmax(ii,jj), x)
                        call akherm1p(x,ixdim,f(1,1,ii,jj),idum1,ipx,
     >                       ier)

                     else if(jspline(1).eq.2) then
                        call mkspline(x,ixdim,f(1,1,ii,jj),
     >                       ibcxmin,bcxmin(ii,jj),
     >                       ibcxmax,bcxmax(ii,jj),
     >                       idum1,ier)
                     endif
                     if(ier.ne.0) exit
                  enddo
                  if(ier.ne.0) exit
               enddo

            else if(jspline(2).gt.0) then
                                ! cubic in y direction
               allocate(wk2(2,ny))

               do jj=1,izdim
                  do ii=1,ixdim
                     wk2(1,1:iydim) = f(1,ii,1:iydim,jj)
                     wk2(2,1:iydim) = 0.0
                     if(jspline(2).eq.1) then
                        call util_bcherm1(wk2, iydim,
     >                       ibcymin, ibcymax,
     >                       bcymin(ii,jj), bcymax(ii,jj), y)
                        call akherm1p(y,iydim,wk2,idum2,ipy,ier)

                     else if(jspline(2).eq.2) then
                        call mkspline(y,iydim,wk2,
     >                       ibcymin,bcymin(ii,jj),
     >                       ibcymax,bcymax(ii,jj),
     >                       idum2,ier)

                     endif
                     if(ier.ne.0) exit
                     f(1:2,ii,1:iydim,jj) = wk2(1:2,1:iydim)
                  enddo
                  if(ier.ne.0) exit
               enddo

               deallocate(wk2)

            else
                                ! cubic in z direction
               allocate(wk2(2,nz))

               do jj=1,iydim
                  do ii=1,ixdim
                     wk2(1,1:izdim) = f(1,ii,jj,1:izdim)
                     wk2(2,1:izdim) = 0.0
                     if(jspline(3).eq.1) then
                        call util_bcherm1(wk2, izdim,
     >                       ibczmin, ibczmax,
     >                       bczmin(ii,jj), bczmax(ii,jj), z)
                        call akherm1p(z,izdim,wk2,idum2,ipz,ier)

                     else if(jspline(3).eq.2) then
                        call mkspline(z,izdim,wk2,
     >                       ibczmin,bczmin(ii,jj),
     >                       ibczmax,bczmax(ii,jj),
     >                       idum2,ier)

                     endif
                     if(ier.ne.0) exit
                     f(1:2,ii,jj,1:izdim) = wk2(1:2,1:izdim)
                  enddo
                  if(ier.ne.0) exit
               enddo

               deallocate(wk2)

            endif
         else
            ! cubic along 2 dimensions
            if(jspline(3).le.0) then
               do ii=1,izdim
                  if(jspline(1).eq.1) then
                     call util_bcherm2(f(1,1,1,ii),ixdim,iydim,
     >                    ibcxmin, ibcxmax, ibcymin, ibcymax,
     >                    bcxmin(1,ii), bcxmax(1,ii),
     >                    bcymin(1,ii), bcymax(1,ii),
     >                    x,y)
                     call akherm2p(x,ixdim,y,iydim,f(1,1,1,ii),ixdim,
     >                    idum1,idum2,ipx,ipy,ier)
                  else
                     call mkbicub(x,ixdim,y,iydim,f(1,1,1,ii),ixdim,
     >                    ibcxmin, bcxmin(1,ii), ibcxmax, bcxmax(1,ii),
     >                    ibcymin, bcymin(1,ii), ibcymax, bcymax(1,ii),
     >                    idum1,idum2,ier)
                  endif
                  if(ier.ne.0) exit
               enddo

            else if(jspline(2).le.0) then
               allocate(wk3(4,nx,nz))

               do ii=1,iydim
                  wk3 = f(1:4,1:nx,ii,1:nz)
                  if(jspline(1).eq.1) then
                     call util_bcherm2(wk3,ixdim,izdim,
     >                    ibcxmin, ibcxmax, ibczmin, ibczmax,
     >                    bcxmin(ii,1:nz), bcxmax(ii,1:nz),
     >                    bczmin(1,ii), bczmax(1,ii), x, z)
                     call akherm2p(x,ixdim,z,izdim,wk3,ixdim,
     >                    idum1,idum2,ipx,ipz,ier)
                  else
                     call mkbicub(x,ixdim,z,izdim,wk3,ixdim,
     >                    ibcxmin,bcxmin(ii,1:nz),
     >                    ibcxmax,bcxmax(ii,1:nz),
     >                    ibczmin,bczmin(1,ii), ibczmax,bczmax(1,ii),
     >                    idum1,idum2,ier)
                  endif
                  if(ier.ne.0) exit
                  f(1:4,1:nx,ii,1:nz) = wk3
               enddo

               deallocate(wk3)

            else
               allocate(wk3(4,ny,nz))

               do ii=1,ixdim
                  wk3 = f(1:4,ii,1:ny,1:nz)
                  if(jspline(2).eq.1) then
                     call util_bcherm2(wk3,iydim,izdim,
     >                    ibcymin, ibcymax, ibczmin, ibczmax,
     >                    bcymin(ii,1:nz), bcymax(ii,1:nz),
     >                    bczmin(ii,1:ny), bczmax(ii,1:ny), y, z)
                     call akherm2p(y,iydim,z,izdim,wk3,iydim,
     >                    idum1,idum2,ipy,ipz,ier)
                  else
                     call mkbicub(y,iydim,z,izdim,wk3,iydim,
     >                    ibcymin,bcymin(ii,1:nz),
     >                    ibcymax,bcymax(ii,1:nz),
     >                    ibczmin,bczmin(ii,1:ny),
     >                    ibczmax,bczmax(ii,1:ny),
     >                    idum1,idum2,ier)
                  endif
                  if(ier.ne.0) exit
                  f(1:4,ii,1:ny,1:nz) = wk3
               enddo

               deallocate(wk3)

            endif
         endif

      endif

      return
      end


subroutine driver( km, jm, im,                                &
         afc, dt, UpdateFreq, p, ps, Cpd, Cpv, Cl, Rv, Rd, Lv0, g, rowl, &
         elcrit, tlcrit, entp, sigd, sigs, omtrain, omtsnow,               &
         coeffr, coeffs, cu, beta, dtmax, alpha, damp,                    &
         t, q, theta, cbmf, tinc, qinc, tdot, qdot, precc )

! In
integer, intent(in)                      :: km,jm,im
!f2py intent(in,hide) km,jm,im

real(8), intent(in)                      :: afc, Cpd, Cpv, Cl, Rv, Rd, Lv0, g, rowl,      &
                                            dt, UpdateFreq,                               &
                                            elcrit,tlcrit,entp,sigd,sigs,omtrain,omtsnow, &
                                            coeffr,coeffs,cu,beta,dtmax,alpha,damp
real(8), intent(in), dimension(jm,im)    :: ps
real(8), intent(in), dimension(km,jm,im) :: p

! Out
real(8), intent(out), dimension(jm,im)    :: precc
real(8), intent(out), dimension(km,jm,im) :: tdot, qdot, tinc, qinc, theta

! In/out
real(8), dimension(jm,im)    :: cbmf
real(8), dimension(km,jm,im) :: t, q
!f2py intent(in,out) t, q, cbmf

! Local
real(8), dimension(km,jm,im) :: told, qold

told=t
qold=q

do i=1,im
do j=1,jm
call main(km, dt, t(:,j,i), q(:,j,i), p(:,j,i), ps(j,i),    &
     Cpd, Cpv, Cl, Rv, Rd, Lv0, g, rowl,              &
     elcrit,tlcrit,entp,sigd,sigs,omtrain,omtsnow,     &
     coeffr,coeffs,cu,beta,dtmax,alpha,damp,          &
     tinc(:,j,i), qinc(:,j,i),                        &
     tdot(:,j,i), qdot(:,j,i), precc(j,i), cbmf(j,i), theta(:,j,i))
enddo
enddo

tdot = ( (t-told)*(1.-2.*afc)/2./UpdateFreq + tdot ) * 86400.
qdot = ( (q-qold)*(1.-2.*afc)/2./UpdateFreq + qdot ) * 86400.

end subroutine driver


module pscore

  use types, only: dp

  implicit none

contains

  function computeP(chrom1, p1, chrom2, p2) result(p)
    use poisbinom

    integer, dimension(:, :), intent(in) :: chrom1
    real(dp), dimension(size(chrom1, 1), size(chrom1, 2)), intent(in) :: p1
    integer, dimension(:, :), intent(in) :: chrom2
    real(dp), dimension(size(chrom2, 1), size(chrom2, 2)), intent(in) :: p2

    real(dp), dimension(size(chrom1, 1), size(chrom2, 1)) :: p

    integer :: i, j

    !$omp parallel do collapse(2)
    do i = 1, size(chrom1, 1)
       do j = 1, size(chrom2, 1)
          p(i, j) = cdf(p1(i, :) * p2(j, :), dot_product(chrom1(i, :), chrom2(j, :)))
       end do
    end do
    !$omp end parallel do
  end function computeP

end module pscore


!-------------------------------------------------------------------------------
!
!+  Program ll2ico
!
!-------------------------------------------------------------------------------
program ll2ico
  !-----------------------------------------------------------------------------
  !
  !++ Description:
  !       This program is the conversion program from lat-lon data
  !       to icosahedral data.
  !
  !++ Current Code Owner: H.Tomita
  !
  !++ History:
  !      Version   Date       Comment
  !      -----------------------------------------------------------------------
  !      0.00      09-??-??   H.Tomita  : Add this program.
  !                12-06-04   R.Yoshida : add direct access output, and add "kmax=k+2"
  !                12-06-07   R.Yoshida : allow large number of record length
  !      -----------------------------------------------------------------------
  !
  !-----------------------------------------------------------------------------
  !
  !++ Used modules (shared)
  !
  use mod_adm, only : &
       ADM_NSYS,      &
       ADM_GALL_PL,   &
       ADM_LALL_PL
  use mod_grd, only : &
       GRD_XDIR,      &
       GRD_YDIR,      &
       GRD_ZDIR
  use mod_misc, only : &
       misc_get_available_fid,&
       misc_make_idstr, &
       MISC_get_latlon

  implicit none

  character(128) :: lldata_fname = 'restart_LLGDATA.dat'
  character(128) :: lldata_dim_fname = 'LLGDATA_dimension.info'
  !
  character(128) :: hgrid_fname = 'grid'
  character(128) :: output_data = 'rst'
  integer :: glevel = 5
  integer :: rlevel = 1
  integer :: num_of_rgn, num_of_gp

  integer :: ctl_fid, fid, fid_grd,fid_odat
  integer :: i,j,k,l,n,t
  character(ADM_NSYS) :: z_coordinate_type
  real(8), allocatable :: lon(:), lat(:), zh(:), z(:), dz(:)
  real(8), allocatable :: data(:,:,:)
  integer :: imax,jmax,kall, tmax, time_increment, kmax
  character(128) :: fname
  !
  integer :: ierr
  real(8),allocatable :: x_ico(:,:),lat_ico(:), lon_ico(:), data_ico(:,:)
  real(8),allocatable :: x_ico_pl(:,:,:),lat_ico_pl(:,:), lon_ico_pl(:,:), data_ico_pl(:,:,:)
  integer :: gall_1d
  real(8) :: dlon, dlat
  real(8) :: a,b,c,d
  !
  integer(8) :: irecl                        ! for long record length ! 12/06/07 R.Yoshida
  character(20) :: access_outdata = 'direct' ! 'direct' or 'sequential' ! 12/06/01 R.Yoshida
  logical :: read_conf = .false.

  namelist / ll2icoparam / &
       lldata_fname,       &
       lldata_dim_fname,   &
       hgrid_fname,        &
       output_data,        &
       access_outdata,     &
       glevel,             &
       rlevel,             &
       read_conf
  !
  !--- open and read configuration file
  ctl_fid = 10
  open(CTL_FID,               &
       file='ll2ico.cnf',     &
       form='formatted',      &
       status='old'           &
       )
  read(CTL_FID,nml=ll2icoparam,iostat=ierr)
  write(*,nml=ll2icoparam)
  if(ierr<0) then
     write(*,*) &
          'Msg : Prg[ll2ico]'
     write(*,*) &
          ' *** Not found namelist.'
     write(*,*) &
          ' *** Use default values.'
  else if(ierr>0) then
     write(*,*) &
          'Msg : Prg[ll2ico]'
     write(*,*) &
          ' *** WARNING : Not appropriate names in namelist!! CHECK!!'
  end if
  close(ctl_fid)
  !
  !---- read lat-lon-z-t dimension data
  fid = MISC_get_available_fid()
  open(fid,file=lldata_dim_fname,form='unformatted',status='old')
  !
  !------ longitude
  read(fid) imax
  allocate(lon(-1:imax+2))
  read(fid) lon(1:imax)
  !
  !------ latitude
  read(fid) jmax
  allocate(lat(jmax))
  read(fid) lat(:)
  !
  !------ z
  read(fid) z_coordinate_type
  read(fid) kall
  kmax = kall + 2       ! 12/06/04 R.Yoshida
  !allocate(zh(kall+1))  ! 12/06/04 R.Yoshida
  allocate(z(kmax))
  allocate(zh(kmax))
  read(fid) z(:)
  read(fid) zh(:)
  !
  allocate(dz(kall+1))
  !allocate(z(kall))  ! 12/06/04 R.Yoshida
  do k=1,kall+1
     !z(k) = 0.5D0*(zh(k+1)+zh(k))  ! 12/06/04 R.Yoshida
     dz(k) = abs(zh(k+1)-zh(k))
  end do
  !
  !------ time
  read(fid) tmax
  read(fid) time_increment
  !
  close(fid)
  !
  !--- debug info
  write(*,*) 'data structure :',imax,jmax,kall,kmax
  write(*,*) 'number of data :',tmax
  !
  !--- set incremental value and longitudinal hallo(2)
  dlon=(lon(imax)-lon(1))/(dble(imax)-1.0D0)
  dlat=(lat(jmax)-lat(1))/(dble(jmax)-1.0D0)
  lon(0) = lon(1)-dlon
  lon(-1) = lon(0)-dlon
  lon(imax+1) = lon(imax)+dlon
  lon(imax+2) = lon(imax+1)+dlon
  !
  !--- memory allocation for latlon data
  !allocate(data(-1:imax+2,jmax,kall))
  allocate(data(-1:imax+2,jmax,kmax))    ! 12/06/04 R.Yoshida
  !
  !--- setup icosahedral info and memory allocation
  num_of_rgn=(2**rlevel)*(2**rlevel)*10
  num_of_gp=(2**(glevel-rlevel)+2)*(2**(glevel-rlevel)+2)
  allocate(x_ico(num_of_gp,GRD_XDIR:GRD_ZDIR))
  allocate(lat_ico(num_of_gp))
  allocate(lon_ico(num_of_gp))
!  allocate(data_ico(num_of_gp,kall))
  allocate(data_ico(num_of_gp,kmax))    ! 12/06/04 R.Yoshida

  allocate(x_ico_pl(ADM_GALL_PL,ADM_LALL_PL,GRD_XDIR:GRD_ZDIR))
  allocate(lat_ico_pl(ADM_GALL_PL,ADM_LALL_PL))
  allocate(lon_ico_pl(ADM_GALL_PL,ADM_LALL_PL))
!  allocate(data_ico_pl(ADM_GALL_PL,kall,ADM_LALL_PL))
  allocate(data_ico_pl(ADM_GALL_PL,kmax,ADM_LALL_PL))    ! 12/06/04 R.Yoshida
  !
  !--- open latlon data
  fid = MISC_get_available_fid()
  irecl = int(imax,kind=8)*int(jmax,kind=8)*int(kmax,kind=8)*8_8    ! 12/06/07 R.Yoshida
!  open(fid,file=lldata_fname,form='unformatted',status='old')
!  open(fid,file=lldata_fname,form='unformatted',status='old',access='direct',recl=8*imax*jmax*kall)
  open(fid,file=lldata_fname,form='unformatted',status='old',access='direct',recl=irecl)    ! 12/06/04 R.Yoshida
  !
  write (*,'(A)') "---------------------------"  ! 12/06/01 R.Yoshida
  !
  !--- main loop
  do t=1,tmax
     !
     write (*,'(" Time Loop:",I4)') t   ! 12/06/07 R.Yoshida
     !
     !--- read data of 1 layer and fix to cyclic condition (longitudinal)
     read(fid,rec=t) data(1:imax,:,:)                                 ! 12/06/04 R.Yoshida
     if( read_conf ) write (*,'(" Read Conf. (t=",I4,", k=1)  Max:",F16.8," Min:",F16.8)') t, &  ! 12/06/01 R.Yoshida
     maxval(data(1:imax,:,:)), minval(data(1:imax,:,:))    ! 12/06/04 R.Yoshida
!     do k=1,kall
!        read(fid) data(1:imax,1:jmax,k)
!        if(k == 1)then  ! 12/06/01 R.Yoshida
!           write (*,'(" Read Conf. (t=",I3,", k=1)  Max:",F10.4," Min:",F10.4)') t, maxval(data), minval(data)
!        endif
!     end do
     data(0,:,:) = data(imax,:,:)
     data(-1,:,:) = data(imax-1,:,:)
     data(imax+1,:,:) = data(1,:,:)
     data(imax+2,:,:) = data(2,:,:)
     !
     !--- regular region
     do l = 1, num_of_rgn
        call MISC_make_idstr(fname,trim(hgrid_fname),'rgn',l)
        fid_grd = MISC_get_available_fid()
        open(fid_grd,file=trim(fname),status='old',form='unformatted',iostat=ierr)
        if(ierr/=0) then
           write(*,*) &
                '   *** No grid file.',trim(fname)
           stop
        end if
        read(fid_grd) gall_1d
        if(gall_1d**2/=num_of_gp) then
           write(*,*) 'inconsistent in number of gridpoint!'
           stop
        end if
        !
        read(fid_grd) x_ico(:,GRD_XDIR)
        read(fid_grd) x_ico(:,GRD_YDIR)
        read(fid_grd) x_ico(:,GRD_ZDIR)
        !
        !
        close(fid_grd)
        !
        !------ setup lat-lon on icosahedral gridpoints
        do n=1,num_of_gp
           call MISC_get_latlon(     &
                lat_ico(n), lon_ico(n),    &
                x_ico(n,GRD_XDIR), x_ico(n,GRD_YDIR), x_ico(n,GRD_ZDIR) )
        end do
        !
        !------ bi-linear interpolation
        do n=1, num_of_gp
           i = floor((lon_ico(n)-lon(1))/dlon)+1
           j = min(max(floor((lat_ico(n)-lat(1))/dlat)+1,1),jmax-1)
           a = (lon(i+1)-lon_ico(n))/dlon
           b = (lon_ico(n)-lon(i))/dlon
           c = (lat(j+1)-lat_ico(n))/dlat
           d = (lat_ico(n)-lat(j))/dlat
           !do k=1,kall
           do k=1,kmax       ! 12/06/04 R.Yoshida
              data_ico(n,k) &
                   = c*(a*data(i,j  ,k)+b*data(i+1,j  ,k)) &
                   + d*(a*data(i,j+1,k)+b*data(i+1,j+1,k))
           end do
        end do
        !
        !------ output
        call MISC_make_idstr(fname,trim(output_data),'rgn',l)
        fid_odat = MISC_get_available_fid()
!        open(fid_odat,file=trim(fname),access='append',form='unformatted')
        if ( access_outdata == 'sequential' ) then ! 12/06/01 R.Yoshida
           open(fid_odat,file=trim(fname),access='sequential',position='append', form='unformatted')
           write(fid_odat) data_ico(:,:)
        else
           !open(fid_odat,file=trim(fname),access='direct',recl=8*num_of_gp*kall,form='unformatted')
           open(fid_odat,file=trim(fname),access='direct',recl=8*num_of_gp*kmax,form='unformatted')   ! 12/06/04 R.Yoshida
           write(fid_odat, rec=t) data_ico(:,:)
        endif
        !
        close(fid_odat)
     end do
     !
     !--- pole region
     fname=trim(hgrid_fname)//'.pl'
     fid_grd = MISC_get_available_fid()
     open(fid_grd,file=trim(fname),status='old',form='unformatted',iostat=ierr)
     if(ierr/=0) then
        write(*,*) &
             '   *** No grid file.',trim(fname)
        stop
     end if
     !
     read(fid_grd) x_ico_pl(:,:,:)
     !
     close(fid_grd)
     !
     !------ setup lat-lon on icosahedral gridpoints
     do l=1,ADM_LALL_PL
        do n=1,ADM_GALL_PL
           call MISC_get_latlon(                    &
                lat_ico_pl(n,l), lon_ico_pl(n,l),    &
                x_ico_pl(n,l,GRD_XDIR), x_ico_pl(n,l,GRD_YDIR), x_ico_pl(n,l,GRD_ZDIR) )
        end do
     end do
     !
     !------ bi-linear interpolation
     do l=1,ADM_LALL_PL
        do n=1,ADM_GALL_PL
           i = floor((lon_ico_pl(n,l)-lon(1))/dlon)+1
           j = min(max(floor((lat_ico_pl(n,l)-lat(1))/dlat)+1,1),jmax-1)
           a = (lon(i+1)-lon_ico_pl(n,l))/dlon
           b = (lon_ico_pl(n,l)-lon(i))/dlon
           c = (lat(j+1)-lat_ico_pl(n,l))/dlat
           d = (lat_ico_pl(n,l)-lat(j))/dlat
           !do k=1,kall
           do k=1,kmax      ! 12/06/04 R.Yoshida
              data_ico_pl(n,k,l) &
                   = c*(a*data(i,j  ,k)+b*data(i+1,j  ,k)) &
                   + d*(a*data(i,j+1,k)+b*data(i+1,j+1,k))
           end do
        end do
     end do
     !
     !------ output
     fname=trim(output_data)//'.pl'
     fid_odat = MISC_get_available_fid()
!     open(fid_odat,file=trim(fname),access='append',form='unformatted')
     open(fid_odat,file=trim(fname),access='sequential',position='append',form='unformatted')
     write(fid_odat) data_ico_pl(:,:,:)
     close(fid_odat)
  end do
  !
  close(fid)

end program ll2ico


c
c ------------------------------------------------------------------
c
      subroutine errlen(f,g,irr,mitot,mjtot,dt,dx,dy,
     *                   lstgrd,mptr)
      implicit double precision (a-h,o-z)
      dimension f(mitot,mjtot,4),g(mitot,mjtot,4),irr(mitot,mjtot)
c
c     # irregular side modifications to fluxes for length only
c
      include "cirr.i"
c
c     # initialize fluxes at boundary to zero and set done array to false.
c     # done(k) is set to true when kth boundary cell is handled and is
c     # used to insure that interfaces between boundary cells
c     # are only handled once.
c
c
c     # modify fluxes on sides of irregular cells to reflect the fact that
c     # the length of each side may be less than the full dx or dy.
c     # (Recall that the fluxes f and g are the actual fluxes multiplied by
c     # the length of the side).
c
c     fix f first
      do 10 i = 2, mitot
      do 10 j = 2, mjtot
       if (irr(i,j) .eq. lstgrd .or. irr(i-1,j) .eq. lstgrd) then
	 f(i,j,1) = f(i,j,1)*dy
	 f(i,j,2) = f(i,j,2)*dy
	 f(i,j,3) = f(i,j,3)*dy
	 f(i,j,4) = f(i,j,4)*dy
       elseif (irr(i,j) .eq. -1 .or. irr(i-1,j) .eq. -1) then
	 f(i,j,1) = 0.d0
	 f(i,j,2) = 0.d0
	 f(i,j,3) = 0.d0
	 f(i,j,4) = 0.d0
c      else both of them are irregular. will recalc. in irreg3e
       endif
 10    continue
      do 20 i = 2, mitot
      do 20 j = 2, mjtot
       if (irr(i,j) .eq. lstgrd .or. irr(i,j-1) .eq. lstgrd) then
	 g(i,j,1) = g(i,j,1)*dx
	 g(i,j,2) = g(i,j,2)*dx
	 g(i,j,3) = g(i,j,3)*dx
	 g(i,j,4) = g(i,j,4)*dx
       elseif (irr(i,j) .eq. -1 .or. irr(i,j-1) .eq. -1) then
	 g(i,j,1) = 0.d0
	 g(i,j,2) = 0.d0
	 g(i,j,3) = 0.d0
	 g(i,j,4) = 0.d0
c      else both of them are irregular. will recalc. in irreg3e
       endif
 20    continue
c
	return
	end


 program main
 use dyn_tt
 integer :: d, rmax, nswp, verb, kickrank, Asize, Ysize, ntrials
 real(8) :: tau
 integer, allocatable :: n(:), m(:), ra(:), ry(:)
 complex(8), allocatable ::  crA(:), crY(:)
 double precision, allocatable ::  drA(:), drY(:)
 integer :: i
    open(unit=10,status='old',file='test_ksl.dat',form='unformatted',access='stream')
    !open(unit=10,status='old',file='test_eye_ksl.dat',form='unformatted',access='stream')
    read(10) d
    print *,'d=',d
    allocate(n(d))
    allocate(m(d))
    read(10) n(1:d)
    read(10) m(1:d)
    allocate(ra(d+1))
    allocate(ry(d+1))
    read(10) ra(1:d+1)
    read(10) ry(1:d+1)

    read(10) Asize
    allocate(crA(Asize))
    read(10) crA(1:Asize)

    allocate(drA(Asize))
    drA(:) = 0.0
    drA(:) = -1.0

    read(10) Ysize
    allocate(crY(Ysize))
    read(10) crY(1:Ysize)
    read(10) tau,rmax,kickrank,nswp,verb
    close(10)

    allocate(drY(Ysize))
    drY(:) = 1.0

    !Test if we read all correctly
    print *,'n=',n(1:d)
    print *,'m=',m(1:d)
    print *,'ra=',ra(1:d+1)
    print *,'ry=',ry(1:d+1)
    print *,'tau=',tau, 'rmax=',rmax,'kickrank=',kickrank,'nswp=',nswp,'verb=',verb

    ntrials = 10
    do while ( ntrials > 0 )
       call ztt_ksl(d,n,m,ra,crA, crY, ry, tau, rmax, kickrank, nswp, verb)
       ntrials = ntrials - 1
    end do
    ! Test real code as well
    ! ntrials = 10
    ! do while ( ntrials > 0 )
    !    call tt_ksl(d,n,m,ra,drA, drY, ry, tau, rmax, kickrank, nswp, verb)
    !    ntrials = ntrials - 1
    ! end do

    deallocate(n,m,ra,ry,crA, crY)
    deallocate(drA, drY)
 end program


      SUBROUTINE COLSOL (A,V,MAXA,NN,NWK,NNM,KKK,IOUT)                  COL00001
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . COL00002
C .                                                                   . COL00003
C .   P R O G R A M                                                   . COL00004
C .        TO SOLVE FINITE ELEMENT STATIC EQUILIBRIUM EQUATIONS IN    . COL00005
C .        CORE, USING COMPACTED STORAGE AND COLUMN REDUCTION SCHEME  . COL00006
C .                                                                   . COL00007
C .  - - INPUT VARIABLES - -                                          . COL00008
C .        A(NWK)    = STIFFNESS MATRIX STORED IN COMPACTED FORM      . COL00009
C .        V(NN)     = RIGHT-HAND-SIDE LOAD VECTOR                    . COL00010
C .        MAXA(NNM) = VECTOR CONTAINING ADDRESSES OF DIAGONAL        . COL00011
C .                    ELEMENTS OF STIFFNESS MATRIX IN A              . COL00012
C .        NN        = NUMBER OF EQUATIONS                            . COL00013
C .        NWK       = NUMBER OF ELEMENTS BELOW SKYLINE OF MATRIX     . COL00014
C .        NNM       = NN + 1                                         . COL00015
C .        KKK       = INPUT FLAG                                     . COL00016
C .            EQ. 1   TRIANGULARIZATION OF STIFFNESS MATRIX          . COL00017
C .            EQ. 2   REDUCTION AND BACK-SUBSTITUTION OF LOAD VECTOR . COL00018
C .        IOUT      = UNIT NUMBER USED FOR OUTPUT                    . COL00019
C .                                                                   . COL00020
C .  - - OUTPUT - -                                                   . COL00021
C .        A(NWK)    = D AND L - FACTORS OF STIFFNESS MATRIX          . COL00022
C .        V(NN)     = DISPLACEMENT VECTOR                            . COL00023
C .                                                                   . COL00024
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . COL00025
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               COL00026
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . COL00027
C .   THIS PROGRAM IS USED IN SINGLE PRECISION ARITHMETIC ON CRAY     . COL00028
C .   EQUIPMENT AND DOUBLE PRECISION ARITHMETIC ON IBM MACHINES,      . COL00029
C .   ENGINEERING WORKSTATIONS AND PCS. DEACTIVATE ABOVE LINE FOR     . COL00030
C .   SINGLE PRECISION ARITHMETIC.                                    . COL00031
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . COL00032
      DIMENSION A(NWK),V(NN),MAXA(NNM)                                  COL00033
C                                                                       COL00034
C     PERFORM L*D*L(T) FACTORIZATION OF STIFFNESS MATRIX                COL00035
C                                                                       COL00036
      IF (KKK-2) 40,150,150                                             COL00037
   40 DO 140 N=1,NN                                                     COL00038
      KN=MAXA(N)                                                        COL00039
      KL=KN + 1                                                         COL00040
      KU=MAXA(N+1) - 1                                                  COL00041
      KH=KU - KL                                                        COL00042
      IF (KH) 110,90,50                                                 COL00043
   50 K=N - KH                                                          COL00044
      IC=0                                                              COL00045
      KLT=KU                                                            COL00046
      DO 80 J=1,KH                                                      COL00047
      IC=IC + 1                                                         COL00048
      KLT=KLT - 1                                                       COL00049
      KI=MAXA(K)                                                        COL00050
      ND=MAXA(K+1) - KI - 1                                             COL00051
      IF (ND) 80,80,60                                                  COL00052
   60 KK=MIN0(IC,ND)                                                    COL00053
      C=0.                                                              COL00054
      DO 70 L=1,KK                                                      COL00055
   70 C=C + A(KI+L)*A(KLT+L)                                            COL00056
      A(KLT)=A(KLT) - C                                                 COL00057
   80 K=K + 1                                                           COL00058
   90 K=N                                                               COL00059
      B=0.                                                              COL00060
      DO 100 KK=KL,KU                                                   COL00061
      K=K - 1                                                           COL00062
      KI=MAXA(K)                                                        COL00063
      C=A(KK)/A(KI)                                                     COL00064
      B=B + C*A(KK)                                                     COL00065
  100 A(KK)=C                                                           COL00066
      A(KN)=A(KN) - B                                                   COL00067
  110 IF (A(KN)) 120,120,140                                            COL00068
  120 WRITE (IOUT,2000) N,A(KN)                                         COL00069
      GO TO 800                                                         COL00070
  140 CONTINUE                                                          COL00071
      GO TO 900                                                         COL00072
C                                                                       COL00073
C     REDUCE RIGHT-HAND-SIDE LOAD VECTOR                                COL00074
C                                                                       COL00075
  150 DO 180 N=1,NN                                                     COL00076
      KL=MAXA(N) + 1                                                    COL00077
      KU=MAXA(N+1) - 1                                                  COL00078
      IF (KU-KL) 180,160,160                                            COL00079
  160 K=N                                                               COL00080
      C=0.                                                              COL00081
      DO 170 KK=KL,KU                                                   COL00082
      K=K - 1                                                           COL00083
  170 C=C + A(KK)*V(K)                                                  COL00084
      V(N)=V(N) - C                                                     COL00085
  180 CONTINUE                                                          COL00086
C                                                                       COL00087
C     BACK-SUBSTITUTE                                                   COL00088
C                                                                       COL00089
      DO 200 N=1,NN                                                     COL00090
      K=MAXA(N)                                                         COL00091
  200 V(N)=V(N)/A(K)                                                    COL00092
      IF (NN.EQ.1) GO TO 900                                            COL00093
      N=NN                                                              COL00094
      DO 230 L=2,NN                                                     COL00095
      KL=MAXA(N) + 1                                                    COL00096
      KU=MAXA(N+1) - 1                                                  COL00097
      IF (KU-KL) 230,210,210                                            COL00098
  210 K=N                                                               COL00099
      DO 220 KK=KL,KU                                                   COL00100
      K=K - 1                                                           COL00101
  220 V(K)=V(K) - A(KK)*V(N)                                            COL00102
  230 N=N - 1                                                           COL00103
      GO TO 900                                                         COL00104
C                                                                       COL00105
  800 STOP                                                              COL00106
  900 RETURN                                                            COL00107
C                                                                       COL00108
 2000 FORMAT (//' STOP - STIFFNESS MATRIX NOT POSITIVE DEFINITE',//,    COL00109
     1          ' NONPOSITIVE PIVOT FOR EQUATION ',I8,//,               COL00110
     2          ' PIVOT = ',E20.12 )                                    COL00111
      END                                                               COL00112


!     Convolution with Intrumental, Rotationprofile and/or Makroturbulence

      SUBROUTINE convol(w,f,n,px,py,answ,fft,
     *                  vdop,gamma,expo,vsini,beta)
      INCLUDE 'physcnst.inc'

      REAL*4 vdop    ! Makroturbulence in cm/s
      REAL*4 expo    ! Makroturbulence in cm/s
      REAL*4 gamma   ! Gamma (Lorentzian) in cm
      REAL*4 vsini   ! Rotationprofile in cm/s
      REAL*4 beta    ! Limbdarkening Parameter (default is 1.5)

      REAL*8    xcen,x,x2
      REAL*8    w(n),px(n) , dw, a, width , fmean
      REAL*4    f(n),py(n) , offs
      REAL*4    answ(2*n)
      COMPLEX*8 fft(n)

      xcen    = (w(n)+w(1)) * .5D0
      dw      = (w(n)-w(1)) / DBLE(n-1)

      px(1)   = 0.
      px(n)   = -dw
      DO i  = 1,n/2-1
         px(n-i) = px(n-i+1) - dw
         px(i+1) = px(i)     + dw
      END DO
      px(n/2+1)  = px(n/2) + dw

      offs  = 0.5*(f(1)+f(n))
      DO i=1,n
        f(i) = f(i) - offs
      ENDDO

      fmean = DBLE(f(1) + f(n))*0.5D0
      DO i=2,n-1
         fmean = fmean + DBLE(f(i))
      ENDDO
      fmean = fmean / DBLE(n-1)

! -------------------------------- rotation ----------------------------
      IF (vsini.GT.0.) THEN
        IF (beta.LE.0.) beta = 1.5
        xnorm = C/(DBLE(vsini)*xcen)
        DO i    = 1,n/2+1
          x     = xnorm * px(i)
          IF(x .LT. 1.) THEN
            x2    = x*x
            py(i) =REAL(dw*(2.D0/PI*SQRT(1.D0-x2)+(1.D0-x2)
     *                 * beta * .5D0) * xnorm  /
     *                  (1.D0+ 0.66666666667D0 * DBLE(beta)))
            IF (i.GT.1) py(n-i+2) = py(i)
          ELSE
            py(i)     = 0.
            py(n-i+1) = 0.
          ENDIF
        END DO

        CALL convlv(f,py,n,+1,answ,fft)
        DO i=1,n
          f(i) = answ(i)  + REAL(fmean)
        ENDDO
      ENDIF
! -------------------------------- vdop ----------------------------
      IF (vdop.GT.0.) THEN
        width = xcen * DBLE(vdop) / C
        IF (gamma.GT.0.) THEN                     ! and gamma = VOIGT
          DO i    = 1,n/2+1
            a     = gamma/ width
            py(i) = REAL(dw*VOIGT(a,px(i)/width) / (SQRT_PI*width))
            IF (i.GT.1) py(n-i+2) = py(i)
          END DO
        ELSE
          DO i    = 1,n/2+1
            py(i) = REAL(dw*DEXP(-(px(i)/width)**2) / (SQRT_PI*width))
            IF (i.GT.1) py(n-i+2) = py(i)
          END DO
        ENDIF
        CALL convlv(f,py,n,+1,answ,fft)
        DO i=1,n
          f(i) = answ(i) + REAL(fmean)
        ENDDO
      ENDIF

! -------------------------------- exponential ----------------------------
      IF (expo.GT.0.) THEN
        width = DBLE(expo) / C  *  xcen
        DO i  = 1,n/2+1
          py(i) = REAL(dw*DEXP( -px(i) / width)  / (2.D0 * width))
          IF (i.GT.1) py(n-i+2) = py(i)
        END DO

        CALL convlv(f,py,n,+1,answ,fft)

        DO i=1,n
          f(i) = answ(i) + REAL(fmean)
        ENDDO
      ENDIF
! -------------------------------------------------------------------------

      DO i=1,n
        f(i) = f(i) + offs
      ENDDO

      RETURN
      END


subroutine calc_grain_sedimentation(j,t)

!***********************************************
! Compute sedimentation of grown grains inside embryo j at time t
!***********************************************

use embryodata
use eosdata, only: pi
implicit none

integer,intent(in) :: j
real,intent(in) :: t
real :: factor

! Define initial sedimentation timescale
embryo(j)%t_sed = embryo(j)%t_sed0

! Define remaining mass of dust not stripped
embryo(j)%msolids = embryo(j)%fg*embryo(j)%M

! Check if grains travelling above critical velocity for destructive collisions

IF(embryo(j)%t_sed < embryo(j)%R/vfrag) THEN
   embryo(j)%t_sed = embryo(j)%R/vfrag
ENDIF

!
! If grains self-gravitate, sedimentation is boosted
!

IF(embryo(j)%iself==1) THEN
   factor = 1.0 - 3.0*(t-embryo(j)%tself)/embryo(j)%t_sed
   ! If growth rate too fast for this timestep, assume Jeans instability forms the entire core
   if(factor< 0.0) then
      ! Assume core fully formed at 1 g cm-3 constant density (this circumstance should be avoided by timestep correction)
      embryo(j)%rg = embryo(j)%msolids/(1.333*pi*1.689e6)
   else
      ! Otherwise grow the core under self-gravity
      embryo(j)%rg = embryo(j)%rself*factor**0.333
   endif

else
   ! Case where no self gravity acts
   embryo(j)%rg = embryo(j)%rg*(1.0 - dt/embryo(j)%t_sed)
endif

if(embryo(j)%rg > embryo(j)%R) embryo(j)%rg = embryo(j)%R

! If Rg small enough that rho(grains) ~ rho(gas), mark core as self-gravitating, set rcore==Rg
if(embryo(j)%rg < (embryo(j)%fg**0.333)*embryo(j)%R .and. embryo(j)%iself==0.and.embryo(j)%ivap==0) then

   embryo(j)%iself=1
   embryo(j)%tself = t
   embryo(j)%rself = embryo(j)%rg
   embryo(j)%rcore = embryo(j)%rg

!   print*, 'Grains self-gravitating for embryo ',j,': ',embryo(j)%rself/udist,embryo(j)%tself/yr

endif

end subroutine calc_grain_sedimentation


      subroutine dkqg_tbqdk_gs(p,msqc)
      implicit none
************************************************************************
*     Author: J. Campbell, January 2012                                *
*                                                                      *
*     Calculates the subtraction term for radiation in the             *
*     top quark decay for the process                                  *
*                                                                      *
*     q(p1) + g(p2) -> t(e(p3)+nu(p4)+b(p5)+g(p8)) + b(p6) + q'(p7)    *
*                                                                      *
*     Top is kept strictly on-shell although all spin correlations     *
*     are retained.                                                    *
*                                                                      *
************************************************************************
      include 'constants.f'
      include 'masses.f'
      include 'ptilde.f'
      include 'qcdcouple.f'
      include 'alfacut.f'
      include 'incldip.f'
      double precision msq(-nf:nf,-nf:nf),msqc(maxd,-nf:nf,-nf:nf),
     . p(mxpart,4),q(mxpart,4),omz,z,fac,ptDpg,pbDpg,ptDpb,pwsq,xr,
     . y,ymax,dot
      integer j,k

      do j=-nf,nf
      do k=-nf,nf
      msqc(1,j,k)=0d0
      enddo
      enddo

      ndmax=1
      incldip(1)=.true.

      call wtransform_generic(p,3,4,5,8,q,pbDpg,ptDpg,ptDpb)

      pwsq=2d0*(q(3,4)*q(4,4)-q(3,1)*q(4,1)-q(3,2)*q(4,2)-q(3,3)*q(4,3))

c--- form of subtraction depends on whether b-quark in decay is massless or not
      if (abs(dot(p,5,5)) .lt. 1d-6) then
c----- massless case
        omz=ptDpg/(ptDpb+ptDpg-pbDpg)
        z=1d0-omz
        xr=dsqrt(pwsq/mt**2)
        ymax=(1d0+xr)**2*z*omz/(z+xr**2*omz)
        y=2d0*pbDpg/mt**2/(1d0-xr)**2
        if ((z .lt. 1d0-aff) .and. (y .gt. aff*ymax)) then
          incldip(1)=.false.
          return
        endif
        fac=gsq*cf*(1d0/pbDpg*(2d0/omz-1d0-z)-(mt/ptDpg)**2)
      else
c----- massive case
c-----  (no alpha-dependence at present)
        fac=gsq*cf*((mt**2+mb**2-pwsq)/(ptDpg*pbDpg)
     &             -(mt/ptDpg)**2-(mb/pbDpg)**2)
      endif

      call qg_tbqdk(q,msq)

      do j=-nf,nf
      do k=-nf,nf
      msqc(1,j,k)=fac*msq(j,k)
      enddo
      enddo

      return
      end


      SUBROUTINE slELUE (DATE, JFORM, EPOCH, ORBINC, ANODE,
     :                      PERIH, AORQ, E, AORL, DM,
     :                      U, JSTAT)
*+
*     - - - - - -
*      E L U E
*     - - - - - -
*
*  Transform conventional osculating orbital elements into "universal"
*  form.
*
*  Given:
*     DATE    d      epoch (TT MJD) of osculation (Note 3)
*     JFORM   i      choice of element set (1-3, Note 6)
*     EPOCH   d      epoch (TT MJD) of the elements
*     ORBINC  d      inclination (radians)
*     ANODE   d      longitude of the ascending node (radians)
*     PERIH   d      longitude or argument of perihelion (radians)
*     AORQ    d      mean distance or perihelion distance (AU)
*     E       d      eccentricity
*     AORL    d      mean anomaly or longitude (radians, JFORM=1,2 only)
*     DM      d      daily motion (radians, JFORM=1 only)
*
*  Returned:
*     U       d(13)  universal orbital elements (Note 1)
*
*               (1)  combined mass (M+m)
*               (2)  total energy of the orbit (alpha)
*               (3)  reference (osculating) epoch (t0)
*             (4-6)  position at reference epoch (r0)
*             (7-9)  velocity at reference epoch (v0)
*              (10)  heliocentric distance at reference epoch
*              (11)  r0.v0
*              (12)  date (t)
*              (13)  universal eccentric anomaly (psi) of date, approx
*
*     JSTAT   i      status:  0 = OK
*                            -1 = illegal JFORM
*                            -2 = illegal E
*                            -3 = illegal AORQ
*                            -4 = illegal DM
*                            -5 = numerical error
*
*  Called:  slUEPV, slPVUE
*
*  Notes
*
*  1  The "universal" elements are those which define the orbit for the
*     purposes of the method of universal variables (see reference).
*     They consist of the combined mass of the two bodies, an epoch,
*     and the position and velocity vectors (arbitrary reference frame)
*     at that epoch.  The parameter set used here includes also various
*     quantities that can, in fact, be derived from the other
*     information.  This approach is taken to avoiding unnecessary
*     computation and loss of accuracy.  The supplementary quantities
*     are (i) alpha, which is proportional to the total energy of the
*     orbit, (ii) the heliocentric distance at epoch, (iii) the
*     outwards component of the velocity at the given epoch, (iv) an
*     estimate of psi, the "universal eccentric anomaly" at a given
*     date and (v) that date.
*
*  2  The companion routine is slUEPV.  This takes the set of numbers
*     that the present routine outputs and uses them to derive the
*     object's position and velocity.  A single prediction requires one
*     call to the present routine followed by one call to slUEPV;
*     for convenience, the two calls are packaged as the routine
*     slPLNE.  Multiple predictions may be made by again calling the
*     present routine once, but then calling slUEPV multiple times,
*     which is faster than multiple calls to slPLNE.
*
*  3  DATE is the epoch of osculation.  It is in the TT timescale
*     (formerly Ephemeris Time, ET) and is a Modified Julian Date
*     (JD-2400000.5).
*
*  4  The supplied orbital elements are with respect to the J2000
*     ecliptic and equinox.  The position and velocity parameters
*     returned in the array U are with respect to the mean equator and
*     equinox of epoch J2000, and are for the perihelion prior to the
*     specified epoch.
*
*  5  The universal elements returned in the array U are in canonical
*     units (solar masses, AU and canonical days).
*
*  6  Three different element-format options are available:
*
*     Option JFORM=1, suitable for the major planets:
*
*     EPOCH  = epoch of elements (TT MJD)
*     ORBINC = inclination i (radians)
*     ANODE  = longitude of the ascending node, big omega (radians)
*     PERIH  = longitude of perihelion, curly pi (radians)
*     AORQ   = mean distance, a (AU)
*     E      = eccentricity, e (range 0 to <1)
*     AORL   = mean longitude L (radians)
*     DM     = daily motion (radians)
*
*     Option JFORM=2, suitable for minor planets:
*
*     EPOCH  = epoch of elements (TT MJD)
*     ORBINC = inclination i (radians)
*     ANODE  = longitude of the ascending node, big omega (radians)
*     PERIH  = argument of perihelion, little omega (radians)
*     AORQ   = mean distance, a (AU)
*     E      = eccentricity, e (range 0 to <1)
*     AORL   = mean anomaly M (radians)
*
*     Option JFORM=3, suitable for comets:
*
*     EPOCH  = epoch of perihelion (TT MJD)
*     ORBINC = inclination i (radians)
*     ANODE  = longitude of the ascending node, big omega (radians)
*     PERIH  = argument of perihelion, little omega (radians)
*     AORQ   = perihelion distance, q (AU)
*     E      = eccentricity, e (range 0 to 10)
*
*  7  Unused elements (DM for JFORM=2, AORL and DM for JFORM=3) are
*     not accessed.
*
*  8  The algorithm was originally adapted from the EPHSLA program of
*     D.H.P.Jones (private communication, 1996).  The method is based
*     on Stumpff's Universal Variables.
*
*  Reference:  Everhart & Pitkin, Am.J.Phys. 51, 712 (1983).
*
*  Last revision:   8 September 2005
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION DATE
      INTEGER JFORM
      DOUBLE PRECISION EPOCH,ORBINC,ANODE,PERIH,AORQ,E,AORL,DM,U(13)
      INTEGER JSTAT

*  Gaussian gravitational constant (exact)
      DOUBLE PRECISION GCON
      PARAMETER (GCON=0.01720209895D0)

*  Sin and cos of J2000 mean obliquity (IAU 1976)
      DOUBLE PRECISION SE,CE
      PARAMETER (SE=0.3977771559319137D0,
     :           CE=0.9174820620691818D0)

      INTEGER J

      DOUBLE PRECISION PHT,ARGPH,Q,W,CM,ALPHA,PHS,SW,CW,SI,CI,SO,CO,
     :                 X,Y,Z,PX,PY,PZ,VX,VY,VZ,DT,FC,FP,PSI,
     :                 UL(13),PV(6)

*  Validate arguments.
      IF (JFORM.LT.1.OR.JFORM.GT.3) THEN
         JSTAT = -1
         GO TO 9999
      END IF
      IF (E.LT.0D0.OR.E.GT.10D0.OR.(E.GE.1D0.AND.JFORM.NE.3)) THEN
         JSTAT = -2
         GO TO 9999
      END IF
      IF (AORQ.LE.0D0) THEN
         JSTAT = -3
         GO TO 9999
      END IF
      IF (JFORM.EQ.1.AND.DM.LE.0D0) THEN
         JSTAT = -4
         GO TO 9999
      END IF

*
*  Transform elements into standard form:
*
*  PHT   = epoch of perihelion passage
*  ARGPH = argument of perihelion (little omega)
*  Q     = perihelion distance (q)
*  CM    = combined mass, M+m (mu)

      IF (JFORM.EQ.1) THEN

*     Major planet.
         PHT = EPOCH-(AORL-PERIH)/DM
         ARGPH = PERIH-ANODE
         Q = AORQ*(1D0-E)
         W = DM/GCON
         CM = W*W*AORQ*AORQ*AORQ

      ELSE IF (JFORM.EQ.2) THEN

*     Minor planet.
         PHT = EPOCH-AORL*SQRT(AORQ*AORQ*AORQ)/GCON
         ARGPH = PERIH
         Q = AORQ*(1D0-E)
         CM = 1D0

      ELSE

*     Comet.
         PHT = EPOCH
         ARGPH = PERIH
         Q = AORQ
         CM = 1D0

      END IF

*  The universal variable alpha.  This is proportional to the total
*  energy of the orbit:  -ve for an ellipse, zero for a parabola,
*  +ve for a hyperbola.

      ALPHA = CM*(E-1D0)/Q

*  Speed at perihelion.

      PHS = SQRT(ALPHA+2D0*CM/Q)

*  In a Cartesian coordinate system which has the x-axis pointing
*  to perihelion and the z-axis normal to the orbit (such that the
*  object orbits counter-clockwise as seen from +ve z), the
*  perihelion position and velocity vectors are:
*
*    position   [Q,0,0]
*    velocity   [0,PHS,0]
*
*  To express the results in J2000 equatorial coordinates we make a
*  series of four rotations of the Cartesian axes:
*
*           axis      Euler angle
*
*     1      z        argument of perihelion (little omega)
*     2      x        inclination (i)
*     3      z        longitude of the ascending node (big omega)
*     4      x        J2000 obliquity (epsilon)
*
*  In each case the rotation is clockwise as seen from the +ve end of
*  the axis concerned.

*  Functions of the Euler angles.
      SW = SIN(ARGPH)
      CW = COS(ARGPH)
      SI = SIN(ORBINC)
      CI = COS(ORBINC)
      SO = SIN(ANODE)
      CO = COS(ANODE)

*  Position at perihelion (AU).
      X = Q*CW
      Y = Q*SW
      Z = Y*SI
      Y = Y*CI
      PX = X*CO-Y*SO
      Y = X*SO+Y*CO
      PY = Y*CE-Z*SE
      PZ = Y*SE+Z*CE

*  Velocity at perihelion (AU per canonical day).
      X = -PHS*SW
      Y = PHS*CW
      Z = Y*SI
      Y = Y*CI
      VX = X*CO-Y*SO
      Y = X*SO+Y*CO
      VY = Y*CE-Z*SE
      VZ = Y*SE+Z*CE

*  Time from perihelion to date (in Canonical Days: a canonical day
*  is 58.1324409... days, defined as 1/GCON).

      DT = (DATE-PHT)*GCON

*  First approximation to the Universal Eccentric Anomaly, PSI,
*  based on the circle (FC) and parabola (FP) values.

      FC = DT/Q
      W = (3D0*DT+SQRT(9D0*DT*DT+8D0*Q*Q*Q))**(1D0/3D0)
      FP = W-2D0*Q/W
      PSI = (1D0-E)*FC+E*FP

*  Assemble local copy of element set.
      UL(1) = CM
      UL(2) = ALPHA
      UL(3) = PHT
      UL(4) = PX
      UL(5) = PY
      UL(6) = PZ
      UL(7) = VX
      UL(8) = VY
      UL(9) = VZ
      UL(10) = Q
      UL(11) = 0D0
      UL(12) = DATE
      UL(13) = PSI

*  Predict position+velocity at epoch of osculation.
      CALL slUEPV(DATE,UL,PV,J)
      IF (J.NE.0) GO TO 9010

*  Convert back to universal elements.
      CALL slPVUE(PV,DATE,CM-1D0,U,J)
      IF (J.NE.0) GO TO 9010

*  OK exit.
      JSTAT = 0
      GO TO 9999

*  Quasi-impossible numerical errors.
 9010 CONTINUE
      JSTAT = -5

 9999 CONTINUE
      END


program ave
 implicit none
 real    :: ener(0:60), ener_0, free, entropy(1:59),entro
 real    :: temperature =2000
 integer :: i,j,k
 open(111,file='energies')
 open(222,file='entropy')
 ener = 0
 do
  read(111,*,iostat=k) j, ener_0
  if (k/=0) exit
  ener(j)=ener(j)+ener_0/4.0
 end do
 ener(0)=4*ener(0)
 ener(60)=4*ener(60)
 do i =0,60
  if(i/=0.and.i/=60) then
   read(222,*) j,entro
   entropy(j)=entro
  end if
  write(6,*)i,ener(i),entropy(i),ener(i)-entropy(i)*temperature
 end do
end program


!*******************Valery Model****************************************
subroutine DVMPW(COST, W, Q2, Phi_g, E, heli, MESONMASS, &
        sigma0, S_T, S_L, S_TT, S_LT, S_LTP)
    !
    !  dsigma/dQ2 dphi dCosTheta* dW for ep-->ep pi0
    !
    !  exc pi0 x-section
    !
    !input:
    ! COST = Cos(Theta*), Theta* is the angle (pi0-gamma* or  p-p')in the CM system
    ! W is W
    ! xb,Q2 x and Q^2 (GeV^2)
    ! Phi_g angle in the photon frame (radians)
    ! E energy of the electron in GeV
    ! heli electron helicity -1.0 or +1.0
    !
    !del2=t (negative GeV^2)           NEGATIVE !!!!
    !
    ! MESONMASS is the mass of the pi0 or eta.
    ! The actual masses that will be used for the calculations are in pi0eta.par file

    IMPLICIT NONE
    REAL    COST, W, del2, xb, Q2, Phi_g, E, heli, mesonmass
    REAL    Mp, mele, pi
    parameter (Mp = 0.93827)
    parameter (mele = 0.000511)
    parameter (pi = 3.1415926536)

    REAL     sigma0, S_T, S_L, S_LT, S_TT, S_LTP
    REAL     SIGMA_T, SIGMA_L, SIGMA_LT, SIGMA_TT, SIGMA_LTP
    REAL     EPS, EPSILON, FLUXW, SIGMA_TOT
    EXTERNAL EPSILON, SIGMA_T, SIGMA_L, SIGMA_LT, SIGMA_TT
    EXTERNAL SIGMA_LTP
    REAL     JACG, JACR
    LOGICAL  CHECK_KINE
    !      REAL DVMPX
    INCLUDE 'pi0eta_new.par'
    !

    CALL XSINIT(MESONMASS)

    !
    S_T = 0.0
    S_L = 0.0
    S_LT = 0.0
    S_TT = 0.0
    S_LTP = 0.0
    IF(.NOT.CHECK_KINE(COST, W, Q2, E, del2, xb, JACG, JACR)) RETURN
    EPS = EPSILON(XB, q2, e)
    S_T = 0.001 / (2. * PI) * SIGMA_T   (COST, W, Q2, E)
    S_L = 0.001 / (2. * PI) * SIGMA_L   (COST, W, Q2, E)
    S_LT = 0.001 / (2. * PI) * 2.0 * SIGMA_LT  (COST, W, Q2, E)
    S_TT = 0.001 / (2. * PI) * SIGMA_TT  (COST, W, Q2, E)
    S_LTP = 0.001 / (2. * PI) * 2.0 * SIGMA_LTP (COST, W, Q2, E)

    !
    !       sigma0 =0.000001*FLUXW(xb,Q2,E)/(2.*PI)*JACG*(
    sigma0 = 1 / (2. * PI) * (&
            S_T + EPS * S_L + &
                    EPS * S_TT * COS(2 * PHI_G) + &
                    SQRT(2. * EPS * (1. + EPS)) * S_LT * COS(PHI_G) + &
                    HELI * SQRT(2. * EPS * (1. - EPS)) * S_LTP * SIN(2 * PHI_G)&
            )

    IF (sigma0.LT.0.0) then
        sigma0 = 0.0
        S_T = 0.0
        S_L = 0.0
        S_LT = 0.0
        S_TT = 0.0
        S_LTP = 0.0
    ENDIF
    !       PRINT *,DVMPW,COST,W,Q2,del2,xb,phi_g,JACG,JACR
    !      PRINT *,DVMPX(del2,xb,Q2, Phi_g,E,heli,MESONMASS)*JACG*JACR
    !      PRINT *,DVMPX(del2,xb,Q2, Phi_g,E,heli,MESONMASS)
    !      PRINT *,del2,xb,Q2, Phi_g,E,heli,MESONMASS

    !       PRINT *,DVMPW,COST,W,Q2,phi_g,eps
    !       print *,'DVMP',sigma0, S_T,S_L,S_TT,S_LT
    !       print *,'S_TT  ',  S_TT, EPS     *S_TT  * COS(2*PHI_G)
    !       print *, 'S_LT ',S_LT,SQRT(2.*EPS*(1.+EPS))*S_LT  * COS(PHI_G)

    RETURN
END

!====================================================================================c

REAL FUNCTION SIGMA_T(COST, W, Q2, E)
    IMPLICIT NONE
    REAL          COST, W, del2, x, Q2, E
    EXTERNAL      tminq
    REAL          tminq, T0, SLOPE, T, JACG, JACR
    LOGICAL       CHECK_KINE
    EXTERNAL      XSIGMA_T
    REAL          XSIGMA_T

    IF(CHECK_KINE(COST, W, Q2, E, del2, x, JACG, JACR)) THEN
        SIGMA_T = JACR * XSIGMA_T(del2, x, Q2, E)
    ELSE
        SIGMA_T = 0.0
    ENDIF
    RETURN
END
!=============================================================
REAL FUNCTION SIGMA_L(COST, W, Q2, E)
    IMPLICIT NONE
    REAL          COST, W, del2, x, Q2, E
    EXTERNAL      tminq
    REAL          tminq, T0, SLOPE, T, JACG, JACR
    LOGICAL CHECK_KINE
    EXTERNAL      XSIGMA_L
    REAL          XSIGMA_L

    IF(CHECK_KINE(COST, W, Q2, E, del2, x, JACG, JACR)) THEN
        SIGMA_L = JACR * XSIGMA_L(del2, x, Q2, E)
    ELSE
        SIGMA_L = 0.0
    ENDIF
    RETURN
END

!=============================================================
REAL FUNCTION SIGMA_TT(COST, W, Q2, E)
    IMPLICIT NONE
    REAL          COST, W, del2, x, Q2, E
    EXTERNAL      tminq
    REAL          tminq, T0, SLOPE, T, JACG, JACR
    LOGICAL CHECK_KINE
    EXTERNAL      XSIGMA_TT
    REAL          XSIGMA_TT

    IF(CHECK_KINE(COST, W, Q2, E, del2, x, JACG, JACR)) THEN
        SIGMA_TT = JACR * XSIGMA_TT(del2, x, Q2, E)
    ELSE
        SIGMA_TT = 0.0
    ENDIF
    RETURN
END

!=============================================================
REAL FUNCTION SIGMA_LT(COST, W, Q2, E)
    IMPLICIT NONE
    REAL          COST, W, del2, x, Q2, E
    EXTERNAL      tminq
    REAL          tminq, T0, SLOPE, T, JACG, JACR
    LOGICAL CHECK_KINE
    EXTERNAL      XSIGMA_LT
    REAL          XSIGMA_LT

    IF(CHECK_KINE(COST, W, Q2, E, del2, x, JACG, JACR)) THEN
        SIGMA_LT = JACR * XSIGMA_LT(del2, x, Q2, E)
    ELSE
        SIGMA_LT = 0.0
    ENDIF
    RETURN
END

!====================================================================================c

REAL FUNCTION SIGMA_LTP(COST, W, Q2, E)
    IMPLICIT NONE
    REAL COST, W, del2, x, Q2, E
    REAL EPS, EPSILON, A2_PHI, FLUXW, SIGMA_TOT
    EXTERNAL EPSILON, FLUXW

    SIGMA_LTP = 0.

    RETURN
END

!====================================================================================c

LOGICAL FUNCTION CHECK_KINE(COST, W, Q2, E, del2, xb, JACG, JACR)
    IMPLICIT NONE
    REAL COST, W, del2, xb, Q2, E, JACG, JACR
    real Mp, mele, pi, mpi0
    real fluxw, rxs
    parameter (Mp = 0.93827)
    parameter (mele = 0.000511)
    parameter (pi = 3.1415926536)

    real nu, W2, qmod, E1cm, P1cm, E2cm, P2cm, del2max, del2min
    real  xmin1, xmax1
    real y, e1, epsilon
    INCLUDE 'pi0eta_new.par'

    MPI0 = AM(K)

    CHECK_KINE = .FALSE.
    W2 = W * W
    XB = Q2 / (W2 + Q2 - Mp * Mp)
    nu = (W2 + Q2 - Mp * Mp) / (2 * Mp)
    qmod = sqrt(nu**2 + Q2)
    IF(W         .LT. Mp + Mpi0)              RETURN
    IF(W         .GT. -Q2 + 2 * Mp * E + Mp * Mp)     RETURN
    IF(Q2 / (4 * E * (E - NU)) .GE. 1.0)            RETURN
    IF(XB        .LT. Q2 / (2 * Mp * E))          RETURN
    IF(ABS(COST) .GT. 1.0)                  RETURN
    xmin1 = Q2 / (2.0 * Mp * E)
    xmax1 = 1.0

    E1cm = Mp * (Mp + nu) / W
    E2cm = (W2 + Mp**2 - Mpi0**2) / (2D0 * W)
    IF(E1cm.LE.Mp .OR. E2cm.LE. Mp) RETURN
    P1cm = Mp * qmod / W
    P2cm = SQRT(E2CM**2 - Mp**2)
    del2max = 2.0 * (Mp**2 - E1cm * E2cm - P1cm * P2cm)
    del2min = 2.0 * (Mp**2 - E1cm * E2cm + P1cm * P2cm)
    del2 = del2min - 2. * P1cm * P2cm * (1 - COST)
    IF(xb.le.xmin1 .or. xb.gt.xmax1)         return   !    x  out of range
    IF(del2.ge.del2min .or. del2.le.del2max) return   ! delta out of range

    y = Q2 / (2 * Mp * xb * E)
    e1 = (y * xb * Mp)**2 / Q2
    EPSILON = (1.0 - y - e1) / (1 - y + y**2 / 2 + e1)

    IF(EPSILON.LT.0. .OR.EPSILON .GT.1.)         RETURN

    !      jacobian
    !      JAC=4*P1cm*P2CM*W*XB/(W2+Q2-Mp*Mp)
    JACG = 2 * W * XB / (W2 + Q2 - Mp * Mp)
    JACR = 2 * P1cm * P2CM

    CHECK_KINE = .TRUE.

    RETURN
END

!=======================================================================================C

SUBROUTINE XSINIT(MESONMASS)
    IMPLICIT NONE
    REAL MESONMASS
    INCLUDE 'pi0eta.par'

    IF(MESONMASS.GT.0.140) THEN
        K=2
    ELSE
        K=1
    ENDIF

    RETURN
END

LOGICAL FUNCTION XCHECK_KINE(del2,xb,Q2,E)
    IMPLICIT NONE
    REAL del2,xb,Q2,E
    real Mp, mele, pi,mpi0
    real fluxw, rxs
    parameter (Mp=0.93827)
    parameter (mele=0.000511)
    parameter (pi=3.1415926536)

    real nu,W2,W,qmod,E1cm,P1cm,E2cm,P2cm,del2max,del2min
    real  xmin1,xmax1
    real y, e1, epsilon

    INCLUDE 'pi0eta.par'

    MPI0=AM(K)
    XCHECK_KINE=.FALSE.
    xmin1 = Q2/(2.0*Mp*E)
    xmax1 = 1.0
    nu  = Q2/(2D0*Mp*xb)
    W2  = Mp**2 + 2.0*Mp*nu - Q2
    IF(W2.LT.(Mp+Mpi0)**2)                               RETURN
    W   = sqrt(W2)
    qmod = sqrt(nu**2 + Q2)

    E1cm = Mp*(Mp + nu)/W
    P1cm = Mp*qmod/W
    E2cm = (W2 + Mp**2-Mpi0**2)/(2.*W)
    IF(E2cm.LE.Mp)                             RETURN
    P2cm = SQRT(E2CM**2 - Mp**2)
    del2max = 2.0*(Mp**2 - E1cm*E2cm - P1cm*P2cm)
    del2min = 2.0*(Mp**2 - E1cm*E2cm + P1cm*P2cm)

    IF( xb.le.xmin1 .or. xb.gt.xmax1 )         return   !    x  out of range
    IF( del2.ge.del2min .or. del2.le.del2max ) return   ! delta out of range

    y=Q2/(2*Mp*xb*E)
    e1=(y*xb*Mp)**2/Q2
    EPSILON=(1.0-y-e1)/(1-y+y**2/2+e1)

    IF(EPSILON.LT.0. .OR.EPSILON .GT.1.)         RETURN

    XCHECK_KINE=.TRUE.

    RETURN
END

REAL FUNCTION XSIGMA_LT(del2,x,Q2,E)
    IMPLICIT NONE
    REAL          del2,x,Q2,E
    EXTERNAL      tminq
    REAL          tminq,T0,SLOPE,T
    LOGICAL XCHECK_KINE
    INCLUDE 'pi0eta.par'

    IF(XCHECK_KINE(del2,x,Q2,E)) THEN
        T0=tminq(Q2,X)
        SLOPE = 2.*1.1*ALOG(X)
        T=-DEL2
        XSIGMA_LT=P(9,k)*SQRT(T-T0)*EXP(SLOPE*T*P(10,k))*X**P(11,k)*(1-X)**P(12,k)/(Q2+P(13,k))**P(14,k)
    ELSE
        XSIGMA_LT=0.0
    ENDIF
    RETURN
END

REAL FUNCTION XSIGMA_LTP(del2,x,Q2,E)
    IMPLICIT NONE
    REAL del2,x,Q2,E
    REAL EPS, EPSILON,A2_PHI,FLUXW,SIGMA_TOT
    EXTERNAL EPSILON,FLUXW
    INCLUDE 'pi0eta.par'

    XSIGMA_LTP=0.

    RETURN
END

REAL FUNCTION tminq(Q2,X)
    IMPLICIT NONE
    REAL Q2,X
    REAL W2,W,S,E1CM,E3CM,P1CM,P3CM,TMAX
    INTEGER I
    real alpha,Mp,PI,Me
    REAL MPI0

    INCLUDE 'pi0eta.par'

    MPI0=AM(K)
    tminq=0.

    Mp=0.9382723
    Me=0.0051
    PI=3.14151926

    IF(X.LE.0. .OR. X.GE.1.)        RETURN
    W2 = Q2*(1./X-1.)+Mp**2
    W=SQRT(W2)
    IF(W.LT.Mp+Mpi0)                RETURN

    E1CM=(W2+Q2+Mp**2)/(2*W)
    P1CM=SQRT(E1CM**2-MP**2)

    E3CM=(W2-MPI0**2+Mp**2)/(2*W)
    P3CM=SQRT(E3CM**2-MP**2)

    TMINQ=-((Q2+MPI0**2)**2/4./W2-(P1CM-P3CM)**2)

    RETURN
END

REAL FUNCTION XSIGMA_L(del2,x,Q2,E)
    IMPLICIT NONE
    REAL          del2,x,Q2,E
    EXTERNAL      tminq
    REAL          tminq,T0,SLOPE,T
    LOGICAL XCHECK_KINE
    INCLUDE 'pi0eta.par'

    IF(XCHECK_KINE(del2,x,Q2,E)) THEN
        T0=tminq(Q2,X)
        SLOPE = 2.*1.1*ALOG(X)
        T=-DEL2
        XSIGMA_L=Q2*(P(4,k)+P(5,k)*(T-T0))*EXP(SLOPE*T*P(6,k))*X**P(11,k)*(1-X)**P(12,k)/(Q2+P(13,k))**P(14,k)
    ELSE
        XSIGMA_L=0.0
    ENDIF
    RETURN
END

REAL FUNCTION XSIGMA_T(del2,x,Q2,E)
    IMPLICIT NONE
    REAL          del2,x,Q2,E
    EXTERNAL      tminq
    REAL          tminq,T0,SLOPE,T
    LOGICAL       XCHECK_KINE
    INCLUDE 'pi0eta.par'

    IF(XCHECK_KINE(del2,x,Q2,E)) THEN
        T0=tminq(Q2,X)
        SLOPE = 2.*1.1*ALOG(X)
        T=-DEL2
        XSIGMA_T=(P(1,k)+P(2,k)*SQRT(T-T0))*EXP(SLOPE*T*P(3,k))*X**P(11,k)*(1-X)**P(12,k)/(Q2+P(13,k))**P(14,k)
    ELSE
        XSIGMA_T=0.0
    ENDIF
    RETURN
END

REAL FUNCTION XSIGMA_TT(del2,x,Q2,E)
    IMPLICIT NONE
    REAL          del2,x,Q2,E
    EXTERNAL      tminq
    REAL          tminq,T0,SLOPE,T
    LOGICAL XCHECK_KINE
    INCLUDE 'pi0eta.par'

    IF(XCHECK_KINE(del2,x,Q2,E)) THEN
        T0=tminq(Q2,X)
        SLOPE = 2.*1.1*ALOG(X)
        T=-DEL2
        XSIGMA_TT=P(7,k)*(T-T0)*EXP(SLOPE*T*P(8,k))*X**P(11,k)*(1-X)**P(12,k)/(Q2+P(13,k))**P(14,k)
    ELSE
        XSIGMA_TT=0.0
    ENDIF
    RETURN
END

real function EPSILON(x,Q2,E)
    implicit none
    real x,Q2,E,y,eps,e1
    real alpha,Mp,PI
    parameter (alpha=1.0/137.036,Mp=0.93827231,PI=3.14151926)

    y=Q2/(2*Mp*x*E)
    e1=(y*x*Mp)**2/Q2
    EPSILON=(1.0-y-e1)/(1-y+y**2/2+e1)
    return
end


!==========================================================================
elemental function gsw_enthalpy_t_exact (sa, t, p)
!==========================================================================
!
! Calculates the specific enthalpy of seawater
!
! sa     : Absolute Salinity                               [g/kg]
! t      : in-situ temperature                             [deg C]
! p      : sea pressure                                    [dbar]
!
! gsw_enthalpy_t_exact : specific enthalpy                 [J/kg]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_gibbs

use gsw_mod_teos10_constants, only : gsw_t0

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, t, p

real (r8) :: gsw_enthalpy_t_exact

integer, parameter :: n0=0, n1=1

gsw_enthalpy_t_exact = gsw_gibbs(n0,n0,n0,sa,t,p) - &
				(t+gsw_t0)*gsw_gibbs(n0,n1,n0,sa,t,p)

return
end function

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