!> \file t_proc.f90
!> Contains module tracer_processes.

!>General substance (T1) and water temperature (T2) processes in HYPE
!Todo: Move T2 processes to this module.
MODULE TRACER_PROCESSES

  !Copyright 2014,2016-2017 SMHI
  !
  !This file is part of HYPE.
  !HYPE is free software: you can redistribute it and/or modify it under the terms of the Lesser GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version.
  !HYPE is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lesser GNU General Public License for more details.
  !You should have received a copy of the Lesser GNU General Public License along with HYPE. If not, see <http://www.gnu.org/licenses/>.

  !Used modules
  USE GENERAL_FUNCTIONS, ONLY : exponential_decay,sedimentation
  USE GENERAL_WATER_CONCENTRATION, ONLY : production_pool,retention_pool,new_concentration
  USE STATETYPE_MODULE, ONLY : snowicestatetype,soilstatetype,riverstatetype,lakestatetype,miscstatetype
  !Subroutines uses modvar, hypevariables
  IMPLICIT NONE
  PRIVATE
  !----------------------------------------------
  ! Private procedures
  !----------------------------------------------
  !decay_of_tracer
  !decay_of_tracer_sorbedphase
  !sorption_of_tracer
  !sedimentation_resuspension_of_tracer
  !T1_crop_sources
  !T1_incorporation
  !release_from_source
  !----------------------------------------------
  PUBLIC :: add_tracer_point_source_to_river, &
            add_tracer_point_source_to_lake,  &
            soil_tracer_processes,      &
            tracer_processes_in_river,  &
            tracer_processes_in_lake

  CONTAINS

  !>Add T1-T2 load from point sources to river inflow
  !>
  !>\b Reference ModelDescription Chapter Water management (Point sources -
  !>Tracer T1 point sources)
  !-----------------------------------------------------------------
  SUBROUTINE add_tracer_point_source_to_river(i,itype,qin,cin)

    USE MODVAR, ONLY : i_t1,    &
                       i_t2,    &
                       tload,   &
                       tloadexist,  &
                       numsubstances

    !Argument declarations
    INTEGER, INTENT(IN) :: i                        !<index of subbasin
    INTEGER, INTENT(IN) :: itype                    !<type of river
    REAL, INTENT(INOUT) :: qin                      !<flow into river (m3/s)
    REAL, INTENT(INOUT) :: cin(numsubstances)       !<concentration of flow into river (-)

    !Local variables
    INTEGER j   !row in tload
    INTEGER dim
    REAL qadd
    REAL cadd(numsubstances)

    IF(ALLOCATED(tloadexist))THEN
      IF(tloadexist(i))THEN
        !Find load
        dim = SIZE(tload)
        IF(dim==0) RETURN
        DO j=1,dim
          IF(tload(j)%subindex==i)THEN
            IF(tload(j)%sw_code==itype*2-1)EXIT
          ENDIF
        ENDDO
        IF(j>dim) RETURN

        !Set source to be added
        qadd = tload(j)%psvol   !m3/s
        IF(qadd>0)THEN
          cadd = 0.
          IF(i_t1>0) cadd(i_t1) = tload(j)%psconc
          IF(i_t2>0) cadd(i_t2) = tload(j)%pstemp

          !Add source to river inflow
          IF(qin>0)THEN
            cin = (qin * cin + qadd * cadd)/(qin + qadd)
            qin = qin + qadd
          ELSE
            qin = qadd
            cin = cadd
          ENDIF
        ENDIF
      ENDIF
    ENDIF

  END SUBROUTINE add_tracer_point_source_to_river

  !>Add T1-T2 load from point sources to lake inflow
  !>
  !>\b Reference ModelDescription Chapter Water management (Point sources -
  !>Tracer T1 point sources)
  !-----------------------------------------------------------------
  SUBROUTINE add_tracer_point_source_to_lake(i,itype,qin,cin)

    USE MODVAR, ONLY : i_t1,    &
                       i_t2,    &
                       tload,   &
                       tloadexist,  &
                       numsubstances

    !Argument declarations
    INTEGER, INTENT(IN) :: i                        !<index of subbasin
    INTEGER, INTENT(IN) :: itype                    !<type of lake
    REAL, INTENT(INOUT) :: qin                      !<flow into lake (m3/s)
    REAL, INTENT(INOUT) :: cin(numsubstances)       !<concentration of flow into lake (-)

    !Local variables
    INTEGER j   !row in tload
    INTEGER dim
    REAL qadd
    REAL cadd(numsubstances)

    IF(ALLOCATED(tloadexist))THEN
      IF(tloadexist(i))THEN
        !Find load
        dim = SIZE(tload)
        IF(dim==0) RETURN
        DO j=1,dim
          IF(tload(j)%subindex==i)THEN
            IF(tload(j)%sw_code==itype*2)EXIT
          ENDIF
        ENDDO
        IF(j>dim) RETURN

        !Set source to be added
        qadd = tload(j)%psvol   !m3/s
        IF(qadd>0)THEN
          cadd = 0.
          IF(i_t1>0) cadd(i_t1) = tload(j)%psconc
          IF(i_t2>0) cadd(i_t2) = tload(j)%pstemp

          !Add source to lake inflow
          IF(qin>0)THEN
            cin = (qin * cin + qadd * cadd)/(qin + qadd)
            qin = qin + qadd
          ELSE
            qin = qadd
            cin = cadd
          ENDIF
        ENDIF
      ENDIF
    ENDIF

  END SUBROUTINE add_tracer_point_source_to_lake

  !>Calculate tracer processes in soil
  !
  !>\b Reference ModelDescription Chapter Tracer simulation (General
  !>tracer (T1) - Processes)
  !------------------------------------------------------------------------------
  SUBROUTINE soil_tracer_processes(i,j,year,thickness,soilstate,miscstate,infilt,T1release)

    USE MODVAR, ONLY : maxsoillayers,     &
                       i_t1,         &
                       dayno,  &
                       genpar, &
                       cropdata

    USE HYPEVARIABLES, ONLY : m_t1rel

    INTEGER, INTENT(IN) :: i                        !<index of subbasin
    INTEGER, INTENT(IN) :: j                        !<index of class
    INTEGER, INTENT(IN) :: year                     !<current year
    REAL, INTENT(IN)    :: thickness(maxsoillayers) !<thickness of soil layers
    TYPE(soilstatetype),INTENT(INOUT)  :: soilstate !<Soil states
    TYPE(miscstatetype),INTENT(INOUT)  :: miscstate !<Miscellaneous states
    REAL, INTENT(IN)    :: infilt                   !<infiltration (snowmelt and precip)
    REAL, INTENT(OUT)   :: T1release                !<release of T1 from surface sources

    IF(i_t1>0)THEN
      !Add source to fields through cropdata
      IF(ALLOCATED(cropdata)) CALL T1_crop_sources(i,j,year,dayno,miscstate%partT1sf(j,i))
      !Decay of T1 in different compartments
      CALL decay_of_tracer(1,soilstate%water(1,j,i),soilstate%conc(:,1,j,i))
      CALL decay_of_tracer_sorbedphase(1,soilstate%partT1(1,j,i))
      CALL decay_of_tracer_sorbedphase(1,miscstate%partT1sf(j,i))
      !Release of surface T1 from rain/snowmelt
      IF(infilt>0. .AND. miscstate%partT1sf(j,i)>0.) THEN
        CALL release_from_source(miscstate%partT1sf(j,i),infilt,T1release,genpar(m_t1rel))
      ENDIF
      !Adsorption/desorption of T1
      CALL sorption_of_tracer(soilstate%water(1,j,i),soilstate%conc(:,1,j,i),soilstate%partT1(1,j,i),thickness(1))
      IF(thickness(2)>0) THEN
        CALL decay_of_tracer(1,soilstate%water(2,j,i),soilstate%conc(:,2,j,i))
        CALL decay_of_tracer_sorbedphase(1,soilstate%partT1(2,j,i))
        CALL sorption_of_tracer(soilstate%water(2,j,i),soilstate%conc(:,2,j,i),soilstate%partT1(2,j,i),thickness(2))
      ENDIF
      IF(thickness(3)>0) THEN
        CALL decay_of_tracer(1,soilstate%water(3,j,i),soilstate%conc(:,3,j,i))
        CALL decay_of_tracer_sorbedphase(1,soilstate%partT1(3,j,i))
        CALL sorption_of_tracer(soilstate%water(3,j,i),soilstate%conc(:,3,j,i),soilstate%partT1(3,j,i),thickness(3))
      ENDIF
      !Incorporation of T1 (ploughing down surface T1)
      IF(ALLOCATED(cropdata))THEN
        IF(thickness(2)==0)THEN
          CALL T1_incorporation(i,j,dayno,1,soilstate,miscstate)
        ELSE
          CALL T1_incorporation(i,j,dayno,2,soilstate,miscstate)
        ENDIF
      ENDIF
    ENDIF

  END SUBROUTINE soil_tracer_processes

  !>River processes of tracer T1
  !>
  !>\b Reference ModelDescription Chapter Tracer simulation (General
  !>tracer (T1) - Processes)
  !-----------------------------------------------------------------
  SUBROUTINE tracer_processes_in_river(i,itype,riverarea,depth,transq,qbank,riverstate)

    USE MODVAR, ONLY : i_t1, &
                       genpar
    USE HYPEVARIABLES, ONLY : m_t1sedexp

    !Argument variables
    INTEGER, INTENT(IN) :: i               !<index of subbasin
    INTEGER, INTENT(IN) :: itype           !<index of river type (local = 1, main = 2)
    REAL, INTENT(IN)    :: riverarea       !<river area
    REAL, INTENT(IN)    :: depth           !<river depth (m)
    REAL, INTENT(IN)    :: transq          !<flow out of translation box chain (m3/s)
    REAL, INTENT(IN)    :: qbank           !<bank full river flow
    TYPE(riverstatetype),INTENT(INOUT) :: riverstate  !<River states

    !Calculate T1 river processes
    IF(i_t1>0)THEN
      CALL decay_of_tracer(1,riverstate%water(itype,i),riverstate%conc(:,itype,i))
      CALL sedimentation_resuspension_of_tracer(i,itype,riverarea,genpar(m_t1sedexp),riverstate,transq,qbank,depth)
      CALL decay_of_tracer_sorbedphase(1,riverstate%T1sed(itype,i))
    ENDIF

  END SUBROUTINE tracer_processes_in_river

  !>Lake processes of tracer T1
  !>
  !>\b Reference ModelDescription Chapter Tracer simulation (General
  !>tracer (T1) - Processes)
  !-----------------------------------------------------------------
  SUBROUTINE tracer_processes_in_lake(i,itype,lakestate)

    USE MODVAR, ONLY : i_t1, &
                       genpar
    USE HYPEVARIABLES, ONLY : m_t1sed

    !Argument declarations
    INTEGER,INTENT(IN) :: i             !<index of subbasin
    INTEGER,INTENT(IN) :: itype         !<index of lake type (ilake = 1, olake = 2)
    TYPE(lakestatetype),INTENT(INOUT) :: lakestate      !<Lake state

    !Calculate T1 lake processes
    IF(i_t1>0)THEN
      CALL decay_of_tracer(1,lakestate%water(itype,i),lakestate%conc(:,itype,i))
      CALL decay_of_tracer(1,lakestate%slowwater(itype,i),lakestate%concslow(:,itype,i))
      CALL sedimentation(lakestate%slowwater(itype,i)*1.E-3,lakestate%concslow(i_t1,itype,i),genpar(m_t1sed))
    ENDIF

  END SUBROUTINE tracer_processes_in_lake

  !>Decay processes of tracer T1
  !>
  !>\b Reference ModelDescription Chapter Tracer simulation (General
  !>tracer (T1) - Processes)
  !-----------------------------------------------------------------
  SUBROUTINE decay_of_tracer(timesteps,vol,conc)

    USE MODVAR, ONLY : i_t1,    &
                       genpar,  &
                       timesteps_per_day, &
                       numsubstances
    USE HYPEVARIABLES, ONLY : m_expdec

    !Argument declarations
    INTEGER, INTENT(IN) :: timesteps            !<number of timesteps
    REAL, INTENT(IN)    :: vol                  !<volume of water
    REAL, INTENT(INOUT) :: conc(numsubstances)  !<concentration of water (-)

    !Local variables
    REAL ts,left

    IF(i_t1>0)THEN
      IF(vol>0. .AND. conc(i_t1)>0.)THEN
        IF(genpar(m_expdec)>0)THEN
          !Exponential decay with parameter t1expdec [days]
          ts = REAL(timesteps) / REAL(timesteps_per_day)  !time in days
          left = exponential_decay(ts,genpar(m_expdec))
          conc(i_t1) = conc(i_t1) * left
        ELSE
          !Other decay equation
        ENDIF

      ENDIF
    ENDIF

  END SUBROUTINE decay_of_tracer

  !>Decay of tracer in sorbed phase
  !>
  !>\b Reference ModelDescription Chapter Tracer simulation (General
  !>tracer (T1) - Processes)
  !--------------------------------------------------------------------
  SUBROUTINE decay_of_tracer_sorbedphase(timesteps,pool)

    USE MODVAR, ONLY : genpar,  &
                       timesteps_per_day, &
                       i_t1
    USE HYPEVARIABLES, ONLY : m_expdec

    !Argument declarations
    INTEGER, INTENT(IN) :: timesteps            !<number of timesteps
    REAL, INTENT(INOUT) :: pool                 !<amount of T1

    !Local variables
    REAL ts,left

    IF(i_t1>0)THEN
      IF(pool>0.)THEN
        IF(genpar(m_expdec)>0)THEN
          !Exponential decay with parameter t1expdec [days]
          ts = REAL(timesteps) / REAL(timesteps_per_day)  !time in days
          left = exponential_decay(ts,genpar(m_expdec))
          pool = pool * left
        ELSE
          !Other decay equation
        ENDIF

      ENDIF
    ENDIF

  END SUBROUTINE decay_of_tracer_sorbedphase

  !>Adsorption of traced to soil particles
  !>
  !>\b Reference ModelDescription Chapter Tracer simulation (General
  !>tracer (T1) - Processes)
  !--------------------------------------------------------------
  SUBROUTINE sorption_of_tracer(vol,conc,sorbed,layerthick)

    USE MODVAR, ONLY : i_t1,    &
                       genpar,  &
                       numsubstances
    USE HYPEVARIABLES, ONLY : m_T1freuc, bulkdensity

    !Argument declarations
    REAL, INTENT(IN)    :: vol                  !<volume of water (mm)
    REAL, INTENT(INOUT) :: conc(numsubstances)  !<concentration in water (-)
    REAL, INTENT(INOUT) :: sorbed               !<T1 sorbed phase
    REAL, INTENT(IN)    :: layerthick           !<thickness of soil layer (m)

    !Local variables
    REAL totalT1, sorbed_conc0, equi_solved,coeff, equi_sorbed, adsdes

    IF(i_t1>0)THEN
      IF((vol>0. .AND. conc(i_t1)>0.) .OR. sorbed>0.)THEN
        totalT1 = sorbed + conc(i_t1) * vol  !Total amount of T1/km2
        sorbed_conc0 = (sorbed / bulkdensity) / layerthick        !T1 /kg soil
        coeff = genpar(m_T1freuc) * bulkdensity * layerthick
        equi_solved = totalT1 / (vol + coeff)
        equi_sorbed = genpar(m_T1freuc) * equi_solved

        !Calculate new pool and concentration, depends on the equilibrium concentration
        adsdes = (equi_sorbed - sorbed_conc0)* bulkdensity * layerthick
        sorbed = sorbed + adsdes   !new Pool T1
        conc(i_t1) = conc(i_t1) - (adsdes / vol)  !new liquid conc
      ENDIF
    ENDIF

  END SUBROUTINE sorption_of_tracer

  !>Sedimentation and resuspension of tracer in river flow
  !>
  !>\b Reference ModelDescription Chapter Tracer simulation (General
  !>tracer (T1) - Processes)
  !---------------------------------------------------------------------------------------------
  SUBROUTINE sedimentation_resuspension_of_tracer(i,watertype,area,sedexppar,riverstate,riverq,qbank,depth)

    USE MODVAR, ONLY : i_t1

    !Argument declaration
    INTEGER, INTENT(IN)           :: i          !<index of current subbasin
    INTEGER, INTENT(IN)           :: watertype  !<river type (1=local, 2=main)
    REAL, INTENT(IN)              :: area       !<river surface area (m2)
    REAL, INTENT(IN)              :: sedexppar  !<sedimentation/resuspension parameter
    TYPE(riverstatetype),INTENT(INOUT) :: riverstate  !<River states
    REAL, INTENT(IN)              :: riverq     !<river discharge
    REAL, INTENT(IN)              :: qbank      !<Q bank full
    REAL, INTENT(IN)              :: depth      !<river depth (m)

    !Local variables
    REAL, DIMENSION(1) :: T1pool           !pools in water
    REAL, DIMENSION(1) :: sedT1, resuspT1  !changes (1/d)
    REAL, DIMENSION(1) :: tempsed          !temporary variable for T1 in river sediment
    REAL sedresp, help, qbankcorr

    !Initial check
    IF(sedexppar == 0) RETURN
    IF(area > 0.) THEN
      tempsed(1) = riverstate%T1sed(watertype,i)

      !Calculate nutrient pool of water
      T1pool = (riverstate%water(watertype,i) * riverstate%conc(i_t1,watertype,i))* 1.0E-3

      !Calculate sedimentation and resuspension
      resuspT1 = 0.
      sedT1 = 0.
      IF(qbank>0)THEN
        qbankcorr = 0.7*qbank
        help = 0
        IF(qbankcorr-riverq/=0) help = help + ((qbankcorr-riverq)/qbankcorr)**sedexppar
        IF(riverq>0) help = help - (riverq/qbankcorr)**sedexppar
        sedresp = MAX(-1., MIN(1.,help))
        IF(sedresp > 0) THEN !sedimentation
          sedT1 = sedresp * (riverstate%conc(i_t1,watertype,i) * MIN(riverstate%water(watertype,i),area * depth)) / 1.0E3
        ELSE                 !resuspension
          resuspT1 = - sedresp * tempsed
        ENDIF

        !Move sedimentation/resuspension to the water/sediment pool
        CALL retention_pool(1,T1pool,sedT1)              !sedT1 may change
        CALL production_pool(1,tempsed,sedT1)
        CALL retention_pool(1,tempsed,resuspT1)          !resuspT1 may change
        CALL production_pool(1,T1pool,resuspT1)
        riverstate%T1sed(watertype,i) = tempsed(1)

        !Calculate the new concentration in the water due to the change in the pool
        CALL new_concentration(T1pool(1),riverstate%water(watertype,i)*1.0E-3,riverstate%conc(i_t1,watertype,i))
      ENDIF
    ENDIF

  END SUBROUTINE sedimentation_resuspension_of_tracer

  !>Add T1 from manure application to above-soil pool of sorbed T1
  !>
  !>\b Reference ModelDescription Chapter Tracer simulation (General
  !>tracer (T1) - Sources)
  !---------------------------------------------------------------------------------
  SUBROUTINE T1_crop_sources(i,j,yearno,dayno,partT1sf)

    USE MODVAR, ONLY : find_croppart,   &
                       cropdata

    !Argument declarations
    INTEGER, INTENT(IN) :: i                        !<subbasin
    INTEGER, INTENT(IN) :: j                        !<class
    INTEGER, INTENT(IN) :: yearno                   !<year
    INTEGER, INTENT(IN) :: dayno                    !<day number of the year
    REAL, INTENT(INOUT) :: partT1sf                 !pool of T1 on soil surface

    !Local variables
    INTEGER k,kcrop
    INTEGER applicperiod
    REAL common_t1add
    REAL part                           !part of class area that is the current crop

    common_t1add   = 0.

    DO kcrop = 1, 2                             !main and secondary crop
      CALL find_croppart(i,j,kcrop,k,part)
      IF(k==0) CYCLE                            !no crop given, no uptake
      IF(cropdata(k)%T1amount==0) CYCLE
      IF(cropdata(k)%T1year==0 .OR. cropdata(k)%T1year == yearno) THEN
        IF(part>0)THEN

          !Calculate common fertiliser and manure use
          applicperiod = MAX(1,cropdata(k)%T1numberofdays)

          IF(dayno >= cropdata(k)%T1day .AND. dayno < cropdata(k)%T1day + applicperiod) THEN
            common_t1add = common_t1add + part * cropdata(k)%T1amount / applicperiod
          ENDIF
         !Calculate common residues
        ENDIF
      ENDIF
    ENDDO

    !Add T1 to surface pool
    IF(common_t1add>0.)THEN
      partT1sf = partT1sf + common_t1add
    ENDIF

  END SUBROUTINE T1_crop_sources

  !>Move sorbed T1 from above-soil pool to soil pool (tilling)
  !>
  !>\b Reference ModelDescription Chapter Tracer simulation (General
  !>tracer (T1) - Sources)
  !-----------------------------------------------------------------
  SUBROUTINE T1_incorporation(i,j,dayno,soillayers,soilstate,miscstate)

      USE MODVAR, ONLY : find_croppart,   &
                         cropdata

    !Argument declarations
    INTEGER, INTENT(IN) :: i                        !<subbasin
    INTEGER, INTENT(IN) :: j                        !<class
    INTEGER, INTENT(IN) :: dayno                    !<day number of the year
    INTEGER, INTENT(IN) :: soillayers               !<number of soil layers T1 will be added to
    TYPE(soilstatetype),INTENT(INOUT) :: soilstate  !<soil states
    TYPE(miscstatetype),INTENT(INOUT) :: miscstate  !<miscellaneous states

    !Local variables
    INTEGER k,kcrop
    REAL part                           !part of class area that is the current crop

    DO kcrop = 1, 2                             !main and secondary crop
      CALL find_croppart(i,j,kcrop,k,part)
      IF(k==0) CYCLE
      IF(part>0)THEN
        IF(dayno == cropdata(k)%T1daydown)THEN
          IF(soillayers == 1)THEN
            soilstate%partT1(1,j,i) = soilstate%partT1(1,j,i) + miscstate%partT1sf(j,i) * cropdata(k)%T1down1
            miscstate%partT1sf(j,i) = miscstate%partT1sf(j,i) * (1. - cropdata(k)%T1down1)
          ELSE
            soilstate%partT1(1,j,i) = soilstate%partT1(1,j,i) + miscstate%partT1sf(j,i) * cropdata(k)%T1down1
            soilstate%partT1(2,j,i) = soilstate%partT1(2,j,i) + miscstate%partT1sf(j,i) * cropdata(k)%T1down2
            miscstate%partT1sf(j,i) = miscstate%partT1sf(j,i) * (1. - cropdata(k)%T1down1 - cropdata(k)%T1down2)
          ENDIF
        ENDIF
      ENDIF
    ENDDO

  END SUBROUTINE T1_incorporation

  !>Release sorbed T1 to dissolved T1 on ground due to rain/snowmelt or surface runoff
  !>
  !>\b Reference ModelDescription Chapter Tracer simulation (General
  !>tracer (T1) - Processes)
  !---------------------------------------------------------------------------------------
  SUBROUTINE release_from_source(sourceT1,qmm,releaseT1,relpar)

    !Argument declarations
    REAL, INTENT(INOUT) :: sourceT1                 !<pool of tracer
    REAL, INTENT(IN)    :: qmm                      !<water in mm in precipitation or surface runoff
    REAL, INTENT(OUT)   :: releaseT1                !<release of tracer from source
    REAL, INTENT(IN)    :: relpar                   !<release parameter

    releaseT1 = sourceT1 * (1. - exp(-relpar * qmm))
    sourceT1 = sourceT1 - releaseT1

  END SUBROUTINE release_from_source

