module setup_m
    !! Routines for doing allocation, etc. in preparation for simulation run.

use constants_m
use strings_m
use random_m
use logger_m
use simbox_m
use atmcfg_m
use config_io_m
use control_m
use stats_m
use interaction_m
use trajectory_m
use bd_solver_m

implicit none

contains

!*******************************************************************************

subroutine run(cpar, job_tag)

    type(ctrlpar_t),  intent(in) :: cpar
    character(len=*), intent(in) :: job_tag
        !! This string will be used as is, i.e. if there are leading or trailing
        !! white spaces, they will appear in any I/O file names.
    character(len=:), allocatable :: fn
    character(len=128) :: msg
    integer(ip_long) :: ccbeg, ccend, crate
    integer(ip_long) :: nts
    type(smbx_t)     :: simbox
    type(atmcfg_t)   :: atc
    integer :: ierr
    logical :: lexists

    ierr =0

    !Read configuration from appropriate files.
    !Note: Reading from file includes initialization of the simulation box and
    !atom configuration.
    if ( cpar%lrevive ) then
        !Restarting simulation: Read revive file
        fn = cpar%fn_revive//job_tag
        call read_dump(nts, simbox, atc, fn)
        call logger%log_msg('read revive file `'//fn//'`')
    else
        !New simulation: Read initial configuration file
        fn = cpar%fn_cfg//job_tag
        call read_config(simbox, atc, fn)
        call logger%log_msg('read config file `'//fn//'`')
        nts = 0
    end if

    !Allocate memory for forces. Forces are not saved in revive file or
    !in config file as they can be calculated from position data.
    allocate( atc%forces(3,atc%num_atoms) )
    atc%forces = 0.0_rp

    !Initialize stats collection
    call stats_init(cpar, simbox, atc, job_tag)
    call logger%log_msg('initialized stats collection')

    !Set up interactions
    call ia_setup(cpar, simbox, atc)
    call logger%log_msg('set up interaction params')

    !Set up trajectory if necessary. There can be only one trajectory per
    !simulation.
    if (cpar%write_traj) then
        fn = cpar%fn_traj//job_tag
        if (cpar%lrevive) then
            !Append/write to existing/new trajectory file
            !Check if trajectory file exists
            inquire(file=fn, exist=lexists)
            if (lexists) then
                !Open existing file for appending
                call traj%init(fn, 'rw', ierr)
                if (ierr /=0 ) then
                    call logger%log_msg('failed to open trajectory file ' &
                        //'`'//fn//'`')
                    call finish(atc); return
                else
                    call logger%log_msg('trajectory file opened')
                end if
            else
                !Create new trajectory file
                call traj%init(fn, atc%num_atoms, [integer:: 1, 0, 0, 0])
                call logger%log_msg('trajectory file created')
            end if
        else
            !Create new trajectory file
            call traj%init(fn, atc%num_atoms, [integer:: 1, 0, 0, 0])
            call logger%log_msg('trajectory file created')
        end if
    end if

    !Initialize random number generator
    if (cpar%read_seed) then
        call init_stream('random_seed.txt'//job_tag)
    else
        call init_stream('')
    end if
    if (cpar%write_seed) call save_seed('random_seed.txt'//job_tag)
    call logger%log_msg('rng initialized')

    !Set up solver.
    call bds_init(cpar, atc%num_atoms, job_tag, ierr)
    if (ierr /= 0) then
        call logger%log_msg('bd solver initialization failed')
        call finish(atc); return
    end if
    call logger%log_msg('bd solver initialized')

    call system_clock(ccbeg, crate)

    call bds_run(nts, simbox, atc, ierr)

    call system_clock(ccend, crate)

    write(msg,'(a,es12.5)') 'execution time(s) = ', (ccend-ccbeg)/real(crate,rp)

    call logger%log_msg(msg)

    call finish(atc)

    end subroutine

!*******************************************************************************

subroutine finish(atc)

    type(atmcfg_t), intent(in out) :: atc

    call bds_finish()
    call traj%delete()
    call ia_finish()
    call stats_finish()
    call atmcfg_delete(atc)

    end subroutine

!*******************************************************************************

end module setup_m


module m_nbr_lists

use m_precision
use m_vector
use m_table
use m_globals

implicit none

private

public :: verlet_init, verlet_build, verlet_delete, &
            atbo_build, atan_build, atdh_build, exat_build
public :: verlet_tab, atbo_tab, atan_tab, atdh_tab, exat_tab

type(itable_t) :: verlet_tab
    !! Verlet table
type(itable_t) :: atbo_tab
    !! Atoms -> bonds table
type(itable_t) :: atan_tab
    !! Atoms -> angles table
type(itable_t) :: atdh_tab
    !! Atoms -> dihedrals table
type(itable_t) :: atat_tab
    !! Atoms -> bonded atoms table (1-ring)
type(itable_t) :: exat_tab
    !! Atoms -> excluded atoms (from vdw calculation) table
real(rp), dimension(:,:), allocatable :: coordinates_save
    !!  (3, *num_atoms*) array
real(rp), dimension(:,:), allocatable :: coordinates_dr
    !!  (3, *num_atoms*) array

real(rp) :: rskin_sq = 0.0_rp
real(rp) :: tskin_sq = 0.0_rp

contains

!******************************************************************************

subroutine verlet_init(rskin, tskin)

    real(rp), intent(in) :: rskin
    real(rp), intent(in) :: tskin

    rskin_sq = rskin**2
    tskin_sq = tskin**2

    call itbl_init(verlet_tab, num_atoms)

    allocate( coordinates_save(3,num_atoms) )
    allocate( coordinates_dr(3,num_atoms)   )

    !Initializing to zero
    coordinates_save = 0.0_rp
    coordinates_dr = 0.0_rp

    end subroutine

!******************************************************************************

subroutine verlet_delete()

    if (allocated(coordinates_save)) deallocate(coordinates_save)
    if (allocated(coordinates_dr)  ) deallocate(coordinates_dr)
    call verlet_tab%delete()

    end subroutine

!******************************************************************************

subroutine verlet_build()

    real(rp), dimension(3) :: ri
    real(rp), dimension(3) :: rj
    real(rp), dimension(3) :: rij
    real(rp) :: dr_sq_max
    real(rp) :: rij_sq
    logical, save :: first_call = .true.
    integer :: i, j

    !On first call no check for rebuilding
    if (.not. first_call) then
        !Check whether rebuilding the list is necessary
        coordinates_dr = coordinates - coordinates_save
        dr_sq_max = maxval(sum(coordinates_dr**2, dim=1))
        if ( 4*dr_sq_max < tskin_sq ) then
            return
        !else
        !    print*, nblks, nts, 4*dr_sq_max
        end if
    end if

    first_call = .false.

    !Clear table
    call verlet_tab%clear()

    !Loop over all pairs to build list (different from MD type table)
    do i = 1, num_atoms
        ri = coordinates(:,i)
        do j = 1, num_atoms
            if ( exat_tab%is_in(i,j) ) cycle
            rj = coordinates(:,j)
            rij = rj - ri
            rij_sq = sum(rij**2)
            if (rij_sq < rskin_sq) call verlet_tab%append(i,j)
        end do
    end do

    !Release additional memory
    call verlet_tab%shrink_to_fit()

    !Back up positions
    coordinates_save = coordinates

    end subroutine

!********************************************************************************

subroutine atbo_build()

    type(ivector_t), dimension(:), allocatable :: buf_map
    integer :: iatm, jatm, ibnd
    integer :: i, j

    !Build table as list of lists
    allocate(buf_map(num_atoms))
    do iatm = 1, num_atoms
        call ivector_init(buf_map(iatm))
    end do

    do ibnd = 1, num_bonds
        iatm = bonds(2,ibnd)
        jatm = bonds(3,ibnd)
        call buf_map(iatm)%append(ibnd)
        call buf_map(jatm)%append(ibnd)
    end do

    !Sort in ascending order
    do iatm = 1, num_atoms
        if (buf_map(iatm)%len > 1) call buf_map(iatm)%sort()
    end do

    !Copy over to table
    call itbl_init(atbo_tab, num_atoms)
    do iatm = 1, num_atoms
        do j = 1, buf_map(iatm)%len
            jatm = buf_map(iatm)%get_val(j)
            call atbo_tab%append(iatm, jatm)
        end do
    end do

    !Delete list of lists table
    do iatm = 1, num_atoms
        call buf_map(iatm)%delete()
    end do
    deallocate(buf_map)

    !Release additional memory
    call atbo_tab%shrink_to_fit()

    end subroutine

!********************************************************************************

subroutine atan_build()

    type(ivector_t), dimension(:), allocatable :: buf_map
    integer :: iatm, jatm, katm, iang
    integer :: i, j

    !Build table as list of lists
    allocate(buf_map(num_atoms))
    do iatm = 1, num_atoms
        call ivector_init(buf_map(iatm))
    end do

    do iang = 1, num_angles
        iatm = angles(2,iang)
        jatm = angles(3,iang)
        katm = angles(4,iang)
        call buf_map(iatm)%append(iang)
        call buf_map(jatm)%append(iang)
        call buf_map(katm)%append(iang)
    end do

    !Sort in ascending order
    do iatm = 1, num_atoms
        if (buf_map(iatm)%len > 1) call buf_map(iatm)%sort()
    end do

    !Copy over to table
    call itbl_init(atan_tab, num_atoms)
    do iatm = 1, num_atoms
        do j = 1, buf_map(iatm)%len
            jatm = buf_map(iatm)%get_val(j)
            call atan_tab%append(iatm, jatm)
        end do
    end do

    !Delete list of lists table
    do iatm = 1, num_atoms
        call buf_map(iatm)%delete()
    end do
    deallocate(buf_map)

    !Release additional memory
    call atan_tab%shrink_to_fit()

    end subroutine

!********************************************************************************

subroutine atdh_build()

    type(ivector_t), dimension(:), allocatable :: buf_map
    integer :: iatm, jatm, katm, latm, idhd
    integer :: i, j

    !Build table as list of lists
    allocate(buf_map(num_atoms))
    do iatm = 1, num_atoms
        call ivector_init(buf_map(iatm))
    end do

    do idhd = 1, num_dihedrals
        iatm = dihedrals(2,idhd)
        jatm = dihedrals(3,idhd)
        katm = dihedrals(4,idhd)
        latm = dihedrals(5,idhd)
        call buf_map(iatm)%append(idhd)
        call buf_map(jatm)%append(idhd)
        call buf_map(katm)%append(idhd)
        call buf_map(latm)%append(idhd)
    end do

    !Sort in ascending order
    do iatm = 1, num_atoms
        if (buf_map(iatm)%len > 1) call buf_map(iatm)%sort()
    end do

    !Copy over to table
    call itbl_init(atdh_tab, num_atoms)
    do iatm = 1, num_atoms
        do j = 1, buf_map(iatm)%len
            jatm = buf_map(iatm)%get_val(j)
            call atdh_tab%append(iatm, jatm)
        end do
    end do

    !Delete list of lists table
    do iatm = 1, num_atoms
        call buf_map(iatm)%delete()
    end do
    deallocate(buf_map)

    !Release additional memory
    call atdh_tab%shrink_to_fit()

    end subroutine

!********************************************************************************

subroutine atat_build()

    integer, dimension(:), pointer :: inc_bonds => null()
    type(ivector_t) :: excl_atms
    integer :: iatm, jatm, jbnd, jbnd_atm1, jbnd_atm2
    integer :: i, j

    !Initialize table
    call itbl_init(atat_tab, num_atoms)
    !List of excluded atoms
    call ivector_init(excl_atms)

    do iatm = 1, num_atoms
        call excl_atms%clear()
        !Get incident bonds
        call atbo_tab%get_row(iatm, inc_bonds)
        !Add atoms from each of the incident bonds, excluding iatom
        do j = 1, size(inc_bonds)
            jbnd = inc_bonds(j)
            jbnd_atm1 = bonds(2,jbnd)
            jbnd_atm2 = bonds(3,jbnd)
            if (jbnd_atm1 /= iatm) call excl_atms%append(jbnd_atm1)
            if (jbnd_atm2 /= iatm) call excl_atms%append(jbnd_atm2)
        end do
        !Sort and remove duplicates. These are the atoms in the 1-ring.
        call excl_atms%unique()

        !Add to atat_tab. Note that iatm does not appear in the atat table
        !for iatm.
        do j = 1, excl_atms%len
            jatm = excl_atms%get_val(j)
            call atat_tab%append(iatm, jatm)
        end do
    end do

    !Release additional memory
    call atat_tab%shrink_to_fit()

    end subroutine

!********************************************************************************

subroutine exat_build()

    integer, dimension(:), pointer :: nbr_atms => null()
    integer, dimension(:), pointer :: nbr2_atms => null()
    integer, dimension(:), pointer :: nbr3_atms => null()
    type(ivector_t) :: excl_atms
    integer :: iatm, jatm, j2atm, j3atm
    integer :: i, j, j2, j3

    !Build atat_tab. This is the 1-ring neighborhood of each atom.
    call atat_build()
    call atat_tab%shrink_to_fit()

    !Debug statements
    !print*, 'ATAT_TAB'
    !call atat_tab%print()

    !Initialize table
    call itbl_init(exat_tab, num_atoms)
    !List of excluded atoms
    call ivector_init(excl_atms)

    do iatm = 1, num_atoms
        call excl_atms%clear()
        if (excluded_atoms > 0) then
            !Get atoms in 1-ring neighborhood
            call atat_tab%get_row(iatm, nbr_atms)
            !Add atoms to excluded atoms list. First adding iatm itself.
            call excl_atms%append(iatm)
            do j = 1, size(nbr_atms)
                jatm = nbr_atms(j)
                call excl_atms%append(jatm)
                !Atoms for second ring neighbors
                if (excluded_atoms > 1) then
                    call atat_tab%get_row(jatm, nbr2_atms)
                    do j2 = 1, size(nbr2_atms)
                        j2atm = nbr2_atms(j2)
                        call excl_atms%append(j2atm)
                        !Atoms for third ring neighbors
                        if (excluded_atoms > 2) then
                            call atat_tab%get_row(j2atm, nbr3_atms)
                            do j3 = 1, size(nbr3_atms)
                                j3atm = nbr3_atms(j3)
                                call excl_atms%append(j3atm)
                            end do
                            !Finished adding all third ring neighbors
                        end if
                    end do
                    !Finished adding all second ring neighbors
                end if
                !Finished adding all first ring neighbors
            end do
        end if

        !Sort and remove duplicates
        call excl_atms%unique()

        !Add to exat_tab. Note that iatom appears in the excluded atoms list for
        !iatom.
        do j = 1, excl_atms%len
            jatm = excl_atms%get_val(j)
            call exat_tab%append(iatm, jatm)
        end do
    end do

    !Release additional memory
    call exat_tab%shrink_to_fit()

    !atat_tab no longer required
    call atat_tab%delete()

    end subroutine

!********************************************************************************

end module m_nbr_lists


module AbstractBiotaModule
    use Globals, only: dp
    implicit none

    type, abstract, public :: AbstractBiota
        character(len=256)  :: ref                                  !! Reference for this instance
        character(len=100)  :: name                                 !! Name of this organism
        integer             :: biotaIndex                           !! Index of this biota index in database, TODO deprecate and deal with data better
        real(dp)            :: C_active                             !! Concentration of nanomaterial in biota [kg/kg dw]
        real(dp)            :: C_stored                             !! Concentration of nanomaterial in biota stored fraction [kg/kg dw]
        real(dp)            :: k_uptake_np                          !! Uptake constant [/day]
        real(dp)            :: k_uptake_transformed                 !! Uptake constant [/day]
        real(dp)            :: k_uptake_dissolved                   !! Uptake constant [/day]
        real(dp)            :: k_elim_np                            !! Elimination constant [/day]
        real(dp)            :: k_elim_transformed
        real(dp)            :: k_elim_dissolved
        real(dp)            :: k_growth                             !! Growth dilution rate [/day]
        real(dp)            :: k_death
        real(dp)            :: storedFraction                       !! Stored fraction of namoaterial [-]
        character(len=17)   :: uptakeFromForm                       !! What form (free, attached) to uptake from. Options: free, attached, free_and_attached
        integer             :: harvestInMonth                       !! Month to harvest biota, i.e. set C_org to zero

      contains
        procedure, public :: create => createAbstractBiota
        procedure, public :: update => updateAbstractBiota
        procedure, public :: parseInputData => parseInputDataAbstractBiota
    end type

  contains

    function createAbstractBiota(me, biotaIndex) result(rslt)
        use ResultModule, only: Result
        class(AbstractBiota)    :: me
        integer                 :: biotaIndex
        type(Result)            :: rslt
    end function

    function updateAbstractBiota(me, t, C_env_np, C_env_transformed, C_env_dissolved) result(rslt)
        use ResultModule, only: Result
        class(AbstractBiota)    :: me
        integer                 :: t
        real(dp)                :: C_env_np(:,:,:)
        real(dp)                :: C_env_transformed(:,:,:)
        real(dp)                :: C_env_dissolved
        type(Result) :: rslt
    end function

    function parseInputDataAbstractBiota(me) result(rslt)
        use ResultModule, only: Result
        class(AbstractBiota)    :: me
        type(Result)            :: rslt
    end function

end module


      SUBROUTINE STA01
CSTA01
C           SUBROUTINE STA01
C
C     ESTABLISH FIRST STATOR EXIT FLOW, ADJUST FLOWS FOR COOLING
C        AIR INJECTION BETWEEN STATIONS 0 AND 1, FIND INLET
C        MACH NUMBER AND INCIDENCE ANGLE LOSS AT STATION 0,
C        ADJUST PT, GET NEW FLOW AT STATION 1 FOR FINAL RESULT.
C
      REAL MFSTOP
      LOGICAL PREVER
      COMMON /SNTCP/G,AJ,PRPC,ICASE,PREVER,MFSTOP,JUMP,LOPIN,ISCASE,
     1 K,GAMF,IP,SCRIT,PTRN,ISECT,KSTG,WTOL,RHOTOL,PRTOL,TRLOOP,LSTG,
     2LBRC,IBRC,ICHOKE,ISORR,CHOKE,PT0PS1(6,8),PTRS2(6,8),TRDIAG,SC,RC,
     3DELPR,PASS,IPC,LOPC,ISS
      COMMON /SINIT/H1(6,8),H2(6,8),DP0(6,8),DP1(6,8),DP1A(6,8),DP2(6,8)
     1,DP2A(6,8),CSALF1(6,8),ALF1(6,8),CSBET2(6,8),BET2(6,8),RADSD(6,8),
     2RADRD(6,8),ANN1(6,8),ANN2(6,8),ANN2A(6,8),ANN1A(6,8),U1A(6,8),
     3U2(6,8),ANN0(6,8),PT0(6,8),TT0(6,8),ALPHA0(6,8),PTP(6,8)
C
      COMMON /SINPUT/
     1PTPS,PTIN,TTIN,WAIR,FAIR,DELC,DELL,DELA,AACS,VCTD,STG,SECT,EXPN,
     2EXPP,EXPRE,RG,RPM,PAF,SLI,STGCH,ENDJOB,XNAME(20),TITLE(20),
     3PCNH(6),GAM(6,8),DR(6,8),DT(6,8),RWG(6,8),ALPHAS(6,8),ALPHA1(6,8),
     4ETARS(6,8),ETAS(6,8),CFS(6,8),ANDO(6,8),BETA1(6,8),BETA2(6,8),ETAR
     5R(6,8),ETAR(6,8),CFR(6,8),TFR(6,8),ANDOR(6,8),OMEGAS(6,8),AS0(6,8)
     6,ASMP0(6,8),ACMN0(6,8),A1(6,8),A2(6,8),A3(6,8),A4(6,8),A5(6,8),A6(
     76,8),OMEGAR(6,8),BSIA(6,8),BSMPIA(6,8),BCMNIA(6,8),B1(6,8),B2(6,8)
     8,B3(6,8),B4(6,8),B5(6,8),B6(6,8),SESTHI(8),RERTHI(8)
     9,fairx(5,8),wairx(5,8),rg1(8),rg1a(8),rg2(8),rg2a(8)
C
      REAL M0
      COMMON /SSTA01/CP0(8),w0(6),               PS0(6,8),V0(6,8),TS0(6,
     18),VU0(6,8),VZ0(6,8),RHOS0(6,8),PS1(6,8),WGT1(8),TA1(8),WG1(6,8),
     2            DPDR1(6,8),SI(6,8),  CP1(8),PHI1(6,8),TS1(6,8),V1(6,8)
     3,RHOS1(6,8),ALF1E(6,8),VU1(6,8),VZ1(6,8),M0(6,8)
C
      COMMON/DESOPT/RVU1(6,8),RVU2(6,8),WG,EPR
      COMMON/TPT1/PT1(6),TT1(6,8)
C     COMMON    WGT0(1),TA0(1),WG0(6,1),TT0TS0(6,1),PT0PS0(6,1),FFA0(6,1
C    1),AAS0(6,1)
C replaced by ....
      COMMON /FSTA01/ WGT0(1),TA0(1),WG0(6,1),TT0TS0(6,1),PT0PS0(6,1),
     1FFA0(6,1),AAS0(6,1)
      COMMON/SLSHFT/STRF1(6,8),STRF2(6,8),UPSI1(6)
      dimension tangms(6,8),tangmr(6,8),tangm1(6,8),tangm2(6,8),tang0(6)
      common/slope/tangms,tangmr,tangm1,tangm2,tang0,iar,icyl
      COMMON /TDIL/TWG (6,8),pwg(6,8)
C     COMMON RES(6),PCNFS(6),        DTT(6),DPT(6)
C replaced by ...............................................6/4/09
      COMMON RES(8),PCNFS(6),        DTT(6),DPT(6)
      DIMENSION PCNF(6,8)
      DIMENSION PTPPS0(6)
      EQUIVALENCE (STRF1     ,PCNF)
C
C     print *,'  Entering in sta01.f.......modified..22 continue...'
      PI=3.14159
      SCRIT=0.0
      wtol01=2.e-5
      WR=RWG(2,K)
      TWGF=0.
      IF(TWG(2,K).GT.0.) TWGF=1.
      WPREV=0.0

      IF(WG.gt.0) then
        WD1=RWG(2,K)*WG
        A1(1,1)=PI/4.*(DT(2,K)**2-DR(2,K)**2)
        FFA1=WD1/A1(1,1)*SQRT(TT1(IP,K))/PT0(IP,K)
      endif

      ID=-1
      WGT1(K)=0.0
      JW=1
      PCNFS(1)=PCNH(1)/2.
      IF(RVU1(1,K).EQ.0.) FFA1=FFA1/CSALF1(IP,K)

      DO I=1,ISECT
        PT1(I)=PT0(I,K)
C        print *,'   PT1(',I,')=',PT1(I),'    in sta01...DO loop 1.'
        TT1(I,K)=TT0(I,K)

        if (twgf.gt.0.0) then
          ttm=(tt0(i,k)+(wr-1.)*twg(2,k))/wr
          tpp=(ttm+tt0(i,k))/2.
          tpc=(ttm+twg(2,k))/2.
          call cpa(ptin,tpc,0.0,0.0,cpc)
          call gama(ptin,tpp,fair,wair,gamtpp)
          extpp=gamtpp/(gamtpp-1.)
          cpp=rg*extpp/aj
          tt1(i,k)=(cpp*tt0(i,k)+(wr-1.)*cpc*twg(2,k))/(cpp+(wr-1.)*cpc)
        end if

        IF(I.NE.1) then
          PCNFS(I)=(PCNH(I)+PCNH(I-1))/2.+PCNFS(I-1)
        endif
      enddo

      KF=ISECT-1
      CALL BESFIT(ISECT,PCNFS,TT0(1,K),KF,DTT,RES)
      ITT=KF+1

      KF=ISECT-1
      CALL BESFIT(ISECT,PCNFS,PT0(1,K),KF,DPT,RES)
      IPT=KF+1

      I=IP

      IF(GAMF.le.0) then
        TA1(K)=.95*TT0(IP,K)
        CALL GAMA(PTIN,TA1(K),FAIRx(2,k),WAIRx(2,k),GAM(2,K))
      endif

      IF(WG.gt.0) then
        EXI=GAM(2,K)/(GAM(2,K)-1.)
        CP1(K)=rg1(k)*EXI/AJ
        VUOT=RVU1(IP,K)**2/CP1(K)/DP1(IP,K)**2/TT1(IP,K)/G/AJ*2.
        PRUP=1./(1.-(GAM(2,K)-1.+2.*VUOT)/(GAM(2,K)+1.)/ETAR(IP,K))**EXI
        PRLOW=1.
        CALL PRATIO(FFA1,GAM(2,K),rg1(k),PT0PS1(I ,K),PRTOL,
     1              ETAS(I ,K),VUOT,k)
      endif
C..........................
      LOOPCOUNT = 1

3     continue
      CALL FLOW1(I)
      IF (PREVER) return

C     print *,'  WGT1(K)=',WGT1(K),'  WG1(I,K) =',WG1(I,K)
      WGT1(K)=WGT1(K)+WG1(I,K)
      LOOPCOUNT = LOOPCOUNT + 1
      IF (LOOPCOUNT.eq.20) STOP
C     print *,'  K =',K,'  WGT1(K) =',WGT1(K)
C        TEST FOR TIP SECTOR
      IF((ISECT-I).gt.0) then
        I=I+ID
C       added '22 continue ' to mask warning message...
22      CONTINUE
        IF(I.gt.0) then
C          commented statement (Label 22 removed here)
C22        L=I-ID
           L=I-ID
c         print *,'  L=',L,'  I=',I,'  ID=',ID
          GM2=(GAM(2,K)-1.)/2.*VU1(L,K)**2/GAM(2,K)/G/rg1(k)/TS1(L,K)
          DRSQ=(DP1(L,K)/DP1(I,K))**2
          PS1(I,K)=PS1(L,K)
     1             *(1.+GM2*(1.-DRSQ))   **(GAM(2,K)/(GAM(2,K)-1.))
          PT0PS1(I,K)=PT1(I  )/PS1(I,K)
          IF ((PT0PS1(I,K)-1.).lt.0) then
            PTRN=-1.
            PT0PS1(I,K)= 1.0
          endif
          GO TO 3
        endif

        ID=1
        I=IP+ID
        GO TO 22
      endif

      IF(WG.le.0) then
C        CALCULATE STA 0 FOR INCIDENCE CORRECTION
        WE1=WPREV/WGT1(K)-1.
        WPREV=WGT1(K)
C       print *,' K=',K,' WGT1(K)=',WGT1(K),'  WTO101=',WTO101
        IF((ABS(WE1)-WTOl01).le.0) then
C         print *,'  going to 18******** WE1=',WE1,'  JW=',JW
          goto 18
        else
C         print *,'  going to 16******** WE1=',WE1,' JW =',Jw
          goto 16
        endif
      endif

C     print *,'  JW =',JW
      IF((JW-20).ge.0) goto 18

      IF((JW-1).le.0) goto 16

      IF((WGT1(K)-WD1).eq.0) then
        goto 18
      else IF((WGT1(K)-WD1).gt.0) then
        PRUP=PT0PS1(IP,K)*.8+.2*PRUP
      else
        PRLOW=PT0PS1(IP,K)*.8+.2*PRLOW
      endif

      WE=WGT1(K)/WD1-1.
      IF((ABS(WE)-WTOl01).le.0) goto 18

16    continue
      IF(GAMF.le.0) then
        tA0(K)=0.99*tt0(ip,k)
        call gama(ptin,ta0(k),fair,wair,gam(1,k))
      endif

      EX=(GAM(1,K)-1.)/GAM(1,K)
      EXI=1./EX
      WGT0(K)=WGT1(K)/RWG(2,K)*RWG(1,K)
      I= IP
      WG0(I,K)=WGT0(K)*PCNH(I)
      w0(i)=wg0(i,k)
      FFA0(I,K)=WG0(I,K)*SQRT(TT0(I,K))/(144.*PTP(I,K)*ANN0(I,K))
      FFA0(I,K)=FFA0(I,K)/COS(ALPHA0(I,K))/cos(atan(tang0(i)))
      J=1

8     continue
      CALL PRATIO(FFA0(I,K),GAM(1,K),RG,PTPPS0(I),PRTOL,1.0,0.,k)
      PS0(I,K)=PTP(I,K)/PTPPS0(I)
      TT0TS0(I,K)=PTPPS0(I)**EX
      TS0(I,K)=TT0(I,K)/TT0TS0(I,K)

      IF(GAMF.le.0) then
        TA0(K)=.5*(TT0(I,K)+TS0(I,K))
        CALL GAMA(PTIN,TA0(K),FAIR,WAIR,GAM(1,K))
        EX=(GAM(1,K)-1.)/GAM(1,K)
        EXI=1./EX

        IF((J-1).le.0) then
          J=J+1
          GO TO 8
        endif
      endif

      CP0(K)=RG*EXI/AJ
      WGT1(K)=0.0
      ANNFUL=PI/144.0*(DT(1,K)*DT(1,K)-DR(1,K)*DR(1,K))/4.0
      DTFM1=DR(1,K)

      DO I=1,ISECT
        ANN0(I,K)=ANNFUL*PCNH(I)
        DTF=SQRT(ANN0(I,K)*4.0*144.0/PI+DTFM1*DTFM1)
        H0=(DTF-DTFM1)/2.0
        DP0(I,K)=DTF-H0
        DTFM1=DTF
        WG0(I,K)=WGT0(K)*PCNH(I)
        w0(i)=wg0(i,k)
        PT0MO= PT0(I,K)
        FFA0(I,K)=WG0(I,K)*SQRT(TT0(I,K))/(144.*PTP(I,K)*
     1  ANN0(I,K))
        FFA0(I,K)=FFA0(I,K)/COS(ALPHA0(I,K))/cos(atan(tang0(i)))

        IF(I.ne.IP) then
          PS0(I,K) =  PS0(IP,K)
          PTPPS0(I)=PTP(I,K)/PS0(I,K)
        endif

        TT0TS0(I,K)=PTPPS0(I)**EX
        TS0(I,K)=TT0(I,K)/TT0TS0(I,K)
        V0(I,K)=SQRT(2.*G*AJ*CP0(K)*(TT0(I,K)-TS0(I,K)))
        AAS0(I,K)=SQRT(GAM(1,K)*G*RG*TS0(I,K))
        M0(I,K)=V0(I,K)/AAS0(I,K)
        SI(I,K)=ALPHA0(I,K)- RADSD(I,K)

        IF(SI(I,K).le.0) then
          EXPS=EXPN
        else
          EXPS=EXPP
        endif

        PT0PS0(I,K)=(1.+EX*M0(I,K)*ETARS(I,K)*GAM(1,K)*M0(I,K)/2.
     1             *(COS(SI(I,K))**EXPS))**EXI
        PT0(I,K)=PS0(I,K)*PT0PS0(I,K)
        WG0(I,K)=WG0(I,K)*PT0(I,K)/PT0MO
        w0(i)=wg0(i,k)
        WG1(I,K)=WG1(I,K)*PT0(I,K)/PT0MO
        RHOS0(I,K)=144.*PS0(I,K)/(RG*TS0(I,K))
        VU0(I,K)=V0(I,K)*SIN(ALPHA0(I,K))
        VZ0(I,K)=V0(I,K)*COS(ALPHA0(I,K))
        WGT1 (K)=WGT1 (K)+WG1(I,K)
      enddo
C        END OF INCIDENCE LOSS CORRECTION LOOP

      PCNF(1,K)=WG1(1,K)/WGT1(K)/2.

      DO I=2,ISECT
        PCNF(I,K)=(WG1(I-1,K)+WG1(I,K))/WGT1(K)/2.+PCNF(I-1,K)
      enddo

      KF=ISECT-1
      CALL BESFIT(ISECT,PCNFS,PT0(1,K),KF,DPT,RES)
      IPT=KF+1

      DO I=1,ISECT
        TT1(I,K)=0.
        PT1(I  )=0.
        PSIRP=1.
        DO IFT=1,ISECT
          IF(IFT.le.IPT) then
            PT1(I)  =PT1(I)  +DPT(IFT)*PSIRP
C            print *,'   PT1(',I,')=',PT1(I),'    in sta01...DO loop 2.'
C            print *,'   DPT(',IFT,')=',DPT(IFT),'  PSIRP =',PSIRP
          endif
          IF(IFT.le.ITT) then
            TT1(I,K)=TT1(I,K)+DTT(IFT)*PSIRP
          endif
          PSIRP=PSIRP*PCNF(I,K)
        enddo

        if (twgf.gt.0.0) then
          ttm=(tt1(i,k)+(wr-1.)*twg(2,k))/wr
          tpp=(ttm+tt1(i,k))/2.
          tpc=(ttm+twg(2,k))/2.
          call cpa(ptin,tpc,0.0,0.0,cpc)
          call gama(ptin,tpp,fair,wair,gamtpp)
          extpp=gamtpp/(gamtpp-1.)
          cpp=rg*extpp/aj
          tt1(i,k)=(cpp*tt1(i,k)+(wr-1.)*cpc*twg(2,k))/(cpp+(wr-1.)*cpc)
        end if
      enddo

      WGT1(K)=0.
      I=IP
      ID=-1
      IF(WG.GT.0.)PT0PS1(IP,K)=(PRLOW+PRUP)/2.
      JW=JW+1
C     print *,'   going to 3  ID =',ID,'  I=',I
      GO TO 3

18    CONTINUE
      WGT0(K)=WGT1(K)/RWG(2,K)*RWG(1,K)
      IF(TRLOOP.ne.0.) then
        WRITE(16,1000) WGT0(K),WGT1(K),(WG0(L,K),L=1,ISECT)
        WRITE(16,1001)              (PT0PS0(L,K),L=1,ISECT)
        WRITE(16,1002)                 (WG1(L,K),L=1,ISECT)
        WRITE(16,1003)              (PT0PS1(L,K),L=1,ISECT)
1000    FORMAT(2X,6H WGT0=,F8.3,2X,6H WGT1=,F8.3/2X,6H  WG0=,6F8.3)
1001    FORMAT(1X,7HPT0PS0=,6F8.5)
1002    FORMAT(2X,6H  WG1=,6F8.3)
1003    FORMAT(1X,7HPT0PS1=,6F8.5)
      endif

      j=2
      GO TO (25,26),J
25    CALL DIAGT(1)
26    RETURN
      END


!========================================================================
!
!                   S P E C F E M 2 D  Version 7 . 0
!                   --------------------------------
!
!     Main historical authors: Dimitri Komatitsch and Jeroen Tromp
!                        Princeton University, USA
!                and CNRS / University of Marseille, France
!                 (there are currently many more authors!)
! (c) Princeton University and CNRS / University of Marseille, April 2014
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
! using a spectral-element method (SEM).
!
! This software is governed by the CeCILL license under French law and
! abiding by the rules of distribution of free software. You can use,
! modify and/or redistribute the software under the terms of the CeCILL
! license as circulated by CEA, CNRS and Inria at the following URL
! "http://www.cecill.info".
!
! As a counterpart to the access to the source code and rights to copy,
! modify and redistribute granted by the license, users are provided only
! with a limited warranty and the software's author, the holder of the
! economic rights, and the successive licensors have only limited
! liability.
!
! In this respect, the user's attention is drawn to the risks associated
! with loading, using, modifying and/or developing or reproducing the
! software by the user in light of its specific status of free software,
! that may mean that it is complicated to manipulate, and that also
! therefore means that it is reserved for developers and experienced
! professionals having in-depth computer knowledge. Users are therefore
! encouraged to load and test the software's suitability as regards their
! requirements in conditions enabling the security of their systems and/or
! data to be ensured and, more generally, to use and operate it in the
! same conditions as regards security.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

subroutine compute_forces_acoustic_GPU()

  use specfem_par, only : Mesh_pointer,nspec_outer_acoustic, nspec_inner_acoustic,num_fluid_solid_edges, &
                          buffer_send_scalar_ext_mesh,NPROC,buffer_recv_scalar_ext_mesh,deltatover2f,b_deltatover2f, &
                          ninterface,max_nibool_interfaces_ext_mesh,nibool_interfaces_ext_mesh, &
                          my_neighbours,tab_requests_send_recv_scalar,ninterface_acoustic,inum_interfaces_acoustic, &
                          b_buffer_send_scalar_ext_mesh,b_buffer_recv_scalar_ext_mesh,b_tab_requests_send_recv_scalar, &
                          nelem_acoustic_surface,STACEY_BOUNDARY_CONDITIONS,any_elastic,any_poroelastic,SIMULATION_TYPE

  implicit none

  ! local parameters
  integer:: iphase
  logical:: phase_is_inner

   if(nelem_acoustic_surface > 0) then

   !  enforces free surface (zeroes potentials at free surface)
    call acoustic_enforce_free_surf_cuda(Mesh_pointer)

  endif

  ! distinguishes two runs: for elements on MPI interfaces, and elements within the partitions
  do iphase=1,2

    !first for points on MPI interfaces, thus outer elements
    if( iphase == 1 ) then
      phase_is_inner = .false.
    else
      phase_is_inner = .true.
    endif

    ! acoustic pressure term
    ! includes code for SIMULATION_TYPE==3
    call compute_forces_acoustic_cuda(Mesh_pointer, iphase, &
                                      nspec_outer_acoustic, nspec_inner_acoustic)

    ! ! Stacey absorbing boundary conditions
    if(STACEY_BOUNDARY_CONDITIONS) then
      call compute_stacey_acoustic_GPU(phase_is_inner)
    endif

    ! elastic coupling
    if(any_elastic ) then
      if( num_fluid_solid_edges > 0 ) then
        ! on GPU
        call compute_coupling_ac_el_cuda(Mesh_pointer,phase_is_inner, &
                                         num_fluid_solid_edges)
      endif
    endif

! poroelastic coupling
    if(any_poroelastic )  then
          stop 'poroelastic not implemented yet in GPU mode'
    endif

    ! sources
    call compute_add_sources_acoustic_GPU(phase_is_inner)

! assemble all the contributions between slices using MPI

    if(ninterface_acoustic > 0) then

    if( phase_is_inner .eqv. .false. ) then

      ! sends potential_dot_dot_acoustic values to corresponding MPI interface neighbors (non-blocking)

     call transfer_boun_pot_from_device(Mesh_pointer, &
                                         buffer_send_scalar_ext_mesh, &
                                         1) ! <-- 1 == fwd accel

      call assemble_MPI_scalar_send_cuda(NPROC, &
                        buffer_send_scalar_ext_mesh,buffer_recv_scalar_ext_mesh, &
                        ninterface,max_nibool_interfaces_ext_mesh, &
                        nibool_interfaces_ext_mesh,&
                        my_neighbours, &
                        tab_requests_send_recv_scalar,ninterface_acoustic,inum_interfaces_acoustic)

      ! adjoint simulations
      if( SIMULATION_TYPE == 3 ) then
        call transfer_boun_pot_from_device(Mesh_pointer, &
                                           b_buffer_send_scalar_ext_mesh,&
                                           3) ! <-- 3 == adjoint b_accel

        call assemble_MPI_scalar_send_cuda(NPROC, &
                          b_buffer_send_scalar_ext_mesh,b_buffer_recv_scalar_ext_mesh, &
                          ninterface,max_nibool_interfaces_ext_mesh, &
                          nibool_interfaces_ext_mesh,&
                          my_neighbours, &
                          b_tab_requests_send_recv_scalar,ninterface_acoustic,inum_interfaces_acoustic)

      endif

    else

      ! waits for send/receive requests to be completed and assembles values
      call assemble_MPI_scalar_write_cuda(NPROC, &
                        Mesh_pointer,&
                        buffer_recv_scalar_ext_mesh, &
                        ninterface, &
                        max_nibool_interfaces_ext_mesh, &
                        tab_requests_send_recv_scalar, &
                        1,ninterface_acoustic,inum_interfaces_acoustic)

      ! adjoint simulations
      if( SIMULATION_TYPE == 3 ) then
        call assemble_MPI_scalar_write_cuda(NPROC, &
                        Mesh_pointer, &
                        b_buffer_recv_scalar_ext_mesh, &
                        ninterface, &
                        max_nibool_interfaces_ext_mesh, &
                        b_tab_requests_send_recv_scalar, &
                        3,ninterface_acoustic,inum_interfaces_acoustic)
      endif
    endif !phase_is_inner

  endif !interface_acoustic

  enddo

! divides pressure with mass matrix
! corrector:
! updates the chi_dot term which requires chi_dot_dot(t+delta)
  call kernel_3_acoustic_cuda(Mesh_pointer,deltatover2f,b_deltatover2f)

! enforces free surface (zeroes potentials at free surface)
 call acoustic_enforce_free_surf_cuda(Mesh_pointer)

end subroutine compute_forces_acoustic_GPU
!

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

! for acoustic solver on GPU

  subroutine compute_stacey_acoustic_GPU(phase_is_inner)

  use constants
  use specfem_par, only : nspec_bottom,nspec_left,nspec_top,nspec_right,b_absorb_acoustic_left,b_absorb_acoustic_right,&
                          b_absorb_acoustic_bottom, b_absorb_acoustic_top,it,NSTEP,SIMULATION_TYPE,SAVE_FORWARD,&
                          nelemabs,Mesh_pointer

  implicit none

! communication overlap
  logical :: phase_is_inner

! adjoint simulations
  real(kind=CUSTOM_REAL),dimension(NGLLX,nspec_bottom) :: b_absorb_potential_bottom_slice
  real(kind=CUSTOM_REAL),dimension(NGLLX,nspec_left) :: b_absorb_potential_left_slice
  real(kind=CUSTOM_REAL),dimension(NGLLX,nspec_right) :: b_absorb_potential_right_slice
  real(kind=CUSTOM_REAL),dimension(NGLLX,nspec_top) :: b_absorb_potential_top_slice

  ! checks if anything to do
  if( nelemabs == 0 ) return

if( SIMULATION_TYPE == 3 ) then
    if( phase_is_inner .eqv. .false. ) then
    b_absorb_potential_left_slice(:,:)=b_absorb_acoustic_left(:,:,NSTEP-it+1)
    b_absorb_potential_right_slice(:,:)=b_absorb_acoustic_right(:,:,NSTEP-it+1)
    b_absorb_potential_top_slice(:,:)=b_absorb_acoustic_top(:,:,NSTEP-it+1)
    b_absorb_potential_bottom_slice(:,:)=b_absorb_acoustic_bottom(:,:,NSTEP-it+1)
    endif
endif

  ! absorbs absorbing-boundary surface using Sommerfeld condition (vanishing field in the outer-space)
  call compute_stacey_acoustic_cuda(Mesh_pointer, phase_is_inner,b_absorb_potential_left_slice,b_absorb_potential_right_slice,&
                                     b_absorb_potential_top_slice,b_absorb_potential_bottom_slice)

  ! adjoint simulations: stores absorbed wavefield part
  if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD ) then
    ! writes out absorbing boundary value only when second phase is running
    if( phase_is_inner .eqv. .true. ) then

    b_absorb_acoustic_bottom(:,:,it) = b_absorb_potential_bottom_slice(:,:)
    b_absorb_acoustic_right(:,:,it) = b_absorb_potential_right_slice(:,:)
    b_absorb_acoustic_top(:,:,it) = b_absorb_potential_top_slice(:,:)
    b_absorb_acoustic_left(:,:,it) = b_absorb_potential_left_slice(:,:)

    endif
  endif

  end subroutine compute_stacey_acoustic_GPU

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

  subroutine compute_add_sources_acoustic_GPU(phase_is_inner)

  use constants
  use specfem_par,only: it,SIMULATION_TYPE,NSTEP, nadj_rec_local,Mesh_pointer

  implicit none

! communication overlap
  logical :: phase_is_inner

! forward simulations
  if (SIMULATION_TYPE == 1 ) call compute_add_sources_ac_cuda(Mesh_pointer,phase_is_inner,it)

! adjoint simulations
  if ( SIMULATION_TYPE == 3 .and. nadj_rec_local > 0 .and. it < NSTEP ) then
        call add_sources_ac_sim_2_or_3_cuda(Mesh_pointer,phase_is_inner, NSTEP -it + 1, nadj_rec_local,NSTEP)
  endif

! adjoint simulations
  if (SIMULATION_TYPE == 3) call compute_add_sources_ac_s3_cuda(Mesh_pointer,phase_is_inner,NSTEP -it + 1)

  end subroutine compute_add_sources_acoustic_GPU


    module Calculator_Cosmology
    use CosmologyTypes
    use CosmoTheory
    use settings
    use GeneralTypes
    implicit none
    private

    real(mcp), parameter :: neutrino_mass_fac= 94.07_mcp !conversion factor for thermal with Neff=3 TCMB-2.7255
    !93.014 for 3.046
    real(mcp), parameter :: standard_neutrino_neff = 3.046_mcp

    Type TCosmologyImportanceOptions
        logical :: redo_cls, redo_pk
    end Type TCosmologyImportanceOptions

    Type, extends(TTheoryCalculator) :: TCosmologyCalculator
        Type(TCosmologyImportanceOptions) :: ImportanceOptions
    contains
    procedure :: BAO_D_v
    procedure :: Hofz
    procedure :: Hofz_Hunit
    procedure :: AngularDiameterDistance
    procedure :: ComovingRadialDistance
    procedure :: ComovingRadialDistanceArr
    procedure :: AngularDiameterDistance2
    procedure :: LuminosityDistance
    procedure :: CMBToTheta
    procedure :: GetNewBackgroundData
    procedure :: GetNewPowerData
    procedure :: GetNewTransferData
    procedure :: GetTheoryForImportance
    procedure :: GetCosmoTheoryForImportance
    procedure :: GetZreFromTau
    procedure :: GetOpticalDepth
    procedure :: SetBackgroundTheoryData
    procedure :: SetParamsForBackground
    procedure :: ReadImportanceParams => TCosmologyCalculator_ReadImportanceParams
    end Type TCosmologyCalculator

    public TCosmologyCalculator, TCosmologyImportanceOptions, neutrino_mass_fac, standard_neutrino_neff
    contains

    subroutine TCosmologyCalculator_ReadImportanceParams(this, Ini)
    class(TCosmologyCalculator) :: this
    class(TSettingIni) :: Ini

    this%ImportanceOptions%redo_cls= Ini%Read_Logical('redo_cls')
    this%ImportanceOptions%redo_pk= Ini%Read_Logical('redo_pk')

    end subroutine TCosmologyCalculator_ReadImportanceParams

    subroutine GetNewBackgroundData(this, CMB,Theory,error)
    class(TCosmologyCalculator) :: this
    class(CMBParams) :: CMB
    class(TCosmoTheoryPredictions) Theory
    integer error

    call this%SetParamsForBackground(CMB)
    select type (Param => this%Config%Parameterization)
    class is (TCosmologyParameterization)
        if (.not. Param%late_time_only) then
            call this%SetBackgroundTheoryData(CMB, Theory, error)
        end if
        class default
        call MpiStop('TCosmologyCalculator: Must have CosmologyParameterization')
    end select

    end subroutine GetNewBackgroundData

    subroutine SetParamsForBackground(this,CMB)
    class(TCosmologyCalculator) :: this
    class(CMBParams) CMB

    call this%ErrorNotImplemented('SetParamsForBackground')

    end subroutine SetParamsForBackground

    subroutine SetBackgroundTheoryData(this, CMB,Theory,error)
    class(TCosmologyCalculator) :: this
    class(CMBParams) :: CMB
    class(TCosmoTheoryPredictions) Theory
    integer error

    !calculate thermal history, e.g. z_drag etc.,
    !save derived parameters in Theory%derived_parameters, Theory%numderived
    call this%ErrorNotImplemented('SetBackgroundTheoryData')

    end subroutine SetBackgroundTheoryData

    subroutine GetNewTransferData(this, CMB, Info,Theory,error)
    class(TCosmologyCalculator) :: this
    class(CMBParams) :: CMB
    class(TTheoryIntermediateCache), pointer :: Info
    class(TCosmoTheoryPredictions) :: Theory
    integer error

    !gets transfer functions in Info, and also set any derived parameters
    call this%ErrorNotImplemented('GetNewTransferData')

    end subroutine GetNewTransferData

    subroutine GetNewPowerData(this, CMB, Info, Theory, error)
    class(TCosmologyCalculator) :: this
    class(CMBParams) :: CMB
    class(TTheoryIntermediateCache), pointer :: Info
    class(TCosmoTheoryPredictions)  :: Theory
    integer error

    !calculate Theory power spectra from transfer functions in Info
    call this%ErrorNotImplemented('GetNewPowerData')

    end subroutine GetNewPowerData

    subroutine GetTheoryForImportance(this, CMB, Theory, error)
    class(TCosmologyCalculator) :: this
    class(TTheoryParams) :: CMB
    class(TTheoryPredictions) :: Theory
    integer error

    select type (CMB)
    class is (CMBParams)
        select type (Theory)
        class is (TCosmoTheoryPredictions)
            call this%GetCosmoTheoryForImportance(CMB, Theory, error)
        end select
    end select

    end subroutine GetTheoryForImportance

    subroutine GetCosmoTheoryForImportance(this, CMB, Theory, error)
    class(TCosmologyCalculator) :: this
    class(CMBParams) :: CMB
    class(TCosmoTheoryPredictions) :: Theory
    integer error

    error=0
    !calculate power spectra from scratch (for importance sampling)
    !Theory may already be calculated, so only fill in missing bits (DoCls, DoPk) + derived
    call this%ErrorNotImplemented('GetTheoryForImportance')

    end subroutine GetCosmoTheoryForImportance

    function GetOpticalDepth(this,CMB)
    class(TCosmologyCalculator) :: this
    class(CMBParams) CMB
    real(mcp) GetOpticalDepth

    call this%ErrorNotImplemented('GetOpticalDepth')
    GetOpticalDepth = 0

    end  function GetOpticalDepth

    function GetZreFromTau(this, CMB, tau)
    class(TCosmologyCalculator) :: this
    class(CMBParams) CMB
    real(mcp), intent(in) :: tau
    real(mcp) GetZreFromTau

    call this%ErrorNotImplemented('GetZreFromTau')
    GetZreFromTau=0

    end function GetZreFromTau

    real(mcp) function CMBToTheta(this, CMB)
    class(TCosmologyCalculator) :: this
    class(CMBParams) CMB

    call this%ErrorNotImplemented('CMBToTheta')
    CMBToTheta=0

    end function CMBToTheta

    real(mcp) function BAO_D_v(this, z)
    class(TCosmologyCalculator) :: this
    real(mcp), intent(IN) :: z

    call this%ErrorNotImplemented('BAO_D_v')
    BAO_D_v = 0

    end function BAO_D_v

    real(mcp) function AngularDiameterDistance(this, z)
    class(TCosmologyCalculator) :: this
    real(mcp), intent(IN) :: z

    call this%ErrorNotImplemented('AngularDiameterDistance')
    AngularDiameterDistance = 0

    end function AngularDiameterDistance

    real(mcp) function ComovingRadialDistance(this, z)
    class(TCosmologyCalculator) :: this
    real(mcp), intent(IN) :: z

    call this%ErrorNotImplemented('ComovingRadialDistance')
    ComovingRadialDistance = 0

    end function ComovingRadialDistance

    subroutine ComovingRadialDistanceArr(this, z, arr, n)
    class(TCosmologyCalculator) :: this
    integer, intent(in) :: n
    real(mcp), intent(IN) :: z(n)
    real(mcp), intent(out) :: arr(n)

    call this%ErrorNotImplemented('ComovingRadialDistanceArr')
    arr= 0

    end subroutine ComovingRadialDistanceArr

    real(mcp) function AngularDiameterDistance2(this, z1, z2)
    class(TCosmologyCalculator) :: this
    real(mcp), intent(IN) :: z1, z2

    call this%ErrorNotImplemented('AngularDiameterDistance2')
    AngularDiameterDistance2 = 0

    end function AngularDiameterDistance2

    real(mcp) function LuminosityDistance(this, z)
    class(TCosmologyCalculator) :: this
    real(mcp), intent(IN) :: z

    call this%ErrorNotImplemented('LuminosityDistance')
    LuminosityDistance = 0

    end function LuminosityDistance

    real(mcp) function Hofz(this, z)
    class(TCosmologyCalculator) :: this
    real(mcp), intent(IN) :: z

    call this%ErrorNotImplemented('Hofz')
    Hofz = 0

    end function Hofz

    real(mcp) function Hofz_Hunit(this, z)
    class(TCosmologyCalculator) :: this
    real(mcp), intent(IN) :: z

    Hofz_Hunit = const_c*this%Hofz(z)/1.d3

    end function Hofz_Hunit

    end module Calculator_Cosmology


!------------------------------------------------------------------------
!-         Monte Carlo                                                  -
!-         Plan de detection de Simbol-X                                -
!-         Detecteurs Si(LED) et Cd(Zn)Te(HED)                          -
!-         Interactions Compton + Photoelectrique                       -
!------------------------------------------------------------------------
module FPA

use OUTILS
use LECTURE

implicit none

    type Eabsorbee
       real (kind=wp), dimension(3) :: position
       integer, dimension(2) :: pixel
       real (kind=wp) :: energie
       logical :: Silicon, Cadmium, Tellurium, Photo, Compton
       logical :: photon_perdu
    endtype Eabsorbee
    type Epixel
       integer, dimension(2) :: pixel
       real (kind=wp) :: energie
    endtype Epixel

    type Detecteur
       logical :: actif                         !detecteur present ou non
       real (kind=wp), dimension(2) :: dim      !dimension x,y du detecteur (en cm)
       real (kind=wp) :: h_top                  !hauteur z du dessus du detecteur (en cm)
       real (kind=wp) :: h_bot                  !hauteur z du dessous du detecteur (en cm)
       real (kind=wp) :: dim_pixel              !dimension des pixels du detecteur (en cm)
       integer, dimension(135,135) :: map       !geometrie du detecteur (HED: zones actives et mortes)
       integer :: nb                            !nombre d'interactions par photon
       type (Eabsorbee), dimension(10) :: Eabs  !liste des energies absorbees, et position des interactions
       type (Epixel), dimension(10) :: Epix     !energies absorbees par pixel
       real (kind=wp), dimension(3) :: err_Pos  !erreur de positionnement du detecteur du a la formation

    endtype Detecteur

contains
!------------------------------------------------------------------------
!-                      Programme principal                             -
!-           ATTENTION: energie en MeV, distance en cm                  -
!------------------------------------------------------------------------
subroutine plan_de_detection(Para_SM,Para_SD,photon, j,k,l)
implicit none

! IN/OUT variables
        type (ParametresSatMiroir) :: Para_SM           !parametres Satellite Miroir
        type (ParametresSatDetecteur) :: Para_SD        !parametres Satellite Detecteur
        type (photons) :: photon                        !position, direction et energie du photon

        integer :: j
        real (kind=wp) :: k, l

! local variables
        type (Detecteur) :: LED         !LED: nb d'interactions, liste des energies absorbees, ...
        type (Detecteur) :: HED         !HED: nb d'interactions, liste des energies absorbees, ...
        integer :: i
        logical :: entreecollimateur, surface_LED, surface_HED
        real (kind=wp) :: x, y
        integer :: f

entreecollimateur=.FALSE.
surface_LED=.FALSE.
surface_HED=.FALSE.

        if (Para_SM%reflexionhyperbole) then
           !===========================================INITIALISATION DES VARIABLES===========================================
           call init(Para_SD, LED,HED,photon)

           !coordonnees du photon sur la face d'entree du collimateur
           x=photon%position(1)+(photon%position(3)-Para_SD%h_col*100)*photon%direction(1)/abs(photon%direction(3))
           y=photon%position(2)+(photon%position(3)-Para_SD%h_col*100)*photon%direction(2)/abs(photon%direction(3))
           !le photon passe t-il dans le collimateur
           if ((x**2+y**2) .lt. (Para_SD%r_col*100)**2) then
              entreecollimateur=.TRUE.
           endif

        endif

        if (entreecollimateur) then
           if (LED%actif) then          !LED ou LED+HED
              !coordonnees du photon a la surface du LED
              photon%position=photon%position+(LED%h_top-photon%position(3))*photon%direction/photon%direction(3)
              if ((ABS(photon%position(1)) .le. LED%dim(1)/2) .and. (ABS(photon%position(2)) .le. LED%dim(2)/2)) then
                 !=>LE PHOTON EST A LA SURFACE D'UN PIXEL DU LED
                 surface_LED=.TRUE.
              endif
           else if (HED%actif) then     !HED
              !coordonnees du photon a la surface du HED
              photon%position=photon%position+(HED%h_top-photon%position(3))*photon%direction/photon%direction(3)
              if ((ABS(photon%position(1)) .le. HED%dim(1)/2) .and. (ABS(photon%position(2)) .le. HED%dim(2)/2)) then
                 !=>LE PHOTON EST A LA SURFACE D'UN PIXEL DU HED
                 surface_HED=.TRUE.
              endif
           endif
        endif

        if (surface_LED .or. surface_HED) then

                !=>ecriture des fichiers position reelles(cm) + position reelles corrigees (a la surface du LED ou du HED)
                j=j+1
                write(11) photon%position(1), photon%position(2), photon%energie*1000
                if (surface_LED) then
                   write(12) photon%position(1)+LED%err_Pos(1), photon%position(2)+LED%err_Pos(2), photon%energie*1000
                else
                   write(12) photon%position(1)+HED%err_Pos(1), photon%position(2)+HED%err_Pos(2), photon%energie*1000
                endif

           !====================================INTERACTION DU PHOTON AVEC LES DETECTEURS=====================================
           call detecteurs(LED,HED,photon)

           !============================================RESOLUTION DES DETECTEURS=============================================
           call resolution('LED',LED)
           call resolution('HED',HED)

                !=>ecriture des fichiers spectres du LED et du HED (sans pixels)
                if (SUM(LED%Epix%energie) .ne. 0) then
                   k=k+1
                   write(13,*) SUM(LED%Epix%energie)
                endif
                if (SUM(HED%Epix%energie) .ne. 0) then
                   l=l+1
                   write(14,*) SUM(HED%Epix%energie)
                endif
                !=>ecriture des fichiers images et spectres du LED et du HED (avec pixels)
                i=1
                do while (LED%Epix(i)%energie .ne. 0)
                   write(15,*) LED%Epix(i)%pixel, LED%Epix(i)%energie
                   i=i+1
                enddo
                i=1
                do while (HED%Epix(i)%energie .ne. 0)
                   write(16,*) HED%Epix(i)%pixel, HED%Epix(i)%energie
                   i=i+1
                enddo

           !=============================================CORRECTION DE L'IMAGERIE=============================================
           call correction(LED,HED)

                !=>ecriture des fichiers images corrigees et spectres du LED et du HED (avec pixels)
                i=1
                do while (LED%Epix(i)%energie .ne. 0)
                   if ((LED%Epix(i)%pixel(1) .ge. 1) .and. (LED%Epix(i)%pixel(2) .ge. 1) .and. &
                       (LED%Epix(i)%pixel(1) .lt. 128) .and. (LED%Epix(i)%pixel(2) .lt. 128)) then
                      write(17,*) LED%Epix(i)%pixel, LED%Epix(i)%energie
                   endif
                   i=i+1
                enddo
                i=1
                do while (HED%Epix(i)%energie .ne. 0)
                   if ((HED%Epix(i)%pixel(1) .ge. 1) .and. (HED%Epix(i)%pixel(2) .ge. 1) .and. &
                       (HED%Epix(i)%pixel(1) .lt. 135) .and. (HED%Epix(i)%pixel(2) .lt. 135)) then
                      write(18,*) HED%Epix(i)%pixel, HED%Epix(i)%energie
                   endif
                   i=i+1
                enddo

!!$           !=>pour produire des images en cours de focalisation
!!$           do f=197,0,-1
!!$              !coordonnees du photon tout le long de la focalisation
!!$              x=photon%position(1)+(photon%position(3)-f/10._wp)*photon%direction(1)/abs(photon%direction(3))
!!$              y=photon%position(2)+(photon%position(3)-f/10._wp)*photon%direction(2)/abs(photon%direction(3))
!!$              j=j+1
!!$              write(11) x, y
!!$           enddo
        endif

end subroutine plan_de_detection

!------------------------------------------------------------------------
!-         Initialisation des variables LED et HED                      -
!-                                                                      -
!------------------------------------------------------------------------
subroutine init(Para_SD, LED,HED,photon)
implicit none

! IN/OUT variables
        type (ParametresSatDetecteur) :: Para_SD!parametres Satellite Detecteur
        type (Detecteur) :: LED                 !LED: nb d'interactions, liste des energies absorbees, ...
        type (Detecteur) :: HED                 !HED: nb d'interactions, liste des energies absorbees, ...
        type (photons) :: photon                !position, direction et energie du photon

!=>Initialisation des variables de LED:
        LED%actif=Para_SD%LED
        !pour passer des metres aux cm
        LED%dim=Para_SD%dimensions_LED*100
        LED%h_top=0
        LED%h_bot=LED%h_top-0.045_wp     !450 micrometres d'epaisseur
        LED%dim_pixel=Para_SD%taille_pixels_LED*100
        LED%err_Pos=Para_SD%err_Pos_LED*100
        LED%nb=0
        LED%Eabs%position(1)=0
        LED%Eabs%position(2)=0
        LED%Eabs%pixel(1)=0
        LED%Eabs%pixel(2)=0
        LED%Eabs%energie=0
        LED%Eabs%Silicon=.FALSE.
        LED%Eabs%Cadmium=.FALSE.
        LED%Eabs%Tellurium=.FALSE.
        LED%Eabs%Photo=.FALSE.
        LED%Eabs%Compton=.FALSE.
        LED%Eabs%photon_perdu=.FALSE.
        LED%Epix%pixel(1)=0
        LED%Epix%pixel(2)=0
        LED%Epix%energie=0

!=>Initialisation des variables de HED:
        HED%actif=Para_SD%HED
        !pour passer des metres aux cm
        HED%dim=Para_SD%dimensions_HED*100
        HED%h_top=Para_SD%pos_HED(3)*100-Para_SD%pos_LED(3)*100+LED%h_bot
        HED%h_bot=HED%h_top-0.2_wp      !2 mm d'epaisseur
        HED%dim_pixel=Para_SD%taille_pixels_HED*100
        HED%map=Para_SD%HED_map
        HED%err_Pos=Para_SD%err_Pos_HED*100
        HED%nb=0
        HED%Eabs%position(1)=0
        HED%Eabs%position(2)=0
        HED%Eabs%pixel(1)=0
        HED%Eabs%pixel(2)=0
        HED%Eabs%energie=0
        HED%Eabs%Silicon=.FALSE.
        HED%Eabs%Cadmium=.FALSE.
        HED%Eabs%Tellurium=.FALSE.
        HED%Eabs%Photo=.FALSE.
        HED%Eabs%Compton=.FALSE.
        HED%Eabs%photon_perdu=.FALSE.
        HED%Epix%pixel(1)=0
        HED%Epix%pixel(2)=0
        HED%Epix%energie=0

!=>Conversion des unites pour le photon:
        !pour passer des metres aux cm
        photon%position=photon%position*100
        !pour passer des keV a MeV
        photon%energie=photon%energie/1000

end subroutine init

!------------------------------------------------------------------------
!-         Interactions du photon incident                              -
!-         avec les detecteurs (LED et HED)                             -
!------------------------------------------------------------------------
subroutine detecteurs(LED,HED,photon)
implicit none

! IN/OUT variables
        type (Detecteur) :: LED         !LED: nb d'interactions, liste des energies absorbees, ...
        type (Detecteur) :: HED         !HED: nb d'interactions, liste des energies absorbees, ...
        type (photons) :: photon        !position, direction et energie du photon

! local variables
        integer, dimension(2) :: pixel

        if (LED%actif .and. HED%actif) then

              call Al_filter(photon)
              !=>LE PHOTON N'A PAS ETE ABSORBE, IL EST A LA SURFACE DU LED
              call inside_LED(LED, photon)
              !print*,'LED',LED%Eabs%energie

              !si un photon se situe entre les detecteurs on le suit jusqu'au prochain (HED ou LED)
              do while ((photon%position(3) .le. LED%h_bot) .and. (photon%position(3) .ge. HED%h_top))

                 !=>LE PHOTON SE DIRIGE VERS LE HED
                 if (photon%direction(3) .lt. 0) then
                    !position du photon a la surface du HED:
                    photon%position=photon%position+(HED%h_top-photon%position(3))*photon%direction/photon%direction(3)
                    if ((ABS(photon%position(1)) .le. HED%dim(1)/2) .and. (ABS(photon%position(2)) .le. HED%dim(2)/2)) then
                       !=>LE PHOTON EST A LA SURFACE DU HED
                       call inside_HED(HED, photon)
                    else
                       !=>LE PHOTON N'EST PAS A LA SURFACE DU HED
                       photon%position=0   !pour sortir de la boucle
                    endif
                    !print*,'HED',HED%Eabs%energie

                 !=>LE PHOTON SE DIRIGE VERS LE LED
                 else if (photon%direction(3) .gt. 0) then
                    !position du photon a la surface du LED:
                    photon%position=photon%position+(LED%h_bot-photon%position(3))*photon%direction/photon%direction(3)
                    if ((ABS(photon%position(1)) .le. LED%dim(1)/2) .and. (ABS(photon%position(2)) .le. LED%dim(2)/2)) then
                       !=>LE PHOTON EST A LA SURFACE DU LED
                       call inside_LED(LED, photon)
                    else
                       !=>LE PHOTON N'EST PAS A LA SURFACE DU HED
                       photon%position=0   !pour sortir de la boucle
                    endif
                    !print*,'LED',LED%Eabs%energie

                 !=>LE PHOTON SE DIRIGE HORIZONTALEMENT
                 else
                    !le photon sort du plan de detection
                    photon%position=0   !pour sortir de la boucle
                 endif

              enddo

        else if (LED%actif) then

           call Al_filter(photon)
           !=>LE PHOTON N'A PAS ETE ABSORBE, IL EST A LA SURFACE DU LED
           call inside_LED(LED, photon)

        else if (HED%actif) then

           call inside_HED(HED, photon)

        endif

end subroutine detecteurs

!------------------------------------------------------------------------
!-         Resolution spatiale et energetique                           -
!-         du detecteur LED et HED                                      -
!------------------------------------------------------------------------
subroutine resolution(detector,ED)
implicit none

! IN/OUT variables
        character (len=3) :: detector                   !detecteur LED ou HED
        type (Detecteur) :: ED                          !nb d'interactions, liste des energies absorbees, ...

! Local variables
        integer :: i, n, indice
        integer, dimension(2) :: min, max, pixel        !coordonnees du pixel ou a eu lieu l'interaction
        integer, dimension(:,:), allocatable :: tab     !tab representant une partie du LED ou du HED et contenant l'indice correspondant
        real (kind=wp) :: G05DDF
        real (kind=wp) :: alea
        real (kind=wp) :: E

        if (SUM(ED%Eabs%energie) .ne. 0) then
           min(1)=MINVAL(ED%Eabs%pixel(1),mask=ED%Eabs%pixel(1) .ne. 0)
           min(2)=MINVAL(ED%Eabs%pixel(2),mask=ED%Eabs%pixel(2) .ne. 0)
           max(1)=MAXVAL(ED%Eabs%pixel(1))
           max(2)=MAXVAL(ED%Eabs%pixel(2))
           !on alloue un tableau representant la partie du detecteur touchee
           allocate(tab(max(1)-min(1)+1,max(2)-min(2)+1))
           tab=0

           n=0
           if (detector .eq. 'LED') then
              do i=1,ED%nb
                 !=>RESOLUTION EN ENERGIE: on pondere l'energie mesuree par une incertitude
                 alea=G05DDF(0._wp,0.000064_wp)                    !resolution du LED: 150 eV FWHM = 0.15keV/2.35 sigma
                 E=ED%Eabs(i)%energie+alea
                 !=>SUEIL DE DETECTION
                 if(E .ge. 0.0001_wp) then                         !seuil de detection du LED: 0.1 keV
                    !=>RESOLUTION SPATIALE: on somme les energies par pixels
                    !dans quel pixel de tab l'energie s'est elle deposee?
                    pixel=ED%Eabs(i)%pixel-min+1
                    if (tab(pixel(1),pixel(2)) .eq. 0) then        !on est en presence d'un nouveau pixel
                       n=n+1
                       tab(pixel(1),pixel(2))=n                    !on lui attribue un nouvel indice que l'on stock dans tab_pixels
                       ED%Epix(n)%pixel=ED%Eabs(i)%pixel           !on remplit la case correspondante avec sa position pixel
                       ED%Epix(n)%energie=E                        !on remplit la case correspondante avec son energie
                    else
                       indice=tab(pixel(1),pixel(2))               !on va chercher l'indice correspondant au pixel
                       ED%Epix(indice)%energie=ED%Epix(indice)%energie + E !on remplit la case correspondante avec son energie
                    endif
                 endif
              enddo

           else if (detector .eq. 'HED') then
              do i=1,ED%nb
                 !=>RESOLUTION EN ENERGIE: on pondere l'energie mesuree par une incertitude
                 alea=G05DDF(0._wp,0.00042_wp)                     !resolution du HED: 1 keV FWHM = 1keV/2.35 sigma
                 E=ED%Eabs(i)%energie+alea
                 !=>SUEIL DE DETECTION
                 if(E .ge. 0.0015_wp) then                         !seuil de detection du HED: 1.5 keV
                    !=>RESOLUTION SPATIALE: on somme les energies par pixels
                    !dans quel pixel de tab l'energie s'est elle deposee?
                    pixel=ED%Eabs(i)%pixel-min+1
                    if (tab(pixel(1),pixel(2)) .eq. 0) then        !on est en presence d'un nouveau pixel
                       n=n+1
                       tab(pixel(1),pixel(2))=n                    !on lui attribue un nouvel indice que l'on stock dans tab_pixels
                       ED%Epix(n)%pixel=ED%Eabs(i)%pixel           !on remplit la case correspondante avec sa position pixel
                       ED%Epix(n)%energie=E                        !on remplit la case correspondante avec son energie
                    else
                       indice=tab(pixel(1),pixel(2))               !on va chercher l'indice correspondant au pixel
                       ED%Epix(indice)%energie=ED%Epix(indice)%energie + E !on remplit la case correspondante avec son energie
                    endif
                 endif
              enddo
           endif
        endif

end subroutine resolution

!------------------------------------------------------------------------
!-         Algorithme de correction pour                                -
!-         l'imagerie du LED et du HED                                  -
!------------------------------------------------------------------------
subroutine correction(LED,HED)
implicit none

! IN/OUT variables
        type (Detecteur) :: LED !LED: nb d'interactions, liste des energies absorbees, ...
        type (Detecteur) :: HED !HED: nb d'interactions, liste des energies absorbees, ...

! Local variables
        integer, dimension(2) :: correction_LED, correction_HED !correction en nb de pixels
        integer :: i

!nb: on corrige uniquement de la position du LED ou du HED dans le referentiel lie aux miroirs,
!on neglige les effets de projection des photons dus a l'inclinaison du plan de detection (max=position/cos(2'))

        !calcul de la correction a appliquer (supposant une grande probabilite au centre du pixel)
        correction_LED(1)=(LED%err_Pos(1)-LED%dim_pixel/2) /LED%dim_pixel +1
        correction_LED(2)=(LED%err_Pos(2)-LED%dim_pixel/2) /LED%dim_pixel +1
        correction_HED(1)=(HED%err_Pos(1)-HED%dim_pixel/2) /HED%dim_pixel +1
        correction_HED(2)=(HED%err_Pos(2)-HED%dim_pixel/2) /HED%dim_pixel +1
        i=1
        do while (LED%Epix(i)%energie .ne. 0)
           LED%Epix(i)%pixel=LED%Epix(i)%pixel+correction_LED
           i=i+1
        enddo
        i=1
        do while (HED%Epix(i)%energie .ne. 0)
           HED%Epix(i)%pixel=HED%Epix(i)%pixel+correction_HED
           i=i+1
        enddo

end subroutine correction

!------------------------------------------------------------------------
!-         Filtre en Aluminium                                          -
!-                                                                      -
!------------------------------------------------------------------------
subroutine Al_filter(photon)
implicit none

! IN/OUT variables
        type (photons) :: photon        !position, direction et energie du photon

! Local variables
        real (kind=wp) :: Al_Photo, Al_Total
        real (kind=wp) :: G05CAF
        real (kind=wp) :: alea
        real (kind=wp) :: l

        !le photon traverse t'il le filtre d' Aluminium?
        call Al_CrossSection(photon%energie, Al_Photo,Al_Total)
        alea=G05CAF()
        l=-LOG(alea)/(Al_Total*2.6941_wp)       !distance avant prochaine interaction (masse volumique de Al=2.6941 g.cm-3)
        if (l .le. 0.00001_wp) then     !=>LE PHOTON NE TRAVERSE PAS LE FILTRE (epaisseur d'aluminium: 100 nm)
           photon%energie=0
        endif

end subroutine Al_filter

!------------------------------------------------------------------------
!-         Interactions rayonnement/matiere                             -
!-         dans le LED                                                  -
!------------------------------------------------------------------------
subroutine inside_LED(LED, photon)
implicit none

! IN/OUT variables
        type (Detecteur) :: LED         !nb d'interactions, liste des energies absorbees, ...
        type (photons) :: photon        !position, direction et energie du photon

! Local variables
        logical :: dedans
        real (kind=wp) :: Si_Photo, Si_Total
        real (kind=wp) :: G05CAF
        real (kind=wp) :: alea
        real (kind=wp) :: l
        integer, dimension(2) :: pixel
        real (kind=wp) :: E                             !energie absorbee

dedans=.TRUE.

        do while ((photon%energie .ne. 0) .and. dedans)

           !selon E0 aller chercher la section efficace du Si
           call Si_CrossSection(photon%energie, Si_Photo,Si_Total)
           !propagation du photon jusqu'a la prochaine interaction
           alea=G05CAF()
           l=-LOG(alea)/(Si_Total*2.329_wp)  !distance avant prochaine interaction (masse volumique du Si=2.329 g.cm-3)
           photon%position=photon%position+l*photon%direction

           !l'interaction du photon se situe t'elle a l'interieur du detecteur?
           if ((ABS(photon%position(1)) .le. LED%dim(1)/2) .and. (ABS(photon%position(2)) .le. LED%dim(2)/2) &
                .and. (photon%position(3) .le. LED%h_top) .and. (photon%position(3) .ge. LED%h_bot)) then
              !dans quel pixel du LED se situe alors le photon:
              pixel=(/ (photon%position(1)+LED%dim(1)/2)/LED%dim_pixel +1 , (photon%position(2)+LED%dim(2)/2)/LED%dim_pixel +1 /)

              !=====================================INTERACTION AVEC LE SILICON=====================================
              LED%Eabs(LED%nb+1)%Silicon=.TRUE.
              alea=G05CAF()
              if (alea .le. Si_Photo/Si_Total) then     !=>EFFET PHOTOELECTRIQUE
                 call photoelectrique('Si',photon,E)
                 LED%Eabs(LED%nb+1)%energie=E
                 LED%Eabs(LED%nb+1)%Photo=.TRUE.
                 LED%Eabs(LED%nb+1)%position=photon%position
                 LED%Eabs(LED%nb+1)%pixel=pixel

              else                                      !=>EFFET COMPTON
                 call Compton(photon,E)
                 LED%Eabs(LED%nb+1)%energie=E
                 LED%Eabs(LED%nb+1)%Compton=.TRUE.
                 LED%Eabs(LED%nb+1)%position=photon%position
                 LED%Eabs(LED%nb+1)%pixel=pixel
              endif
              LED%nb=LED%nb+1   !nombre d'interactions pour un photon dans le LED

           else
              !=>LE PHOTON N'EST PAS DANS UN PIXEL
              LED%Eabs(LED%nb+1)%photon_perdu=.TRUE.
              dedans=.FALSE.
           endif

           !le photon a t'il traverse le detecteur (en direction du HED)?
           if (photon%position(3) .lt. LED%h_bot) then
              !si oui 'repositionner' ce photon juste a la sortie du detecteur
              photon%position=photon%position+(LED%h_bot-photon%position(3))*photon%direction/photon%direction(3)
              photon%position(3)=LED%h_bot      !pour une valeur non approchee pour la condition .le. LED%h_bot de la boucle dans detecteurs
           endif

        enddo

end subroutine inside_LED

!------------------------------------------------------------------------
!-         Interactions rayonnement/matiere                             -
!-         dans le HED                                                  -
!------------------------------------------------------------------------
subroutine inside_HED(HED, photon)
implicit none

! IN/OUT variables
        type (Detecteur) :: HED         !nb d'interactions, liste des energies absorbees, ...
        type (photons) :: photon        !position, direction et energie du photon

! Local variables
        logical :: dedans
        real (kind=wp) :: Cd_Photo, Cd_Total
        real (kind=wp) :: Te_Photo, Te_Total
        real (kind=wp) :: Cd_CdTe, CdTe_Total
        real (kind=wp) :: G05CAF
        real (kind=wp) :: alea
        real (kind=wp) :: l
        integer, dimension(2) :: pixel
        real (kind=wp) :: E                             !energie absorbee

dedans=.TRUE.

        do while ((photon%energie .ne. 0) .and. dedans)

           !selon E0 aller chercher la section efficace de chaque element
           call Cd_CrossSection(photon%energie, Cd_Photo,Cd_Total)
           call Te_CrossSection(photon%energie, Te_Photo,Te_Total)
           !fraction en masse du Cd:0.468358, Te:0.531642
           CdTe_Total=0.468358_wp*Cd_Total+0.531642_wp*Te_Total
           !propagation du photon jusqu'a la prochaine interaction
           alea=G05CAF()
           l=-LOG(alea)/(CdTe_Total*5.85_wp)    !distance avant prochaine interaction (masse volumique du CdTe=5.85 g.cm-3)
           photon%position=photon%position+l*photon%direction

           !l'interaction du photon se situe t'elle a l'interieur du detecteur?
           if ((ABS(photon%position(1)) .le. HED%dim(1)/2) .and. (ABS(photon%position(2)) .le. HED%dim(2)/2) &
                .and. (photon%position(3) .le. HED%h_top) .and. (photon%position(3) .ge. HED%h_bot)) then
              !dans quel secteur du HED se situe alors le photon:
              pixel=(/ (photon%position(1)+HED%dim(1)/2)/HED%dim_pixel +1 , (photon%position(2)+HED%dim(2)/2)/HED%dim_pixel +1 /)
              if (HED%map(pixel(1),pixel(2)) .eq. 1) then       !=>LE PHOTON SE SITUE DANS UN PIXEL

                 !interaction avec le Cd ou le Te: rapport de la section efficace de Cd par rapport au CdTe
                 Cd_CdTe=(0.468358_wp*Cd_Total)/CdTe_Total

                 alea=G05CAF()
                 !=====================================INTERACTION AVEC LE CADMIUM=====================================
                 if (alea .le. Cd_CdTe) then
                    HED%Eabs(HED%nb+1)%Cadmium=.TRUE.
                    alea=G05CAF()
                    if (alea .le. Cd_Photo/Cd_Total) then     !=>EFFET PHOTOELECTRIQUE
                       call photoelectrique('Cd',photon,E)
                       HED%Eabs(HED%nb+1)%energie=E
                       HED%Eabs(HED%nb+1)%Photo=.TRUE.
                       HED%Eabs(HED%nb+1)%position=photon%position
                       HED%Eabs(HED%nb+1)%pixel=pixel

                    else                                      !=>EFFET COMPTON
                       call Compton(photon,E)
                       HED%Eabs(HED%nb+1)%energie=E
                       HED%Eabs(HED%nb+1)%Compton=.TRUE.
                       HED%Eabs(HED%nb+1)%position=photon%position
                       HED%Eabs(HED%nb+1)%pixel=pixel
                    endif

                    !====================================INTERACTION AVEC LE TELLURIUM====================================
                 else
                    HED%Eabs(HED%nb+1)%Tellurium=.TRUE.
                    alea=G05CAF()
                    if (alea .le. Te_Photo/Te_Total)then      !=>EFFET PHOTOELECTRIQUE
                       call photoelectrique('Te',photon,E)
                       HED%Eabs(HED%nb+1)%energie=E
                       HED%Eabs(HED%nb+1)%Photo=.TRUE.
                       HED%Eabs(HED%nb+1)%position=photon%position
                       HED%Eabs(HED%nb+1)%pixel=pixel

                    else                                      !=>EFFET COMPTON
                       call Compton(photon,E)
                       HED%Eabs(HED%nb+1)%energie=E
                       HED%Eabs(HED%nb+1)%Compton=.TRUE.
                       HED%Eabs(HED%nb+1)%position=photon%position
                       HED%Eabs(HED%nb+1)%pixel=pixel
                    endif

                 endif
                 HED%nb=HED%nb+1        !nombre d'interactions pour un photon dans le HED

              else
                 !=>LE PHOTON N'EST PAS DANS UN PIXEL
                 HED%Eabs(HED%nb+1)%photon_perdu=.TRUE.
                 dedans=.FALSE.
              endif

           else
              !=>LE PHOTON N'EST PAS DANS UN PIXEL
              HED%Eabs(HED%nb+1)%photon_perdu=.TRUE.
              dedans=.FALSE.
           endif

           !le photon a t'il traverse le detecteur (en direction du LED)?
           if (photon%position(3) .gt. HED%h_top) then
              !si oui 'repositionner' ce photon juste a la sortie du detecteur
              photon%position=photon%position+(HED%h_top-photon%position(3))*photon%direction/photon%direction(3)
              photon%position(3)=HED%h_top      !pour une valeur non approchee pour la condition .ge. HED%h_top de la boucle dans detecteurs
           endif

        enddo

end subroutine inside_HED

!------------------------------------------------------------------------
!-         Effet Photoelectrique                                        -
!-         (photon de fluorescence + electron Auger)                    -
!------------------------------------------------------------------------
subroutine photoelectrique(element,photon,Ea)
implicit none

! IN/OUT variables
        character (len=2) :: element    !element avec lequel le photon interagit
        type (photons) :: photon        !position, direction et energie du photon
        real (kind=wp) :: Ea            !energie absorbee

! Local variables
        real (kind=wp) :: G05CAF, G05DAF
        real (kind=wp) :: alea
        real (kind=wp) :: Pi
        real (kind=wp) :: alpha, delta

Pi=ACOS(-1._wp)

        !=======================================INTERACTION AVEC LE SILICON=======================================
        if (element .eq. 'Si') then

           alea=G05CAF()
           !=>COUCHE K si energie>Kedge et alea>rapport L/K
           if ((photon%energie .ge. 0.001839_wp) .and. (alea .gt. 0.096_wp)) then
              Ea=photon%energie-0.001839_wp             !Energie absorbee = energie du photon - energie de liaison 1s
              !une fois l'electron arrache de la couche K la desexcitation de l'atome entraine:
              alea=G05CAF()
              !emission d'un photon de fluorescence
              if (alea .lt. 0.91_wp) then
                 photon%energie=0.00174_wp              !energie de transition moyenne vers la couche K
                 Ea=Ea+(0.001839_wp-0.00174_wp)         !complement absorbe
                 !nouvelle direction du photon
                 alpha=G05DAF(-Pi,Pi)
                 delta=G05DAF(0,2*Pi)
                 call anglesolide(photon%direction,alpha,delta)
              !ejection d'un electron Auger
              else
                 Ea=Ea+0.001839_wp                      !toute l'energie est absorbee
                 photon%energie=0                       !il n'y a plus de photon
              endif

           !=>COUCHE L sinon
           else
              Ea=photon%energie                         !on fait l'approximation que toute l'energie est absorbee
              photon%energie=0                          !il n'y a plus de photon
           endif

        !=======================================INTERACTION AVEC LE CADMIUM=======================================
        else if (element .eq. 'Cd') then

           alea=G05CAF()
           !=>COUCHE K si energie>Kedge et alea>rapport L/K
           if ((photon%energie .ge. 0.02671_wp) .and. (alea .gt. 0.159_wp)) then
              Ea=photon%energie-0.02671_wp              !Energie absorbee = energie du photon - energie de liaison 1s
              !une fois l'electron arrache de la couche K la desexcitation de l'atome entraine:
              alea=G05CAF()
              !emission d'un photon de fluorescence
              if (alea .lt. 0.91_wp) then
                 photon%energie=0.02317_wp              !energie de transition moyenne vers la couche K
                 Ea=Ea+(0.02671_wp-0.02317_wp)          !complement absorbe
                 !nouvelle direction du photon
                 alpha=G05DAF(-Pi,Pi)
                 delta=G05DAF(0,2*Pi)
                 call anglesolide(photon%direction,alpha,delta)
              !ejection d'un electron Auger
              else
                 Ea=Ea+0.02671_wp                       !toute l'energie est absorbee
                 photon%energie=0                       !il n'y a plus de photon
              endif

           !=>COUCHE L sinon
           else
              Ea=photon%energie                         !on fait l'approximation que toute l'energie est absorbee
              photon%energie=0                          !il n'y a plus de photon
           endif

        !======================================INTERACTION AVEC LE TELLURIUM======================================
        else if (element .eq. 'Te') then

           alea=G05CAF()
           !=>COUCHE K si energie>Kedge et alea>rapport L/K
           if ((photon%energie .ge. 0.03181_wp) .and. (alea .gt. 0.165_wp)) then
              Ea=photon%energie-0.03181_wp              !Energie absorbee = energie du photon - energie de liaison 1s
              !une fois l'electron arrache de la couche K la desexcitation de l'atome entraine:
              alea=G05CAF()
              !emission d'un photon de fluorescence
              if (alea .lt. 0.91_wp) then
                 photon%energie=0.02747_wp              !energie de transition moyenne vers la couche K
                 Ea=Ea+(0.03181_wp-0.02747_wp)          !complement absorbe
                 !nouvelle direction du photon
                 alpha=G05DAF(-Pi,Pi)
                 delta=G05DAF(0,2*Pi)
                 call anglesolide(photon%direction,alpha,delta)
              !ejection d'un electron Auger
              else
                 Ea=Ea+0.03181_wp                       !toute l'energie est absorbee
                 photon%energie=0                       !il n'y a plus de photon
              endif

           !=>COUCHE L sinon
           else
              Ea=photon%energie                         !on fait l'approximation que toute l'energie est absorbee
              photon%energie=0                          !il n'y a plus de photon
           endif

        endif

end subroutine photoelectrique

!------------------------------------------------------------------------
!-         Effet Compton                                                -
!-         (diffusion du photon incident)                               -
!------------------------------------------------------------------------
subroutine Compton(photon,Ea)
implicit none

! IN/OUT variables
        type (photons) :: photon        !position, direction et energie du photon
        real (kind=wp) :: Ea            !energie absorbee

! Local variables
        real (kind=wp) :: a                     !rapport entre l'energie du photon et l'energie incidente
        real (kind=wp) :: a1, a2, a3, a4        !coefficient du polynome F(X)
        real (kind=wp) :: Xmin, Xmax, X, dX     !ensemble de definition
        real (kind=wp) :: Fmin, Fmax, F         !bornes de F(X) sur l'ensemble de definition

        real (kind=wp) :: G05CAF, G05DAF
        real (kind=wp) :: alea
        integer :: i
        real (kind=wp) :: Pi
        real (kind=wp) :: theta, phi

Pi=ACOS(-1._wp)

        !soit la fonction de repartition de la distribution Compton en energie:
        !F(X)=(mc^2)/E1( X^2(1/2) + X(2mc^2/E1+(mc^2/E1)^2) + lnX(1-2mc^2/E1-2(mc^2/E1)^2) - 1/X(mc^2/E1)^2)
        !avec X=E2/E1
        a=0.511_wp/photon%energie
        a1=0.5_wp
        a2=2*a+a**2
        a3=1-2*a-2*a**2
        a4=-a**2

        !bornes de la fonction sur l'ensemble de definition [Xmin,Xmax]
        Xmin=1/(1+2/a)
        Xmax=1
        !F(X)=a*( a1*X**2 + a2*X + a3*LOG(X) + a4/X )
        Fmin=a*( a1*Xmin**2 + a2*Xmin + a3*LOG(Xmin) + a4/Xmin )
        Fmax=a*( a1*Xmax**2 + a2*Xmax + a3*LOG(Xmax) + a4/Xmax )

        !tirage uniforme sur l'intervalle [Fmin,Fmax]
        alea=G05DAF(Fmin,Fmax)
        !dicotomie pour trouver l'antecedent X (F(X)=alea) de cette valeur:
        dX=(Xmax-Xmin)/2
        X=Xmax-dX
        do i=1,10
           F=a*( a1*X**2 + a2*X + a3*LOG(X) + a4/X )
           dX=dX/2
           if (F .gt. alea) then
              X=X-dX
           else
              X=X+dX
           endif
        enddo

        !energie deposee
        Ea=photon%energie*(1-X)
        !energie du photon diffuse
        photon%energie=photon%energie*X
        !nouvelle direction du photon diffuse
        theta=ACOS(1-a*(1/X-1))
        phi=G05DAF(0,2*Pi)
        call anglesolide(photon%direction,theta,phi)

end subroutine Compton

!------------------------------------------------------------------------
!-         Surface efficace                                             -
!-         de l' Aluminum Z=13 [0.001,1.0]MeV                           -
!------------------------------------------------------------------------
subroutine Al_CrossSection(E0, aPhoto,aTotal)
implicit none

! IN/OUT variables
       real (kind=wp) :: E0
       real (kind=wp) :: aPhoto, aTotal

! Local variables
       real (kind=wp) :: aCompt
       real (kind=wp), dimension(27) :: E, Compt, Photo
Data E     /0.001000_wp, 0.001500_wp, 0.001560_wp, 0.001560_wp, 0.0020000_wp, 0.0030000_wp, 0.0040_wp, &
            0.005000_wp, 0.006000_wp, 0.008000_wp, 0.010000_wp, 0.0150000_wp, 0.0200000_wp, 0.0300_wp, &
            0.040000_wp, 0.050000_wp, 0.060000_wp, 0.080000_wp, 0.1000000_wp, 0.1500000_wp, 0.2000_wp, &
            0.300000_wp, 0.400000_wp, 0.500000_wp, 0.600000_wp, 0.8000000_wp, 1.0000000_wp/
Data Compt /0.014300_wp, 0.024800_wp, 0.025900_wp, 0.025900_wp, 0.0337000_wp, 0.0473000_wp, 0.0581_wp, &
            0.067900_wp, 0.077000_wp, 0.092900_wp, 0.106000_wp, 0.1270000_wp, 0.1370000_wp, 0.1460_wp, &
            0.149000_wp, 0.150000_wp, 0.148000_wp, 0.144000_wp, 0.1390000_wp, 0.1270000_wp, 0.1170_wp, &
            0.102000_wp, 0.091600_wp, 0.083700_wp, 0.077500_wp, 0.0681000_wp, 0.0613000_wp/
Data Photo /1180.000_wp, 400.0000_wp, 360.0000_wp, 3960.000_wp, 2260.0000_wp, 787.00000_wp, 359.00_wp, &
            192.0000_wp, 114.0000_wp, 49.50000_wp, 25.60000_wp, 7.5100000_wp, 3.1000000_wp, 0.8720_wp, &
            0.350000_wp, 0.172000_wp, 0.095600_wp, 0.037800_wp, 0.0184000_wp, 0.0049900_wp, 0.0020_wp, &
            0.000574_wp, 0.000248_wp, 0.000134_wp, 0.000084_wp, 0.0000425_wp, 0.0000264_wp/
       integer :: i
       real (kind=wp) :: coeff

!Quel est le mu/rho de l' Aluminum pour un photon d'energie E0?
       if (E0 .eq. 0.00156_wp) then    !point double de la courbe: Kedge
          aCompt=0.0259_wp
          aPhoto=3960.0_wp
          aTotal=aCompt+aPhoto
       else                             !interpolation sur la droite log
          i=2
          do while (E(i) .lt. E0)       !on cherche l'interval [i-1,i]
             i=i+1
          enddo
          coeff=LOG10(Photo(i)/Photo(i-1))/LOG10(E(i)/E(i-1))
          aPhoto=10._wp**(coeff*LOG10(E0/E(i-1))+LOG10(Photo(i-1)))
          coeff=LOG10(Compt(i)/Compt(i-1))/LOG10(E(i)/E(i-1))
          aCompt=10._wp**(coeff*LOG10(E0/E(i-1))+LOG10(Compt(i-1)))
          aTotal=aCompt+aPhoto
       endif

end subroutine Al_CrossSection

!------------------------------------------------------------------------
!-         Surface efficace                                             -
!-         du Silicon Z=14 [0.001,1.0]MeV                               -
!------------------------------------------------------------------------
subroutine Si_CrossSection(E0, aPhoto,aTotal)
implicit none

! IN/OUT variables
       real (kind=wp) :: E0
       real (kind=wp) :: aPhoto, aTotal

! Local variables
       real (kind=wp) :: aCompt
       real (kind=wp), dimension(27) :: E, Compt, Photo
Data E     /0.001000_wp, 0.001500_wp, 0.001839_wp, 0.001839_wp, 0.0020000_wp, 0.0030000_wp, 0.00400_wp, &
            0.005000_wp, 0.006000_wp, 0.008000_wp, 0.010000_wp, 0.0150000_wp, 0.0200000_wp, 0.03000_wp, &
            0.040000_wp, 0.050000_wp, 0.060000_wp, 0.080000_wp, 0.1000000_wp, 0.1500000_wp, 0.20000_wp, &
            0.300000_wp, 0.400000_wp, 0.500000_wp, 0.600000_wp, 0.8000000_wp, 1.0000000_wp/
Data Compt /0.013200_wp, 0.023900_wp, 0.030800_wp, 0.030800_wp, 0.0339000_wp, 0.0496000_wp, 0.06130_wp, &
            0.071100_wp, 0.079800_wp, 0.095100_wp, 0.108000_wp, 0.1290000_wp, 0.1400000_wp, 0.15000_wp, &
            0.153000_wp, 0.154000_wp, 0.153000_wp, 0.148000_wp, 0.1430000_wp, 0.1310000_wp, 0.12100_wp, &
            0.106000_wp, 0.094800_wp, 0.086600_wp, 0.080200_wp, 0.0705000_wp, 0.0634000_wp/
Data Photo /1570.000_wp, 533.0000_wp, 307.0000_wp, 3190.000_wp, 2770.0000_wp, 977.00000_wp, 451.000_wp, &
            244.0000_wp, 146.0000_wp, 63.80000_wp, 33.10000_wp, 9.8500000_wp, 4.0900000_wp, 1.16000_wp, &
            0.469000_wp, 0.231000_wp, 0.129000_wp, 0.051200_wp, 0.0250000_wp, 0.0068100_wp, 0.00274_wp, &
            0.000788_wp, 0.000341_wp, 0.000185_wp, 0.000116_wp, 0.0000585_wp, 0.0000364_wp/
       integer :: i
       real (kind=wp) :: coeff

!Quel est le mu/rho du Silicon pour un photon d'energie E0?
       if (E0 .eq. 0.001839_wp) then    !point double de la courbe: Kedge
          aCompt=0.0308_wp
          aPhoto=3190.0_wp
          aTotal=aCompt+aPhoto
       else                             !interpolation sur la droite log
          i=2
          do while (E(i) .lt. E0)       !on cherche l'interval [i-1,i]
             i=i+1
          enddo
          coeff=LOG10(Photo(i)/Photo(i-1))/LOG10(E(i)/E(i-1))
          aPhoto=10._wp**(coeff*LOG10(E0/E(i-1))+LOG10(Photo(i-1)))
          coeff=LOG10(Compt(i)/Compt(i-1))/LOG10(E(i)/E(i-1))
          aCompt=10._wp**(coeff*LOG10(E0/E(i-1))+LOG10(Compt(i-1)))
          aTotal=aCompt+aPhoto
       endif

end subroutine Si_CrossSection

!------------------------------------------------------------------------
!-         Surface efficace                                             -
!-         du Cadmium Z=48 [0.005,1.0]MeV                               -
!------------------------------------------------------------------------
subroutine Cd_CrossSection(E0, aPhoto,aTotal)
implicit none

! IN/OUT variables
       real (kind=wp) :: E0
       real (kind=wp) :: aPhoto, aTotal

! Local variables
       real (kind=wp) :: aCompt
       real (kind=wp), dimension(22) :: E, Compt, Photo
Data E     /0.00500_wp, 0.0060_wp, 0.0080_wp, 0.0100_wp, 0.0150_wp, 0.0200_wp, 0.02671_wp, &
            0.02671_wp, 0.0300_wp, 0.0400_wp, 0.0500_wp, 0.0600_wp, 0.0800_wp, 0.10000_wp, &
            0.15000_wp, 0.2000_wp, 0.3000_wp, 0.4000_wp, 0.5000_wp, 0.6000_wp, 0.80000_wp, 1.00000_wp/
Data Compt /0.03550_wp, 0.0417_wp, 0.0528_wp, 0.0621_wp, 0.0790_wp, 0.0899_wp, 0.09970_wp, &
            0.09970_wp, 0.1030_wp, 0.1100_wp, 0.1140_wp, 0.1150_wp, 0.1150_wp, 0.11300_wp, &
            0.10700_wp, 0.0998_wp, 0.0885_wp, 0.0800_wp, 0.0734_wp, 0.0682_wp, 0.06010_wp, 0.05410_wp/
Data Photo /764.000_wp, 475.00_wp, 222.00_wp, 122.00_wp, 40.000_wp, 17.900_wp, 7.93000_wp, &
            49.8000_wp, 36.900_wp, 17.200_wp, 9.3600_wp, 5.6400_wp, 2.5000_wp, 1.32000_wp, &
            0.40700_wp, 0.1770_wp, 0.0561_wp, 0.0257_wp, 0.0144_wp, 0.0092_wp, 0.00475_wp, 0.00297_wp/
       integer :: i
       real (kind=wp) :: coeff

!Quel est le mu/rho du Cadmium pour un photon d'energie E0?
       if (E0 .eq. 0.02671_wp) then     !point double de la courbe: Kedge
          aCompt=0.0997_wp
          aPhoto=49.800_wp
          aTotal=aCompt+aPhoto
       else                             !interpolation sur la droite log
          i=2
          do while (E(i) .lt. E0)       !on cherche l'interval [i-1,i]
             i=i+1
          enddo
          coeff=LOG10(Photo(i)/Photo(i-1))/LOG10(E(i)/E(i-1))
          aPhoto=10._wp**(coeff*LOG10(E0/E(i-1))+LOG10(Photo(i-1)))
          coeff=LOG10(Compt(i)/Compt(i-1))/LOG10(E(i)/E(i-1))
          aCompt=10._wp**(coeff*LOG10(E0/E(i-1))+LOG10(Compt(i-1)))
          aTotal=aCompt+aPhoto
       endif

end subroutine Cd_CrossSection

!------------------------------------------------------------------------
!-         Surface efficace                                             -
!-         du Tellurium Z=52 [0.005,1.0]MeV                             -
!------------------------------------------------------------------------
subroutine Te_CrossSection(E0, aPhoto,aTotal)
implicit none

! IN/OUT variables
       real (kind=wp) :: E0
       real (kind=wp) :: aPhoto, aTotal

! Local variables
       real (kind=wp) :: aCompt
       real (kind=wp), dimension(22) :: E, Compt, Photo
Data E     /0.00500_wp, 0.00600_wp, 0.0080_wp, 0.0100_wp, 0.0150_wp, 0.0200_wp, 0.03000_wp, &
            0.03181_wp, 0.03181_wp, 0.0400_wp, 0.0500_wp, 0.0600_wp, 0.0800_wp, 0.10000_wp, &
            0.15000_wp, 0.20000_wp, 0.3000_wp, 0.4000_wp, 0.5000_wp, 0.6000_wp, 0.80000_wp, 1.00000_wp/
Data Compt /0.03460_wp, 0.04010_wp, 0.0498_wp, 0.0582_wp, 0.0742_wp, 0.0846_wp, 0.09700_wp, &
            0.09840_wp, 0.09840_wp, 0.1030_wp, 0.1070_wp, 0.1090_wp, 0.1090_wp, 0.10800_wp, &
            0.10100_wp, 0.09490_wp, 0.0842_wp, 0.0763_wp, 0.0700_wp, 0.0650_wp, 0.05730_wp, 0.05160_wp/
Data Photo /897.000_wp, 568.000_wp, 267.00_wp, 147.00_wp, 48.900_wp, 22.100_wp, 7.07000_wp, &
            5.99000_wp, 36.4000_wp, 20.100_wp, 11.000_wp, 6.6900_wp, 3.0000_wp, 1.59000_wp, &
            0.49900_wp, 0.21900_wp, 0.0700_wp, 0.0322_wp, 0.0182_wp, 0.0116_wp, 0.00602_wp, 0.00376_wp/
       integer :: i
       real (kind=wp) :: coeff

!Quel est le mu/rho du Cadmium pour un photon d'energie E0?
       if (E0 .eq. 0.03181_wp) then     !point double de la courbe: Kedge
          aCompt=0.0984_wp
          aPhoto=36.400_wp
          aTotal=aCompt+aPhoto
       else                             !interpolation sur la droite log
          i=2
          do while (E(i) .lt. E0)       !on cherche l'interval [i-1,i]
             i=i+1
          enddo
          coeff=LOG10(Photo(i)/Photo(i-1))/LOG10(E(i)/E(i-1))
          aPhoto=10._wp**(coeff*LOG10(E0/E(i-1))+LOG10(Photo(i-1)))
          coeff=LOG10(Compt(i)/Compt(i-1))/LOG10(E(i)/E(i-1))
          aCompt=10._wp**(coeff*LOG10(E0/E(i-1))+LOG10(Compt(i-1)))
          aTotal=aCompt+aPhoto
       endif

end subroutine Te_CrossSection

!------------------------------------------------------------------------
!-      Distribution du vecteur photon dans l'angle solide              -
!------------------------------------------------------------------------
subroutine anglesolide(vecteur,alpha,delta)

implicit none

! IN/OUT variables
        real (kind=wp), dimension(3) :: vecteur
        real (kind=wp) :: alpha, delta

! local variables
        real (kind=wp), dimension(3) :: axe, temp

!produit vectoriel de vecteur par n'importe quoi pour trouver axe de rotation orthogonal:
        !si vecteur est colineaire a (0,0,1) alors
        if ((vecteur(1) .eq. 0) .and. (vecteur(2) .eq. 0)) then
           axe(1)=0             !vecteur^(1,0,0)
           axe(2)=vecteur(3)
           axe(3)=-vecteur(2)
        !si vecteur n'est pas colineaire a (0,0,1) alors
        else
           axe(1)=vecteur(2)    !vecteur^(0,0,1)
           axe(2)=-vecteur(1)
           axe(3)=0
        endif

        temp=vecteur
!rotation de alpha autour de l'axe orthogonal au vecteur
        call rotation_rad(axe,vecteur,alpha)
!rotation de delta autour du vecteur d'origine
        call rotation_rad(temp,vecteur,delta)

end subroutine anglesolide

end module FPA