! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! H0 X
! H0 X   libAtoms+QUIP: atomistic simulation library
! H0 X
! H0 X   Portions of this code were written by
! H0 X     Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode,
! H0 X     Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield.
! H0 X
! H0 X   Copyright 2006-2010.
! H0 X
! H0 X   These portions of the source code are released under the GNU General
! H0 X   Public License, version 2, http://www.gnu.org/copyleft/gpl.html
! H0 X
! H0 X   If you would like to license the source code under different terms,
! H0 X   please contact Gabor Csanyi, gabor@csanyi.net
! H0 X
! H0 X   Portions of this code were written by Noam Bernstein as part of
! H0 X   his employment for the U.S. Government, and are not subject
! H0 X   to copyright in the USA.
! H0 X
! H0 X
! H0 X   When using this software, please cite the following reference:
! H0 X
! H0 X   http://www.libatoms.org
! H0 X
! H0 X  Additional contributions by
! H0 X    Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras
! H0 X
! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

program test_CASTEP_water_chain
use libatoms_module
use potential_module
implicit none
  type(Atoms) :: cluster_qm, cluster_mm, bulk
  type(Inoutput) :: io
  character(len=STRING_LENGTH) :: init_args, calc_args, infile
  real(dp) :: g_width_O, g_width_H, vacuum, charge_scale
  integer :: qm_center_i, qm_center_i_cluster
  real(dp) :: r_qm, r
  type(Potential) :: pot
  type(Dictionary) :: cli
  real(dp), allocatable :: f(:,:)
  integer :: i, ii, j
  real(dp) :: charge(128)
  real(dp) :: lat(3,3)

  call system_initialise(seed=1)

  call initialise(cli)
  init_args = ""
  call param_register(cli, "init_args", param_mandatory, init_args, help_string="No help yet.  This source file was $LastChangedBy$")
  calc_args = ""
  call param_register(cli, "calc_args", "", calc_args, help_string="No help yet.  This source file was $LastChangedBy$")
  infile = ""
  call param_register(cli, "infile", "stdin", infile, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(cli, "qm_center_i", param_mandatory, qm_center_i, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(cli, "r_qm", param_mandatory, r_qm, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(cli, "charge_scale", "1.0", charge_scale, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(cli, "g_width_O", ""//(1.2_dp/sqrt(2.0_dp)), g_width_O, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(cli, "g_width_H", ""//(0.44_dp/sqrt(2.0_dp)), g_width_H, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(cli, "vacuum", "15.0", vacuum, help_string="No help yet.  This source file was $LastChangedBy$")
  if (.not. param_read_args(cli, ignore_unknown=.false.)) &
    call system_abort("Failed to parse CLI parameters")

  call print("qm_center_i " // qm_center_i)
  call print("r_qm " // r_qm)
  call print("charge_scale " // charge_scale)
  call print("g_width_O " // g_width_O)
  call print("g_width_H " // g_width_H)
  call print("vacuum " // vacuum)

  charge = 0.0_dp
  charge(1) = 0.417_dp*charge_scale
  charge(8) = -0.834_dp*charge_scale

  call finalise(cli)

  call read(bulk, trim(infile))

  call initialise(pot, init_args)
  call initialise(cluster_qm,0,bulk%lattice)
  call initialise(cluster_mm,0,bulk%lattice)

  call calc_connect(bulk)

  call print("past calc_connect(bulk)", PRINT_ALWAYS)

  ! create qm and mm lists
  do i=1, bulk%N
    if (mod(i,1000) == 1) call print("creating qm and mm lists for atom " // i, PRINT_ALWAYS)
    if (bulk%Z(i) == 8) then
      r = distance_min_image(bulk, i, qm_center_i)
      if (r <= r_qm) then
        call add_atoms(cluster_qm, bulk%pos(:,i), bulk%Z(i))
        if (i == qm_center_i) qm_center_i_cluster = cluster_qm%N
        call print("atom " // i // " n_neigh " // atoms_n_neighbours(bulk, i))
        do ii=1, atoms_n_neighbours(bulk, i)
          j = atoms_neighbour(bulk, i, ii)
          call add_atoms(cluster_qm, bulk%pos(:,j), bulk%Z(j))
        end do
      else
        call add_atoms(cluster_mm, bulk%pos(:,i), bulk%Z(i))
        do ii=1, atoms_n_neighbours(bulk, i)
          j = atoms_neighbour(bulk, i, ii)
          call add_atoms(cluster_mm, bulk%pos(:,j), bulk%Z(j))
        end do
      endif
    endif
  end do

  call print("past creating cluster_mm and cluster_qm", PRINT_ALWAYS)

  ! move qm_center to origin
  do i=1, cluster_qm%N
    cluster_qm%pos(:,i) = cluster_qm%pos(:,i) - bulk%pos(:,qm_center_i)
  end do
  do i=1, cluster_mm%N
    cluster_mm%pos(:,i) = cluster_mm%pos(:,i) - bulk%pos(:,qm_center_i)
  end do

  call print("past shifting positions cluster_mm and cluster_qm", PRINT_ALWAYS)

  ! map back into cell with original (bulk) lattice
  call map_into_cell(cluster_mm)
  call map_into_cell(cluster_qm)

  call print("past map_into_cell positions cluster_mm and cluster_qm", PRINT_ALWAYS)

  call calc_connect(cluster_mm)
  call print("past calc_connect cluster_mm", PRINT_ALWAYS)
  ! make sure MM molecules aren't broken up by PBCs
  do i=1, cluster_mm%N, 3
    if (mod(i,1000) == 1) call print("coalescing molecule for atom " // i, PRINT_ALWAYS)
    call coalesce_in_one_periodic_image(cluster_mm, i)
  end do

  ! calculate qm lattice, and center around middle of qm cell
  ! calulate pbcs for qm region
  lat = 0.0_dp
  lat(1,1) = (maxval(cluster_qm%pos(1,:))-minval(cluster_qm%pos(1,:)))+vacuum
  lat(2,2) = (maxval(cluster_qm%pos(2,:))-minval(cluster_qm%pos(2,:)))+vacuum
  lat(3,3) = (maxval(cluster_qm%pos(3,:))-minval(cluster_qm%pos(3,:)))+vacuum
  call set_lattice(cluster_qm, lat, scale_positions=.false.)

  call print("lat", PRINT_ALWAYS)
  call print(lat, PRINT_ALWAYS)

  do i=1, cluster_qm%N
    cluster_qm%pos(:,i) = cluster_qm%pos(:,i) + sum(lat,2)/2.0_dp
  end do
  do i=1, cluster_mm%N
    cluster_mm%pos(:,i) = cluster_mm%pos(:,i) + sum(lat,2)/2.0_dp
  end do

  call finalise(bulk)

  call initialise(io, "extcharges", OUTPUT)
  do i=1, cluster_mm%N
    if (cluster_mm%Z(i) == 1) then
      call print(charge(cluster_mm%Z(i)) //" " // cluster_mm%pos(:,i) //" " // g_width_H, file=io)
    else if (cluster_mm%Z(i) == 8) then
      call print(charge(cluster_mm%Z(i)) //" " // cluster_mm%pos(:,i) //" " // g_width_O, file=io)
    else
      call system_abort("No width defined for Z="//cluster_mm%Z(i))
    endif
  end do
  call finalise(io)

  call print("BOB "//(cluster_qm%N+cluster_mm%N))
  call print("BOB ")
  do i=1, cluster_qm%N
    call print("BOB "//cluster_qm%Z(i)//" "//cluster_qm%pos(:,i))
  end do
  do i=1, cluster_mm%N
    call print("BOB " //(cluster_mm%Z(i)+1)//" "//cluster_mm%pos(:,i))
  end do

  allocate(f(3,cluster_qm%N))
  f = 0.0_dp
  call calc(pot, cluster_qm, f=f, args_str=calc_args)

  do i=1, cluster_qm%N
    if (i == qm_center_i_cluster) then
      call print(" " // r_qm // " " // i // " " // cluster_qm%pos(:,i) // " " // f(:,i) // " CTR")
    else
      call print(" " // r_qm // " " // i // " " // cluster_qm%pos(:,i) // " " // f(:,i))
    endif
  end do

  call finalise(pot)
  call system_finalise()

contains

  subroutine add_water(at, p)
    type(Atoms), intent(inout) :: at
    real(dp), intent(in) :: p(3)

    real(dp) :: po(3), ph1(3), ph2(3)
    real(dp), parameter :: r_oh = 0.95_dp, theta_hoh=105.0_dp*PI/180.0_dp
    real(dp) :: v1(3), v2(3)

    v1 = random_unit_vector()
    v2 = random_unit_vector()
    v2 = v2 - (v1.dot.v2)*v1
    v2 = v2 / norm(v2)

    po = -v1*r_oh*cos(theta_hoh/2.0_dp)/3.0_dp
    ph1 = po + v1*r_oh*cos(theta_hoh/2.0_dp) + v2*r_oh*sin(theta_hoh/2.0_dp)
    ph2 = po + v1*r_oh*cos(theta_hoh/2.0_dp) - v2*r_oh*sin(theta_hoh/2.0_dp)

    call add_atoms(at, p+po, 8)
    call add_atoms(at, p+ph1, 1)
    call add_atoms(at, p+ph2, 1)

  end subroutine add_water

end program test_CASTEP_water_chain


C$Procedure ZZCKCV01 ( Private --- C-kernel segment coverage, type 01 )

      SUBROUTINE ZZCKCV01 ( HANDLE,  ARRBEG,  ARREND,
     .                      SCLKID,  TOL,     TIMSYS,  SCHEDL  )

C$ Abstract
C
C     SPICE Private routine intended solely for the support of SPICE
C     routines.  Users should not call this routine directly due
C     to the volatile nature of this routine.
C
C     Determine the "window" of coverage of a type 01 C-kernel segment.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     CK
C     DAF
C
C$ Keywords
C
C     CK
C     UTILITY
C     PRIVATE
C
C$ Declarations

      IMPLICIT NONE

      INTEGER               LBCELL
      PARAMETER           ( LBCELL = -5 )

      INTEGER               HANDLE
      INTEGER               ARRBEG
      INTEGER               ARREND
      INTEGER               SCLKID
      DOUBLE PRECISION      TOL
      CHARACTER*(*)         TIMSYS
      DOUBLE PRECISION      SCHEDL ( LBCELL:* )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     HANDLE     I   Handle of a C-kernel open for read access
C     ARRBEG     I   Beginning DAF address
C     ARREND     I   Ending DAF address
C     SCLKID     I   ID of SCLK associated with segment.
C     TOL        I   Tolerance in ticks.
C     TIMSYS     I   Time system used to represent coverage.
C     SCHEDL    I/O  An initialized window/schedule of interval
C
C$ Detailed_Input
C
C     HANDLE     is the handle of some DAF that is open for reading.
C
C     ARRBEG     is the beginning address of a type 01 segment
C
C     ARREND     is the ending address of a type 01 segment.
C
C     SCLKID     is the ID code of the spacecraft clock associated with
C                the object for which the segment contains pointing.
C                This is the ID code used by the SCLK conversion
C                routines.
C
C     TOL        is a tolerance value expressed in ticks of the
C                spacecraft clock associated with the segment. Before
C                each interval is inserted into the coverage window,
C                the intervals are expanded by TOL:  the left endpoint
C                of each interval is reduced by TOL and the right
C                endpoint is increased by TOL.  Any intervals that
C                overlap as a result of the expansion are merged.
C
C                The coverage window returned when TOL > 0 indicates
C                the coverage provided by the file to the CK readers
C                CKGPAV and CKGP when that value of TOL is passed to
C                them as an input.
C
C
C     TIMSYS     is a string indicating the time system used in the
C                output coverage window.  TIMSYS may have the values:
C
C                   'SCLK'    Elements of SCHEDL are expressed in
C                             encoded SCLK ("ticks"), where the clock
C                             is associated with the object designated
C                             by IDCODE.
C
C                   'TDB'     Elements of SCHEDL are expressed as
C                             seconds past J2000 TDB.
C
C                TIMSYS must be consistent with the system used for
C                the contents of SCHEDL on input, if any.
C
C
C     SCHEDL     is a schedule (window) of intervals, to which the
C                intervals of coverage for this segment will be added.
C
C$ Detailed_Output
C
C     SCHEDL     the input schedule updated to include the intervals
C                of coverage for this segment. Since type 01 segments,
C                don't have interpolation intervals, each epoch
C                associated with a pointing instance is treated as a
C                singleton interval.
C
C$ Parameters
C
C     None.
C
C$ Files
C
C     This routine reads the contents of the file associated with
C     HANDLE to locate coverage intervals.
C
C$ Exceptions
C
C     1) The error SPICE(BADCK1SEGMENT) is signaled if the derived
C        segment length from ARRBEG and ARREND does not match
C        the possible lengths computed from the segment metadata.
C
C     2) Routines in the call tree of this routine may signal errors
C        if insufficient room in SCHEDL exists or other error
C        conditions relating to file access arise.
C
C     3)  If TOL is negative, the error SPICE(VALUEOUTOFRANGE) is
C         signaled.
C
C     4)  If TIMSYS is not recognized, the error SPICE(INVALIDOPTION)
C         is signaled.
C
C     5) If a time conversion error occurs, the error will be
C         diagnosed by a routine in the call tree of this routine.
CC
C$ Particulars
C
C     This is a utility routine that determines the intervals of
C     coverage for a type 01 C-kernel segment. Since type 01 segments,
C     don't have interpolation intervals, each epoch associated with a
C     pointing instance is treated as a singleton interval.
C
C$ Examples
C
C     None.
C
C$ Restrictions
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber      (JPL)
C     N.J. Bachman    (JPL)
C     B.V. Semenov    (JPL)
C
C$ Literature_References
C
C     None.
C
C$ Version
C
C-    SUPPORT Version 1.0.0, 03-JAN-2005 (WLT)(NJB)(BVS)
C
C        Initial version.
C
C-&

C
C     SPICELIB Functions
C
      LOGICAL               EQSTR
      LOGICAL               RETURN

C
C     Local Parameters
C
      INTEGER               BUFSIZ
      PARAMETER           ( BUFSIZ = 100 )

      INTEGER               QAVSIZ
      PARAMETER           ( QAVSIZ = 7 )

      INTEGER               QSIZ
      PARAMETER           ( QSIZ   = 4 )

C
C     Local Variables
C
      DOUBLE PRECISION      BEGIN
      DOUBLE PRECISION      BUFFER ( BUFSIZ )
      DOUBLE PRECISION      ET
      DOUBLE PRECISION      FINISH

      INTEGER               I
      INTEGER               N
      INTEGER               NREC
      INTEGER               OFFSET
      INTEGER               PSIZ
      INTEGER               REMAIN
      INTEGER               TBASE
      INTEGER               NAVSLN
      INTEGER               AVSLN
      INTEGER               SEGLEN

      LOGICAL               ISTDB

C
C     Standard SPICE error handling.
C
      IF ( RETURN() ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'ZZCKCV01' )
      END IF

C
C     Check tolerance value.
C
      IF ( TOL .LT. 0.D0 ) THEN

         CALL SETMSG ( 'Tolerance must be non-negative; actual value '//
     .                 'was #.'                                       )
         CALL ERRDP  ( '#',  TOL                                      )
         CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'                       )
         CALL CHKOUT ( 'ZZCKCV01'                                     )
         RETURN

      END IF

C
C     Set a logical flag indicating whether the time systm is SCLK.
C
      ISTDB  = EQSTR ( TIMSYS, 'TDB' )

C
C     Check time system.
C
      IF ( .NOT. ISTDB ) THEN

         IF (  .NOT.  EQSTR ( TIMSYS, 'SCLK' )  )THEN

            CALL SETMSG ( 'Time system spec TIMSYS was #; allowed ' //
     .                    'values are SCLK and TDB.'                )
            CALL ERRCH  ( '#',  TIMSYS                              )
            CALL SIGERR ( 'SPICE(INVALIDOPTION)'                    )
            CALL CHKOUT ( 'ZZCKCV01'                                )
            RETURN

         END IF

      END IF

C
C     The coverage window is the set of singleton intervals consisting
C     of the epochs of the pointing records. We'll need to find the
C     epochs.
C
C     First, get the number of records in this segment.
C
      CALL DAFGDA ( HANDLE, ARREND, ARREND, BUFFER )

      NREC = INT( BUFFER(1) )

C
C     Determine the size of the pointing packets. This is dependent
C     on whether angular rate data is present in the segment or not.
C     We can determine this with the following computation:
C
C     Assume a record size of 4, i.e. no angular rate data.
C
      NAVSLN = 5 * NREC + ( NREC - 1 ) / 100 + 1

C
C     Assume a record size of 7, i.e. angular rate data.
C
      AVSLN  = 8 * NREC + ( NREC - 1 ) / 100 + 1

C
C     Compute the actual length of the segment.
C
      SEGLEN = ARREND - ARRBEG + 1

      IF ( SEGLEN .EQ. NAVSLN ) THEN
         PSIZ = QSIZ
      ELSE IF ( SEGLEN .EQ. AVSLN ) THEN
         PSIZ = QAVSIZ
      ELSE
         CALL SETMSG ( 'The requested segment in file # reports a '
     .   //            'length of # d.p. numbers, but the metadata '
     .   //            'in the segment indicates the length must '
     .   //            'either be # (no angular rate data) or # '
     .   //            '(angular rate data). Perhaps the segment '
     .   //            'is not type 1?'                              )
         CALL ERRHAN ( '#', HANDLE                                   )
         CALL ERRINT ( '#', SEGLEN                                   )
         CALL ERRINT ( '#', NAVSLN                                   )
         CALL ERRINT ( '#', AVSLN                                    )
         CALL SIGERR ( 'SPICE(BADCK1SEGMENT)'                        )
         CALL CHKOUT ( 'ZZCKCV01'                                    )
         RETURN
      END IF

C
C     The epochs start right after the pointing data. Let TBASE be the
C     address preceding the first epoch.
C
      TBASE  = ARRBEG  +  NREC * PSIZ  -  1

C
C     Grab the epochs. Make a singleton interval out of each one; add
C     the interval to the coverage window.
C
C     For efficiency, we'll read the epochs into a buffer of length
C     BUFSIZ.
C
      REMAIN = NREC
      OFFSET = 0

      DO WHILE ( REMAIN .GT. 0 )

C
C        Buffer the next set of epochs.
C
         N  =  MIN ( BUFSIZ, REMAIN )

         CALL DAFGDA ( HANDLE,
     .                 TBASE + OFFSET + 1,
     .                 TBASE + OFFSET + N,
     .                 BUFFER              )

C
C        Insert the current batch of N singleton intervals.
C
         DO I = 1, N

            BEGIN   =  BUFFER(I)
            FINISH  =  BUFFER(I)

            IF ( TOL .GT. 0.D0 ) THEN
C
C              Adjust the interval using the tolerance.
C
               BEGIN   =  MAX( BEGIN  - TOL, 0.D0 )
               FINISH  =       FINISH + TOL

            END IF

C
C           Convert the time to TDB if necessary.
C
            IF ( ISTDB ) THEN

               CALL SCT2E ( SCLKID, BEGIN,  ET )
               BEGIN  = ET

               CALL SCT2E ( SCLKID, FINISH, ET )
               FINISH = ET

            END IF

            CALL WNINSD ( BEGIN, FINISH, SCHEDL )

         END DO

         OFFSET = OFFSET + N
         REMAIN = REMAIN - N

      END DO

      CALL CHKOUT ( 'ZZCKCV01' )
      RETURN
      END


c  Obsolete 2020
c
      subroutine tlinit(np,h0,geo)
      use tfmem, only:ktaloc
      implicit none
      integer*4 np
      real*8 h0,geo(3,4)
      integer*8 katbl
      integer*4 np0,ltbl,lpoint
      real*8 geo0(3,4),tax,tay,taz,t0,gx,gy,gz,gt
      common /radlcomr/geo0,t0,tax,tay,taz,gx,gy,gz,gt
      common /radlcomi/katbl,np0,ltbl,lpoint
      np0=np
      ltbl=int(h0*10.d0)+1
      katbl=ktaloc(np*4*ltbl)
      lpoint=0
      gx=geo(1,4)
      gy=geo(2,4)
      gz=geo(3,4)
      gt=0.d0
      geo0(:,3)=geo(:,3)
      geo0(1,4)=gx
      geo0(2,4)=gy
      geo0(3,4)=gz
      t0=gt
      return
      end

      subroutine tlstore(np,x,y,z,dv,theta,dl,dphi,rho0,v0,dvfs,keep)
      use tfstk
      implicit none
      integer*8 katbl,new,kai
      integer*4 np,np0,ltbl,lpoint,m,i
      real*8 x(np),y(np),z(np),dv(np),theta,dphi,rho0,v0,
     $     x1,x2,x3,y1,y2,y3,sp0,cp0,r1,r2,
     $     geoi(3,3),cost,sint,dl
      real*8 geo0(3,4),tax,tay,taz,t0,gx,gy,gz,gt,dvfs
      logical*4 keep
      common /radlcomr/geo0,t0,tax,tay,taz,gx,gy,gz,gt
      common /radlcomi/katbl,np0,ltbl,lpoint
c     begin initialize for preventing compiler warning
      cost=1.d0
      sint=0.d0
      y1=0.d0
      y2=0.d0
      y3=0.d0
c     end   initialize for preventing compiler warning
c      write(*,*)'tlstore ',lpoint,dphi,dl,theta,rho0,v0
      if(dphi .eq. 0.d0)then
        gx=geo0(1,4)+dl*geo0(1,3)
        gy=geo0(2,4)+dl*geo0(2,3)
        gz=geo0(3,4)+dl*geo0(3,3)
        geoi=geo0(:,1:3)
        gt=t0+dl/v0
      else
        if(theta .ne. 0.d0)then
          cost=cos(theta)
          sint=sin(theta)
          x1= cost*geo0(1,1)-sint*geo0(1,2)
          x2= cost*geo0(2,1)-sint*geo0(2,2)
          x3= cost*geo0(3,1)-sint*geo0(3,2)
          y1= sint*geo0(1,1)+cost*geo0(1,2)
          y2= sint*geo0(2,1)+cost*geo0(2,2)
          y3= sint*geo0(3,1)+cost*geo0(3,2)
        else
          x1= geo0(1,1)
          x2= geo0(2,1)
          x3= geo0(3,1)
        endif
        sp0=sin(dphi)
        cp0=cos(dphi)
        r1=rho0*sp0
        if(cp0 .ge. 0.d0)then
          r2=rho0*sp0**2/(1.d0+cp0)
        else
          r2=rho0*(1.d0-cp0)
        endif
        gx=geo0(1,4)+(r1*geo0(1,3)-r2*x1)
        gy=geo0(2,4)+(r1*geo0(2,3)-r2*x2)
        gz=geo0(3,4)+(r1*geo0(3,3)-r2*x3)
        geoi(1,1)= cp0*x1+sp0*geo0(1,3)
        geoi(1,3)=-sp0*x1+cp0*geo0(1,3)
        geoi(2,1)= cp0*x2+sp0*geo0(2,3)
        geoi(2,3)=-sp0*x2+cp0*geo0(2,3)
        geoi(3,1)= cp0*x3+sp0*geo0(3,3)
        geoi(3,3)=-sp0*x3+cp0*geo0(3,3)
        geoi(1,2)=geo0(1,2)
        geoi(2,2)=geo0(2,2)
        geoi(3,2)=geo0(3,2)
        gt=t0+abs(rho0*dphi)/v0
      endif
      lpoint=lpoint+1
      if(lpoint .gt. ltbl)then
c        write(*,*)'tlspect ',ltbl,np0,ltbl*8*np0
        new=ktaloc(ltbl*8*np0)
        if(new .gt. 0)then
          call tmov(rlist(katbl),rlist(new),ltbl*np0)
          call tmov(rlist(katbl+ltbl),rlist(new+ltbl*2),ltbl*np0)
          call tmov(rlist(katbl+ltbl*2),rlist(new+ltbl*4),ltbl*np0)
          call tmov(rlist(katbl+ltbl*3),rlist(new+ltbl*6),ltbl*np0)
          ltbl=ltbl*2
          call tfree(katbl)
          katbl=new
        else
          write(*,*)'Too long ltbl',ltbl
          call abort
        endif
      endif
      m=ltbl*4
      do i=1,np
        kai=(i-1)*4*ltbl+katbl+lpoint-1
        rlist(kai       )=gt-z(i)/(v0*(1.d0-dv(i)+dvfs))
        rlist(kai+ltbl  )=gx+x(i)*geoi(1,1)+y(i)*geoi(1,2)
        rlist(kai+ltbl*2)=gy+x(i)*geoi(2,1)+y(i)*geoi(2,2)
        rlist(kai+ltbl*3)=gz+x(i)*geoi(3,1)+y(i)*geoi(3,2)
      enddo
      if(keep)then
        geo0(:,3)=geoi(:,3)
        if(dphi .ne. 0 .and. theta .ne. 0.d0)then
          geo0(1,2)=-sint*geo0(1,1)+cost*y1
          geo0(1,1)= cost*geo0(1,1)+sint*y1
          geo0(2,2)=-sint*geo0(2,1)+cost*y2
          geo0(2,1)= cost*geo0(2,1)+sint*y2
          geo0(3,2)=-sint*geo0(3,1)+cost*y3
          geo0(3,1)= cost*geo0(3,1)+sint*y3
        endif
        geo0(1,4)=gx
        geo0(2,4)=gy
        geo0(3,4)=gz
        t0=gt
      endif
      return
      end

      subroutine tlresult(kx)
      use tfstk
      implicit none
      type (sad_descriptor) kx
      type (sad_dlist), pointer :: klx,kli
      type (sad_rlist), pointer :: klrij
      integer*8 katbl,kati
      integer*4 np0,ltbl,lpoint,i,j
      real*8 geo0(3,4),tax,tay,taz,t0,gx,gy,gz,gt
      common /radlcomr/geo0,t0,tax,tay,taz,gx,gy,gz,gt
      common /radlcomi/katbl,np0,ltbl,lpoint
c      write(*,*)ltbl,lpoint,katbl,ilist(1,katbl-1)
      kx=kxadaloc(-1,np0,klx)
      do i=1,np0
        kati=katbl+ltbl*4*(i-1)
        klx%dbody(i)=kxadaloc(0,4,kli)
        do j=1,4
          kli%dbody(j)=kxavaloc(0,lpoint,klrij)
          call tmov(rlist(kati+(j-1)*ltbl),klrij%rbody(1),lpoint)
        enddo
      enddo
      call tfree(katbl)
      return
      end

      subroutine tlfield(isp1,kx,irtc)
      use tfstk
      implicit none
      type (sad_rlist), pointer :: klt
      integer*8 kx, ke
      integer*4 isp1,irtc,n,m,itfmessage
      real*8 tx,ty,tz
      if(isp .ne. isp1+2)then
        irtc=itfmessage(9,'General::narg','"2"')
        return
      endif
      call tfmsize(ktastk(isp1+1),n,m,irtc)
      if(irtc .ne. 0)then
        return
      elseif(n .ne. 4)then
        irtc=itfmessage(9,'General::wrongleng','"#1","4"')
        return
      endif
      if(.not. tfreallistq(ktastk(isp),klt))then
        irtc=itfmessage(9,'General::wrongtype',
     $       '"List of Reals for #2"')
        return
      endif
      if(klt%nl .ne. 3)then
        irtc=itfmessage(9,'General::wrongleng','"#2","3"')
        return
      endif
      tx=klt%rbody(1)
      ty=klt%rbody(2)
      tz=klt%rbody(3)
      call tlcalc(ktastk(isp1+1),ke,m,tx,ty,tz)
      kx=ktflist+ke
      return
      end

      subroutine tlcalc(ka,ke,lpoint,tx,ty,tz)
      use tfstk
      use tmacro
      implicit none
      integer*8 ka,ke
      integer*4 lpoint,i,j
      real*8 xtbl(lpoint,4),f(lpoint,10),
     $     tx,ty,tz,dxi,dyi,dzi,ri,r0,dri,coeff,dt,f1,z0
      call tfl2m(klist(ktfaddr(ka)-3),xtbl,lpoint,4,.true.)
      z0=4.d-7*2.d0*asin(1.d0)*c
      r0=sqrt(tx**2+ty**2+tz**2)
      do i=1,lpoint
        dxi=tx-xtbl(i,2)
        dyi=ty-xtbl(i,3)
        dzi=tz-xtbl(i,4)
        ri=sqrt(dxi**2+dyi**2+dzi**2)
        dri=-(xtbl(i,2)*(tx+dxi)+xtbl(i,3)*(ty+dyi)
     $       +xtbl(i,4)*(tz+dzi))/(r0+ri)
        xtbl(i,1)=xtbl(i,1)+dri/c
        xtbl(i,2)=dxi/ri
        xtbl(i,3)=dyi/ri
        xtbl(i,4)=dzi/ri
        f(i,8)=ri/c
      enddo
      do i=2,4
        call spline(lpoint,xtbl(1,1),xtbl(1,i),f(1,i),f(1,1),0,0.d0)
      enddo
      do i=5,7
        do j=1,lpoint
          f(j,10)=xtbl(j,i-3)/f(j,8)**2
        enddo
        call spline(lpoint,xtbl(1,1),f(1,10),f(1,i),f(1,1),0,0.d0)
        f1=f(lpoint-1,i)
        do j=1,lpoint-1
          dt=xtbl(j+1,1)-xtbl(j,1)
          f(j,i)=f(j,10)+f(j,8)*
     $         ((f(j+1,10)-f(j,10))/dt-dt*(2.d0*f(j,i)+f(j+1,i)))
        enddo
        dt=xtbl(lpoint,1)-xtbl(lpoint-1,1)
        f(lpoint,i)=f(lpoint,10)+f(lpoint,8)*
     $       ((f(lpoint,10)-f(lpoint-1,10))/dt
     $       +dt*(f1+2.d0*f(lpoint,i)))
      enddo
      coeff=1.d-7*e*charge
      do i=1,lpoint
        f(i,1)=xtbl(i,1)
        f(i,2)=coeff*(6.d0*f(i,2)+f(i,5))
        f(i,3)=coeff*(6.d0*f(i,3)+f(i,6))
        f(i,4)=coeff*(6.d0*f(i,4)+f(i,7))
        f(i,5) =(xtbl(i,3)*f(i,4)-xtbl(i,4)*f(i,3))/z0
        f(i,6) =(xtbl(i,4)*f(i,2)-xtbl(i,2)*f(i,4))/z0
        f(i,7) =(xtbl(i,2)*f(i,3)-xtbl(i,3)*f(i,2))/z0
        f(i,8) =f(i,3)*f(i,7)-f(i,4)*f(i,6)
        f(i,9) =f(i,4)*f(i,5)-f(i,2)*f(i,7)
        f(i,10)=f(i,2)*f(i,6)-f(i,3)*f(i,5)
      enddo
      ke=ktfaddr(kxm2l(f,lpoint,10,lpoint,.true.))
      return
      end

      subroutine tlspect(isp1,kx,nparallel,irtc)
      use tfstk
      use macphys
      use tfshare,only:itffork
      implicit none
      type (sad_dlist), pointer :: klp,klx
      type (sad_rlist), pointer :: kl1,kl2,klt
      real*8 speedoflight
      parameter (speedoflight=cveloc)
      integer*8 kx,k1,k2,kac,kas,kal,kack,kad
      integer*4 isp1,irtc,m,na,i,k,
     $     na1,nastep,nparallel,ipr,getpid,j,
     $     wait,irw,naa,isw,ipid,itfmessage
      real*8 al0,al1,dal,w,c,s,a0,a1,x,ak,ak0,ak1,dak
      integer*4 ichpid(100)
      character*64 fn
c     begin initialize for preventing compiler warning
      ipid=0
      naa=0
      kal=0
      kas=0
c     end   initialize for preventing compiler warning
      irtc=0
      if(isp .ne. isp1+2)then
        irtc=itfmessage(9,'General::narg','"2"')
        return
      endif
      if(.not. tflistq(ktastk(isp1+1),klp))then
        irtc=itfmessage(9,'General::wrongtype','"List for #1"')
        return
      endif
      if(klp%nl .ne. 2)then
        irtc=itfmessage(9,'General::wrongleng','"#1","2"')
        return
      endif
      k1=klp%dbody(1)%k
      k2=klp%dbody(2)%k
      if(.not. tfreallistq(k1,kl1) .or. .not. tfreallistq(k2,kl2))then
        irtc=itfmessage(9,'General::wrongtype',
     $       '"List of List of Reals for #1"')
        return
      endif
      m=kl1%nl
      if(m .ne. kl2%nl)then
        irtc=itfmessage(9,'General::equalleng','"#1[[1]] and #[[2]]"')
        return
      endif
      if(.not. tfreallistq(ktastk(isp),klt))then
        irtc=itfmessage(9,'General::wrongtype','"List of Reals for #2"')
        return
      endif
      if(klt%nl .ne. 3)then
        irtc=itfmessage(9,'General::wrongleng','"#","3"')
        return
      endif
      al0=klt%rbody(1)
      al1=klt%rbody(2)
      dal=klt%rbody(3)
      na=int((al1-al0)/dal+2.5d0)
      ak0=2.d0*pi/al1
      ak1=2.d0*pi/al0
      dak=(ak1-ak0)/(na-1)
      na1=1
      if(nparallel .gt. 1 .and. na .ge. nparallel)then
        ipid=getpid()
        nastep=nparallel
        ipr=1
        do while(na1 .lt. nparallel .and. ipr .gt. 0)
          ipr=itffork()
          if(ipr .gt. 0)then
            ichpid(na1)=ipr
            na1=na1+1
          else
            call tfsetintm(-1.d0)
          endif
        enddo
      else
        ipr=1
        nastep=1
      endif
      if(ipr .eq. 0)then
        naa=(na-na1)/nastep+1
        kac=ktaloc(naa*3)
      else
        kac=ktavaloc(0,na)
        kas=ktavaloc(0,na)
        kal=ktavaloc(0,na)
      endif
      do k=na1,na,nastep
        ak=ak0+dak*(k-1)
        w=ak*speedoflight
        c=0.d0
        s=0.d0
        do i=2,m-1
          x=w*kl1%rbody(i)
          a0=(kl2%rbody(i)-kl2%rbody(i-1))/
     $         (kl1%rbody(i)-kl1%rbody(i-1))
          a1=(kl2%rbody(i+1)-kl2%rbody(i))/
     $         (kl1%rbody(i+1)-kl1%rbody(i))
          c=c+cos(x)*(a0-a1)
          s=s+sin(x)*(a0-a1)
        enddo
        a0=(kl2%rbody(m)-kl2%rbody(m-1))/
     $       (kl1%rbody(m)-kl1%rbody(m-1))
        x=w*kl1%rbody(m)
        c=c/w+cos(x)*a0/w+kl2%rbody(m)*sin(x)
        s=s/w+sin(x)*a0/w-kl2%rbody(m)*cos(x)
        a1=(kl2%rbody(2)-kl2%rbody(1))/
     $       (kl1%rbody(2)-kl1%rbody(1))
        x=w*kl1%rbody(1)
        c=(c-cos(x)*a1/w-kl2%rbody(1)*sin(x))/w
        s=(s-sin(x)*a1/w+kl2%rbody(1)*cos(x))/w
        if(ipr .eq. 0)then
          kack=kac+(k-na1)/nastep*3
          rlist(kack  )=ak
          rlist(kack+1)=c
          rlist(kack+2)=s
        else
          rlist(kal+k)=ak
          rlist(kac+k)=c
          rlist(kas+k)=s
        endif
      enddo
      if(nparallel .gt. 1 .and. na .ge. nparallel)then
        if(ipr .eq. 0)then
          write(fn,'(a,i12.12)')'/tmp/',(ipid*nparallel)+na1
          open(999,file=fn,form='unformatted',status='unknown')
          write(999)(rlist(kac+i),i=0,naa*3-1)
          stop
        else
          kad=ktaloc(((na-1)/nastep+1)*3)
          do j=1,nparallel-1
 3001       irw=wait(isw)
            do k=1,nparallel-1
              if(irw .eq. ichpid(k))then
                na1=k
                ichpid(k)=0
                go to 3010
              endif
            enddo
            write(*,*)'RadiationSpectrum Strange child: ',irw,isw
            go to 3001
 3010       write(fn,'(a,i12.12)')'/tmp/',(ipid*nparallel)+na1
            open(999,file=fn,form='unformatted',status='old')
            naa=(na-na1)/nastep+1
            read(999)(rlist(kad+i),i=0,naa*3-1)
            close(999,status='DELETE')
            do k=na1,na,nastep
              kack=kad+(k-na1)/nastep*3
              rlist(kal+k)=rlist(kack  )
              rlist(kac+k)=rlist(kack+1)
              rlist(kas+k)=rlist(kack+2)
            enddo
          enddo
          call tfree(kad)
        endif
      endif
      kx=ktflist+ktadaloc(-1,3,klx)
      klx%dbody(1)%k=ktflist+kal
      klx%dbody(2)%k=ktflist+kac
      klx%dbody(3)%k=ktflist+kas
      return
      end

c$$$      subroutine tsynchrad(p,alr,bxa,bya,
c$$$     $     dprad,dpradx,dprady,
c$$$     $     mp,l,al,s0,phi,theta,xi,yi,pxi,pyi)
c$$$      use tfstk
c$$$      use ffs
c$$$      use ffs_pointer
c$$$      use tffitcode
c$$$      implicit none
c$$$      integer*4 irtn,ng,l,mp
c$$$      real*8 p,alr,bxa,bya,dprad,dpradx,dprady,tran,
c$$$     $     b0,e0,eg,thx,thy,xi30,thu,thv,
c$$$     $     c1,c2,s1,s2,xi3,xi2,xi1,s0,phi1,
c$$$     $     thx1,thy1,ds,thu1,xi,yi,pxi,pyi,al,al1,
c$$$     $     phi,theta,gx,gy,gz,dpgx,dpgy,dpgz
c$$$      e0=amass*sqrt((p*p0)**2+1.d0)
c$$$      b0=sqrt(bxa**2+bya**2)
c$$$      call SYNRADCL(E0,B0,alr,2,NG,EG,thu,thv,XI30,XI2,IRTN)
c$$$      if(irtn .gt. 100 .or. ng .eq. 0)then
c$$$        dprad=0.d0
c$$$        dpradx=0.d0
c$$$        dprady=0.d0
c$$$      else
c$$$        dprad=eg/amass/p0
c$$$        c1=bya/b0
c$$$        s1=bxa/b0
c$$$        thx=thu*c1+thv*s1
c$$$        thy=-thu*s1+thv*c1
c$$$        dpradx=thx*dprad
c$$$        dprady=thy*dprad
c$$$        if(photons)then
c$$$          c2=(c1-s1)*(c1+s1)
c$$$          s2=2.d0*c1*s1
c$$$          xi3=c2*xi30
c$$$          xi1=-s2*xi30
c$$$          ds=tran()*alr
c$$$          thu1=thu-(s0+ds)*b0/brho
c$$$          thx1=thu1*c1+thv*s1
c$$$          thy1=-thu1*s1+thv*c1
c$$$          al1=al+ds+s0
c$$$          if(al .eq. 0.d0)then
c$$$            phi1=0.d0
c$$$          else
c$$$            phi1=phi*al1/al
c$$$          endif
c$$$          call tphotonconv(al1,phi1,theta,
c$$$     $         geo(:,:,l),xi,yi,
c$$$     $         dprad,pxi-thx1,pyi-thy1,
c$$$     $         gx,gy,gz,dpgx,dpgy,dpgz,xi1,xi3)
c$$$          call tphotonstore(mp,l,gx,gy,gz,
c$$$     $         dpgx*p0,dpgy*p0,dpgz*p0,
c$$$     $         xi1,xi2,xi3)
c$$$        endif
c$$$      endif
c$$$      return
c$$$      end


module peeled_images

  use core_lib
  use mpi_core
  use mpi_hdf5_io

  use grid_geometry, only : place_in_cell
  use grid_propagate

  use type_image
  use type_photon
  use type_source
  use type_dust

  use sources
  use dust_main
  use dust_interact

  use grid_mrw

  implicit none
  save

  private

  public :: peeled_images_adjust_scale
  public :: peeled_images_setup
  public :: peeled_images_write
  public :: peeloff_photon
  public :: a_peeloff

  logical,public :: make_peeled_images

  integer,public :: n_groups = 0
  integer,public :: n_peeled = 0
  ! number of directions

  integer,allocatable :: group_id(:)
  integer,allocatable :: view_id(:)

  logical,allocatable :: inside_observer(:)
  logical,allocatable :: ignore_optical_depth(:)
  type(vector3d_dp), allocatable :: r_peeloff(:)
  type(angle3d_dp), allocatable :: viewing_angles(:)
  ! angles in which to make peeled images

  type(image),allocatable,public :: peeled_image(:)
  ! the peeled images

  type(image),allocatable,dimension(:),public :: peeled_image_sum

  real(dp),allocatable :: d_min(:), d_max(:)
  ! the distance range within which to peeloff photons for each group

  real(dp),allocatable :: column_density(:)

  ! Cache for raytracing

  type cached_source_spectrum
     real(dp),allocatable :: spectrum(:)
  end type cached_source_spectrum

  type(cached_source_spectrum), allocatable, target :: cached_source_spectra(:,:)

  type cached_dust_emissivity
     real(dp),allocatable :: log10_emissivity(:,:)
  end type cached_dust_emissivity

  type(cached_dust_emissivity), allocatable, target :: cached_dust_emissivities(:,:)

  type cached_dust_extinction
     real(dp),allocatable :: chi_nu(:)
  end type cached_dust_extinction

  type(cached_dust_extinction), allocatable, target :: cached_dust_extinctions(:,:)

  type spectrum
     real(dp),allocatable :: spectrum(:)
     real(dp),allocatable :: chi_nu(:)
  end type spectrum

  type(spectrum),allocatable :: tmp(:)

contains

  subroutine peeled_images_adjust_scale(scale)
    implicit none
    real(dp),intent(in) :: scale
    integer :: ig
    do ig=1,n_groups
       call image_scale(peeled_image(ig), scale)
    end do
  end subroutine peeled_images_adjust_scale

  subroutine peeloff_photon(p_orig, polychromatic)

    implicit none

    type(photon),intent(in) :: p_orig
    type(photon) :: p
    real(dp) :: tau
    integer :: ip,ig,iv,id
    type(angle3d_dp) :: a_req, a_sky, a_diff
    type(vector3d_dp) :: v_req
    logical,intent(in) :: polychromatic
    real(dp) :: x_image, y_image
    real(dp) :: tmax
    type(vector3d_dp) :: dr
    real(dp) :: d
    logical :: killed

    do ip=1,n_peeled

       ig = group_id(ip)
       iv = view_id(ip)

       p = p_orig

       ! Set photon properties to pre-interaction (except frequency)
       p%s = p%s_prev
       p%a = p%a_prev
       p%v = p%v_prev

       ! Find peeloff angle
       a_req = a_peeloff(p%r, ip)
       call angle3d_to_vector3d(a_req, v_req)

       ! Find peeloff probability
       if(p%last_isotropic) then
          p%s = stokes_dp(1._dp, 0._dp, 0._dp, 0._dp)
          p%a = a_req
          p%v = v_req
       else
          select case(p%last)
          case('sr')
             call emit_peeloff(p, a_req)
          case('ds','de')
             call interact_peeloff(p, a_req)
          case('me')
             call mrw_peeloff(p, a_req)
          case default
             call error("peeloff_photon","unexpected p%last flag: "//p%last)
          end select
       end if

       ! Update wall and cell that photon is on, because when the direction
       ! of the photon changes, the cell and wall it might be considered on
       ! may change. For example, if a photon is propagaging in the positive x
       ! direction and is in cell 2 on the xmin wall, but gets peeled off in
       ! the negative direction, we need to treat it as if it was in cell 1 on
       ! the xmax wall.
       call place_in_cell(p)

       if(inside_observer(ig)) then
          dr = p%r-r_peeloff(ig)
          d = sqrt(dr.dot.dr)
          tmax = d - d_min(ig)
       else
          d = -(v_req.dot.p%r)
          tmax = - d_min(ig) + d
       end if

       if(d < d_min(ig) .or. d > d_max(ig)) cycle

       if(inside_observer(ig)) then

          if(abs(viewing_angles(ip)%cost) .gt. 1.e-10) then
             call rotate_angle3d(viewing_angles(ip), angle3d_deg(90._dp, 0._dp), a_diff)
             call difference_angle3d(a_diff, -p%a, a_sky)
          else
             a_sky = p%a
          end if

          ! Convert to angles in degrees
          x_image = atan2(a_sky%sinp, a_sky%cosp) * rad2deg
          y_image = atan2(a_sky%sint, a_sky%cost) * rad2deg - 90._dp

          ! Make sure the photon falls inside the image (wrap angles around)
          x_image = peeled_image(ig)%x_max + modulo(x_image - peeled_image(ig)%x_max, 360._dp)
          y_image = peeled_image(ig)%y_min + modulo(y_image - peeled_image(ig)%y_min, 360._dp)

       else

          ! Project onto 2-D plane perpendicular to direction of peeling-off
          dr = p%r - r_peeloff(ig)
          x_image = dr%y * p%a%cosp - dr%x * p%a%sinp
          y_image = dr%z * p%a%sint - dr%y * p%a%cost * p%a%sinp - dr%x * p%a%cost * p%a%cosp

       end if

       if(in_image(peeled_image(ig),x_image, y_image)) then

          if(ignore_optical_depth(ig)) then
             if(polychromatic) then
                column_density = 0._dp
             else
                tau = 0._dp
             end if
             killed = .false.
          else
             if(polychromatic) then
                call grid_escape_column_density(p,tmax,column_density,killed)
             else
                call grid_escape_tau(p,tmax,tau,killed)
             end if
          end if

          ! For inside observer, don't want optical depth to escape grid, just to go to observer!
          ! Need to include 1/d^2!

          if(.not.killed) then

             if(inside_observer(ig)) p%s = p%s / (4._dp * pi * tmax**2._dp)

             if(polychromatic) then

                ! Now the fun begins
                select case(p%emiss_type)
                case(1,2)
                   call get_source_spectrum(p%source_id, ig, tmp(ig)%spectrum)
                case(3)
                   call get_dust_emissivity(p%dust_id, ig, p%emiss_var_id, p%emiss_var_frac, tmp(ig)%spectrum)
                case default
                   stop "unknown emiss_type"
                end select

                tmp(ig)%spectrum = tmp(ig)%spectrum * p%s%i * p%energy

                do id=1,n_dust
                   call get_dust_extinction(id, ig, tmp(ig)%chi_nu)
                   tmp(ig)%spectrum = tmp(ig)%spectrum * exp(- column_density(id) * tmp(ig)%chi_nu)
                end do

                call image_bin_raytraced(peeled_image(ig),p,x_image,y_image,iv, tmp(ig)%spectrum)

             else
                p%s = p%s * exp(-tau)
                call image_bin(peeled_image(ig),p,x_image,y_image,iv)
             end if

          end if

       end if

    end do

  end subroutine peeloff_photon

  subroutine peeled_images_setup(handle, paths, use_raytracing, use_exact_nu, frequencies)

    implicit none

    integer(hid_t),intent(in) :: handle
    character(len=*),intent(in) :: paths(:)

    real(dp),intent(in),optional :: frequencies(:)

    logical,intent(in) :: use_raytracing, use_exact_nu

    integer :: ig,iv,ip = 0

    integer :: n_view

    ! real(dp) :: array_size = 0.

    real(dp),allocatable :: theta(:), phi(:)

    n_groups = size(paths)

    allocate(peeled_image(n_groups))
    allocate(peeled_image_sum(n_groups))
    if(main_process()) write(*,'(" [peeled_images] setting up ",I0," peeled image groups ")') n_groups

    allocate(inside_observer(n_groups))
    allocate(ignore_optical_depth(n_groups))
    allocate(r_peeloff(n_groups))
    allocate(d_min(n_groups))
    allocate(d_max(n_groups))

    ! Find total number of viewing angles
    n_peeled = 0
    do ig=1,n_groups
       call mp_read_keyword(handle, paths(ig), 'inside_observer', inside_observer(ig))
       call mp_read_keyword(handle, paths(ig), 'ignore_optical_depth', ignore_optical_depth(ig))
       call mp_read_keyword(handle, paths(ig), 'n_view', n_view)
       if(.not. n_view > 0) call error("n_view should be a positive integer", "peeled_images_setup")
       call mp_read_keyword(handle, paths(ig), 'd_min', d_min(ig))
       call mp_read_keyword(handle, paths(ig), 'd_max', d_max(ig))
       if(inside_observer(ig).and.d_min(ig) < 0.) then
          if(main_process()) call warn("d_min cannot be < 0. for inside observer - resetting to 0", "peeled_images_setup")
          d_min(ig) = 0.
       end if
       n_peeled = n_peeled + n_view
    end do

    allocate(group_id(n_peeled))
    allocate(view_id(n_peeled))
    allocate(viewing_angles(n_peeled))

    ip = 0

    if(use_raytracing) then
       allocate(cached_source_spectra(n_groups, n_sources))
       allocate(cached_dust_emissivities(n_groups, n_dust))
       allocate(cached_dust_extinctions(n_groups, n_dust))
    end if

    do ig=1,n_groups

       if(inside_observer(ig)) then
          call mp_read_keyword(handle, paths(ig), 'observer_x', r_peeloff(ig)%x)
          call mp_read_keyword(handle, paths(ig), 'observer_y', r_peeloff(ig)%y)
          call mp_read_keyword(handle, paths(ig), 'observer_z', r_peeloff(ig)%z)
       else
          call mp_read_keyword(handle, paths(ig), 'peeloff_x', r_peeloff(ig)%x)
          call mp_read_keyword(handle, paths(ig), 'peeloff_y', r_peeloff(ig)%y)
          call mp_read_keyword(handle, paths(ig), 'peeloff_z', r_peeloff(ig)%z)
       end if

       call mp_read_keyword(handle, paths(ig), 'n_view', n_view)
       call mp_table_read_column_auto(handle, trim(paths(ig))//'/angles', 'theta', theta)
       call mp_table_read_column_auto(handle, trim(paths(ig))//'/angles', 'phi', phi)

       call image_setup(handle,paths(ig),peeled_image(ig),n_view,n_sources,n_dust,use_exact_nu,frequencies)

       if(peeled_image(ig)%use_filters.and.use_raytracing) then
          call error("peeled_images_setup", "filter convolution cannot be used with raytracing")
       end if

       peeled_image(ig)%group_id = ig

       ! If an inside observer, check that the longitudes are inverted
       if(inside_observer(ig)) then
          if(peeled_image(ig)%compute_image) then
             if(peeled_image(ig)%x_min < peeled_image(ig)%x_max) call error("peeled_images_setup", "longitudes should increase towards the left for inside observers")
          end if
          if(peeled_image(ig)%compute_sed) then
            call error("peeled_images_setup", "computing SEDs for inside observers is not supported")
          end if
       end if

       do iv=1,n_view
          ip = ip + 1
          group_id(ip) = ig
          view_id(ip) = iv
          viewing_angles(ip) = angle3d_deg(theta(iv), phi(iv))
       end do

    end do

    allocate(column_density(n_dust))

    allocate(tmp(n_groups))
    do ig=1,n_groups
       allocate(tmp(ig)%spectrum(peeled_image(ig)%n_nu))
       allocate(tmp(ig)%chi_nu(peeled_image(ig)%n_nu))
    end do

  end subroutine peeled_images_setup

  subroutine peeled_images_write(group)

    integer(hid_t),intent(in) :: group
    integer(hid_t) :: g_indiv

    integer :: ig

    character(len=100) :: group_name

    do ig=1,n_groups

       write(group_name, '("group_",I5.5)') ig

       g_indiv = mp_create_group(group, group_name)
       call image_write(peeled_image(ig),g_indiv)
       call mp_write_keyword(g_indiv, '.', 'inside_observer', inside_observer(ig))

       call mp_write_keyword(g_indiv, '.', 'd_min', d_min(ig))
       call mp_write_keyword(g_indiv, '.', 'd_max', d_max(ig))

       call mp_close_group(g_indiv)

    end do

  end subroutine peeled_images_write

  type(angle3d_dp) function a_peeloff(r, ip)
    implicit none
    type(vector3d_dp), intent(in) :: r
    integer, intent(in) :: ip
    integer :: ig
    ig = group_id(ip)
    if(inside_observer(ig)) then
       call vector3d_to_angle3d(r_peeloff(ig)-r, a_peeloff)
    else
       a_peeloff = viewing_angles(ip)
    end if
  end function a_peeloff

  subroutine get_source_spectrum(source_id, group_id, spectrum)

    implicit none

    integer,intent(in) :: source_id, group_id
    real(dp), intent(out) :: spectrum(:)

    ! For now, if the cache is set then we can just use that. In future we
    ! may have to check whether any conditions (e.g. viewing angle) have
    ! changed since last time this was called.

    if(.not.allocated(cached_source_spectra(group_id, source_id)%spectrum)) then

       allocate(cached_source_spectra(group_id,source_id)%spectrum(peeled_image(group_id)%n_nu))

       if(peeled_image(group_id)%use_exact_nu) then
          spectrum = get_spectrum_interp(s(source_id), peeled_image(group_id)%nu)
       else
          spectrum = get_spectrum_binned(s(source_id), peeled_image(group_id)%n_nu, &
               & peeled_image(group_id)%nu_min, peeled_image(group_id)%nu_max)
       end if

       ! Store the cached spectrum
       cached_source_spectra(group_id,source_id)%spectrum = spectrum

    end if

    spectrum = cached_source_spectra(group_id, source_id)%spectrum

  end subroutine get_source_spectrum

  subroutine get_dust_emissivity(dust_id, group_id, jnu_var_id, jnu_var_frac, spectrum)

    implicit none

    integer,intent(in) :: dust_id, group_id, jnu_var_id
    real(dp), intent(in) :: jnu_var_frac
    integer :: ijnu
    real(dp), intent(out) :: spectrum(:)
    real(dp), pointer :: log10_j_nu(:,:)

    ! For now, if the cache is set then we can just use that. In future we
    ! may have to check whether any conditions (e.g. viewing angle) have
    ! changed since last time this was called.

    if(.not.allocated(cached_dust_emissivities(group_id, dust_id)%log10_emissivity)) then

       allocate(cached_dust_emissivities(group_id,dust_id)%log10_emissivity(peeled_image(group_id)%n_nu, size(d(dust_id)%j_nu_var)))

       do ijnu=1,size(d(dust_id)%j_nu_var)

          if(peeled_image(group_id)%use_exact_nu) then
             spectrum = get_j_nu_interp(d(dust_id), peeled_image(group_id)%nu, ijnu)
          else
             spectrum = get_j_nu_binned(d(dust_id), peeled_image(group_id)%n_nu, &
                  & peeled_image(group_id)%nu_min, peeled_image(group_id)%nu_max, ijnu)

          end if

          ! Assign to cache
          cached_dust_emissivities(group_id,dust_id)%log10_emissivity(:,ijnu) = log10(spectrum)

       end do

    end if

    log10_j_nu => cached_dust_emissivities(group_id,dust_id)%log10_emissivity

    spectrum = (log10_j_nu(:,jnu_var_id+1) - log10_j_nu(:,jnu_var_id)) * jnu_var_frac + &
         &      log10_j_nu(:,jnu_var_id)

    spectrum = 10._dp ** spectrum

    where(is_nan(spectrum))
       spectrum = 0.
    end where

  end subroutine get_dust_emissivity

  subroutine get_dust_extinction(dust_id, group_id, extinction)

    implicit none

    integer,intent(in) :: dust_id, group_id
    real(dp), intent(out) :: extinction(:)

    ! For now, if the cache is set then we can just use that.

    if(.not.allocated(cached_dust_extinctions(group_id, dust_id)%chi_nu)) then

       allocate(cached_dust_extinctions(group_id,dust_id)%chi_nu(peeled_image(group_id)%n_nu))

       if(peeled_image(group_id)%use_exact_nu) then
          extinction = get_chi_nu_interp(d(dust_id), peeled_image(group_id)%nu)
       else
          extinction = get_chi_nu_binned(d(dust_id), peeled_image(group_id)%n_nu, &
               & peeled_image(group_id)%nu_min, peeled_image(group_id)%nu_max)

       end if

       ! Store the cached extinction
       cached_dust_extinctions(group_id,dust_id)%chi_nu = extinction

    end if

    extinction = cached_dust_extinctions(group_id, dust_id)%chi_nu

  end subroutine get_dust_extinction

end module peeled_images


      SUBROUTINE SK2OUT(x0, y0, dx, dy, skpt, npts, time)
c
C     Print out the forecasts for the skiles2 program virtual drift.
C     Bob Grumbine 4 April 1994.
C     Print of Alaskan points brought in to local routine.
C     Bob Grumbine 22 March 1996.
c     added code to write Alaska and global bulletins
c     Larry Burroughs 25 July 1997
c     Larry Burroughs 5 May 1998
c     Larry Burroughs 4 May 2001
C     27 January 2010 Robert Grumbine: coldp and cnewp merged in to sk2out.f file
C     20 April 2012 Robert Grumbine: add call to kmlout
c
      IMPLICIT none
c
      INTEGER npts, skpt(npts)
      REAL x0(npts), y0(npts), dx(npts), dy(npts)
      REAL dir(npts), dist(npts)
      INTEGER time
      CHARACTER(8) DATE
      CHARACTER(90) fname
c
      REAL arcdis, wdir, xp, yp, dxnm, dynm, dummy, kmtonm,rinc(5)
      PARAMETER (kmtonm = 1. /  1.852 )
      REAL xstl, ystl, akrad
      PARAMETER (xstl = -170.0)
      PARAMETER (ystl =  65.0 )
      PARAMETER (akrad = 2500.0)
      CHARACTER(1) line1(21),line2(9),line3(40),line4(26),line5(41),
     1            hdrfxp(23),hdrnfp(38),bln(4),indx(10),old(20),new(36),
     2            line5a(42)
      INTEGER maxnewpts, maxaknewpts
      PARAMETER (maxnewpts   = 10000)
      PARAMETER (maxaknewpts =  2000)
      CHARACTER(1) oldpts(207,20),newpts(maxnewpts,36),akoldp(160,20),
     1     km,jn,Q, aknewp(maxaknewpts,36),lf,cr,eom,blk,B,C,D,E,F,G,H,
     2     jI,jJ,jk,A, jL,O,P,R,S,X,W,glbmsg(1280,31),akmsg(1280,8),
     3     ldr(40), T,z,aps,copt(17),cnpt(33)
c
      INTEGER k,ii,ij,ik,il,idis,idir,igtot,iputg,iatot,iputa,i,j,
     1        iy,im,id,ih,idate,jy,jm,jd,jh,jdate,left,inc1,inc2,
     2        inc3,next,ix0(npts),iy0(npts),idat(8),jdat(8),jc
c
      data line1/'F','Z','A','K','4','1',' ','K','W','N','O',' ',
     1           '0','0','0','0','0','0','<','<','@'/
      DATA line2/'I','D','M','A','K','W','<','<','@'/
      DATA line3/'P','A','R','T',' ','P','A','A',' ','A','L','A','S',
     1           'K','A',' ','S','E','A',' ','I','C','E',' ',
     2           'D','R','I','F','T',' ','V','E','C','T','O','R',
     3           'S','<','<','@'/
      DATA LINE4/'A','M','O','S','P','H','E','R','I','C',' ','D',
     1           'R','I','V','I','N','G',' ','O','N','L','Y','<',
     2           '<','@'/
      DATA LINE5/'0','0','H','R',' ','F','O','R','E','C','A','S',
     1           'T',' ','V','T',' ','0','0','/','0','0','/','0',
     2           '0',' ','0','0','0','0',' ','U','T','C','<','<',
     3           '@',' ','<','<','@'/
      DATA LINE5a/'0','0','0','H','R',' ','F','O','R','E','C','A','S',
     1           'T',' ','V','T',' ','0','0','/','0','0','/','0',
     2           '0',' ','0','0','0','0',' ','U','T','C','<','<',
     3           '@',' ','<','<','@'/
      DATA HDRFXP/'P','O','I','N','T',' ',' ','D','I','R',' ',' ',
     1            'D','I','S','T','(','N','M',')','<','<','@'/
      DATA HDRNFP/'P','O','I','N','T',' ','I','N','I','T','I','A',
     1            'L',' ','L','O','C','A','T','I','O','N',' ','D',
     2            'I','R',' ','D','I','S','T','(','N','M',')','<',
     3            '<','@'/
      DATA CR/'<'/,LF/'@'/,EOM/'%'/,BLK/' '/,B/'B'/,C/'C'/,D/'D'/,
     1     E/'E'/,F/'F'/,G/'G'/,H/'H'/,jI/'I'/,jJ/'J'/,A/'A'/,
     2     jL/'L'/,O/'O'/,P/'P'/,R/'R'/,X/'X'/,W/'W'/,jk/'K'/,
     3     S/'S'/,km/'M'/,jn/'N'/,Q/'Q'/,T/'T'/,z/'Z'/
      data indx/'1','2','3','4','5','6','7','8','9','0'/
c
      IF (MOD(time,24) .NE. 0 ) RETURN
      call W3UTCDAT(idat)
      rinc(1)=0.
      rinc(2)=time
      rinc(3)=0.
      rinc(4)=0.
      rinc(5)=0.
      call W3MOVDAT(rinc,idat,jdat)
c
      read(91,6000)aps
 6000 format(a1)
      do i=1,31
         do j=1,1280
            glbmsg(j,i)=blk
         enddo
      enddo
      do i=1,8
         do j=1,1280
            akmsg(j,i)=blk
         enddo
      enddo
      do i=1,40
         ldr(1)=aps
         ldr(2)=indx(1)
         if(i.gt.2.and.i.lt.8)ldr(i)=indx(10)
         if(i.ge.8)ldr(i)=blk
      enddo
c     write(6,6010)ldr
c6010 format(40a1)
      bln(1)=blk
      bln(2)=cr
      bln(3)=cr
      bln(4)=lf
      do i=1,20
         do j=1,207
            if(i.lt.18)then
               if(j.gt.160)go to 8000
               akoldp(j,i)=blk
 8000          oldpts(j,i)=blk
            else
               if(j.gt.160)go to 8010
               akoldp(j,18)=cr
               akoldp(j,19)=cr
               akoldp(j,20)=lf
 8010          oldpts(j,18)=cr
               oldpts(j,19)=cr
               oldpts(j,20)=lf
            endif
         enddo
      enddo
      do i=1,36
         do j=1,maxnewpts
            if(i.lt.34)then
               if(j.gt.maxaknewpts)go to 8020
               aknewp(j,i)=blk
 8020          newpts(j,i)=blk
            else
               if(j.gt.maxaknewpts)go to 8030
               aknewp(j,34)=cr
               aknewp(j,35)=cr
               aknewp(j,36)=lf
 8030          newpts(j,34)=cr
               newpts(j,35)=cr
               newpts(j,36)=lf
            endif
         enddo
      enddo
c
      WRITE (60,9002) time
      WRITE (61,9002) time
      WRITE (62,9002) time
 9002 FORMAT (I3,'-Hour Forecast ice drift')
      WRITE (60,9003)
      WRITE (61,9003)
      WRITE (62,9003)
 9003 FORMAT ('Atmosphere only driving')
      CALL date_and_time(DATE=DATE)
      WRITE (60,9004) DATE
      WRITE (61,9004) DATE
      WRITE (62,9004) DATE
 9004 FORMAT ('          Day Zero = ',A8)
      WRITE (60,9005)
      WRITE (61,9005)
      WRITE (62,9005)
c
      WRITE (60,9001)
      WRITE (61,9011)
      WRITE (62,9011)
      ii=1
      ij=1
      ik=1
      il=1
      DO 1000 k = 1, npts
        xp = x0(k)+dx(k)
        yp = y0(k)+dy(k)
        dxnm = kmtonm * arcdis(x0(k), y0(k), xp, y0(k))
        dynm = kmtonm * arcdis(x0(k), y0(k), x0(k), yp)
        dxnm = SIGN(dxnm, x0(k)-xp)
        dynm = SIGN(dynm, y0(k)-yp)
        if(x0(k).gt.180.)then
           ix0(k)=10*(360.-x0(k))
        elseif(x0(k).lt.180.)then
           ix0(k)=10.*x0(k)
        elseif(x0(k).eq.180.)then
           ix0(k)=180
        else
           ix0(k)=0
        endif
        iy0(k)=10.*y0(k)
c
C       BG output file
c
        dir(k) = wdir  (-dxnm, -dynm, dummy)
        dist(k) =  kmtonm * arcdis(x0(k),y0(k),xp,yp)
        WRITE (60,9010) skpt(k), x0(k), y0(k),
     3  wdir  (-dxnm, -dynm, dummy),
     2  kmtonm * arcdis(x0(k),y0(k),xp,yp)
c
C       Operational output file
c
        IF(k .LE. 207) THEN
           WRITE (61,9012) skpt(k), wdir(-dxnm, -dynm, dummy),
     1                     kmtonm * arcdis(x0(k),y0(k),xp,yp)
           idir=wdir(-dxnm,-dynm,dummy)+0.5
           idis=10.*(kmtonm*arcdis(x0(k),y0(k),xp,yp)+0.05)
           call coldp(skpt(k),idir,idis,copt)
           do i=1,17
              oldpts(ii,i)=copt(i)
           enddo
           ii=ii+1
           IF(arcdis(xstl, ystl, x0(k), y0(k) ) .LE. akrad) THEN
              WRITE (62,9012) skpt(k), wdir(-dxnm, -dynm, dummy),
     1        kmtonm * arcdis(x0(k),y0(k),xp,yp)
              idir=wdir(-dxnm,-dynm,dummy)+0.5
              idis=10.*(kmtonm*arcdis(x0(k),y0(k),xp,yp)+0.05)
              call coldp(skpt(k),idir,idis,copt)
              do i=1,17
                 akoldp(ij,i)=copt(i)
              enddo
              ij=ij+1
           ENDIF
c
        ELSE
           IF (k .EQ. 208) WRITE (61,9001)
           IF (k .EQ. 208) WRITE (62,9001)
           WRITE (61,9010) skpt(k), x0(k), y0(k),
     1     wdir  (-dxnm, -dynm, dummy),
     2     kmtonm * arcdis(x0(k),y0(k),xp,yp)
           idir=wdir(-dxnm,-dynm,dummy)+0.5
           idis=10.*(kmtonm*arcdis(x0(k),y0(k),xp,yp)+0.05)
           call cnewp(skpt(k),ix0(k),iy0(k),idir,idis,cnpt)
           do i=1,33
              newpts(ik,i)=cnpt(i)
           enddo
           ik=ik+1
           IF(arcdis(xstl, ystl, x0(k), y0(k) ) .LE. akrad) THEN
              WRITE (62,9010) skpt(k), x0(k), y0(k),
     1        wdir  (-dxnm, -dynm, dummy),
     2        kmtonm * arcdis(x0(k),y0(k),xp,yp)
              idir=wdir(-dxnm,-dynm,dummy)+0.5
              idis=10.*(kmtonm*arcdis(x0(k),y0(k),xp,yp)+0.05)
              call cnewp(skpt(k),ix0(k),iy0(k),idir,idis,cnpt)
              do i=1,33
                 aknewp(il,i)=cnpt(i)
              enddo
              il=il+1
c          else
c             il=999
           ENDIF
        ENDIF
 1000 CONTINUE
c
      WRITE (60,9005)
      WRITE (61,9005)
      WRITE (62,9005)
      WRITE (60,9005)
      WRITE (61,9005)
      WRITE (62,9005)
c
 9001 FORMAT ('Point ',' Initial location ',
     1    '   Dir  Dist(nm)')
 9011 FORMAT ('Point ','  Dir   Dist(nm)')
c
 9010 FORMAT (I4,3X,2F8.3,2X,2F6.1)
 9012 FORMAT (I4,3X,2F6.1)
 9005 FORMAT (' ')

C
C
C      Now have dir and dist filled, and other output written.
C      Write out the kml file:
       CALL kmlout(x0, y0, npts, dir, dist, time, idat, 70)
!      SUBROUTINE kmlout(lat, lon, npts, dir, dist, hours, date, unit)
c
c        Create tran files for OSO.  Each forecast time is a separate
c          part of each bulletin with its own header lines which are
c          the same as the first part with the exception of the label
c          and the verification time (VT).
c
c        Create global tran file
c
      read(90,7000)iy,im,id
 7000 format(i4,i2,i2)
      ih=00
      if(time.lt.100)then
         igtot=40+21+9+40+26+41+23+4+(ii-1)*20+4+38+4+(ik-1)*36+1
         iputg=igtot/1280
         left=mod(igtot,1280)
         if(left.gt.0)iputg=iputg+1
CD         write(06,7100)igtot,iputg
 7100    format(' igtot=',i5,' iputg=',i2/)
      else
         igtot=40+21+9+40+26+42+23+4+(ii-1)*20+4+38+4+(ik-1)*36+1
         iputg=igtot/1280
         left=mod(igtot,1280)
         if(left.gt.0)iputg=iputg+1
CD         write(06,7100)igtot,iputg
      endif
      next=0
      call W3AI19(ldr,40,glbmsg,igtot,next)
c     write(06,7101)ldr
c7101 format(' ',40a1)
      line1( 3)=x
      line1( 4)=x
      inc1=id/10
      inc2=id-10*inc1
      if(inc1.eq.0)inc1=10
      if(inc2.eq.0)inc2=10
      line1(13)=indx(inc1)
      line1(14)=indx(inc2)
      call W3AI19(line1,21,glbmsg,igtot,next)
c     write(06,7102)line1
c7102 format(' ',21a1)
      line2(4)=p
      line2(5)=jl
      line2(6)=r
      call W3AI19(line2, 9,glbmsg,igtot,next)
c     write(06,7103)line2
c7103 format(' ',9a1)
      line3(10)=G
      line3(11)=jL
      line3(12)=O
      line3(13)=B
      line3(14)=A
      line3(15)=jL
      if(time.eq. 24)line3(8)=A
      if(time.eq. 48)line3(8)=B
      if(time.eq. 72)line3(8)=C
      if(time.eq. 96)line3(8)=D
      if(time.eq.120)line3(8)=E
      if(time.eq.144)line3(8)=F
      if(time.eq.168)line3(8)=G
      if(time.eq.192)line3(8)=H
      if(time.eq.216)line3(8)=jI
      if(time.eq.240)line3(8)=jj
      if(time.eq.264)line3(8)=jk
      if(time.eq.288)line3(8)=jL
      if(time.eq.312)line3(8)=km
      if(time.eq.336)line3(8)=jn
      if(time.eq.360)line3(8)=O
      if(time.eq.384)line3(7)=z
      if(time.eq.384)line3(8)=P
      call W3AI19(line3,40,glbmsg,igtot,next)
c     write(06,7104)line3
c7104 format(' ',39a1)
      call W3AI19(line4,26,glbmsg,igtot,next)
c     write(06,7105)line4
c7105 format(' ',26a1)
      if(time.lt.100)then
         inc1=time/10
         inc2=time-10*inc1
         if(inc1.eq.0)inc1=10
         if(inc2.eq.0)inc2=10
         line5(1)=indx(inc1)
         line5(2)=indx(inc2)
         jc=jdat(1)/100
         jy=jdat(1)-100*jc
         jm=jdat(2)
         jd=jdat(3)
         jh=jdat(5)
         inc1=jm/10
         inc2=jm-10*inc1
         if(inc1.eq.0)inc1=10
         if(inc2.eq.0)inc2=10
         line5(18)=indx(inc1)
         line5(19)=indx(inc2)
         inc1=jd/10
         inc2=jd-10*inc1
         if(inc1.eq.0)inc1=10
         if(inc2.eq.0)inc2=10
         line5(21)=indx(inc1)
         line5(22)=indx(inc2)
         inc1=jy/10
         inc2=jy-10*inc1
         if(inc1.eq.0)inc1=10
         if(inc2.eq.0)inc2=10
         line5(24)=indx(inc1)
         line5(25)=indx(inc2)
         call W3AI19(line5,41,glbmsg,igtot,next)
c        write(06,7106)line5
c7106    format(' ',41a1)
      else
         inc1= time/100
         inc2=(time-100*inc1)/10
         inc3= time-100*inc1-10*inc2
         if(inc1.eq.0)then
            line5a(3)=blk
            if(inc2.eq.0)inc2=10
            if(inc3.eq.0)inc3=10
            line5a(1)=indx(inc2)
            line5a(2)=indx(inc3)
         else
            line5a(1)=indx(inc1)
            if(inc2.eq.0)inc2=10
            if(inc3.eq.0)inc3=10
            line5a(2)=indx(inc2)
            line5a(3)=indx(inc3)
         endif
         jc=jdat(1)/100
         jy=jdat(1)-100*jc
         jm=jdat(2)
         jd=jdat(3)
         jh=jdat(5)
         inc1=jm/10
         inc2=jm-10*inc1
         if(inc1.eq.0)inc1=10
         if(inc2.eq.0)inc2=10
         line5a(19)=indx(inc1)
         line5a(20)=indx(inc2)
         inc1=jd/10
         inc2=jd-10*inc1
         if(inc1.eq.0)inc1=10
         if(inc2.eq.0)inc2=10
         line5a(22)=indx(inc1)
         line5a(23)=indx(inc2)
         inc1=jy/10
         inc2=jy-10*inc1
         if(inc1.eq.0)inc1=10
         if(inc2.eq.0)inc2=10
         line5a(25)=indx(inc1)
         line5a(26)=indx(inc2)
         call W3AI19(line5a,42,glbmsg,igtot,next)
c        write(06,7118)line5a
c7118    format(' ',42a1)
      endif
      call W3AI19(hdrfxp,23,glbmsg,igtot,next)
c     write(06,7107)hdrfxp
c7107 format(' ',23a1)
      call W3AI19(bln,4,glbmsg,igtot,next)
c     write(06,7108)bln
c7108 format(' ',4a1)
      do i=1,ii-1
         do j=1,20
            old(j)=oldpts(i,j)
         enddo
         call W3AI19(old,20,glbmsg,igtot,next)
c        write(06,7109)old
c7109    format(' ',20a1)
      enddo
      call W3AI19(bln,4,glbmsg,igtot,next)
c     write(06,7108)bln
      call W3AI19(hdrnfp,38,glbmsg,igtot,next)
c     write(06,7111)hdrnfp
c7111 format(' ',38a1)
      call W3AI19(bln,4,glbmsg,igtot,next)
c     write(06,7108)bln
      do i=1,ik-1
         do j=1,36
            new(j)=newpts(i,j)
         enddo
         call W3AI19(new,36,glbmsg,igtot,next)
c        write(06,7113)new
c7113    format(' ',36a1)
      enddo
      call W3AI19(eom,1,glbmsg,igtot,next)
c     write(06,7114)eom
c7114 format(' ',a1//)
      do i=1,iputg
c        write(63)(glbmsg(j,i),j=1,1280)
         write(63,7300)(glbmsg(j,i),j=1,1280)
 7300    format(1280a1)
c        write(06,7115)(glbmsg(j,i),j=1,1280)
c7115    format(' ',80a1/)
CD         print *, (glbmsg(j,i),j=1,1280)
      enddo
c
c        Create Alaska tran file
c
CD      write(06,7116)
 7116 format(//)
      if(time.lt.100)then
c        if(il.eq.999)then
c           iatot=40+21+9+40+26+41+23+4+(ij-1)*20+1
c           iputa=iatot/1280
c           left=mod(iatot,1280)
c           if(left.gt.0)iputa=iputa+1
c        else
            iatot=40+21+9+40+26+41+23+4+(ij-1)*20+4+38+4+(il-1)*36+1
            iputa=iatot/1280
            left=mod(iatot,1280)
            if(left.gt.0)iputa=iputa+1
c        endif
CD         write(06,7117)iatot,iputa
 7117    format(' iatot=',i5,' iputa=',i2/)
      else
c        if(il.eq.999)then
c           iatot=40+21+9+40+26+42+23+4+(ij-1)*20+1
c           iputa=iatot/1280
c           left=mod(iatot,1280)
c           if(left.gt.0)iputa=iputa+1
c        else
            iatot=40+21+9+40+26+42+23+4+(ij-1)*20+4+38+4+(il-1)*36+1
            iputa=iatot/1280
            left=mod(iatot,1280)
            if(left.gt.0)iputa=iputa+1
c        endif
CD         write(06,7117)iatot,iputa
      endif
      next=0
      call W3AI19(ldr,40,akmsg,iatot,next)
c     write(06,7101)ldr
      line1( 3)=a
      line1( 4)=jk
      call W3AI19(line1,21,akmsg,iatot,next)
c     write(06,7102)line1
      line2(4)=a
      line2(5)=jk
      line2(6)=w
      call W3AI19(line2, 9,akmsg,iatot,next)
c     write(06,7103)line2
      line3(10)=A
      line3(11)=jL
      line3(12)=A
      line3(13)=S
      line3(14)=jK
      line3(15)=A
      call W3AI19(line3,40,akmsg,iatot,next)
c     write(06,7104)line3
      call W3AI19(line4,26,akmsg,iatot,next)
c     write(06,7105)line4
      if(time.lt.100)then
         call W3AI19(line5,41,akmsg,iatot,next)
c        write(06,7106)line5
      else
         call W3AI19(line5a,42,akmsg,iatot,next)
c        write(06,7118)line5a
      endif
      call W3AI19(hdrfxp,23,akmsg,iatot,next)
c     write(06,7107)hdrfxp
      call W3AI19(bln,4,akmsg,iatot,next)
c     write(06,7108)bln
      do i=1,ij-1
         do j=1,20
            old(j)=akoldp(i,j)
         enddo
         call W3AI19(old,20,akmsg,iatot,next)
c        write(06,7109)old
      enddo
c     if(il.eq.999)go to 7500
      call W3AI19(bln,4,akmsg,iatot,next)
c     write(06,7108)bln
      call W3AI19(hdrnfp,38,akmsg,iatot,next)
c     write(06,7111)hdrnfp
      call W3AI19(bln,4,akmsg,iatot,next)
c     write(06,7108)bln
      do i=1,il-1
         do j=1,36
            new(j)=aknewp(i,j)
         enddo
         call W3AI19(new,36,akmsg,iatot,next)
c        write(06,7113)new
      enddo
 7500 continue
      call W3AI19(eom,1,akmsg,iatot,next)
c     write(06,7114)eom
      do i=1,iputa
c        write(64)(akmsg(j,i),j=1,1280)
         write(64,7300)(akmsg(j,i),j=1,1280)
c        write(06,7115)(akmsg(j,i),j=1,1280)
CD         print *, (akmsg(j,i),j=1,1280)
      enddo
CD      write(06,7116)
      rewind 90
      rewind 91
      RETURN
      END
c
      subroutine coldp(ipt,idir,idis,copt)
c
c         This subroutine converts point number and direction and
c           distance of ice drift from integer to character and
c           fills a multipoint character array with data for the
c           sea ice drift bulletins.
c
c         970821 - created by Larry Burroughs
c
      implicit none
c
      integer i,ipt,idir,idis,incl1,incl2,incl3,incl4
      CHARACTER(1) copt(17),indx(10),pt,blnk
c
      data indx/'1','2','3','4','5','6','7','8','9','0'/,pt/'.'/,
     1     blnk/' '/
c
c         Convert point number from integer to character, and
c           blank out leading zeros
c
      do i=1,17
         copt(i)=blnk
      enddo
      incl1= ipt/1000
      incl2=(ipt-1000*incl1)/100
      incl3=(ipt-1000*incl1-100*incl2)/10
      incl4= ipt-1000*incl1-100*incl2-10*incl3
      if(incl1.eq.0)then
         copt( 2)=blnk
      else
         copt( 2)=indx(incl1)
      endif
      if(incl1.eq.0.and.incl2.eq.0)then
         copt( 3)=blnk
      else
         if(incl2.eq.0)incl2=10
         copt( 3)=indx(incl2)
      endif
      if(incl1.eq.0.and.incl2.eq.0.and.incl3.eq.0)then
         copt( 4)=blnk
      else
         if(incl3.eq.0)incl3=10
         copt( 4)=indx(incl3)
      endif
      if(incl4.eq.0)incl4=10
      copt( 5)=indx(incl4)
c
c         Convert direction of ice growth from integer to character,
c           and blank out leading zeros.
c
      incl1= idir/100
      incl2=(idir-100*incl1)/10
      incl3= idir-100*incl1-10*incl2
      if(incl1.eq.0)then
         copt( 8)=blnk
      else
         copt( 8)=indx(incl1)
      endif
      if(incl1.eq.0.and.incl2.eq.0)then
         copt( 9)=blnk
      else
         if(incl2.eq.0)incl2=10
         copt( 9)=indx(incl2)
      endif
      if(incl3.eq.0)incl3=10
      copt(10)=indx(incl3)
c
c         Convert distance of ice growth from integer to character,
c           and blank out leading zeros.
c
      incl1= idis/1000
      incl2=(idis-1000*incl1)/100
      incl3=(idis-1000*incl1-100*incl2)/10
      incl4= idis-1000*incl1-100*incl2-10*incl3
      if(incl1.eq.0)then
         copt(12)=blnk
      else
         copt(12)=indx(incl1)
      endif
      if(incl1.eq.0.and.incl2.eq.0)then
         copt(13)=blnk
      else
         if(incl2.eq.0)incl2=10
         copt(13)=indx(incl2)
      endif
      if(incl3.eq.0)incl3=10
      copt(14)=indx(incl3)
      copt(15)=pt
      if(incl4.eq.0)incl4=10
      copt(16)=indx(incl4)
      return
      end
c
      subroutine cnewp(ipt,ix,iy,idir,idis,cnpt)
c
c         This subroutine converts point number, initial latitude and
c           longitude of the ice point, and direction and distance
c           of ice drift from integer to character.  It also fills a
c           multipoint character array with data for the sea ice
c           drift bulletins.
c
c         970821 - created by Larry Burroughs
c
      implicit none
c
      integer i,ipt,ix,iy,idir,idis,in,incl1,incl2,incl3,incl4
      CHARACTER(1) cnpt(33),indx(10),pt,blnk,n,s,e,w
c
      data indx/'1','2','3','4','5','6','7','8','9','0'/,pt/'.'/,
     1     blnk/' '/,n/'N'/,s/'S'/,e/'E'/,w/'W'/
c
c         Convert point number from integer to character, and
c           blank out leading zeros
c
      do i=1,33
         cnpt(i)=blnk
      enddo
      incl1= ipt/1000
      incl2=(ipt-1000*incl1)/100
      incl3=(ipt-1000*incl1-100*incl2)/10
      incl4= ipt-1000*incl1-100*incl2-10*incl3
      if(incl1.eq.0)then
         cnpt( 2)=blnk
      else
         cnpt( 2)=indx(incl1)
      endif
      if(incl1.eq.0.and.incl2.eq.0)then
         cnpt( 3)=blnk
      else
         if(incl2.eq.0)incl2=10
         cnpt( 3)=indx(incl2)
      endif
      if(incl1.eq.0.and.incl2.eq.0.and.incl3.eq.0)then
         cnpt( 4)=blnk
      else
         if(incl3.eq.0)incl3=10
         cnpt( 4)=indx(incl3)
      endif
      if(incl4.eq.0)incl4=10
      cnpt( 5)=indx(incl4)
c
c         Convert latitude from integer to character, and blank out
c           leading zeros
c
      incl1= abs(iy)/100
      incl2=(abs(iy)-100*incl1)/10
      incl3= abs(iy)-100*incl1-10*incl2
      cnpt( 9)=indx(incl1)
      if(incl2.eq.0)incl2=10
      cnpt(10)=indx(incl2)
      if(incl3.eq.0)incl3=10
      cnpt(11)=pt
      cnpt(12)=indx(incl3)
      if(iy.lt.0)then
         cnpt(13)=s
      elseif(iy.eq.0)then
         cnpt(13)=blnk
      else
         cnpt(13)=n
      endif
c
c         Convert longitude from integer to character, and blank
c           out leading zeros
c
      incl1= abs(ix)/1000
      incl2=(abs(ix)-1000*incl1)/100
      incl3=(abs(ix)-1000*incl1-100*incl2)/10
      incl4= abs(ix)-1000*incl1-100*incl2-10*incl3
      if(incl1.eq.0)then
         cnpt(16)=blnk
      else
         cnpt(16)=indx(incl1)
      endif
      if(incl1.eq.0.and.incl2.eq.0)then
         cnpt(17)=blnk
      else
         if(incl2.eq.0)incl2=10
         cnpt(17)=indx(incl2)
      endif
      if(incl3.eq.0)incl3=10
      cnpt(18)=indx(incl3)
      cnpt(19)=pt
      if(incl4.eq.0)incl4=10
      cnpt(20)=indx(incl4)
      if(iy.gt.-180.and.iy.lt.0)then
         cnpt(21)=e
      elseif(iy.eq.0.or.abs(iy).eq.180)then
         cnpt(21)=blnk
      else
         cnpt(21)=w
      endif
c
c         Convert direction of ice growth from integer to character,
c           and blank out leading zeros.
c
      incl1= idir/100
      incl2=(idir-100*incl1)/10
      incl3= idir-100*incl1-10*incl2
      if(incl1.eq.0)then
         cnpt(24)=blnk
      else
         cnpt(24)=indx(incl1)
      endif
      if(incl1.eq.0.and.incl2.eq.0)then
         cnpt(25)=blnk
      else
         if(incl2.eq.0)incl2=10
         cnpt(25)=indx(incl2)
      endif
      if(incl3.eq.0)incl3=10
      cnpt(26)=indx(incl3)
c
c         Convert distance of ice growth from integer to character,
c           and blank out leading zeros.
c
      incl1= idis/1000
      incl2=(idis-1000*incl1)/100
      incl3=(idis-1000*incl1-100*incl2)/10
      incl4= idis-1000*incl1-100*incl2-10*incl3
      if(incl1.eq.0)then
         cnpt(29)=blnk
      else
         cnpt(29)=indx(incl1)
      endif
      if(incl1.eq.0.and.incl2.eq.0)then
         cnpt(30)=blnk
      else
         if(incl2.eq.0)incl2=10
         cnpt(30)=indx(incl2)
      endif
      if(incl3.eq.0)incl3=10
      cnpt(31)=indx(incl3)
      cnpt(32)=pt
      if(incl4.eq.0)incl4=10
      cnpt(33)=indx(incl4)
      return
      end


      SUBROUTINE PHO_DATINI
C*********************************************************************
C
C     initialization of variables and switches
C
C*********************************************************************
      IMPLICIT NONE
      INTEGER i , k , m
      DOUBLE PRECISION twopim
      SAVE

C  input/output channels
      INCLUDE 'inc/poinou'
C  some constants
      INCLUDE 'inc/pocons'
C  event debugging information
      INCLUDE 'inc/podebg'
C  event weights and generated cross section
      INCLUDE 'inc/powght'
C  scale parameters for parton model calculations
      INCLUDE 'inc/pohscl'
C  integration precision for hard cross sections (obsolete)
      INCLUDE 'inc/pogaup'
C  hard scattering parameters used for most recent hard interaction
      INCLUDE 'inc/pohapa'
C  current beam selection
      INCLUDE 'inc/pobeam'
C  cut probability distribution
#ifndef FOR_CORSIKA
      INCLUDE 'inc/poprob'
#else
      INCLUDE 'inc/poprob50'
#endif
C  gamma-lepton or gamma-hadron vertex information
      INCLUDE 'inc/pofsrc'
C  photon flux kinematics and cuts
      INCLUDE 'inc/pofcut'
C  obsolete cut-off information
      INCLUDE 'inc/pocut1'
C  global event kinematics and particle IDs
      INCLUDE 'inc/pogcms'
C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INCLUDE 'inc/pohdfl'
C  some hadron information, will be deleted in future versions
      INCLUDE 'inc/pohdrn'
C  model switches and parameters
      INCLUDE 'inc/pomdls'
C  general process information
      INCLUDE 'inc/poprcs'
C  parameters of the "simple" Vector Dominance Model
      INCLUDE 'inc/posvdm'
C  parameters for DGLAP backward evolution in ISR
      INCLUDE 'inc/podgl1'
C  particles created by initial state evolution
      INCLUDE 'inc/popisr'
C  names of hard scattering processes
      INCLUDE 'inc/pohpro'
C  hard cross sections and MC selection weights
      INCLUDE 'inc/pohrcs'
C  interpolation tables for hard cross section and MC selection weights
#ifndef FOR_CORSIKA
      INCLUDE 'inc/pohtab'
#else
      INCLUDE 'inc/pohtab50'
#endif

C  initialize /POCONS/
      PI = ATAN(1.D0)*4.D0
      PI2 = 2.D0*PI
      PI4 = 2.D0*PI2
C  GeV**-2 --> millibarn (multiply by GEV2MB to get mb as units)
      GEV2mb = 0.389365D0
C  precalculate quark charges
      DO i = 1 , 6
         Q_Ch(i) = DBLE(2-3*MOD(i,2))/3.D0
         Q_Ch(-i) = -Q_Ch(i)

         Q_Ch2(i) = Q_Ch(i)**2
         Q_Ch2(-i) = Q_Ch2(i)

         Q_Ch4(i) = Q_Ch2(i)**2
         Q_Ch4(-i) = Q_Ch4(i)
      END DO
      Q_Ch(0) = 0.D0
      Q_Ch2(0) = 0.D0
      Q_Ch4(0) = 0.D0

C  initialize /GLOCMS/
      ECM = 50.D0
      PMAss(1) = 0.D0
      PVIrt(1) = 0.D0
      PMAss(2) = 0.D0
      PVIrt(2) = 0.D0
      IFPap(1) = 22
      IFPap(2) = 22
C  initialize /HADVAL/
      IHFld(1,1) = 0
      IHFld(1,2) = 0
      IHFld(2,1) = 0
      IHFld(2,2) = 0
      IHFls(1) = 1
      IHFls(2) = 1
      XPSub = 1.D0
      XTSub = 1.D0
C  initialize /MODELS/
      ISWmdl(1) = 3
      MDLna(1) = 'AMPL MOD'
      ISWmdl(2) = 1
      MDLna(2) = 'MIN-BIAS'
      ISWmdl(3) = 1
      MDLna(3) = 'PTS DISH'
      ISWmdl(4) = 1
      MDLna(4) = 'PTS DISP'
      ISWmdl(5) = 2
      MDLna(5) = 'PTS ASSI'
      ISWmdl(6) = 3
      MDLna(6) = 'HADRONIZ'
      ISWmdl(7) = 2
      MDLna(7) = 'MASS COR'
      ISWmdl(8) = 3
      MDLna(8) = 'PAR SHOW'
      ISWmdl(9) = 0
      MDLna(9) = 'GLU SPLI'
      ISWmdl(10) = 2
      MDLna(10) = 'VIRT PHO'
      ISWmdl(11) = 0
      MDLna(11) = 'LARGE NC'
      ISWmdl(12) = 0
      MDLna(12) = 'LIPA POM'
      ISWmdl(13) = 1
      MDLna(13) = 'QELAS VM'
      ISWmdl(14) = 2
      MDLna(14) = 'ENHA GRA'
      ISWmdl(15) = 4
      MDLna(15) = 'MULT SCA'
      ISWmdl(16) = 4
      MDLna(16) = 'MULT DIF'
      ISWmdl(17) = 4
      MDLna(17) = 'MULT CDF'
      ISWmdl(18) = 0
      MDLna(18) = 'BALAN PT'
      ISWmdl(19) = 1
      MDLna(19) = 'POMV FLA'
      ISWmdl(20) = 0
      MDLna(20) = 'SEA  FLA'
      ISWmdl(21) = 2
      MDLna(21) = 'SPIN DEC'
      ISWmdl(22) = 1
      MDLna(22) = 'DIF.MASS'
      ISWmdl(23) = 1
      MDLna(23) = 'DIFF RES'
      ISWmdl(24) = 0
      MDLna(24) = 'PTS HPOM'
      ISWmdl(25) = 0
      MDLna(25) = 'POM CORR'
      ISWmdl(26) = 1
      MDLna(26) = 'OVERLAP '
      ISWmdl(27) = 0
      MDLna(27) = 'MUL R/AN'
      ISWmdl(28) = 1
      MDLna(28) = 'SUR PROB'
      ISWmdl(29) = 1
      MDLna(29) = 'PRIMO KT'
      ISWmdl(30) = 0
      MDLna(30) = 'DIFF. CS'
      ISWmdl(31) = -9999
C  mass-independent sea flavour ratios (for low-mass strings)
      PARmdl(1) = 0.425D0
      PARmdl(2) = 0.425D0
      PARmdl(3) = 0.15D0
      PARmdl(4) = 0.D0
      PARmdl(5) = 0.D0
      PARmdl(6) = 0.D0
C  suppression by energy momentum conservation
      PARmdl(8) = 9.D0
      PARmdl(9) = 7.D0
C  VDM factors
      PARmdl(10) = 0.866D0
      PARmdl(11) = 0.288D0
      PARmdl(12) = 0.288D0
      PARmdl(13) = 0.288D0
      PARmdl(14) = 0.866D0
      PARmdl(15) = 0.288D0
      PARmdl(16) = 0.288D0
      PARmdl(17) = 0.288D0
      PARmdl(18) = 0.D0
C  lower energy limit for initialization
      PARmdl(19) = 2.5D0
C  soft pt for hard scattering remnants
      PARmdl(20) = 5.D0
C  low energy beta of soft pt distribution 1
      PARmdl(21) = 4.5D0
C  high energy beta of soft pt distribution 1
      PARmdl(22) = 3.0D0
C  low energy beta of soft pt distribution 0
      PARmdl(23) = 2.5D0
C  high energy beta of soft pt distribution 0
      PARmdl(24) = 0.4D0
C  effective quark mass in photon wave function
      PARmdl(25) = 0.2D0
C  normalization of unevolved Pomeron PDFs
      PARmdl(26) = 0.3D0
C  effective VDM parameters for Q**2 dependence of cross section
      PARmdl(27) = 0.65D0
      PARmdl(28) = 0.08D0
      PARmdl(29) = 0.05D0
      PARmdl(30) = 0.22D0
      PARmdl(31) = 0.589824D0
      PARmdl(32) = 0.609961D0
      PARmdl(33) = 1.038361D0
      PARmdl(34) = 1.96D0
C  Q**2 suppression of multiple interactions
      PARmdl(35) = 0.59D0
C  pt cutoff defaults
      PARmdl(36) = 2.5D0
      PARmdl(37) = 2.5D0
      PARmdl(38) = 2.5D0
      PARmdl(39) = 2.5D0
C  enhancement factor for diffractive cross sections
      PARmdl(40) = 1.D0
      PARmdl(41) = 1.D0
      PARmdl(42) = 1.D0
C  mass in soft pt distribution
      PARmdl(43) = 0.D0
C  maximum of x allowed for leading particle
      PARmdl(44) = 0.9D0
C  max. mass sampled in diffraction
      PARmdl(45) = SQRT(0.4D0)
C  mass threshold in diffraction (2pi mass)
      PARmdl(46) = 0.3D0
C  regularization of slope parameter in diffraction
      PARmdl(47) = 4.D0
C  renormalized intercept for enhanced graphs
      PARmdl(48) = 1.08D0
C  coherence constraint for diff. cross sections
      PARmdl(49) = SQRT(0.05D0)
C  exponents of x distributions
C  baryon
      PARmdl(50) = 1.5D0
      PARmdl(51) = -0.5D0
      PARmdl(52) = -0.99D0
      PARmdl(53) = -0.99D0
C  meson (non-strangeness part)
      PARmdl(54) = -0.5D0
      PARmdl(55) = -0.5D0
      PARmdl(56) = -0.99D0
      PARmdl(57) = -0.99D0
C  meson (strangeness part)
      PARmdl(58) = -0.2D0
      PARmdl(59) = -0.2D0
      PARmdl(60) = -0.99D0
      PARmdl(61) = -0.99D0
C  particle remnant (no valence quarks)
      PARmdl(62) = -0.5D0
      PARmdl(63) = -0.5D0
      PARmdl(64) = -0.99D0
      PARmdl(65) = -0.99D0
C  ratio beetween triple-pomeron/reggeon couplings grrp/gppp
      PARmdl(66) = 10.D0
C  ratio beetween triple-pomeron/reggeon couplings gppr/gppp
      PARmdl(67) = 10.D0
C  min. abs(t) in diffraction
      PARmdl(68) = 0.D0
C  max. abs(t) in diffraction
      PARmdl(69) = 10.D0
C  min. mass for elastic pomerons in central diffraction
      PARmdl(70) = 2.D0
C  min. mass of diffractive blob in central diffraction
      PARmdl(71) = 2.D0
C  min. Feynman x cut in central diffraction
      PARmdl(72) = 0.D0
C  direct pomeron coupling
      PARmdl(74) = 0.D0
C  relative deviation allowed for energy-momentum conservation
C  energy-momentum relative deviation
      PARmdl(75) = 0.01D0
C  transverse momentum deviation
      PARmdl(76) = 0.01D0
C  couplings for unitarization in diffraction
C  non-unitarized pomeron coupling (sqrt(mb))
      PARmdl(77) = 3.D0
C  rescaling factor for pomeron PDF
      PARmdl(78) = 3.D0
C  coupling probabilities
      PARmdl(79) = 1.D0
      PARmdl(80) = 0.D0
C  scales to calculate alpha-s of matrix element
      PARmdl(81) = 1.D0
      PARmdl(82) = 1.D0
      PARmdl(83) = 1.D0
C  scales to calculate alpha-s of initial state radiation
      PARmdl(84) = 1.D0
      PARmdl(85) = 1.D0
      PARmdl(86) = 1.D0
C  scales to calculate alpha-s of final state radiation
      PARmdl(87) = 1.D0
      PARmdl(88) = 1.D0
      PARmdl(89) = 1.D0
C  scales to calculate PDFs
      PARmdl(90) = 1.D0
      PARmdl(91) = 1.D0
      PARmdl(92) = 1.D0
C  scale for ISR starting virtuality
      PARmdl(93) = 1.D0
C  min. virtuality to generate time-like showers in ISR
      PARmdl(94) = 2.D0
C  factor to scale the max. allowed time-like parton shower virtuality
      PARmdl(95) = 4.D0
C  max. transverse momentum to include inhard cross section
      PARmdl(96) = 900.D0
C  max. transverse momentum for primordial kt
      PARmdl(100) = 2.D0
C  weight factors for pt-distribution
      PARmdl(101) = 2.D0
      PARmdl(102) = 2.D0
      PARmdl(103) = 4.D0
      PARmdl(104) = 2.D0
      PARmdl(105) = 6.D0
      PARmdl(106) = 4.D0
C
C     PARMDL(110-125)  reserved for hard scattering
C  currently chosen scales for hard scattering
      DO i = 1 , 16
         PARmdl(109+i) = 0.D0
      END DO
C  virtuality cutoff in initial state evolution
      PARmdl(126) = PARmdl(36)**2
      PARmdl(127) = PARmdl(37)**2
      PARmdl(128) = PARmdl(38)**2
      PARmdl(129) = PARmdl(39)**2
C  virtuality cutoff for direct contribution to photon PDF
      PARmdl(130) = 1.D30
      PARmdl(131) = 1.D30
      PARmdl(132) = 1.D30
      PARmdl(133) = 1.D30
C  fraction of events without popcorn
      PARmdl(134) = -1.D0
C  fraction of diquarks with spin 1 (relative to sum of spin 1 and 0)
      PARmdl(135) = 0.5D0
C  soft color re-connection (fraction)
C  g g final state
      PARmdl(140) = 1.D0/64.D0
C  g q final state
      PARmdl(141) = 1.D0/24.D0
C  q q final state
      PARmdl(142) = 1.D0/9.D0
C  effective scale in Drees-Godbole like suppresion in photon PDF
      PARmdl(144) = 0.766D0**2
C  QCD scales (if PDF scales are not used, 4 active flavours)
      PARmdl(145) = 0.2D0**2
      PARmdl(146) = 0.2D0**2
      PARmdl(147) = 0.2D0**2
C  threshold scales for variable flavour calculation (GeV**2)
      PARmdl(148) = 1.3D0**2
      PARmdl(149) = 4.75D0**2
      PARmdl(150) = 172.D0**2
C  constituent quark masses
      PARmdl(151) = 0.3D0
      PARmdl(152) = 0.3D0
      PARmdl(153) = 0.5D0
      PARmdl(154) = 1.6D0
      PARmdl(155) = 5.D0
      PARmdl(156) = 174.D0
C  min. masses of valence quark
      PARmdl(157) = 0.3D0
C  min. masses of valence diquark
      PARmdl(158) = 0.8D0
C  min. mass of sea quark
      PARmdl(159) = 0.D0
C  suppression of strange quarks as photon valences
      PARmdl(160) = 0.2D0
C  min. masses for strings (used in PHO_SOFTXX)
      PARmdl(161) = 1.D0
      PARmdl(162) = 1.D0
      PARmdl(163) = 1.D0
      PARmdl(164) = 1.D0
C  min. momentum fraction for soft processes
      PARmdl(165) = 0.3D0
C  min. phase space for x-sampling
      PARmdl(166) = 0.135D0
C  Ross-Stodolsky exponent
      PARmdl(170) = 4.2D0
C  cutoff on photon-pomeron invariant mass in hadron-hadron collisions
      PARmdl(175) = 2.D0

C*sr
C  extra factor multiplying difference between Goulianos and PHOJET-
C  diff. cross sections
      PARmdl(200) = 0.6D0
C*
C**af  energy dependence of pt-cutoff in Golec-Biernat-Wusthoff model
      PARmdl(250) = 2.0D0
      PARmdl(251) = 400.D0
      PARmdl(252) = 200.D0
      PARmdl(253) = 0.19D0
C       PARMDL(250) = 1.6D0
C       PARMDL(251) = 515.D0
C       PARMDL(252) = 230.D0
C       PARMDL(253) = 0.20D0
C**af  alpomhp
      PARmdl(260) = 0.10D0
C     Regularization factor for PYTHIA style p_T0 hep-ph/0402078
      PARmdl(261) = 0.D0
C     Energy dependence of k-factor
      PARmdl(262) = 0.13D0
C  complex amplitudes, eikonal functions
      IPAmdl(1) = 0
C  allow for Reggeon cuts
      IPAmdl(2) = 1
C  decay of hadron resonances in diffraction (0 iso, 1 trans, 2 long)
      IPAmdl(3) = 0
C  polarization of photon resonances (0 none, 1 trans, 2 long)
      IPAmdl(4) = 1
C  pt of valence partons
      IPAmdl(5) = 1
C  pt of hard scattering remnant
      IPAmdl(6) = 2
C  energy-dependent cutoff for hard scattering
      IPAmdl(7) = 3
C  intercept used for the calculation of enhanced graphs
      IPAmdl(8) = 1
C  effective slope of hard scattering amplitde
      IPAmdl(9) = 3
C  mass dependence of slope parameters
      IPAmdl(10) = 0
C  lepton-photon vertex 1
      IPAmdl(11) = 0
C  lepton-photon vertex 2
      IPAmdl(12) = 0
C  call by DPMJET
      IPAmdl(13) = 0
C  method to sample x distributions
      IPAmdl(14) = 3
C  energy-momentum check
      IPAmdl(15) = 1
C  phase space correction for DPMJET interface
      IPAmdl(16) = 1
C  fragment strings from projectile/target/central diff. separately
      IPAmdl(17) = 1
C  method to construct strings for hard interactions
      IPAmdl(18) = 1
C  method to construct strings for soft sea (pomeron cuts)
      IPAmdl(19) = 0
C  method to construct strings in pomeron interactions
      IPAmdl(20) = 0
C  soft color re-connection
      IPAmdl(21) = 0
C  resummation of triple- and loop-Pomeron
      IPAmdl(24) = 1
C  resummation of X iterated triple-Pomeron
      IPAmdl(25) = 1
C  dimension of interpolation table for weights in hard scattering
      IPAmdl(30) = MAX_TAB_E
C  dimension of interpolation table for pomeron cut distribution
      IPAmdl(31) = IEETA1
C  number of cut soft pomerons (restriction by field dimension)
      IPAmdl(32) = IIMAX
C  number of cut hard pomerons (restriction by field dimension)
      IPAmdl(33) = KKMAX
C  tau pair production in direct photon-photon collisions
      IPAmdl(64) = 0
C  currently chosen scales for hard scattering
C  ATTENTION:   IPAMDL(65-80)  reserved for hard scattering!
      DO i = 1 , 16
         IPAmdl(64+i) = -99999
      END DO
C  scales to calculate alpha-s of matrix element
      IPAmdl(81) = 1
      IPAmdl(82) = 1
      IPAmdl(83) = 1
C  scales to calculate alpha-s of initial state radiation
      IPAmdl(84) = 1
      IPAmdl(85) = 1
      IPAmdl(86) = 1
C  scales to calculate alpha-s of final state radiation
      IPAmdl(87) = 1
      IPAmdl(88) = 1
      IPAmdl(89) = 1
C  scales to calculate PDFs
      IPAmdl(90) = 1
      IPAmdl(91) = 1
      IPAmdl(92) = 1
C  where to get the parameter sets from
      IPAmdl(99) = 1
C  program PHO_ABORT for fatal errors (simulation of division by zero)
      IPAmdl(100) = 0
C  initial state parton showers for all / hardest interaction(s)
      IPAmdl(101) = 1
C  final state parton showers for all / hardest interaction(s)
      IPAmdl(102) = 1
C  initial virtuality for ISR generation
      IPAmdl(109) = 1
C  qqbar-gamma coupling in initial state showers
      IPAmdl(110) = 1
C  generation of time-like showers during ISR
      IPAmdl(111) = 1
C  reweighting of multiple soft contributions for virtual photons
      IPAmdl(114) = 1
C  reweighting / use photon virtuality in photon PDF calculations
      IPAmdl(115) = 0
C  use full QPM model incl. interference terms (direct part in gam-gam)
      IPAmdl(116) = 0
C  matching sigma_tot to F2 as given by parton density at high Q2
      IPAmdl(117) = 1
C  use virtuality of target in F2 calculations (two-gamma only)
      IPAmdl(118) = 1
C  calculation of alpha_em
      IPAmdl(120) = 1
C  strict pt cutoff for gamma-gamma events
      IPAmdl(121) = 0
C  photon virtuality sampled in photon flux approximations
      IPAmdl(174) = 1
C  photon-pomeron: 0,1,2: both,left,right photon emission
      IPAmdl(175) = 0
C  keep full history information in PHOJET-JETSET interface
      IPAmdl(178) = 1
C  max. number of conservation law violations allowed in one run
      IPAmdl(179) = 20
C  selection of soft X values
C  max. iteration number in PHO_SELSXS
      IPAmdl(180) = 50
C  max. iteration number in PHO_SELSXR
      IPAmdl(181) = 200
C  max. iteration number in PHO_SELSX2
      IPAmdl(182) = 100
C  max. iteration number in PHO_SELSXI
      IPAmdl(183) = 50

C  Default directory for data files
      IF ( LENdir.EQ.0 ) THEN
            DATDir = 'dpmdata/'
            LENDir = 8
      END IF
C  Parameter file path
      IF ( INDEX(PARfn,'.dat').EQ.0 ) PARfn =
     &   DATdir(1:LENdir)//'dpmjpar.dat'

C  initialize /PROBAB/
      IEEmax = IEETA1
      IMAx = IIMAX
      KMAx = KKMAX

      DO i = 1 , 30
         PARmdl(300+i) = -100000.D0
      END DO
C  initialize /POHDRN/
      QMAss(1) = PARmdl(151)
      QMAss(2) = PARmdl(152)
      QMAss(3) = PARmdl(153)
      QMAss(4) = PARmdl(154)
      QMAss(5) = PARmdl(155)
      QMAss(6) = PARmdl(156)
      BET = 8.D0
      PCOudi = 0.D0
      VALprg(1) = 1.D0
      VALprg(2) = 1.D0
C  number of light flavours (quarks treated as massless)
      NFS = 4
C  initialize /POCUT1/
      PTCut(1) = PARmdl(36)
      PTCut(2) = PARmdl(37)
      PTCut(3) = PARmdl(38)
      PTCut(4) = PARmdl(39)
      PSOmin = 0.D0
      XSOmin = 0.D0
C  initialize /POHAPA/
      NFBeta = 4
      NF = 4
      BQCd(1) = PI4/(11.D0-(2.D0/3.D0)*3)
      BQCd(2) = PI4/(11.D0-(2.D0/3.D0)*4)
      BQCd(3) = PI4/(11.D0-(2.D0/3.D0)*5)
      BQCd(4) = PI4/(11.D0-(2.D0/3.D0)*6)
C  initialize /POGAUP/
      NGAup1 = 12
      NGAup2 = 12
      NGAuet = 16
      NGAuin = 12
      NGAuso = 96
C  initialize //
      DO i = 1 , 100
         IF ( IDEb(i).EQ.0 ) IDEb(i) = 0
      END DO
C  initialize /PROCES/
      DO i = 1 , 11
         IPRon(i,1) = 1
      END DO

C  DPMJET default: no elastic scattering
      IPRon(2,1) = 0

      DO k = 2 , 4
         DO i = 2 , 11
            IPRon(i,k) = 0
         END DO
         IPRon(1,k) = 1
         IPRon(8,k) = 1
      END DO
C  initialize /POSVDM/
      twopim = 0.28D0
      RMIn(1) = 0.285D0
      RMIn(2) = 0.45D0
      RMIn(3) = 1.D0
      RMIn(4) = twopim
      VMAs(1) = 0.770D0
      VMAs(2) = 0.787D0
      VMAs(3) = 1.02D0
      VMAs(4) = twopim
      GAMm(1) = 0.155D0
      GAMm(2) = 0.01D0
      GAMm(3) = 0.0045D0
      GAMm(4) = 1.D0
      RMAx(1) = VMAs(1) + twopim
      RMAx(2) = VMAs(2) + twopim
      RMAx(3) = VMAs(3) + twopim
      RMAx(4) = VMAs(1) + twopim
      VMSl(1) = 11.D0
      VMSl(2) = 10.D0
      VMSl(3) = 6.D0
      VMSl(4) = 4.D0
      VMFa(1) = 0.0033D0
      VMFa(2) = 0.00036D0
      VMFa(3) = 0.0002D0
      VMFa(4) = 0.0002D0
C  initialize /PODGL1/
      Q2Misr(1) = PARmdl(36)**2
      Q2Misr(2) = PARmdl(36)**2
      PMIsr(1) = 1.D0
      PMIsr(2) = 1.D0
      ZMIsr(1) = 0.001D0
      ZMIsr(2) = 0.001D0
      AL2isr(1) = 0.046D0
      AL2isr(2) = 0.046D0
      NFSisr = 4
C  initialize /POPISR/
      DO i = 1 , 50
         IPOisr(1,2,i) = 0
         IPOisr(2,2,i) = 0
      END DO
C  initialize /POHPRO/
      PROc(0) = 'sum over processes'
      PROc(1) = 'G  +G  --> G  +G  '
      PROc(2) = 'Q  +QB --> G  +G  '
      PROc(3) = 'G  +Q  --> G  +Q  '
      PROc(4) = 'G  +G  --> Q  +QB '
      PROc(5) = 'Q  +QB --> Q  +QB '
      PROc(6) = 'Q  +QB --> QP +QBP'
      PROc(7) = 'Q  +Q  --> Q  +Q  '
      PROc(8) = 'Q  +QP --> Q  +QP '
      PROc(9) = 'resolved processes'
      PROc(10) = 'gam+Q  --> G  +Q  '
      PROc(11) = 'gam+G  --> Q  +QB '
      PROc(12) = 'Q  +gam--> G  +Q  '
      PROc(13) = 'G  +gam--> Q  +QB '
      PROc(14) = 'gam+gam--> Q  +QB '
      PROc(15) = 'direct processes  '
      PROc(16) = 'gam+gam--> l+ +l- '

C  initialize /POHRCS/
      DO m = 1 , MAX_PRO_2
         DO k = 1 , MPARMAX
            HWGx(m,k) = 0.D0
            HSIg(m,k) = 0.D0
            HDPt(m,k) = 0.D0
         END DO
      END DO
      DO i = 0 , 4
         DO k = 1 , MPARMAX
            DO m = -1 , MAX_PRO_2
C  switch all hard subprocesses on
               MH_pro_on(m,i,k) = 1
C  reset all counters
               MH_tried(m,i,k) = 0
               MH_acc_1(m,i,k) = 0
               MH_acc_2(m,i,k) = 0
            END DO
            MH_pro_on(16,i,k) = 0
         END DO
      END DO

C  initialize /POHTAB/
      DO i = 0 , 4
         DO k = 1 , MPARMAX
            IH_ecm_up(i,k) = 0
            IH_q2a_up(i,k) = 0
            IH_q2b_up(i,k) = 0
            HECm_tab(1,i,k) = 0.D0
         END DO
      END DO
      HECm_last = 0.D0
      IHA_last = 0
      IHB_last = 0

C  initialize /POFSRC/
      IGHel(1) = -1
      IGHel(2) = -1
C  initialize /LEPCUT/
      ECMin = 5.D0
      ECMax = 1.D+30
      EEMin1 = 1.D0
      EEMin2 = 1.D0
      YMAx1 = -1.D0
      YMAx2 = -1.D0
      THMin1 = 0.D0
      THMax1 = PI
      THMin2 = 0.D0
      THMax2 = PI
      ITAg1 = 1
      ITAg2 = 1
C  initialize /POWGHT/
      DO i = 1 , 20
         HSWcut(i) = 0.D0
         ISWcut(i) = 0
      END DO
      EVWght(1) = 1.D0
      IVWght(1) = 0
      SIGgen(1) = 0.D0
      SIGgen(2) = 0.D0
      SIGgen(3) = 0.D0
      SIGgen(4) = 0.D0

      END SUBROUTINE