END MODULE TRACER_PROCESSES


      subroutine ffsort (iabs,doptz)

c KJ 1-06 : I added second input argument doptz
      implicit double precision (a-h, o-z)

c     finds iabs-th atom of 'iphabs' type in file atoms.dat and writes
c     a smaller list of all atoms within 'rclabs' of that particular
c     absorber into 'geom.dat' file.
c      first coded by a.l.ankudinov, 1998 for CFAVERAGE card
c      modified by a.l.ankudinov, march 2001 for new i/o structure

      include '../HEADERS/const.h'
      include '../HEADERS/dim.h'
      include '../HEADERS/vers.h'
      include '../HEADERS/parallel.h'
      include '../RDINP/allinp.h'

cc    INPUT
cc    atoms.dat
c--allinp--        integer  natt
c--allinp--        integer iphatx(nattx)
c--allinp--        double precision  ratx(3,nattx)
        logical doptz  !KJ 1-06 : call mkptz or not?
cc    global.dat
c       configuration average
c--allinp--        integer nabs, iphabs
c       global polarization data
c--allinp--        integer  ipol, ispin, le2
c--allinp--        double precision evec(3), xivec(3), spvec(3), elpty,angks,rclabs
c--allinp--        complex*16 ptz(-1:1, -1:1)
cc    OUTPUT: geom.dat
        integer  nat
        integer iatph(0:nphx), iphat(natx), index(natx)
        double precision  rat(3,natx)

c     Local stuff
      parameter (big = 1.0e5)
      character*512 slog

      external dist

c     if (worker) go to 400

c     standard formats for string, integers and real numbers
c  10  format(a)
c  20  format (20i4)
c  30  format (6f13.5)

c--json--cc    read atoms.dat file
c--json--      open (file='atoms.dat', unit=3, status='old',iostat=ios)
c--json--        read(3, 35) slog, natt
c--json--  35    format (a8, i7)
c--json--        read  (3, 10) slog
c--json--        do 40  iat = 1, natt
c--json--          read (3,36) ratx(1,iat), ratx(2,iat), ratx(3,iat), iphatx(iat)
c--json--  36      format( 3f13.5, i4)
c--json--  40    continue
c--json--      close(3)

c  45    format ( 2i8, f13.5)
c  50    format ( 3i5, 2f12.4)
c--json--c     read global.inp
c--json--c     CFAVERAGE iphabs nabs rclabs
c--json--        open (file='global.dat', unit=3, status='old',iostat=ios)
c--json--        call chopen (ios, 'global.inp', 'ffsort')
c--json--        read (3, 10) slog
c--json--        read (3, 45) nabs, iphabs, rclabs
c--json--c       global polarization data
c--json--        read  (3,10) slog
c--json--        read  (3, 50)  ipol, ispin, le2, elpty, angks
c--json--        read  (3, 10) slog
c--json--        do 60 i = 1,3
c--json--          read  (3,30) evec(i), xivec(i), spvec(i)
c--json--  60    continue
c--json--        read  (3, 10) slog
c--json--        do 70 i = -1, 1
c--json--          read (3,30) a1, b1, a2, b2, a3, b3
c--json--          ptz(-1,i)= dcmplx(a1,b1)
c--json--          ptz(0,i) = dcmplx(a2,b2)
c--json--          ptz(1,i) = dcmplx(a3,b3)
c--json--  70    continue
c--json--      close(3)

      call json_read_atoms(natt, ratx, iphatx)

      call json_read_global(nabs, iphabs, rclabs, ipol, ispin, le2,
     1                      elpty, angks, evec, xivec, spvec, ptz)

c     Find the first absorber (iphabs type) in a long list (iabs.le.0),
c     or find iabs-th atom in the list of type iphabs (iabs.gt.0)
      iatabs = 0
      icount = 0
      ifound = 0
      do iat = 1, natt
         if (iphatx(iat) .eq. 0) iphatx(iat) = iphabs
         if (iphatx(iat) .eq. iphabs) icount = icount +1
         if (ifound.eq.0 .and. icount.gt.0 .and. (icount.eq.iabs .or.
     1                          (iabs.le.0 .and. icount.eq.1))) then
            iatabs = iat
            ifound =1
         endif
      enddo

c     Make several sanity checks
      if (iatabs.eq.0 .and. natt.gt.1) then
         call wlog(' No absorbing atom (unique pot 0 or iphabs in'//
     1             ' CFAVERAGE  card) was defined.')
         call par_stop('RDINP')
      endif
      if (iphabs.eq.0 .and. icount.gt.1) then
         call wlog(' More than one absorbing atom (potential 0)')
         call wlog(' Only one absorbing atom allowed')
         call par_stop('RDINP')
      endif
      if ((icount.gt.0 .and. icount.lt.nabs) .or. nabs.le.0) then
         nabs = icount
         call wlog(' Averaging over ALL atoms of iphabs type')
      endif

c     Make absorbing atom first in the short list
      if (iatabs .ne. 0) then
         rat(1,1) = 0
         rat(2,1) = 0
         rat(3,1) = 0
         iphat(1) = 0
         index(1) = iatabs
      endif

c     make a smaller list of atoms from a big one
      nat = 1
      do iat = 1,natt
         if (iat.ne.iatabs) then
            tmp = dist (ratx(1,iat), ratx(1,iatabs))
            if (tmp.gt.0.1 .and. tmp.le.rclabs) then
               nat = nat + 1
               if (nat.gt.natx) then
                 write (slog, 307) nat, natx
  307            format (' Number of atoms', i6, 'exceeds max allowed',
     1           ' for the pathfinder =', i6)
                 call wlog (' Use or reduce rclabs in CFAVERAGE card')
                 call wlog (' Or increase parameter natx and recompile')
                 call par_stop('RDINP')
               endif
               rat(1,nat) = ratx(1,iat)-ratx(1,iatabs)
               rat(2,nat) = ratx(2,iat)-ratx(2,iatabs)
               rat(3,nat) = ratx(3,iat)-ratx(3,iatabs)
               iphat(nat) = iphatx(iat)
               index(nat) = iat
            endif
         endif
      enddo
c     sort atoms by distance
      do iat = 1,nat-1
        r2min = rat(1,iat)**2 + rat(2,iat)**2 + rat(3,iat)**2
        imin = iat
        do i = iat+1,nat
          r2 = rat(1,i)**2 + rat(2,i)**2 + rat(3,i)**2
          if (r2.lt.r2min) then
            r2min = r2
            imin = i
          endif
       enddo
        if (imin.ne.iat) then
c         permute coordinates for atoms iat and imin
          do i = 1,3
            r2 = rat(i,iat)
            rat(i,iat) = rat(i,imin)
            rat(i,imin) = r2
         enddo
          i = iphat(iat)
          iphat(iat) = iphat(imin)
          iphat(imin) = i
          i = index(iat)
          index(iat) = index(imin)
          index(imin) = i
        endif
      enddo

c     rotate xyz frame for the most convinience and make
c     polarization tensor
c     make polarization tensor when z-axis is along k-vector
      if (doptz)  !KJ I added this if-statement 1-06
     1  call mkptz( ipol, elpty, evec, xivec, ispin, spvec, nat, rat,
     2           angks, le2, ptz)
c     rewrite global.json for initial iteration to update 'ptz'
      call json_global(nabs)

c--json--c     rewrite global.inp for initial iteration to update 'ptz'
c--json--      open (file='global.dat', unit=3, status='unknown',iostat=ios)
c--json--c       configuration average data
c--json--        write (3, 10) ' nabs, iphabs - CFAVERAGE data'
c--json--        write (3, 45) nabs, iphabs, rclabs
c--json--c       global polarization data
c--json--        write (3,10) ' ipol, ispin, le2, elpty, angks'
c--json--        write (3, 50)  ipol, ispin, le2, elpty, angks
c--json--        write (3, 10) 'evec         xivec        spvec'
c--json--        do 360 i = 1,3
c--json--          write (3,30) evec(i), xivec(i), spvec(i)
c--json-- 360    continue
c--json--        write (3, 10) ' polarization tensor '
c--json--        do 370 i = -1, 1
c--json--          write(3,30) dble(ptz(-1,i)), dimag(ptz(-1,i)), dble(ptz(0,i)),
c--json--     1                dimag(ptz(0,i)),  dble(ptz(1,i)), dimag(ptz(1,i))
c--json-- 370    continue
c--json--      close(3)

c     Find model atoms for unique pots that have them
c     Use atom closest to absorber for model
      do iph = 1, nphx
         iatph(iph) = 0
      enddo
c     By construction absorbing atom is first in the list
      iatph(0) = 1
      nph = 0
      do iph = 1, nphx
         rabs = big
         do iat = 2, nat
            if (iph .eq. iphat(iat))  then
               tmp = dist (rat(1,iat), rat(1,1))
               if (tmp .lt. rabs)  then
c                 this is the closest so far
                  rabs = tmp
                  iatph(iph) = iat
               endif
            endif
         enddo
         if (iatph(iph).gt.0) nph = iph
      enddo
c     if iatph > 0, a model atom has been found.

c     Check if 2 atoms are closer together than 1.75 bohr (~.93 Ang)
      ratmin = 1.0e20
      do iat = 1, nat
         do jat = iat+1, nat
            rtmp = dist(rat(1,iat),rat(1,jat))
            if (rtmp .lt. ratmin)  ratmin = rtmp
            if (rtmp .lt. 1.75 * bohr)  then
               call wlog(' WARNING:  TWO ATOMS VERY CLOSE TOGETHER.' //
     1                   '  CHECK INPUT.')
               iatx = index(iat)
               jatx = index(jat)
               write(slog,'(a,2i8)') ' atoms ', iatx, jatx
               call wlog(slog)
               write(slog,'(i5,1p,3e13.5)') iatx, (ratx(i,iatx),i=1,3)
               call wlog(slog)
               write(slog,'(i5,1p,3e13.5)') jatx, (ratx(i,jatx),i=1,3)
               call wlog(slog)
               call wlog(' Run continues in case you really meant it.')
            endif
         enddo
      enddo

c--json--c     Write output geom.dat
c--json--      open (file='geom.dat', unit=3, status='unknown',iostat=ios)
c--json--        write (3,535) nat, nph
c--json--  535   format ('nat, nph = ', 2i5)
c--json--        write (3,516) (iatph(iph), iph=0,nph)
c--json--  516   format(16i5)
c--json--        write (3, 10) ' iat     x       y        z       iph  '
c--json--        write (3, 526)
c--json--  526   format (1x, 71('-'))
c--json--        ibounc = 1
c--json--        do 540  i = 1, nat
c--json--          write(3,536) i, rat(1,i), rat(2,i), rat(3,i), iphat(i), ibounc
c--json--  536     format(i4, 3f13.5, 2i4)
c--json--  540   continue
c--json--      close(3)
      call json_geom(iatph,rat,iphat)

c     Atoms for the pathfinder
      if (iatabs .le. 0)  then
         call wlog(' Absorbing atom coords not specified.')
         call wlog(' Cannot find multiple scattering paths.')
         call par_stop('RDINP')
      endif

c 400 call par_barrier

      return
      end


	SUBROUTINE YGTORB(ISTAT)
*
*  Module number:
*
*  Module name: YGTORB
*
*  Keyphrase:
*  ----------
*       Read shp header keywords for orbital and positional information
*
*  Description:
*  ------------
*       This routine reads keywords from the shp that give
*	positional and orbital information about HST and
*       places the values in a common block.
*
*  FORTRAN name: ygtorb.for
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*  Name                         I/O     Description / Comments
*       <rootname>.SHH          I       FOS data file
*
*  Subroutines Called:
*  -------------------
*  CDBS:
*       ymsput
*  SDAS:
*       uhdgs*
*
*  History:
*  --------
*  Version      Date        Author          Description
*       1       May 91  S. Hulbert      Designed and coded
*     1.1       Jun 91  S. Hulbert      Fixed bug in reading attitiude keywords
*-------------------------------------------------------------------------------
        INTEGER ISTAT
C                                    --->ERROR status
C
C     UMSPUT DESTINATIONS -- CB, DAO, 4-SEP-87
C
      INTEGER STDOUT
      PARAMETER (STDOUT = 1)
      INTEGER STDERR
      PARAMETER (STDERR = 2)
C
C Common block containing input/output file descriptions
C
C       IDS - file id numbers
C       GCOUNT - group counts
C       NAXIS - naxis
C       NAXIS1 - first dimensions
C       NAXIS2 - second dimensions
C       FILL - Fill values
C
        INTEGER IDS(30),NAXIS(30),NAXIS1(30),NAXIS2(30),GCOUNT(30)
        REAL FILL(30)
        COMMON /IOCOM/IDS,GCOUNT,NAXIS,NAXIS1,NAXIS2,FILL

C
C Common block containing orbital/positional parameters
C
        DOUBLE PRECISION EPCHTIME,SDMEANAN,CIRVELOC,COSINCLI
        DOUBLE PRECISION ECCENTRY,ECCENTX2,ECBDX4D3,ESQDX5D2,ECBDX3
        DOUBLE PRECISION FDMEANAN,RCASCNRV,ARGPERIG,MEANANOM,RCARGPER
        DOUBLE PRECISION RASCASCN,SINEINCL,SEMILREC
        DOUBLE PRECISION PSANGLV3,RTASCNV1,DECLNV1
        COMMON /ORBPAR/ EPCHTIME,SDMEANAN,CIRVELOC,COSINCLI,
     $  ECCENTRY,ECCENTX2,ECBDX4D3,ESQDX5D2,ECBDX3,
     $  FDMEANAN,RCASCNRV,ARGPERIG,MEANANOM,RCARGPER,
     $  RASCASCN,SINEINCL,SEMILREC,
     $  PSANGLV3,RTASCNV1,DECLNV1
C
C Local variables
C
        INTEGER I, ID, ISTATS(20)
        CHARACTER*8 NAMES(20)
        CHARACTER*80 CONTXT
        DATA NAMES/'EPCHTIME','SDMEANAN','CIRVELOC','COSINCLI',
     $  'ECCENTRY','ECCENTX2','ECBDX4D3','ESQDX5D2','ECBDX3',
     $  'FDMEANAN','RCASCNRV','ARGPERIG','MEANANOM','RCARGPER',
     $  'RASCASCN','SINEINCL','SEMILREC',
     $  'PA_V3','RA_V1','DEC_V1'/
C----------------------------------------------------------------
        ID = IDS(6)
        CALL UHDGSD(ID,NAMES(1),EPCHTIME,ISTATS(1))
        CALL UHDGSD(ID,NAMES(2),SDMEANAN,ISTATS(2))
        CALL UHDGSD(ID,NAMES(3),CIRVELOC,ISTATS(3))
        CALL UHDGSD(ID,NAMES(4),COSINCLI,ISTATS(4))
        CALL UHDGSD(ID,NAMES(5),ECCENTRY,ISTATS(5))
        CALL UHDGSD(ID,NAMES(6),ECCENTX2,ISTATS(6))
        CALL UHDGSD(ID,NAMES(7),ECBDX4D3,ISTATS(7))
        CALL UHDGSD(ID,NAMES(8),ESQDX5D2,ISTATS(8))
        CALL UHDGSD(ID,NAMES(9),ECBDX3,ISTATS(9))
        CALL UHDGSD(ID,NAMES(10),FDMEANAN,ISTATS(10))
        CALL UHDGSD(ID,NAMES(11),RCASCNRV,ISTATS(11))
        CALL UHDGSD(ID,NAMES(12),ARGPERIG,ISTATS(12))
        CALL UHDGSD(ID,NAMES(13),MEANANOM,ISTATS(13))
        CALL UHDGSD(ID,NAMES(14),RCARGPER,ISTATS(14))
        CALL UHDGSD(ID,NAMES(15),RASCASCN,ISTATS(15))
        CALL UHDGSD(ID,NAMES(16),SINEINCL,ISTATS(16))
        CALL UHDGSD(ID,NAMES(17),SEMILREC,ISTATS(17))
        CALL UHDGSD(ID,NAMES(18),PSANGLV3,ISTATS(18))
        CALL UHDGSD(ID,NAMES(19),RTASCNV1,ISTATS(19))
        CALL UHDGSD(ID,NAMES(20),DECLNV1,ISTATS(20))
C
        DO 100 I=1,20
            IF(ISTATS(I).NE.0)THEN
                CONTXT='ERROR reading keyword '//NAMES(I)//
     *                  ' from .shh file'
                GO TO 999
            ENDIF
100     CONTINUE
C
        ISTAT=0
        GO TO 1000
999     CALL YMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
        ISTAT=1
1000    RETURN
        END


Subroutine hjana2
  Parameter (ymax=1.0, ymin=-1.0)
  Parameter (dmt=0.05, dy=0.2)
  Parameter (dr=0.2, dt=0.2)
  Parameter (maxptn=400001)
  Parameter (maxstr=150001)
  Double Precision pxsgs, pysgs, pzsgs, pesgs, pmsgs, gxsgs, gysgs, gzsgs, ftsgs
  Dimension dyp2(50), dmyp2(200), deyp2(50)
  Dimension dyg2(50), dmyg2(200), deyg2(50)
  Dimension snyp2(50), smyp2(200), seyp2(50)
  Dimension snyg2(50), smyg2(200), seyg2(50)
  Dimension dnrpj2(50), dnrtg2(50), dnrin2(50), dnrtt2(50)
  Dimension dtpj2(50), dttg2(50), dtin2(50), dttot2(50)
  Dimension dyg2c(50), dmyg2c(50), deyg2c(50)
  Dimension snrpj2(50), snrtg2(50), snrin2(50), snrtt2(50)
  Dimension stpj2(50), sttg2(50), stin2(50), sttot2(50)
  Dimension snyg2c(50), smyg2c(50), seyg2c(50)
  Double Precision ataui, zt1, zt2, zt3
  Double Precision gx5, gy5, gz5, ft5, px5, py5, pz5, e5, xmass5
  Common /para1/mul
  Common /hparnt/hipr1(100), ihpr2(50), hint1(100), ihnt2(50)
  Common /srec2/ataui(maxstr), zt1(maxstr), zt2(maxstr), zt3(maxstr)
  Common /hjjet1/npj(300), kfpj(300, 500), pjpx(300, 500), pjpy(300, 500), pjpz(300, 500), pjpe(300, 500), pjpm(300, 500), ntj(300), kftj(300, 500), pjtx(300, 500), pjty(300, 500), pjtz(300, 500), pjte(300, 500), pjtm(300, 500)
  Common /hjjet2/nsg, njsg(maxstr), iasg(maxstr, 3), k1sg(maxstr, 100), k2sg(maxstr, 100), pxsg(maxstr, 100), pysg(maxstr, 100), pzsg(maxstr, 100), pesg(maxstr, 100), pmsg(maxstr, 100)
  Common /prec2/gx5(maxptn), gy5(maxptn), gz5(maxptn), ft5(maxptn), px5(maxptn), py5(maxptn), pz5(maxptn), e5(maxptn), xmass5(maxptn), ityp5(maxptn)
  Common /arevt/iaevt, iarun, miss
  Common /arout/iout
  Common /anim/nevent, isoft, isflag, izpc
  Common /soft/pxsgs(maxstr, 3), pysgs(maxstr, 3), pzsgs(maxstr, 3), pesgs(maxstr, 3), pmsgs(maxstr, 3), gxsgs(maxstr, 3), gysgs(maxstr, 3), gzsgs(maxstr, 3), ftsgs(maxstr, 3), k1sgs(maxstr, 3), k2sgs(maxstr, 3), njsgs(maxstr)
  Save
  Data iw/0/
  If (isevt==iaevt .And. isrun==iarun) Then
    Do i = 1, 200
      dmyp2(i) = smyp2(i)
      dmyg2(i) = smyg2(i)
    End Do
    Do i = 1, 50
      dyp2(i) = snyp2(i)
      deyp2(i) = seyp2(i)
      dyg2(i) = snyg2(i)
      deyg2(i) = seyg2(i)
      dnrpj2(i) = snrpj2(i)
      dnrtg2(i) = snrtg2(i)
      dnrin2(i) = snrin2(i)
      dnrtt2(i) = snrtt2(i)
      dtpj2(i) = stpj2(i)
      dttg2(i) = sttg2(i)
      dtin2(i) = stin2(i)
      dttot2(i) = sttot2(i)
      dyg2c(i) = snyg2c(i)
      dmyg2c(i) = smyg2c(i)
      deyg2c(i) = seyg2c(i)
    End Do
    nsubp = nsubps
    nsubg = nsubgs
    nisg = nisgs
  Else
    Do i = 1, 200
      smyp2(i) = dmyp2(i)
      smyg2(i) = dmyg2(i)
    End Do
    Do i = 1, 50
      snyp2(i) = dyp2(i)
      seyp2(i) = deyp2(i)
      snyg2(i) = dyg2(i)
      seyg2(i) = deyg2(i)
      snrpj2(i) = dnrpj2(i)
      snrtg2(i) = dnrtg2(i)
      snrin2(i) = dnrin2(i)
      snrtt2(i) = dnrtt2(i)
      stpj2(i) = dtpj2(i)
      sttg2(i) = dttg2(i)
      stin2(i) = dtin2(i)
      sttot2(i) = dttot2(i)
      snyg2c(i) = dyg2c(i)
      smyg2c(i) = dmyg2c(i)
      seyg2c(i) = deyg2c(i)
    End Do
    nsubps = nsubp
    nsubgs = nsubg
    nisgs = nisg
    isevt = iaevt
    isrun = iarun
    iw = iw + 1
  End If
  If (isoft==3 .Or. isoft==4 .Or. isoft==5) Goto 510
  Do i = 1, ihnt2(1)
    Do j = 1, npj(i)
      ityp = kfpj(i, j)
      px = pjpx(i, j)
      py = pjpy(i, j)
      pz = pjpz(i, j)
      pe = pjpe(i, j)
      pm = pjpm(i, j)
      xmt = sqrt(px**2+py**2+pm**2)
      dxmt = xmt - pm
      If (xmt>0.) Then
        rap = asinh(pz/xmt)
      Else
        Print *, ' IN HJANA2 mt=0'
        rap = 1000000.0*sign(1., pz)
      End If
      iy = 1 + int(abs(rap)/dy)
      If (iy<1 .Or. iy>50) Goto 100
      dyp2(iy) = dyp2(iy) + 1.0
      deyp2(iy) = deyp2(iy) + xmt
      If (ityp==21) Then
        dyg2(iy) = dyg2(iy) + 1.0
        deyg2(iy) = deyg2(iy) + xmt
      End If
      100 Continue
      If (rap>ymax .Or. rap<=ymin) Goto 200
      imt = 1 + int(dxmt/dmt)
      If (imt>200) Goto 200
      dmyp2(imt) = dmyp2(imt) + 1.0/xmt
      If (ityp==21) Then
        dmyg2(imt) = dmyg2(imt) + 1.0/xmt
      End If
      200 Continue
    End Do
  End Do
  Do i = 1, ihnt2(3)
    Do j = 1, ntj(i)
      ityp = kftj(i, j)
      px = pjtx(i, j)
      py = pjty(i, j)
      pz = pjtz(i, j)
      pe = pjte(i, j)
      pm = pjtm(i, j)
      xmt = sqrt(px**2+py**2+pm**2)
      dxmt = xmt - pm
      If (xmt>0.) Then
        rap = asinh(pz/xmt)
      Else
        Print *, ' IN HJANA2 mt=0'
        rap = 1000000.0*sign(1., pz)
      End If
      iy = 1 + int(abs(rap)/dy)
      If (iy<1 .Or. iy>50) Goto 300
      dyp2(iy) = dyp2(iy) + 1.0
      deyp2(iy) = deyp2(iy) + xmt
      If (ityp==21) Then
        dyg2(iy) = dyg2(iy) + 1.0
        deyg2(iy) = deyg2(iy) + xmt
      End If
      300 Continue
      If (rap>ymax .Or. rap<=ymin) Goto 400
      imt = 1 + int(dxmt/dmt)
      If (imt>200) Goto 400
      dmyp2(imt) = dmyp2(imt) + 1.0/xmt
      If (ityp==21) Then
        dmyg2(imt) = dmyg2(imt) + 1.0/xmt
      End If
      400 Continue
    End Do
  End Do
  510 Continue
  Do i = 1, nsg
    nj = njsg(i)
    If (isoft==3 .Or. isoft==4 .Or. isoft==5) nj = njsgs(i)
    Do j = 1, nj
      ityp = k2sg(i, j)
      px = pxsg(i, j)
      py = pysg(i, j)
      pz = pzsg(i, j)
      pe = pesg(i, j)
      pm = pmsg(i, j)
      If (isoft==3 .Or. isoft==4 .Or. isoft==5) Then
        ityp = k2sgs(i, j)
        px = sngl(pxsgs(i,j))
        py = sngl(pysgs(i,j))
        pz = sngl(pzsgs(i,j))
        pe = sngl(pesgs(i,j))
        pm = sngl(pmsgs(i,j))
      End If
      xmt = sqrt(px**2+py**2+pm**2)
      dxmt = xmt - pm
      If (xmt>0.) Then
        rap = asinh(pz/xmt)
      Else
        Print *, ' IN HJANA2 mt=0'
        rap = 1000000.0*sign(1., pz)
      End If
      iy = 1 + int(abs(rap)/dy)
      If (iy<1 .Or. iy>50) Goto 500
      dyp2(iy) = dyp2(iy) + 1.0
      deyp2(iy) = deyp2(iy) + xmt
      If (ityp==21) Then
        dyg2(iy) = dyg2(iy) + 1.0
        deyg2(iy) = deyg2(iy) + xmt
      End If
      500 Continue
      If (rap>ymax .Or. rap<=ymin) Goto 600
      imt = 1 + int(dxmt/dmt)
      If (imt>200) Goto 600
      dmyp2(imt) = dmyp2(imt) + 1.0/xmt
      If (ityp==21) Then
        dmyg2(imt) = dmyg2(imt) + 1.0/xmt
      End If
      600 Continue
    End Do
  End Do
  If (isoft==3 .Or. isoft==4 .Or. isoft==5) Goto 520
  Do i = 1, ihnt2(1)
    j = i
    yr = sqrt(sngl(zt1(j)**2+zt2(j)**2))
    ir = 1 + int(yr/dr)
    If (ir>50 .Or. ir<1) Goto 601
    dnrpj2(ir) = dnrpj2(ir) + 1.0
    dnrtt2(ir) = dnrtt2(ir) + 1.0
    601 Continue
    it = 1 + int(sngl(ataui(j))/dt)
    If (it>50 .Or. it<1) Goto 602
    dtpj2(it) = dtpj2(it) + 1.0
    dttot2(it) = dttot2(it) + 1.0
    602 Continue
  End Do
  Do i = 1, ihnt2(3)
    j = i + ihnt2(1)
    yr = sqrt(sngl(zt1(j)**2+zt2(j)**2))
    ir = 1 + int(yr/dr)
    If (ir>50 .Or. ir<1) Goto 603
    dnrtg2(ir) = dnrtg2(ir) + 1.0
    dnrtt2(ir) = dnrtt2(ir) + 1.0
    603 Continue
    it = 1 + int(sngl(ataui(j))/dt)
    If (it>50 .Or. it<1) Goto 604
    dttg2(it) = dttg2(it) + 1.0
    dttot2(it) = dttot2(it) + 1.0
    604 Continue
  End Do
  520 Continue
  Do i = 1, nsg
    j = i + ihnt2(1) + ihnt2(3)
    If (isoft==3 .Or. isoft==4 .Or. isoft==5) j = i
    yr = sqrt(sngl(zt1(j)**2+zt2(j)**2))
    ir = 1 + int(yr/dr)
    If (ir>50 .Or. ir<1) Goto 605
    dnrin2(ir) = dnrin2(ir) + 1.0
    dnrtt2(ir) = dnrtt2(ir) + 1.0
    605 Continue
    it = 1 + int(sngl(ataui(j))/dt)
    If (it>50 .Or. it<1) Goto 606
    dtin2(it) = dtin2(it) + 1.0
    dttot2(it) = dttot2(it) + 1.0
    606 Continue
  End Do
  Do i = 1, mul
    ityp = ityp5(i)
    px = sngl(px5(i))
    py = sngl(py5(i))
    pz = sngl(pz5(i))
    pe = sngl(e5(i))
    pm = sngl(xmass5(i))
    xmt = sqrt(px**2+py**2+pm**2)
    dxmt = xmt - pm
    If (xmt>0.) Then
      rap = asinh(pz/xmt)
    Else
      Print *, ' IN HJANA2 mt=0'
      rap = 1000000.0*sign(1., pz)
    End If
    iy = 1 + int(abs(rap)/dy)
    If (iy<1 .Or. iy>50) Goto 700
    dyg2c(iy) = dyg2c(iy) + 1.0
    deyg2c(iy) = deyg2c(iy) + xmt
    700 Continue
    If (rap>ymax .Or. rap<=ymin) Goto 800
    imt = 1 + int(dxmt/dmt)
    If (imt>50) Goto 800
    dmyg2c(imt) = dmyg2c(imt) + 1.0/xmt
    800 Continue
  End Do
  If (isoft==3 .Or. isoft==4 .Or. isoft==5) Goto 530
  Do i = 1, ihnt2(1)
    Do j = 1, npj(i)
      nsubp = nsubp + 1
      If (kfpj(i,j)==21) nsubg = nsubg + 1
    End Do
  End Do
  Do i = 1, ihnt2(3)
    Do j = 1, ntj(i)
      nsubp = nsubp + 1
      If (kftj(i,j)==21) nsubg = nsubg + 1
    End Do
  End Do
  530 Continue
  Do i = 1, nsg
    nj = njsg(i)
    If (isoft==3 .Or. isoft==4 .Or. isoft==5) nj = njsgs(i)
    Do j = 1, nj
      nsubp = nsubp + 1
      If (isoft==3 .Or. isoft==4 .Or. isoft==5) Then
        If (k2sgs(i,j)==21) nsubg = nsubg + 1
      Else
        If (k2sg(i,j)==21) nsubg = nsubg + 1
      End If
    End Do
  End Do
  nisg = nisg + nsg
  If (iout==1) Then
    Print *, ' in HJANA2 '
    Print *, ' total number of partons = ', nsubp/iw
    Print *, ' total number of gluons = ', nsubg/iw
    Print *, ' number of independent strings = ', nisg/iw
  End If
  Call hjan2a
  Call hjan2b
  Return
End Subroutine hjana2


      SUBROUTINE CGUESS( NOUT, SHORTO, LERR, CPOINT, CVECT, SAMPLE,
     &                  ATMAX, ATNO, ATBRK, ATRES, ATCHN, ATRNO,
     &                  ATXYZ, ATVDW, ATBND, CUTSIZE)
      IMPLICIT NONE
C ********************************************************************
C *                                                                  *
C * This software is an unpublished work containing confidential and *
C * proprietary information of Oliver Smart. Use,           *
C * disclosure, reproduction and transfer of this work without the   *
C * express written consent of Oliver Smart are prohibited. *
C * This notice must be attached to all copies or extracts of the    *
C * software.                                                        *
C *                                                                  *
C * (c) 200 Oliver Smart                    *
C *                                                                  *
C ********************************************************************
C
C Modification history:
C
C Date	Author		Modification
C 08/00 O.S.S.		First version
C			This s/r try to guess an initial point
C			and/or a channel vector for a calculation
C
C passed vbles *****************

C output stream numbers
      INTEGER			NOUT

C error indicator
      LOGICAL			LERR

C variable to reduce text output, if oshort =
C 0: full text output
C 1: no in run progress reported
C 2: ditto plus no graph type output - only leaving
C    Minimum radius & conductance calculations.
C 3: All text output other than input card mirroring
C    and error messages turned off
      INTEGER                   SHORTO

C an initial point in the channel
      DOUBLE PRECISION          CPOINT(3)

C a vector in the direction of the channel
      DOUBLE PRECISION          CVECT(3)

C a sampling distance - the distance between planes
      DOUBLE PRECISION          SAMPLE

C the number of steps to be taken
C on each Monte Carlo application
      INTEGER                   MCSTEP

C array bound for maximum number of atoms and the actual maximum
      INTEGER			ATMAX, ATNO

C atom names found in Brookhaven file:
      CHARACTER*4               ATBRK(ATMAX)

C residue name in brook
      CHARACTER*3               ATRES(ATMAX)

C chain identifier in brookhaven pdb file
      CHARACTER*1               ATCHN(ATMAX)

C integer residue no.
      INTEGER                   ATRNO(ATMAX)

C co-ordinates
      DOUBLE PRECISION          ATXYZ( 3, ATMAX)

C vdw and bond radii of each atoms
      DOUBLE PRECISION          ATVDW(ATMAX), ATBND(ATMAX)

C cut off list control vble, -ve: no cutoff lists used in calculation
C otherwise this is the additional radius above the sphere radius
C to be used for cutoff list (see s/r holeen)
      DOUBLE PRECISION          CUTSIZE

C internal vbles ***************

C store for all atom and ca centroids
      DOUBLE PRECISION		CENTROID_ALLATOM(3),
     &				CENTROID_CA(3)
      INTEGER			NUMBER_CA

C loop counts
      INTEGER			ACOUNT, XCOUNT, YCOUNT, ZCOUNT
      DOUBLE PRECISION		RCOUNT

C for call to holen
      DOUBLE PRECISION		TSTXYZ(3), TSTENG
      INTEGER			IAT1, IAT2, IAT3
      DOUBLE PRECISION		DAT2, DAT3

C store for the sum of the radii found along a particular direction
      DOUBLE PRECISION		SUM_PRAD, MAX_PRAD
      INTEGER			XYZBEST

C vbles for grid search
      INTEGER			NCYCLE
      DOUBLE PRECISION		BESTXYZ(3), BESTRAD

C end of decs ******************

      WRITE( NOUT, '(A)')
     &' ',
     &' S/R cguess will try to guess CPOINT and/or CVECT',
     &' ',
     &' THESE GUESSES MAY WELL BE WRONG!!!!',
     &' Routine relies on having a reasonably symmetric',
     &' channel oriented along x, y or z vector',
     &' YOU ARE STRONGLY ADVISED TO CHECK THE RESULTS',
     &'                       WITH MOLECULAR GRAPHICS'

      IF (CPOINT(1).EQ.-55555.) THEN
C try to identify a suitable initial point
C either (a) the centroid of all "CA" atoms or
C        (b) the centroid of all atoms
        CENTROID_ALLATOM(1) = 0.
        CENTROID_ALLATOM(2) = 0.
        CENTROID_ALLATOM(3) = 0.
        CENTROID_CA(1) = 0.
        CENTROID_CA(2) = 0.
        CENTROID_CA(3) = 0.
	NUMBER_CA = 0
        DO ACOUNT = 1, ATNO ! go thru atoms
	  CENTROID_ALLATOM(1) = CENTROID_ALLATOM(1) + ATXYZ(1,ACOUNT)
	  CENTROID_ALLATOM(2) = CENTROID_ALLATOM(2) + ATXYZ(2,ACOUNT)
	  CENTROID_ALLATOM(3) = CENTROID_ALLATOM(3) + ATXYZ(3,ACOUNT)
	  IF (ATBRK(ACOUNT)(1:2).EQ.'CA') THEN
	    NUMBER_CA = NUMBER_CA + 1
            CENTROID_CA(1) = CENTROID_CA(1) + ATXYZ(1,ACOUNT)
            CENTROID_CA(2) = CENTROID_CA(2) + ATXYZ(2,ACOUNT)
            CENTROID_CA(3) = CENTROID_CA(3) + ATXYZ(3,ACOUNT)
	  ENDIF
	ENDDO ! end of going thru atoms
        IF (NUMBER_CA.GE.3) THEN ! guess cpoint based on calpha position
	  CPOINT(1) = CENTROID_CA(1)/NUMBER_CA
	  CPOINT(2) = CENTROID_CA(2)/NUMBER_CA
	  CPOINT(3) = CENTROID_CA(3)/NUMBER_CA
	  IF (SHORTO.LE.1) WRITE( NOUT, '(A,I5,A,3F12.4 )')
     &' Initial CPOINT guess - centroid of', NUMBER_CA,
     &            ' ''CA'' atom positions', CPOINT
        ELSE  ! guess cpoint based on all atoms
	  CPOINT(1) = CENTROID_ALLATOM(1)/ATNO
	  CPOINT(2) = CENTROID_ALLATOM(2)/ATNO
	  CPOINT(3) = CENTROID_ALLATOM(3)/ATNO
	  IF (SHORTO.LE.1) WRITE( NOUT, '(A,I5,A,3F12.4 )')
     &' Initial CPOINT guess - centroid of', ATNO,
     &            'ALL atom positions', CPOINT
	ENDIF

C m121 original procedure does not work on 1omf!
C try a bit more sophistication
C do a grid search on 1angs grid
        IF (SHORTO.LE.1) WRITE( NOUT, '(A)')
     &' Now do quick grid search on cpoint'
C try 5 cycles initially
        DO NCYCLE = 1, 5
          BESTRAD = -1E10
	  DO XCOUNT = -1, 1 ! go thru x
	    TSTXYZ(1) = CPOINT(1) + REAL(XCOUNT)
            DO YCOUNT= -1, 1 ! go thru y
	      TSTXYZ(2) = CPOINT(2) + REAL(YCOUNT)
	      DO ZCOUNT= -1, 1 ! go thru z
	        TSTXYZ(3) = CPOINT(3) + REAL(ZCOUNT)
	        CALL HOLEEN( TSTXYZ, TSTENG, IAT1, IAT2, IAT3,
     &            DAT2, DAT3,ATMAX, ATNO, ATXYZ, ATVDW, CUTSIZE)
                TSTENG = -TSTENG
	        IF (TSTENG.GT.BESTRAD) THEN !best point so far?
	          BESTRAD = TSTENG
		  BESTXYZ(1) = TSTXYZ(1)
		  BESTXYZ(2) = TSTXYZ(2)
		  BESTXYZ(3) = TSTXYZ(3)
	        ENDIF
	      ENDDO ! go thru z
	    ENDDO ! go thru y
	  ENDDO ! go thru x
          CPOINT(1) = BESTXYZ(1)
          CPOINT(2) = BESTXYZ(2)
          CPOINT(3) = BESTXYZ(3)
	  IF (SHORTO.LE.1) WRITE( NOUT, '(A,I5,A,F10.3,A,3F8.3)')
     &' cycle ', NCYCLE, ' bestrad= ', BESTRAD, ' at ', CPOINT
	ENDDO ! number of cycles (NCYCLE)

      ENDIF  ! end of if (cpoint(1).eq.-55555.) then

C ok. now have a cpoint - try to get a cvect
      IF (CVECT(1).EQ.-55555.) THEN
        IF (SHORTO.LE.1) WRITE( NOUT, '(A/ A,16X,A)')
     &' testing points from cpoint in X, Y then Z direction',
     &'   point', '   pore radius'
        MAX_PRAD = -1E10
	XYZBEST = -1
        DO XCOUNT = 1, 3 ! go thru x, y, and z
C vector to test
          IF (SHORTO.LE.1) WRITE(NOUT, '(A,I5)') 'direction ', XCOUNT
          CVECT(1) = 0.
          CVECT(2) = 0.
          CVECT(3) = 0.
          CVECT(XCOUNT) = 1.
C starting at the initial point
C now look at points from -5 to +5 along proposed cvect
C find hole radius of points
          SUM_PRAD =  0.
          DO RCOUNT = -5.,5.001,1.
	    TSTXYZ(1) = CPOINT(1) + RCOUNT*CVECT(1)
	    TSTXYZ(2) = CPOINT(2) + RCOUNT*CVECT(2)
	    TSTXYZ(3) = CPOINT(3) + RCOUNT*CVECT(3)
C for each point find hole pore radius
            CALL HOLEEN( TSTXYZ, TSTENG, IAT1, IAT2, IAT3, DAT2, DAT3,
     &           ATMAX, ATNO, ATXYZ, ATVDW, CUTSIZE)
            TSTENG = -TSTENG
	    IF (SHORTO.LE.1) WRITE(NOUT, '(3F8.3,F10.3)') TSTXYZ, TSTENG
	    SUM_PRAD = SUM_PRAD + TSTENG
          ENDDO ! end of going thru the 11 points
	  IF (SHORTO.LE.1) WRITE( NOUT, '(A,F10.3)')
     &' Average pore radius along the line= ', SUM_PRAD/11.
	  IF (SUM_PRAD.GT.MAX_PRAD) THEN
	    MAX_PRAD = SUM_PRAD
	    XYZBEST = XCOUNT
	  ENDIF
        ENDDO ! go thru x, y, and z
C best direction?
        CVECT(1) = 0.
        CVECT(2) = 0.
        CVECT(3) = 0.
        CVECT(XYZBEST) = 1.
        IF (SHORTO.LE.1) WRITE( NOUT, '(A,I5)')
     &' Best direction is found to be ', XYZBEST, '(1=X,2=Y,3=Z)'

      ENDIF ! end of whether we should guess cpoint

      WRITE( NOUT, '(A/ A,3F12.4/ A,3F12.4)')
     &' s/r cguess has produced initial values for cpoint &/or cvect:',
     &'CPOINT ', CPOINT,
     &'CVECT  ', CVECT
      WRITE( NOUT, '(A)')
     &' THESE GUESSES MAY WELL BE WRONG!!!!',
     &' Routine relies on having a reasonably symmetric',
     &' channel oriented along x, y or z vector',
     &' YOU ARE STRONGLY ADVISED TO CHECK THE RESULTS',
     &'                       WITH MOLECULAR GRAPHICS',
     &' ',
     &' '

      RETURN
      END


!
!    Copyright 2011 Sebastian Heimann
!
!    Licensed under the Apache License, Version 2.0 (the "License");
!    you may not use this file except in compliance with the License.
!    You may obtain a copy of the License at
!
!        http://www.apache.org/licenses/LICENSE-2.0
!
!    Unless required by applicable law or agreed to in writing, software
!    distributed under the License is distributed on an "AS IS" BASIS,
!    WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!    See the License for the specific language governing permissions and
!    limitations under the License.
!

program ahfull

    ! This program calculates homogeneous fullspace seismograms for a
    ! superposition of sources at a number of receivers

    ! usage: ahfull sources receivers material source-time-function dt output-filename-base output-format

    ! sources:
    !   t x y z mxx myy mzz mxy mxz myz fx fy fz

    ! receivers
    !   x y z nf ff

    ! material
    !  rho alpha beta

    ! stf (but time column is ignored; dt from command line is rules!)
    !   t f

    ! output-format: 'table' or 'sac' or 'mseed'
    !    'table' : one ascii table file per receiver, component, and window
    !              filenames are: $fnbase-$receiver-$component-$window.table
    !              columns are: <time> <displacement>
    !    'sac'   : one sac seismogram file per receiver, component, and window
    !              filenames are: $fnbase-$receiver-$component-$window.sac
    !    'mseed' : one mseed seismogram file per receiver, component, and window
    !              filenames are: $fnbase-$receiver-$component-$window.sac

    use util
    use better_varying_string
    use varying_string_getarg
    use read_table
    use seismogram_io
    use elseis_oo
    use unit
    ! use f90_unix_env

    implicit none

    type source_t
        real                              :: tshift
        real, dimension(3)                :: location
        real, dimension(3,3)              :: mt
        real, dimension(3)                :: sf
    end type source_t

    type receiver_t
        real, dimension(3)                :: location
        logical                           :: nfflag
        logical                           :: ffflag
    end type receiver_t

    real, allocatable, dimension(:,:)           :: sources_tab, receivers_tab, material_tab, stf_tab
    real, allocatable, dimension(:)             :: stf
    real                                        :: dt
    integer                                     :: isource, ireceiver, nsources, nreceivers, nstfsamples
    integer                                     :: iwindow, nwindows
    integer                                     :: nsamples, n,p,q
    type(elseis_t)                              :: es
    type(source_t), allocatable, dimension(:)   :: sources(:)
    type(receiver_t), allocatable, dimension(:) :: receivers(:)
    real                                        :: rho, alpha, beta
    real, dimension(:,:), allocatable           :: seismograms
    real, dimension(3)                          :: rlocation, sourcelocation
    real, dimension(2)                          :: tbegin, tend
    real                                        :: d, tstf
    real                                        :: firstarrival_p, lastarrival_p, firstarrival_s, lastarrival_s
    integer                                     :: nerr
    character, dimension(3), parameter          :: xyz = (/'x','y','z'/)
    type(varying_string)                        :: fn, basefn, offormat
    integer                                     :: ibeg, iend
    integer                                     :: split_window

    g_pn = 'ahfull'
    g_usage = 'usage: ahfull sources receivers material source-time-function dt output-filename-base output-format split-window'

    ! process command line arguments and read input files
    if (iargc() /= 8) call usage()
    call readtable_arg( 1, 13, 1, sources_tab )
    call readtable_arg( 2, 5, 1, receivers_tab )
    call readtable_arg( 3, 3, 1, material_tab )
    call readtable_arg( 4, 2, 2, stf_tab )
    call readreal_arg( 5, tiny(dt), huge(dt), dt )
    call vs_getarg( 6, basefn )
    call vs_getarg( 7, offormat )
    call readint_arg( 8, 0, 1, split_window )

    if (offormat /= 'table' .and. offormat /= 'sac' .and. offormat /= 'mseed') &
        call die('unknown output fomat: ''' // offormat // '''; should be ''table'', ''sac'' or ''mseed''' )

    nstfsamples = size(stf_tab, 2)
    nsources = size(sources_tab, 2)
    nreceivers = size(receivers_tab, 2)

    ! prepare stf
    allocate( stf(nstfsamples) )
    stf(:) = stf_tab(2,:)
    tstf = (nstfsamples-1)*dt

    ! prepare sources
    allocate( sources(nsources) )
    sourcelocation = (/0,0,0/)
    do isource=1,nsources
        sources(isource) % tshift      = sources_tab(1,isource)
        sources(isource) % location(:) = sources_tab(2:4,isource)
        sources(isource) % mt(1,1)     = sources_tab(5,isource)
        sources(isource) % mt(2,2)     = sources_tab(6,isource)
        sources(isource) % mt(3,3)     = sources_tab(7,isource)
        sources(isource) % mt(1,2)     = sources_tab(8,isource)
        sources(isource) % mt(2,1)     = sources_tab(8,isource)
        sources(isource) % mt(1,3)     = sources_tab(9,isource)
        sources(isource) % mt(3,1)     = sources_tab(9,isource)
        sources(isource) % mt(2,3)     = sources_tab(10,isource)
        sources(isource) % mt(3,2)     = sources_tab(10,isource)
        sources(isource) % sf(:)       = sources_tab(11:13,isource)
        sourcelocation(:) =  sourcelocation(:) + sources(isource) % location(:)
    end do

    ! prepare receivers
    allocate( receivers(nreceivers) )
    do ireceiver=1,nreceivers
        receivers(ireceiver) % location(:) = receivers_tab(1:3,ireceiver)
        receivers(ireceiver) % nfflag      = (receivers_tab(4,ireceiver) /= 0.)
        receivers(ireceiver) % ffflag      = (receivers_tab(5,ireceiver) /= 0.)
    end do

    ! prepare material
    rho = material_tab(1,1)
    alpha = material_tab(2,1)
    beta = material_tab(3,1)

    call set_stf( es, stf, dt )
    call set_material( es, rho, alpha, beta )

    ! iterate over receivers
    do ireceiver=1,nreceivers

        ! det min and max distance between sources and receiver to calculate appropriate length
        firstarrival_p =  huge(firstarrival_p)
        firstarrival_s =  huge(firstarrival_s)
        lastarrival_p = -huge(lastarrival_p)
        lastarrival_s = -huge(lastarrival_s)

        do isource=1,nsources
            d = dist(sources(isource)%location,receivers(ireceiver)%location)

            firstarrival_p = min(firstarrival_p, &
                snapdown(d/alpha + sources(isource) % tshift,dt))
            lastarrival_p  = max(lastarrival_p, &
                snapup(d/alpha + sources(isource) % tshift + tstf,dt))

            firstarrival_s = min(firstarrival_s, &
                snapdown(d/beta + sources(isource) % tshift,dt))
            lastarrival_s  = max(lastarrival_s, &
                snapup(d/beta + sources(isource) % tshift + tstf,dt))
        end do

        if ((lastarrival_p >= firstarrival_s) .or. (split_window .eq. 0)) then ! s and p time windows overlap
            nwindows = 1
            tbegin(1) = firstarrival_p
            tend(1) = lastarrival_s
        else                                        ! they are separated
            nwindows = 2
            tbegin(1) = firstarrival_p
            tend(1) = lastarrival_p
            tbegin(2) = firstarrival_s
            tend(2) = lastarrival_s
        end if

        ! iterate over time windows
        do iwindow=1,nwindows

            nsamples = (tend(iwindow) - tbegin(iwindow)) / dt + 1
            if (allocated( seismograms )) deallocate(seismograms)
            allocate( seismograms(3,nsamples) )
            seismograms(:,:) = 0.

            ! sum up elementary seismograms for every receiver-source combination
            do isource=1,nsources
                rlocation(:) = receivers(ireceiver)%location(:) - sources(isource)%location(:)
                call set_coords( es, rlocation, receivers(ireceiver)%nfflag, receivers(ireceiver)%ffflag )
                do n=1,3
                    do p=1,3
                        do q=1,3
                            call set_npq( es, n, p, q )
                            call add_elseis_mt( es, &
                                                tbegin(iwindow)-sources(isource)%tshift , &
                                                sources(isource) % mt(p,q), &
                                                seismograms(n,:) )
                        end do
                        call add_elseis_sf( es, &
                                            tbegin(iwindow)-sources(isource)%tshift , &
                                            sources(isource) % sf(p), &
                                            seismograms(n,:) )
                    end do
                end do
            end do

            do n=1,3
                ibeg = 1
                iend = nsamples

                fn = basefn // '-' // ireceiver // '-' // xyz(n) // '-' // iwindow // '.' // offormat

                call writeseismogram( fn, offormat, seismograms(n,ibeg:iend), &
                    real(tbegin(iwindow)+dt*(ibeg-1),8), dt, &
                    var_str(''), var_str(ireceiver), var_str(''), var_str(xyz(n)), nerr )
                if (nerr /= 0) call die('failed to save seismogram to file: ' // fn )
                end do
        end do

        ! output filenames to stdout in a way, that gfdb_build understands
        do n=1,3
            fn = ""
            do iwindow=1,nwindows
                fn = fn // " " // basefn // '-' // ireceiver // '-' // xyz(n) // '-' // iwindow // '.' // offormat
            end do
            call put_line( fn )
            call flush(stdout)
        end do

    end do

    call cleanup()

  contains

    pure real function snapdown(t,dt)
        real, intent(in) :: t, dt
        snapdown = floor(t/dt)*dt
    end function

    pure real function snapup(t,dt)
        real, intent(in) :: t, dt
        snapup = ceiling(t/dt)*dt
    end function

    function absmax_ind( array ) result(ind)
        real, dimension(:), intent(in) :: array
        integer                        :: ind,i

    ! get indice of first absmax

        real                           :: absmax

        absmax = 0.0
        ind = 1
        do i=1,size(array)
            if (abs(array(i)) > absmax) then
                absmax=abs(array(i))
                ind = i
            end if
        end do

    end function absmax_ind

    subroutine readtable_arg( iarg, min_cols, min_rows, field )

        integer, intent(in) :: iarg, min_cols, min_rows
        real, dimension(:,:), allocatable, intent(out) :: field

    ! this sub reads a filename from argument iarg and then reads a table of real numbers contained in this file to field
    ! it is checked, that the table has at least min_cols columns and min_rows rows

        type(varying_string) :: fn
        integer :: ifile, iostat

        call vs_getarg( iarg, fn )
        call claim_unit( ifile )
        open( unit=ifile, file=char(fn), status='old', iostat=iostat )
        if (iostat /= 0) call die( 'can''t open file "' // fn // '"' )
        call readtable( field, iunit=ifile )
        close( ifile )
        call release_unit( ifile )
        if (size(field,1) <  min_cols) call die( 'expected at least ' // min_cols // ' column(s) in file "' // fn // '"' )
        if (size(field,1) <  min_rows) call die( 'expected at least ' // min_rows // ' row(s) in file "' // fn // '"' )

    end subroutine

    subroutine readreal_arg( iarg, min, max, val )

        integer, intent(in) :: iarg
        real, intent(in) :: min, max
        real, intent(out) :: val

    ! reads argument iarg from the argument list and converts it to real number val
    ! it is checked, that val is in the range [min, max]

        type(varying_string) :: vs

        call vs_getarg( iarg, vs )
        val = vs

        if ((val < min) .or. (max < val)) &
            call die( 'expected real value at argument ' // iarg  &
                 // ' in range [' // min // ',' // max // '], but got' // val // '.' )

    end subroutine readreal_arg

    subroutine readint_arg( iarg, min, max, val )

        integer, intent(in) :: iarg
        integer, intent(in) :: min, max
        integer, intent(out) :: val

    ! reads argument iarg from the argument list and converts it to integer number val
    ! it is checked, that val is in the range [min, max]

        type(varying_string) :: vs

        call vs_getarg( iarg, vs )
        val = vs

        if ((val < min) .or. (max < val)) &
            call die( 'expected integer value at argument ' // iarg  &
                 // ' in range [' // min // ',' // max // '], but got' // val // '.' )

    end subroutine readint_arg

    pure function dist(a,b) result(r)

        real, intent(in), dimension(3) :: a,b
        real :: r

        r = sqrt((a(1)-b(1))**2+(a(2)-b(2))**2+(a(3)-b(3))**2)

    end function dist

    pure subroutine trans_xyz_lqt( origin, point, xyz )

        real, dimension(3), intent(in)       :: origin, point
        real, dimension(:,:), intent(inout)  :: xyz
        integer                              :: i
        real, dimension(3)                   :: er, eh, ep, rhp

    ! inplace tranform displacement vectors to local coordinate system
    ! defined by radial (rel. to source), horizontal
    ! and a component perpendicular to the other two

        ! assuming size(xyz,2) == size(rhp,2)

        ! setup normal vectors for radial, horizontal and perpendicular components
        er(:) = point(:) - origin(:)
        call normalize(er)
        eh = cp(er,(/0.,0.,1./))
        if ( .not. any(eh /= 0.) ) eh = (/1.,0.,0./)
        call normalize(eh)
        ep = cp(er,eh)

        ! transform each element in xyz
        do i=1,size(xyz,2)
            rhp(1) = sp(xyz(:,i),er)
            rhp(2) = sp(xyz(:,i),eh)
            rhp(3) = sp(xyz(:,i),ep)
            xyz(:,i) = rhp(:)
        end do

    end subroutine trans_xyz_lqt

    pure subroutine normalize( vec )
        real, intent(inout), dimension(3) :: vec
        real :: r
        r = sqrt(vec(1)**2 + vec(2)**2 + vec(3)**2)
        vec(1:3) = vec(1:3) / r
    end subroutine normalize

    pure function sp( a, b ) result( c )
        real, intent(in), dimension(3) :: a,b
        real                           :: c
    ! scalar product
        c = a(1)*b(1)+a(2)*b(2)+a(3)*b(3)
    end function sp

    pure function cp( a, b ) result( c )
        real, intent(in), dimension(3) :: a,b
        real, dimension(3)             :: c
    ! cross product
        c(1) = a(2)*b(3) - a(3)*b(2)
        c(2) = a(3)*b(1) - a(1)*b(3)
        c(3) = a(1)*b(2) - a(2)*b(1)
    end function

end program


MODULE trc_oce
   !!======================================================================
   !!                      ***  MODULE  trc_oce  ***
   !! Ocean passive tracer  :  share SMS/Ocean variables
   !!======================================================================
   !! History :  1.0  !  2004-03  (C. Ethe)  Original code
   !!----------------------------------------------------------------------

   !!----------------------------------------------------------------------
   !!   trc_oce_rgb   : tabulated attenuation coefficients for RGB light penetration
   !!----------------------------------------------------------------------
   USE par_oce        ! ocean parameters
   USE dom_oce        ! ocean space and time domain
   !
   USE in_out_manager ! I/O manager
   USE lib_mpp        ! MPP library

   IMPLICIT NONE
   PRIVATE

   PUBLIC   trc_oce_rgb        ! routine called by traqsr.F90
   PUBLIC   trc_oce_rgb_read   ! routine called by traqsr.F90
   PUBLIC   trc_oce_ext_lev    ! function called by traqsr.F90 at least
   PUBLIC   trc_oce_alloc      ! function called by nemogcm.F90

   INTEGER , PUBLIC                                      ::   nn_dttrc      !: frequency of step on passive tracers
   REAL(wp), PUBLIC                                      ::   r_si2         !: largest depth of extinction (blue & 0.01 mg.m-3)  (RGB)
   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   etot3         !: light absortion coefficient
   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   facvol        !: volume for degraded regions

   !!----------------------------------------------------------------------
   !! Default option                          No bio-model light absorption
   !!----------------------------------------------------------------------
   LOGICAL, PUBLIC, PARAMETER ::   lk_top     = .FALSE.   !: TOP model

   !!----------------------------------------------------------------------
   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
   !! $Id: trc_oce.F90 6140 2015-12-21 11:35:23Z timgraham $
   !! Software governed by the CeCILL licence     (./LICENSE)
   !!----------------------------------------------------------------------
CONTAINS

   INTEGER FUNCTION trc_oce_alloc()
      !!----------------------------------------------------------------------
      !!                  ***  trc_oce_alloc  ***
      !!----------------------------------------------------------------------
      INTEGER ::   ierr(2)        ! Local variables
      !!----------------------------------------------------------------------
      ierr(:) = 0
                     ALLOCATE( etot3 (jpi,jpj,jpk), STAT=ierr(1) )
      IF( lk_degrad) ALLOCATE( facvol(jpi,jpj,jpk), STAT=ierr(2) )
      trc_oce_alloc  = MAXVAL( ierr )
      !
      IF( trc_oce_alloc /= 0 )   CALL ctl_warn('trc_oce_alloc: failed to allocate etot3 array')
   END FUNCTION trc_oce_alloc

   SUBROUTINE trc_oce_rgb( prgb )
      !!---------------------------------------------------------------------
      !!                  ***  ROUTINE p4z_opt_init  ***
      !!
      !! ** Purpose :   Initialization of of the optical scheme
      !!
      !! ** Method  :   Set a look up table for the optical coefficients
      !!                i.e. the attenuation coefficient for R-G-B light
      !!                tabulated in Chlorophyll class (from JM Andre)
      !!
      !! ** Action  :   prgb(3,61) tabulated R-G-B attenuation coef.
      !!
      !! Reference  : Lengaigne et al. 2007, Clim. Dyn., V28, 5, 503-516.
      !!----------------------------------------------------------------------
      REAL(wp), DIMENSION(3,61), INTENT(out) ::   prgb   ! tabulated attenuation coefficient
      !
      INTEGER  ::   jc     ! dummy loop indice
      INTEGER  ::   irgb   ! temporary integer
      REAL(wp) ::   zchl   ! temporary scalar
      REAL(wp), DIMENSION(4,61) ::   zrgb   ! tabulated attenuation coefficient (formerly read in 'kRGB61.txt')
      !!----------------------------------------------------------------------
      !
      IF(lwp) THEN
         WRITE(numout,*)
         WRITE(numout,*) 'trc_oce_rgb : Initialisation of the optical look-up table'
         WRITE(numout,*) '~~~~~~~~~~~ '
      ENDIF
      !
      !  Chlorophyll        !     Blue attenuation     !     Green attenuation    !     Red attenuation      !
      zrgb(1, 1) =  0.010   ;   zrgb(2, 1) = 0.01618   ;   zrgb(3, 1) = 0.07464   ;   zrgb(4, 1) = 0.37807
      zrgb(1, 2) =  0.011   ;   zrgb(2, 2) = 0.01654   ;   zrgb(3, 2) = 0.07480   ;   zrgb(4, 2) = 0.37823
      zrgb(1, 3) =  0.013   ;   zrgb(2, 3) = 0.01693   ;   zrgb(3, 3) = 0.07499   ;   zrgb(4, 3) = 0.37840
      zrgb(1, 4) =  0.014   ;   zrgb(2, 4) = 0.01736   ;   zrgb(3, 4) = 0.07518   ;   zrgb(4, 4) = 0.37859
      zrgb(1, 5) =  0.016   ;   zrgb(2, 5) = 0.01782   ;   zrgb(3, 5) = 0.07539   ;   zrgb(4, 5) = 0.37879
      zrgb(1, 6) =  0.018   ;   zrgb(2, 6) = 0.01831   ;   zrgb(3, 6) = 0.07562   ;   zrgb(4, 6) = 0.37900
      zrgb(1, 7) =  0.020   ;   zrgb(2, 7) = 0.01885   ;   zrgb(3, 7) = 0.07586   ;   zrgb(4, 7) = 0.37923
      zrgb(1, 8) =  0.022   ;   zrgb(2, 8) = 0.01943   ;   zrgb(3, 8) = 0.07613   ;   zrgb(4, 8) = 0.37948
      zrgb(1, 9) =  0.025   ;   zrgb(2, 9) = 0.02005   ;   zrgb(3, 9) = 0.07641   ;   zrgb(4, 9) = 0.37976
      zrgb(1,10) =  0.028   ;   zrgb(2,10) = 0.02073   ;   zrgb(3,10) = 0.07672   ;   zrgb(4,10) = 0.38005
      zrgb(1,11) =  0.032   ;   zrgb(2,11) = 0.02146   ;   zrgb(3,11) = 0.07705   ;   zrgb(4,11) = 0.38036
      zrgb(1,12) =  0.035   ;   zrgb(2,12) = 0.02224   ;   zrgb(3,12) = 0.07741   ;   zrgb(4,12) = 0.38070
      zrgb(1,13) =  0.040   ;   zrgb(2,13) = 0.02310   ;   zrgb(3,13) = 0.07780   ;   zrgb(4,13) = 0.38107
      zrgb(1,14) =  0.045   ;   zrgb(2,14) = 0.02402   ;   zrgb(3,14) = 0.07821   ;   zrgb(4,14) = 0.38146
      zrgb(1,15) =  0.050   ;   zrgb(2,15) = 0.02501   ;   zrgb(3,15) = 0.07866   ;   zrgb(4,15) = 0.38189
      zrgb(1,16) =  0.056   ;   zrgb(2,16) = 0.02608   ;   zrgb(3,16) = 0.07914   ;   zrgb(4,16) = 0.38235
      zrgb(1,17) =  0.063   ;   zrgb(2,17) = 0.02724   ;   zrgb(3,17) = 0.07967   ;   zrgb(4,17) = 0.38285
      zrgb(1,18) =  0.071   ;   zrgb(2,18) = 0.02849   ;   zrgb(3,18) = 0.08023   ;   zrgb(4,18) = 0.38338
      zrgb(1,19) =  0.079   ;   zrgb(2,19) = 0.02984   ;   zrgb(3,19) = 0.08083   ;   zrgb(4,19) = 0.38396
      zrgb(1,20) =  0.089   ;   zrgb(2,20) = 0.03131   ;   zrgb(3,20) = 0.08149   ;   zrgb(4,20) = 0.38458
      zrgb(1,21) =  0.100   ;   zrgb(2,21) = 0.03288   ;   zrgb(3,21) = 0.08219   ;   zrgb(4,21) = 0.38526
      zrgb(1,22) =  0.112   ;   zrgb(2,22) = 0.03459   ;   zrgb(3,22) = 0.08295   ;   zrgb(4,22) = 0.38598
      zrgb(1,23) =  0.126   ;   zrgb(2,23) = 0.03643   ;   zrgb(3,23) = 0.08377   ;   zrgb(4,23) = 0.38676
      zrgb(1,24) =  0.141   ;   zrgb(2,24) = 0.03842   ;   zrgb(3,24) = 0.08466   ;   zrgb(4,24) = 0.38761
      zrgb(1,25) =  0.158   ;   zrgb(2,25) = 0.04057   ;   zrgb(3,25) = 0.08561   ;   zrgb(4,25) = 0.38852
      zrgb(1,26) =  0.178   ;   zrgb(2,26) = 0.04289   ;   zrgb(3,26) = 0.08664   ;   zrgb(4,26) = 0.38950
      zrgb(1,27) =  0.200   ;   zrgb(2,27) = 0.04540   ;   zrgb(3,27) = 0.08775   ;   zrgb(4,27) = 0.39056
      zrgb(1,28) =  0.224   ;   zrgb(2,28) = 0.04811   ;   zrgb(3,28) = 0.08894   ;   zrgb(4,28) = 0.39171
      zrgb(1,29) =  0.251   ;   zrgb(2,29) = 0.05103   ;   zrgb(3,29) = 0.09023   ;   zrgb(4,29) = 0.39294
      zrgb(1,30) =  0.282   ;   zrgb(2,30) = 0.05420   ;   zrgb(3,30) = 0.09162   ;   zrgb(4,30) = 0.39428
      zrgb(1,31) =  0.316   ;   zrgb(2,31) = 0.05761   ;   zrgb(3,31) = 0.09312   ;   zrgb(4,31) = 0.39572
      zrgb(1,32) =  0.355   ;   zrgb(2,32) = 0.06130   ;   zrgb(3,32) = 0.09474   ;   zrgb(4,32) = 0.39727
      zrgb(1,33) =  0.398   ;   zrgb(2,33) = 0.06529   ;   zrgb(3,33) = 0.09649   ;   zrgb(4,33) = 0.39894
      zrgb(1,34) =  0.447   ;   zrgb(2,34) = 0.06959   ;   zrgb(3,34) = 0.09837   ;   zrgb(4,34) = 0.40075
      zrgb(1,35) =  0.501   ;   zrgb(2,35) = 0.07424   ;   zrgb(3,35) = 0.10040   ;   zrgb(4,35) = 0.40270
      zrgb(1,36) =  0.562   ;   zrgb(2,36) = 0.07927   ;   zrgb(3,36) = 0.10259   ;   zrgb(4,36) = 0.40480
      zrgb(1,37) =  0.631   ;   zrgb(2,37) = 0.08470   ;   zrgb(3,37) = 0.10495   ;   zrgb(4,37) = 0.40707
      zrgb(1,38) =  0.708   ;   zrgb(2,38) = 0.09056   ;   zrgb(3,38) = 0.10749   ;   zrgb(4,38) = 0.40952
      zrgb(1,39) =  0.794   ;   zrgb(2,39) = 0.09690   ;   zrgb(3,39) = 0.11024   ;   zrgb(4,39) = 0.41216
      zrgb(1,40) =  0.891   ;   zrgb(2,40) = 0.10374   ;   zrgb(3,40) = 0.11320   ;   zrgb(4,40) = 0.41502
      zrgb(1,41) =  1.000   ;   zrgb(2,41) = 0.11114   ;   zrgb(3,41) = 0.11639   ;   zrgb(4,41) = 0.41809
      zrgb(1,42) =  1.122   ;   zrgb(2,42) = 0.11912   ;   zrgb(3,42) = 0.11984   ;   zrgb(4,42) = 0.42142
      zrgb(1,43) =  1.259   ;   zrgb(2,43) = 0.12775   ;   zrgb(3,43) = 0.12356   ;   zrgb(4,43) = 0.42500
      zrgb(1,44) =  1.413   ;   zrgb(2,44) = 0.13707   ;   zrgb(3,44) = 0.12757   ;   zrgb(4,44) = 0.42887
      zrgb(1,45) =  1.585   ;   zrgb(2,45) = 0.14715   ;   zrgb(3,45) = 0.13189   ;   zrgb(4,45) = 0.43304
      zrgb(1,46) =  1.778   ;   zrgb(2,46) = 0.15803   ;   zrgb(3,46) = 0.13655   ;   zrgb(4,46) = 0.43754
      zrgb(1,47) =  1.995   ;   zrgb(2,47) = 0.16978   ;   zrgb(3,47) = 0.14158   ;   zrgb(4,47) = 0.44240
      zrgb(1,48) =  2.239   ;   zrgb(2,48) = 0.18248   ;   zrgb(3,48) = 0.14701   ;   zrgb(4,48) = 0.44765
      zrgb(1,49) =  2.512   ;   zrgb(2,49) = 0.19620   ;   zrgb(3,49) = 0.15286   ;   zrgb(4,49) = 0.45331
      zrgb(1,50) =  2.818   ;   zrgb(2,50) = 0.21102   ;   zrgb(3,50) = 0.15918   ;   zrgb(4,50) = 0.45942
      zrgb(1,51) =  3.162   ;   zrgb(2,51) = 0.22703   ;   zrgb(3,51) = 0.16599   ;   zrgb(4,51) = 0.46601
      zrgb(1,52) =  3.548   ;   zrgb(2,52) = 0.24433   ;   zrgb(3,52) = 0.17334   ;   zrgb(4,52) = 0.47313
      zrgb(1,53) =  3.981   ;   zrgb(2,53) = 0.26301   ;   zrgb(3,53) = 0.18126   ;   zrgb(4,53) = 0.48080
      zrgb(1,54) =  4.467   ;   zrgb(2,54) = 0.28320   ;   zrgb(3,54) = 0.18981   ;   zrgb(4,54) = 0.48909
      zrgb(1,55) =  5.012   ;   zrgb(2,55) = 0.30502   ;   zrgb(3,55) = 0.19903   ;   zrgb(4,55) = 0.49803
      zrgb(1,56) =  5.623   ;   zrgb(2,56) = 0.32858   ;   zrgb(3,56) = 0.20898   ;   zrgb(4,56) = 0.50768
      zrgb(1,57) =  6.310   ;   zrgb(2,57) = 0.35404   ;   zrgb(3,57) = 0.21971   ;   zrgb(4,57) = 0.51810
      zrgb(1,58) =  7.079   ;   zrgb(2,58) = 0.38154   ;   zrgb(3,58) = 0.23129   ;   zrgb(4,58) = 0.52934
      zrgb(1,59) =  7.943   ;   zrgb(2,59) = 0.41125   ;   zrgb(3,59) = 0.24378   ;   zrgb(4,59) = 0.54147
      zrgb(1,60) =  8.912   ;   zrgb(2,60) = 0.44336   ;   zrgb(3,60) = 0.25725   ;   zrgb(4,60) = 0.55457
      zrgb(1,61) = 10.000   ;   zrgb(2,61) = 0.47804   ;   zrgb(3,61) = 0.27178   ;   zrgb(4,61) = 0.56870
      !
      prgb(:,:) = zrgb(2:4,:)
      !
      r_si2 = 1.e0 / zrgb(2, 1)        ! blue with the smallest chlorophyll concentration)
      IF(lwp) WRITE(numout,*) '      RGB longest depth of extinction    r_si2 = ', r_si2
      !
      DO jc = 1, 61                         ! check
         zchl = zrgb(1,jc)
         irgb = NINT( 41 + 20.* LOG10( zchl ) + 1.e-15 )
         IF(lwp .AND. nn_print >= 1 ) WRITE(numout,*) '    jc =', jc, '  Chl = ', zchl, '  irgb = ', irgb
         IF( irgb /= jc ) THEN
            IF(lwp) WRITE(numout,*) '    jc =', jc, '  Chl = ', zchl, '  Chl class = ', irgb
            CALL ctl_stop( 'trc_oce_rgb : inconsistency in Chl tabulated attenuation coeff.' )
         ENDIF
      END DO
      !
   END SUBROUTINE trc_oce_rgb

   SUBROUTINE trc_oce_rgb_read( prgb )
      !!----------------------------------------------------------------------
      !!                  ***  ROUTINE p4z_opt_init  ***
      !!
      !! ** Purpose :   Initialization of of the optical scheme
      !!
      !! ** Method  :   read the look up table for the optical coefficients
      !!
      !! ** input   :   xkrgb(61) precomputed array corresponding to the
      !!                          attenuation coefficient (from JM Andre)
      !!----------------------------------------------------------------------
      REAL(wp), DIMENSION(3,61), INTENT(out) ::   prgb   ! tabulated attenuation coefficient
      !
      INTEGER  ::   jc, jb ! dummy loop indice
      INTEGER  ::   irgb   ! temporary integer
      REAL(wp) ::   zchl   ! temporary scalar
      INTEGER  ::   numlight
      !!----------------------------------------------------------------------
      !
      IF(lwp) THEN                         ! control print
         WRITE(numout,*)
         WRITE(numout,*) ' trc_oce_rgb_read : optical look-up table read in kRGB61.txt file'
         WRITE(numout,*) ' ~~~~~~~~~~~~~~~~'
         WRITE(numout,*)
      ENDIF
      !
      CALL ctl_opn( numlight, 'kRGB61.txt', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp )
      DO jc = 1, 61
         READ(numlight,*) zchl, ( prgb(jb,jc), jb = 1, 3 )
         irgb = NINT( 41 + 20.* LOG10( zchl ) + 1.e-15 )
         IF(lwp) WRITE(numout,*) '    jc =', jc, '  Chl = ', zchl, '  irgb = ', irgb
         IF( irgb /= jc ) THEN
            IF(lwp) WRITE(numout,*) '    jc =', jc, '  Chl = ', zchl, '  Chl class = ', irgb
            CALL ctl_stop( 'trc_oce_rgb_read : inconsistency in Chl tabulated attenuation coeff.' )
         ENDIF
      END DO
      CLOSE( numlight )
      !
      r_si2 = 1.e0 / prgb(1, 1)      ! blue with the smallest chlorophyll concentration)
      IF(lwp) WRITE(numout,*) '      RGB longest depth of extinction    r_si2 = ', r_si2
      !
   END SUBROUTINE trc_oce_rgb_read

   FUNCTION trc_oce_ext_lev( prldex, pqsr_frc ) RESULT( pjl )
      !!----------------------------------------------------------------------
      !!                 ***  ROUTINE trc_oce_ext_lev  ***
      !!
      !! ** Purpose :   compute max. level for light penetration
      !!
      !! ** Method  :   the function provides the level at which irradiance
      !!                becomes negligible (i.e. = 1.e-15 W/m2) for 3 or 2 bands light
      !!                penetration: I(z) = pqsr_frc * EXP(hext/prldex) = 1.e-15 W/m2
      !!                # prldex is the longest depth of extinction:
      !!                   - prldex = 23 m (2 bands case)
      !!                   - prldex = 62 m (3 bands case: blue waveband & 0.01 mg/m2 for the chlorophyll)
      !!                # pqsr_frc is the fraction of solar radiation which penetrates,
      !!                considering Qsr=240 W/m2 and rn_abs = 0.58:
      !!                   - pqsr_frc = Qsr * (1-rn_abs)   = 1.00e2 W/m2 (2 bands case)
      !!                   - pqsr_frc = Qsr * (1-rn_abs)/3 = 0.33e2 W/m2 (3 bands case & equi-partition)
      !!
      !!----------------------------------------------------------------------
      REAL(wp), INTENT(in) ::   prldex    ! longest depth of extinction
      REAL(wp), INTENT(in) ::   pqsr_frc  ! frac. solar radiation which penetrates
      !
      INTEGER  ::   jk, pjl            ! levels
      REAL(wp) ::   zhext              ! deepest level till which light penetrates
      REAL(wp) ::   zprec = 15._wp     ! precision to reach -LOG10(1.e-15)
      REAL(wp) ::   zem                ! temporary scalar
      !!----------------------------------------------------------------------
      !
      ! It is not necessary to compute anything below the following depth
      zhext = prldex * ( LOG(10._wp) * zprec + LOG(pqsr_frc) )
      !
      ! Level of light extinction
      pjl = jpkm1
      DO jk = jpkm1, 1, -1
         IF(SUM(tmask(:,:,jk)) > 0 ) THEN
            zem = MAXVAL( gdepw_0(:,:,jk+1) * tmask(:,:,jk) )
            IF( zem >= zhext )   pjl = jk                       ! last T-level reached by Qsr
         ELSE
            pjl = jk                                            ! or regional sea-bed depth
         ENDIF
      END DO
      !
   END FUNCTION trc_oce_ext_lev

   !!======================================================================
END MODULE trc_oce