*+ clean_image

       subroutine clean_image(residual_map, map, beam,
     *                        cc_values, cc_posns, cc_list, status )
C      -------------------------------------------------------------
C
C Open the existing residual map file and CLEAN / RESTORE
C
C Given:
C   File name of the residual file
       character*(*)      residual_map
C   work space for the map
       real*4             map(*)
C   work space for the beam
       real*4             beam(*)
C   work space for the clean components
       real*4             cc_values(*)
       integer*2          cc_posns(2,*)
       integer*2          cc_list(*)
C Returned:
C   error status
       integer            status

C
C The CLEAN routine requires:
C  A) File name of an existing RESDIUAL map
C  B) Work space for the map, beam and clean components
C
C If the beam is in fact a BEAM-SET, then the routine panels the beam
C into a number of beam windows - one for each sub-beam in the beam-set.
C CLEANing proceeds using the beam window appropriate to the local
C maxima found on the map.
C
C Search-Windows, Clean-Windows and an overall Beam-Window may be
C specified by the user.
*-

       include      '../include/clean_record.inc'
       include      '/mrao/include/chrlib_functions.inc'
       include      '/mrao/include/maplib_redtape.inc'

C additional file names
       character*60   def_dir, clean_components_map, cleaned_map
       integer        len_file
C output unit
       integer        iout
C buffer for clean-components redtape and extra redtape
       integer        redt_cc(1024), extra_RT(1024)
C descriptors for extra redtape
       integer        ndesc
       character*8    desc_list(12)
C unit numbers for residual map, beam and clean map
       integer        iresi, ibeam, icc, iclean
C logical flag indicating a beam set clean
       logical        bset_clean
C number of beams in a beam set clean
       integer        n_beam
C map/beam areas
       integer        clean_area(4),
     *                search_area(4,10),
     *                beam_area(4,500),
     *                box_area(4), bset_window(4)
C centres of beams on beam set
       integer        bset_u, bset_v
C UV-ranges on beam and map and size of map, beam
       integer        uv_beam(4), uv_map(4),
     *                ixmap, iymap, ixbeam, iybeam
C loop counter
       integer        n, nn_ext, nn_style
C array used in SORT clean
       integer        index(1)
C variables used in defining redtape of output maps
       real*4         zmnx(10)
       integer        iuv(4),izmnx(10)
       integer        count

C check status
       if (status.ne.0) return

C determine output file
       call io_enqout(iout)

C open the residual map file and read the control record
       write(iout,'(1X/1X,''CLEAN: Starting clean of '',A/1X)')
     *       residual_map(1:chr_lenb(residual_map))
       call opemap(iresi, residual_map(1:chr_lenb(residual_map)),
     *               'WRITE', 1, status)
       call rdredt(iresi, 1, status )
       call enxrdt(nn_ext,nn_style,status)
       call enxrec(clean_text_header, clean_record, status)
       call enmdir( def_dir, status )
       call io_makfil( def_dir(1:chr_lenb(def_dir)),
     *              generic_name(1:chr_lenb(generic_name)),
     *              'ccmp', clean_components_map, len_file )
       call io_makfil( def_dir(1:chr_lenb(def_dir)),
     *              generic_name(1:chr_lenb(generic_name)),
     *              'cln', cleaned_map, len_file )
       print *,'CLEAN:'
       call dpredt( redt_map, status )
       call iuv_load( uv_map, status )
       call iuv_load( iuv, status )
       ixmap = ixmax
       iymap = iymax
       call rdmap(iresi,map,status)
       print *,'CLEAN:'
       if (status.ne.0) then
         call cmd_err(STATUS,'CLEAN','Error on residual: CLEAN failed')
         goto 999
       end if

C .. create the clean map file
       print *,'CLEAN:'
       call io_wrout('CLEAN: creating CLEANed map')
       call io_wrout(cleaned_map(1:chr_lenb(cleaned_map)))
       call opemap( iclean, cleaned_map(1:chr_lenb(cleaned_map)),
     *             'WRITE', 0, status )
       call wrredt( iclean, 0, status )
       close (iclean)
       print *,'CLEAN:'

C open the clean components map and read
       call io_wrout(
     *      clean_components_map(1:chr_lenb(clean_components_map)))
       call opemap(icc,
     *      clean_components_map(1:chr_lenb(clean_components_map)),
     *      'UPDATE', 0, status)
       call rdredt(icc, 0, status )
       call enxrec(clean_text_header, clean_record, status)
       call dpredt(redt_cc, status)
       call dpxrdt(extra_RT, 1, status)
       call rdmapc(icc,cc_posns,cc_values,max_cc_iter,number_cc,status)
       if (status.ne.0) then
         call cmd_err(STATUS,'CLEAN',
     *                'Error on clean components: CLEAN failed')
         goto 999
       end if

C Open the beam and read
       call opemap( ibeam, beam_name(1:chr_lenb(beam_name)), 'READ',
     *              0, status )
       call rdredt( ibeam, 0, status)
       call dpredt( redt_beam, status)
       call iuv_load( uv_beam, status )
       ixbeam = ixmax
       iybeam = iymax
       call rdmap(ibeam,beam,status)
       close (ibeam)
       if (status.ne.0) then
         call cmd_err(status,'CLEAN','Error on beam: CLEAN failed')
         goto 999
       end if
       print *,'CLEAN:'

C take special action if a beam set clean is required
C check for a beam set clean
       bset_clean = maptyp.eq.3
       if (bset_clean .and. lclean) then
         call ldredt( redt_beam, status )
         n_beam = 0
         do bset_v = v0set, v0set+(nvset-1)*dvset, dvset
           do bset_u = u0set, u0set+(nuset-1)*duset, duset
C .. Set up a window on the current beam in the beamset
             bset_window(1) = bset_u-duset/2
             bset_window(2) = bset_u+duset/2
             bset_window(3) = bset_v+dvset/2
             bset_window(4) = bset_v-dvset/2

C .. Only include whole beams
             if ((bset_window(1) .ge. beam_window(1)) .and.
     *           (bset_window(2) .le. beam_window(2)) .and.
     *           (bset_window(3) .le. beam_window(3)) .and.
     *           (bset_window(4) .ge. beam_window(4))       ) then
                 n_beam = n_beam + 1
                 call uv_conv(uv_beam, bset_window, beam_area(1,n_beam))
              end if
           end do
         end do
       print *,'CLEAN:'

       else

         n_beam = 1
         call uv_conv(uv_beam, beam_window, beam_area(1,1))

       end if

       call uv_conv(uv_map, clean_window, clean_area)
       call uv_conv(uv_map, box_window, box_area)
       do n = 1,number_search
         call uv_conv(uv_map, search_window(1,n), search_area(1,n))
       end do
       print *,'CLEAN:'

C do CLEAN
       if (lclean) then
         itlim = itlim + number_it_done
         call ldredt( redt_map, status )
       print *,'CLEAN: -- CLEANING'
         call clean_map ( map, ixmap, iymap,
     *                    clean_area, search_area, box_area,
     *                    beam, ixbeam, iybeam, n_beam, beam_area,
     *                    cc_values, cc_posns, cc_list, number_cc,
     *                    number_it_done, index, status           )
       print *,'CLEAN: -- DONE'

C .. write the clean components
         itlim = 0
         call ldredt( redt_cc, status )
         call ldxrdt( extra_RT, 1, status )
         times_cleaned = times_cleaned + 1
         call io_wrout('CLEAN: writing CLEAN COMPONENTS map')
         zmnx(1) = -1.0E+30
         zmnx(2) = 1.0E+30
         do n=1,number_cc
           if (cc_values(n).gt.zmnx(1)) then
             zmnx(1) = cc_values(n)
             izmnx(1) = cc_posns(1,n)
             izmnx(2) = cc_posns(2,n)
           end if
           if (cc_values(n).lt.zmnx(2)) then
             zmnx(2) = cc_values(n)
             izmnx(3) = cc_posns(1,n)
             izmnx(4) = cc_posns(2,n)
           end if
         end do
         call adredt('history','CLEAN',status)
         hpfbwu = usamp
         hpfbwv = vsamp
         beampa = 0.0
         call stxrec( clean_text_header, clean_record, status )
         if (status.ne.0) then
           status = 0
           call enxdsc( desc_list, ndesc, status )
           print *,'***(CLEAN-IMAGE) Number of descriptors = ',ndesc
           do n=1,ndesc
             print *,'***(CLEAN-IMAGE) Descriptor = ',desc_list(n)
           end do
           status = 0
         end if
         call stscal( zmnx, izmnx, status )
         call wrredt( icc, 0, status )
         call wrmapc( icc, cc_posns, cc_values,
     *                number_cc, status )

C .. save residual map
         call ldredt( redt_map, status )
         call io_wrout('CLEAN: writing RESIDUAL map')
         call adredt('created','CLEAN',status)
         call iuv_load(iuv,status)
         call stxrec( clean_text_header, clean_record, status )
         call scnmap( map, iuv, zmnx, izmnx, status )
         call stredt( iuv, 3, status )
         call stscal( zmnx, izmnx, status )
         call wrredt( iresi, 0, status )
         call wrmap( iresi, map, status )
       end if

C restore sources if required
       if (lrest) then

         write(iout,
     *       '(''+CLEAN: RESTORing with '',i5,
     *         '' CLEAN components'',30X)')
     *         number_cc
         call restore_map(map, ixmap, iymap, clean_area,
     *                    beam, ixbeam, iybeam, beam_area,
     *                    cc_values, cc_posns, number_cc,
     *                    status                  )

C .. open the clean map file
         call ldredt( redt_map, status )
         call io_wrout('CLEAN: writing CLEANed map')
         call adredt('history','CLEAN',status)
C .. set beam sizes on CLEANed map
         hpfbwu = beam_size_u
         hpfbwv = beam_size_v
         beampa = beam_pa
         call opemap( iclean, cleaned_map(1:chr_lenb(cleaned_map)),
     *               'WRITE', 0, status )
         call stxrec( clean_text_header, clean_record, status )
         call scnmap( map, iuv, zmnx, izmnx, status )
         call stredt( iuv, 3, status )
         call stscal( zmnx, izmnx, status )
         call wrredt( iclean, 0, status )
         call wrmap( iclean, map, status )
         close ( iclean )
         call mapcat_addtocat(cleaned_map(1:chr_lenb(cleaned_map)),
     *                        .false.,count,status)
       end if

999    close (iresi)
       close (icc)
       end


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE PLTSPC(S1,RED1,GREEN1,BLUE1,S2,RED2,GREEN2,BLUE2)
      REAL DEVCAP(23)
      REAL DEFOUT(7)
      COMMON /STATUS/DEVCAP,DEFOUT
      REAL DEVP(5)
      COMMON /DEVICE/DEVP
      REAL COLP(3)
      REAL PALETT(3,16)
      COMMON /COLOR/COLP,PALETT
      REAL TEXTP(40)
      COMMON /TEXT/TEXTP
      REAL VECTP(5)
      REAL XCUR
      REAL YCUR
      COMMON /VECTRC/VECTP,XCUR,YCUR
      INTEGER IDEX(200,2)
      INTEGER NVECT(200,2)
      REAL XSIZE(200,2)
      REAL YSIZE(200,2)
      REAL X0(2300,2)
      REAL Y0(2300,2)
      REAL X1(2300,2)
      REAL Y1(2300,2)
      COMMON /FONT/IDEX,NVECT,XSIZE,YSIZE,X0,Y0,X1,Y1
      REAL GRAPHP(100)
      COMMON /GRAPH/GRAPHP
      COMMON /MAPPAR/MAPP(11)
      REAL MAPP
      COMMON /STORAG/MEMORY(1000)
      DIMENSION DCOLOR(3,256),ICOL(256)

      IF (S1.LT.0. .OR. S1.GE.1.) THEN
         CALL PLTFLU
         CALL SIORPT('PLTSPC',
     *               'Starting value of color spectrum is out of range',
     *               2)
         RETURN

      END IF

      IF (S2.LE.0. .OR. S2.GT.1.) THEN
         CALL PLTFLU
         CALL SIORPT('PLTSPC',
     *               'Ending value of color spectrum is out of range',2)
         RETURN

      END IF

      IF (S2.LE.S1) THEN
         CALL PLTFLU
         CALL SIORPT('PLTSPC',
     *'Starting value of color spectrum must be less than the ending val
     *ue',2)
         RETURN

      END IF

      IF (COLP(3).EQ.0.) THEN
         RETURN

      END IF

      I1 = INT(COLP(2)) + NINT(S1*COLP(3))
      I2 = INT(COLP(2)) + NINT(S2*COLP(3)-1.)
      IDS = I2 - I1 + 1
      DS = IDS
      DR = (RED2-RED1)/DS
      DG = (GREEN2-GREEN1)/DS
      DB = (BLUE2-BLUE1)/DS
      ICOL(1) = I1
      DCOLOR(1,1) = RED1
      DCOLOR(2,1) = GREEN1
      DCOLOR(3,1) = BLUE1
      DO 2000 I = 2,IDS
         ICOL(I) = ICOL(I-1) + 1
         DCOLOR(1,I) = DCOLOR(1,I-1) + DR
         DCOLOR(1,I) = MAX(0.,DCOLOR(1,I))
         DCOLOR(1,I) = MIN(1.,DCOLOR(1,I))
         DCOLOR(2,I) = DCOLOR(2,I-1) + DG
         DCOLOR(2,I) = MAX(0.,DCOLOR(2,I))
         DCOLOR(2,I) = MIN(1.,DCOLOR(2,I))
         DCOLOR(3,I) = DCOLOR(3,I-1) + DB
         DCOLOR(3,I) = MAX(0.,DCOLOR(3,I))
         DCOLOR(3,I) = MIN(1.,DCOLOR(3,I))
 2000 CONTINUE
      CALL VDSTCO(IDS,ICOL,DCOLOR,0)
      RETURN

      END


C$Procedure ILLUM ( Illumination angles )

      SUBROUTINE ILLUM ( TARGET,  ET,     ABCORR,  OBSRVR,
     .                   SPOINT,  PHASE,  SOLAR,   EMISSN )

C$ Abstract
C
C     Deprecated: This routine has been superseded by the SPICELIB
C     routine ILUMIN. This routine is supported for purposes of
C     backward compatibility only.
C
C     Find the illumination angles at a specified surface point of a
C     target body.
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     KERNEL
C     NAIF_IDS
C     SPK
C     TIME
C
C$ Keywords
C
C     GEOMETRY
C     MOSPICE
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE               'zzctr.inc'

      CHARACTER*(*)         TARGET
      DOUBLE PRECISION      ET
      CHARACTER*(*)         ABCORR
      CHARACTER*(*)         OBSRVR
      DOUBLE PRECISION      SPOINT ( 3 )
      DOUBLE PRECISION      PHASE
      DOUBLE PRECISION      SOLAR
      DOUBLE PRECISION      EMISSN

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     TARGET     I   Name of target body.
C     ET         I   Epoch in ephemeris seconds past J2000.
C     ABCORR     I   Desired aberration correction.
C     OBSRVR     I   Name of observing body.
C     SPOINT     I   Body-fixed coordinates of a target surface point.
C     PHASE      O   Phase angle at the surface point.
C     SOLAR      O   Solar incidence angle at the surface point.
C     EMISSN     O   Emission angle at the surface point.
C
C$ Detailed_Input
C
C     TARGET         is the name of the target body.  TARGET is
C                    case-insensitive, and leading and trailing blanks
C                    in TARGET are not significant. Optionally, you may
C                    supply a string containing the integer ID code for
C                    the object.  For example both 'MOON' and '301' are
C                    legitimate strings that indicate the moon is the
C                    target body.
C
C     ET             is the epoch, specified in ephemeris seconds past
C                    J2000, at which the apparent illumination angles at
C                    the specified surface point on the target body, as
C                    seen from the observing body, are to be computed.
C
C     ABCORR         is the aberration correction to be used in
C                    computing the location and orientation of the
C                    target body and the location of the Sun.  Possible
C                    values are:
C
C                       'NONE'        No aberration correction.
C
C                       'LT'          Correct the position and
C                                     orientation of target body for
C                                     light time, and correct the
C                                     position of the Sun for light
C                                     time.
C
C                       'LT+S'        Correct the observer-target vector
C                                     for light time and stellar
C                                     aberration, correct the
C                                     orientation of the target body
C                                     for light time, and correct the
C                                     target-Sun vector for light time
C                                     and stellar aberration.
C
C                       'CN'          Converged Newtonian light time
C                                     correction. In solving the light
C                                     time equation, the 'CN'
C                                     correction iterates until the
C                                     solution converges (three
C                                     iterations on all supported
C                                     platforms). Whether the 'CN+S'
C                                     solution is substantially more
C                                     accurate than the 'LT' solution
C                                     depends on the geometry of the
C                                     participating objects and on the
C                                     accuracy of the input data. In
C                                     all cases this routine will
C                                     execute more slowly when a
C                                     converged solution is computed.
C                                     See the Particulars section of
C                                     SPKEZR for a discussion of
C                                     precision of light time
C                                     corrections.
C
C                                     Both the state and rotation of
C                                     the target body are corrected for
C                                     light time.
C
C                          'CN+S'     Converged Newtonian light time
C                                     correction and stellar aberration
C                                     correction.
C
C                                     Both the state and rotation of
C                                     the target body are corrected for
C                                     light time.
C
C     OBSRVR         is the name of the observing body, typically a
C                    spacecraft, the earth, or a surface point on the
C                    earth.  OBSRVR is case-insensitive, and leading
C                    and trailing blanks in OBSRVR are not significant.
C                    Optionally, you may supply a string containing the
C                    integer ID code for the object.  For example both
C                    'EARTH' and '399' are legitimate strings that
C                    indicate the earth is the observer.
C
C                    OBSRVR may be not be identical to TARGET.
C
C     SPOINT         is a surface point on the target body, expressed
C                    in rectangular body-fixed (body equator and prime
C                    meridian) coordinates.  SPOINT need not be visible
C                    from the observer's location at time ET.
C
C$ Detailed_Output
C
C
C     PHASE          is the phase angle at SPOINT, as seen from OBSRVR
C                    at time ET.  This is the angle between the
C                    SPOINT-OBSRVR vector and the SPOINT-Sun vector.
C                    Units are radians.  The range of  PHASE is [0, pi].
C                    See Particulars below for a detailed discussion of
C                    the definition.
C
C     SOLAR          is the solar incidence angle at SPOINT, as seen
C                    from OBSRVR at time ET.  This is the angle
C                    between the surface normal vector at SPOINT and the
C                    SPOINT-Sun vector.  Units are radians.  The range
C                    of SOLAR is [0, pi]. See Particulars below for a
C                    detailed discussion of the definition.
C
C     EMISSN         is the emission angle at SPOINT, as seen from
C                    OBSRVR at time ET.  This is the angle between the
C                    surface normal vector at SPOINT and the
C                    SPOINT-observer vector.  Units are radians.  The
C                    range of EMISSN is [0, pi]. See Particulars below
C                    for a detailed discussion of the definition.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If TARGET and OBSRVR are not distinct, the error
C         SPICE(BODIESNOTDISTINCT) will be signaled.
C
C     2)  If no SPK (ephemeris) data are available for the observer,
C         target, and Sun at the time specified by ET, the error will
C         be diagnosed by routines called by this routine.  If light
C         time corrections are used, SPK data for the target body must
C         be available at the time ET - LT, where LT is the one-way
C         light time from the target to the observer at ET.
C         Additionally, SPK data must be available for the Sun at the
C         time ET - LT - LT2, where LT2 is the light time from the Sun
C         to the target body at time ET - LT.
C
C     3)  If PCK data defining the orientation or shape of the target
C         body are unavailable, the error will be diagnosed by routines
C         called by this routine.
C
C     4)  If no body-fixed frame is associated with the target body,
C         the error SPICE(NOFRAME) is signaled.
C
C     5) If name of target or observer cannot be translated to its
C        NAIF ID code, the error SPICE(IDCODENOTFOUND) is signaled.
C
C$ Files
C
C     No files are input to this routine.  However, ILLUM expects
C     that the appropriate SPK and PCK files have been loaded via
C     FURNSH.
C
C$ Particulars
C
C
C     The term "illumination angles" refers to following set of
C     angles:
C
C
C        solar incidence angle    Angle between the surface normal at
C                                 the specified surface point and the
C                                 vector from the surface point to the
C                                 Sun.
C
C        emission angle           Angle between the surface normal at
C                                 the specified surface point and the
C                                 vector from the surface point to the
C                                 observer.
C
C        phase angle              Angle between the vectors from the
C                                 surface point to the observing body's
C                                 location and from the surface point
C                                 to the Sun.
C
C
C     The diagram below illustrates the geometrical relationships
C     defining these angles.  The labels for the solar incidence,
C     emission, and phase angles are "s.i.", "e.", and "phase".
C
C
C                                                      *
C                                                     Sun
C
C                    surface normal vector
C                              ._                 _.
C                              |\                 /|  Sun vector
C                                \    phase      /
C                                 \   .    .    /
C                                 .            .
C                                   \   ___   /
C                              .     \/     \/
C                                    _\ s.i./
C                             .    /   \   /
C                             .   |  e. \ /
C         *             <--------------- *  surface point on
C      viewing            vector            target body
C      location           to viewing
C      (observer)         location
C
C
C     Note that if the target-observer vector, the target normal vector
C     at the surface point, and the target-sun vector are coplanar,
C     then phase is the sum of incidence and emission.  This is rarely
C     true; usually
C
C        phase angle  <  solar incidence angle + emission angle
C
C     All of the above angles can be computed using light time
C     corrections, light time and stellar aberration corrections, or
C     no aberration corrections.  The way aberration corrections
C     are used is described below.
C
C     Care must be used in computing light time corrections.  The
C     guiding principle used here is "describe what appears in
C     an image."  We ignore differential light time; the light times
C     from all points on the target to the observer are presumed to be
C     equal.
C
C
C        Observer-target body vector
C        ---------------------------
C
C        Let ET be the epoch at which an observation or remote
C        sensing measurement is made, and let ET - LT ("LT" stands
C        for "light time") be the epoch at which the photons received
C        at ET were emitted from the body (we use the term "emitted"
C        loosely here).
C
C        The correct observer-target vector points from the observer's
C        location at ET to the target body's location at ET - LT.
C        The target-observer vector points in the opposite direction.
C
C        Since light time corrections are not symmetric, the correct
C        target-observer vector CANNOT be found by computing the light
C        time corrected position of the observer as seen from the
C        target body.
C
C
C        Target body's orientation
C        -------------------------
C
C        Using the definitions of ET and LT above, the target
C        body's orientation at ET - LT is used.  The surface
C        normal is dependent on the target body's orientation, so
C        the body's orientation model must be evaluated for the correct
C        epoch.
C
C
C        Target body -- Sun vector
C        -------------------------
C
C        All surface features on the target body will appear in
C        a measurement made at ET as they were at ET-LT.  In
C        particular, lighting on the target body is dependent on
C        the apparent location of the Sun as seen from the target
C        body at ET-LT.  So, a second light time correction is used
C        in finding the apparent location of the Sun.
C
C
C     Stellar aberration corrections, when used, are applied as follows:
C
C
C        Observer-target body vector
C        ---------------------------
C
C        In addition to light time correction, stellar aberration is
C        used in computing the apparent target body position as seen
C        from the observer's location at time ET.  This apparent
C        position defines the observer-target body vector.
C
C
C        Target body-Sun vector
C        ----------------------
C
C        The target body-Sun vector is the apparent position of the Sun,
C        corrected for light time and stellar aberration, as seen from
C        the target body at time ET-LT.  Note that the target body's
C        position is not affected by the stellar aberration correction
C        applied in finding its apparent position as seen by the
C        observer.
C
C
C     Once all of the vectors, as well as the target body's
C     orientation, have been computed with the proper aberration
C     corrections, the element of time is eliminated from the
C     computation.  The problem becomes a purely geometrical one,
C     and is described by the diagram above.
C
C
C$ Examples
C
C     The numerical results shown for this example may differ across
C     platforms.  The results depend on the SPICE kernels used as
C     input, the compiler and supporting libraries, and the machine
C     specific arithmetic implementation.
C
C     In the following example program, the file
C
C        spk_m_031103-040201_030502.bsp
C
C     is a binary SPK file containing data for Mars Global Surveyor,
C     Mars, and the Sun for a time interval bracketing the date
C
C         2004 JAN 1 12:00:00 UTC.
C
C     pck00007.tpc is a planetary constants kernel file containing
C     radii and rotation model constants.  naif0007.tls is a
C     leapseconds kernel.
C
C     Find the phase, solar incidence, and emission angles at the
C     sub-solar and sub-spacecraft points on Mars as seen from the
C     Mars Global Surveyor spacecraft at a specified UTC time.
C     Use light time and stellar aberration corrections.
C
C           PROGRAM ANGLES
C           IMPLICIT NONE
C     C
C     C     SPICELIB functions
C     C
C           DOUBLE PRECISION      DPR
C
C     C
C     C     Local parameters
C     C
C           INTEGER               NAMLEN
C           PARAMETER           ( NAMLEN = 32 )
C
C           INTEGER               TIMLEN
C           PARAMETER           ( TIMLEN = 25 )
C
C     C
C     C     Local variables
C     C
C           CHARACTER*(NAMLEN)    OBSRVR
C           CHARACTER*(NAMLEN)    TARGET
C           CHARACTER*(TIMLEN)    UTC
C
C           DOUBLE PRECISION      ALT
C           DOUBLE PRECISION      ET
C           DOUBLE PRECISION      SSCEMI
C           DOUBLE PRECISION      SSCPHS
C           DOUBLE PRECISION      SSCSOL
C           DOUBLE PRECISION      SSLEMI
C           DOUBLE PRECISION      SSLPHS
C           DOUBLE PRECISION      SSLSOL
C           DOUBLE PRECISION      SSOLPT ( 3 )
C           DOUBLE PRECISION      SSCPT  ( 3 )
C
C     C
C     C     Load kernel files.
C     C
C           CALL FURNSH ( 'naif0007.tls'                   )
C           CALL FURNSH ( 'pck00007.tpc'                   )
C           CALL FURNSH ( 'spk_m_031103-040201_030502.bsp' )
C
C
C     C
C     C     Convert our UTC time to ephemeris seconds past J2000.
C     C
C           UTC = '2004 JAN 1 12:00:00'
C
C           CALL UTC2ET ( UTC, ET )
C
C     C
C     C     Assign observer and target names.  The acronym MGS
C     C     indicates Mars Global Surveyor.  See NAIF_IDS for a
C     C     list of names recognized by SPICE.
C     C
C           TARGET = 'Mars'
C           OBSRVR = 'MGS'
C
C     C
C     C     Find the sub-solar point on the Earth as seen from
C     C     the MGS spacecraft at ET.  Use the "surface intercept"
C     C     style of sub-point definition. This makes it easy
C     C     to verify the solar incidence angle.
C     C
C           CALL SUBSOL ( 'Near point', TARGET,  ET,
C          .              'LT+S',       OBSRVR,  SSOLPT  )
C
C     C
C     C     Now find the sub-spacecraft point.  Use the
C     C     "nearest point" definition of the sub-point
C     C     here---this makes it easy to verify the emission angle.
C     C
C           CALL SUBPT ( 'Near point',  TARGET,  ET,
C          .             'LT+S',        OBSRVR,  SSCPT,  ALT )
C
C     C
C     C     Find the phase, solar incidence, and emission
C     C     angles at the sub-solar point on the Earth as seen
C     C     from Mars Observer at time ET.
C     C
C           CALL ILLUM ( TARGET, ET,     'LT+S', OBSRVR,
C          .             SSOLPT, SSLPHS, SSLSOL, SSLEMI )
C
C     C
C     C     Do the same for the sub-spacecraft point.
C     C
C           CALL ILLUM ( TARGET, ET,     'LT+S', OBSRVR,
C          .             SSCPT,  SSCPHS, SSCSOL, SSCEMI )
C
C     C
C     C     Convert the angles to degrees and write them out.
C     C
C           SSLPHS = DPR() * SSLPHS
C           SSLSOL = DPR() * SSLSOL
C           SSLEMI = DPR() * SSLEMI
C
C           SSCPHS = DPR() * SSCPHS
C           SSCSOL = DPR() * SSCSOL
C           SSCEMI = DPR() * SSCEMI
C
C           WRITE (*,*) ' '
C           WRITE (*,*) 'UTC epoch is ', UTC
C           WRITE (*,*) ' '
C           WRITE (*,*) 'Illumination angles at the sub-solar point:'
C           WRITE (*,*) ' '
C           WRITE (*,*) 'Phase angle           (deg.): ', SSLPHS
C           WRITE (*,*) 'Solar incidence angle (deg.): ', SSLSOL
C           WRITE (*,*) 'Emission angle        (deg.): ', SSLEMI
C           WRITE (*,*) ' '
C           WRITE (*,*) 'The solar incidence angle should be 0.'
C           WRITE (*,*) 'The emission and phase angles should be equal.'
C
C           WRITE (*,*) ' '
C           WRITE (*,*) 'Illumination angles at the sub-s/c point:'
C           WRITE (*,*) ' '
C           WRITE (*,*) 'Phase angle           (deg.): ', SSCPHS
C           WRITE (*,*) 'Solar incidence angle (deg.): ', SSCSOL
C           WRITE (*,*) 'Emission angle        (deg.): ', SSCEMI
C           WRITE (*,*) ' '
C           WRITE (*,*) 'The emission angle should be 0.'
C           WRITE (*,*) 'The solar incidence and phase angles should '//
C          .            'be equal.'
C
C           END
C
C
C     When this program is executed, the output will be:
C
C
C        UTC epoch is 2004 JAN 1 12:00:00
C
C        Illumination angles at the sub-solar point:
C
C        Phase angle           (deg.):   150.210714
C        Solar incidence angle (deg.):   6.3735213E-15
C        Emission angle        (deg.):   150.210714
C
C        The solar incidence angle should be 0.
C        The emission and phase angles should be equal.
C
C        Illumination angles at the sub-s/c point:
C
C        Phase angle           (deg.):   123.398202
C        Solar incidence angle (deg.):   123.398202
C        Emission angle        (deg.):   6.36110936E-15
C
C        The emission angle should be 0.
C        The solar incidence and phase angles should be equal.
C
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     C.H. Acton     (JPL)
C     B.V. Semenov   (JPL)
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.3.0, 04-JUL-2014 (NJB) (BVS)
C
C        Discussion of light time corrections was updated. Assertions
C        that converged light time corrections are unlikely to be
C        useful were removed.
C
C     Last update was 19-SEP-2013 (BVS)
C
C        Updated to save the input body names and ZZBODTRN state
C        counters and to do name-ID conversions only if the counters
C        have changed.
C
C-    SPICELIB Version 1.2.2, 18-MAY-2010 (BVS)
C
C        Index lines now state that this routine is deprecated.
C
C-    SPICELIB Version 1.2.1, 07-FEB-2008 (NJB)
C
C        Abstract now states that this routine is deprecated.
C
C-    SPICELIB Version 1.2.0, 23-OCT-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VSUB calls.  Replaced call to BODVAR with call to BODVCD.
C
C-    SPICELIB Version 1.1.0, 22-JUL-2004 (NJB)
C
C        Updated to support representations of integers in the input
C        arguments TARGET and OBSRVR.
C
C-    SPICELIB Version 1.0.2, 27-JUL-2003 (NJB) (CHA)
C
C        Various header corrections were made.  The example program
C        was upgraded to use real kernels, and the program's output is
C        shown.
C
C-    SPICELIB Version 1.0.1, 10-JUL-2002 (NJB)
C
C        Updated Index_Entries header section.
C
C-    SPICELIB Version 1.0.0, 21-MAR-1999 (NJB)
C
C        Adapted from the MGSSPICE version dated 10-MAR-1992.
C-&

C$ Index_Entries
C
C     DEPRECATED illumination angles
C     DEPRECATED lighting angles
C     DEPRECATED phase angle
C     DEPRECATED solar incidence angle
C     DEPRECATED emission angle
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.2.0, 23-OCT-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VSUB calls.  Replaced call to BODVAR with call to BODVCD.
C
C-    SPICELIB Version 1.1.0, 22-JUL-2004 (NJB)
C
C        Updated to support representations of integers in the
C        input arguments TARGET and OBSRVR:  calls to BODN2C
C        were replaced by calls to BODS2C.
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      VSEP

      LOGICAL               EQSTR
      LOGICAL               RETURN

C
C     Local parameters
C
      INTEGER               SUN
      PARAMETER           ( SUN    =  10 )

      INTEGER               FRNMLN
      PARAMETER           ( FRNMLN =  80 )

C
C     Saved body name length.
C
      INTEGER               MAXL
      PARAMETER           ( MAXL  = 36 )

C
C     Local variables
C
      CHARACTER*(FRNMLN)    FRNAME

      DOUBLE PRECISION      LT
      DOUBLE PRECISION      LTS
      DOUBLE PRECISION      NORMAL ( 3 )
      DOUBLE PRECISION      OBSVEC ( 3 )
      DOUBLE PRECISION      OFFOBS ( 3 )
      DOUBLE PRECISION      OFFSUN ( 3 )
      DOUBLE PRECISION      RADII  ( 3 )
      DOUBLE PRECISION      SSTATE ( 6 )
      DOUBLE PRECISION      SUNVEC ( 3 )
      DOUBLE PRECISION      TEPOCH
      DOUBLE PRECISION      TSTATE ( 6 )

      INTEGER               FRCODE
      INTEGER               OBSCDE
      INTEGER               TRGCDE
      INTEGER               N

      LOGICAL               FOUND

C
C     Saved name/ID item declarations.
C
      INTEGER               SVCTR1 ( CTRSIZ )
      CHARACTER*(MAXL)      SVTARG
      INTEGER               SVTCDE
      LOGICAL               SVFND1

      INTEGER               SVCTR2 ( CTRSIZ )
      CHARACTER*(MAXL)      SVOBSR
      INTEGER               SVOBSC
      LOGICAL               SVFND2

      LOGICAL               FIRST

C
C     Saved name/ID items.
C
      SAVE                  SVCTR1
      SAVE                  SVTARG
      SAVE                  SVTCDE
      SAVE                  SVFND1

      SAVE                  SVCTR2
      SAVE                  SVOBSR
      SAVE                  SVOBSC
      SAVE                  SVFND2

      SAVE                  FIRST

C
C     Initial values.
C
      DATA                  FIRST   / .TRUE. /

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

C
C     Initialization.
C
      IF ( FIRST ) THEN

C
C        Initialize counters.
C
         CALL ZZCTRUIN( SVCTR1 )
         CALL ZZCTRUIN( SVCTR2 )

         FIRST = .FALSE.

      END IF

C
C     Obtain integer codes for the target and observer.
C
      CALL ZZBODS2C ( SVCTR1, SVTARG, SVTCDE, SVFND1,
     .                TARGET, TRGCDE, FOUND    )

      IF ( .NOT. FOUND ) THEN

         CALL SETMSG ( 'The target, '
     .   //            '''#'', is not a recognized name for an '
     .   //            'ephemeris object. The cause of this '
     .   //            'problem may be that you need an updated '
     .   //            'version of the SPICE Toolkit. '           )
         CALL ERRCH  ( '#', TARGET                                )
         CALL SIGERR ( 'SPICE(IDCODENOTFOUND)'                    )
         CALL CHKOUT ( 'ILLUM'                                    )
         RETURN

      END IF

      CALL ZZBODS2C ( SVCTR2, SVOBSR, SVOBSC, SVFND2,
     .                OBSRVR, OBSCDE, FOUND    )

      IF ( .NOT. FOUND ) THEN

         CALL SETMSG ( 'The observer, '
     .   //            '''#'', is not a recognized name for an '
     .   //            'ephemeris object. The cause of this '
     .   //            'problem may be that you need an updated '
     .   //            'version of the SPICE Toolkit. '           )
         CALL ERRCH  ( '#', OBSRVR                                )
         CALL SIGERR ( 'SPICE(IDCODENOTFOUND)'                    )
         CALL CHKOUT ( 'ILLUM'                                    )
         RETURN

      END IF

C
C     The observer and target must be distinct.
C
      IF ( TRGCDE .EQ. OBSCDE ) THEN

         CALL SETMSG ( 'Target is #; observer is #.' )
         CALL ERRCH  ( '#', TARGET                   )
         CALL ERRCH  ( '#', OBSRVR                   )
         CALL SIGERR ( 'SPICE(BODIESNOTDISTINCT)'    )
         CALL CHKOUT ( 'ILLUM'                       )
         RETURN

      END IF

C
C     Find the name of the body-fixed frame associated with the
C     target body.  We'll want the state of the target relative to
C     the observer in this body-fixed frame.
C
      CALL CIDFRM ( TRGCDE, FRCODE, FRNAME, FOUND )

      IF ( .NOT. FOUND ) THEN

         CALL SETMSG ( 'No body-fixed frame is associated with '   //
     .                 'target body #; a frame kernel must be '    //
     .                 'loaded to make this association.  Consult '//
     .                 'the FRAMES Required Reading for details.'   )
         CALL ERRCH  ( '#', TARGET                                  )
         CALL SIGERR ( 'SPICE(NOFRAME)'                             )
         CALL CHKOUT ( 'ILLUM'                                      )
         RETURN

      END IF

C
C     Find the body-fixed state of the target as seen from the observer
C     at ET.  The appropriate aberration corrections will be used in
C     evaluating this state.
C
      CALL SPKEZ ( TRGCDE, ET, FRNAME, ABCORR, OBSCDE, TSTATE, LT )

C
C     Determine the epoch to be used in computing the target-Sun vector.
C
      IF (  EQSTR( ABCORR, 'NONE' )  ) THEN
         TEPOCH = ET
      ELSE
         TEPOCH = ET - LT
      END IF

C
C     Find the body-fixed state of the Sun as seen from the target at
C     TEPOCH.
C
      CALL SPKEZ  ( SUN, TEPOCH, FRNAME, ABCORR, TRGCDE, SSTATE, LTS )

C
C     Grab the position portions of the states (the first three
C     elements of each state).  Negate the observer-target vector,
C     since the vector required for the illumination angle
C     computation is the target-observer vector.  The vectors we've
C     found point from the target body center to the observer and
C     Sun, and already take light time corrections into account.
C
      CALL VMINUS ( TSTATE, OBSVEC )
      CALL VEQU   ( SSTATE, SUNVEC )

C
C     Now we'll modify target-observer and target-Sun vectors to
C     take into account the offset between the target center and the
C     surface point of interest; we want the vectors to point from
C     the surface point to the observer and Sun respectively.
C
      CALL VSUB ( OBSVEC, SPOINT, OFFOBS )
      CALL VSUB ( SUNVEC, SPOINT, OFFSUN )

C
C     Find the surface normal at SPOINT.  We'll need the radii of the
C     target body.
C
      CALL BODVCD ( TRGCDE,  'RADII',   3,  N,    RADII )

      CALL SURFNM ( RADII(1), RADII(2), RADII(3), SPOINT, NORMAL )

C
C     Find the illumination angles.  VSEP will give us angular
C     separation in radians.
C
      PHASE   =  VSEP ( OFFSUN, OFFOBS )
      SOLAR   =  VSEP ( NORMAL, OFFSUN )
      EMISSN  =  VSEP ( NORMAL, OFFOBS )

      CALL CHKOUT ( 'ILLUM' )
      RETURN
      END


program spgen
!Jason Rowe 2015 - jasonfrowe@gmail.com
!generates GR700-SOSS spectrum with 3-order traces + PSF + response
use precision
use response
implicit none
integer xmax,ymax,iargc,nunit,filestatus,nmodelmax,iflag,nmodel,i,j,npx,&
   npy,nK,xout,yout,noversample,nKd2,npt,nrK,nKs,Ks,ntrace,ntracemax,   &
   seed,nmodeltype
integer, dimension(2) :: ybounds
integer, dimension(3) :: now
real(double) :: w2p,px,py,ptrace,dxmaxp1,dymaxp1,dnossq,rv,dnpt,wl,mSum,&
   fmodres,respond,awmod,snr,dumr,ran2,b,p2w,time
real(double), allocatable, dimension(:) :: wmod,fmod,wmod2,fmod2,       &
   fmodbin,wv,yres1,yres2,yres3,rprs
real(double), allocatable, dimension(:,:) :: pixels,Kernel,cpixels,     &
   opixels,wKernel,wpixels,wcpixels,nll,nll2
real(double), allocatable, dimension(:,:,:) :: rKernel
character(80) :: modelfile,fileout,fileout_m,fileout_c,cline,pmodelfile,&
   prefix

interface
   subroutine readmodel(nunit,nmodelmax,nmodel,wmod,fmod,iflag)
      use precision
      implicit none
      integer, intent(inout) :: nunit,nmodelmax,nmodel,iflag
      real(double), dimension(:), intent(inout) :: wmod, fmod
   end subroutine
end interface
interface
   subroutine readatlas(nunit,nmodelmax,nmodel,wmod,fmod,nll,iflag)
      use precision
      implicit none
      integer, intent(inout) :: nunit,nmodelmax,nmodel,iflag
      real(double), dimension(:), intent(inout) :: wmod, fmod
      real(double), dimension(:,:), intent(inout) :: nll
   end subroutine
end interface
interface
   subroutine writefits(nxmax,nymax,parray,fileout,time)
      use precision
      implicit none
      integer, intent(inout) :: nxmax,nymax
      real(double), intent(inout) :: time
      real(double), dimension(:,:), intent(inout) :: parray
      character(80) :: fileout
   end subroutine
end interface
interface
   subroutine binmodel(npt,wv,nmodel,wmod,fmod,fmodbin,rv)
      use precision
      implicit none
      integer, intent(inout) :: npt,nmodel
      real(double), intent(inout) :: rv
      real(double), dimension(:), intent(inout) :: wv,wmod,fmod
      real(double), dimension(:), intent(inout) :: fmodbin
   end subroutine
end interface
interface
   subroutine readKernels(nrK,nK,rKernel,noversample)
      use precision
      implicit none
      integer,intent(inout) :: nrK,nK,noversample
      real(double), dimension(:,:,:), intent(inout) :: rKernel
   end subroutine
end interface
interface
   subroutine addgnoise(xout,yout,opixels,snr,seed)
      use precision
      implicit none
      integer, intent(inout) :: xout,yout,seed
      real(double), intent(in) :: snr
      real(double), dimension(:,:), intent(inout) :: opixels
   end subroutine
end interface
interface
   subroutine tmodel(nmodel,fmod,rprs,nll,b)
      use precision
      implicit none
      integer, intent(inout) :: nmodel
      real(double), intent(inout) :: b
      real(double), dimension(:), intent(inout) :: fmod,rprs
      real(double), dimension(:,:), intent(inout) :: nll
   end subroutine
end interface
interface
   subroutine readpmodel(nunit,nmodel,wmod,rprs)
      use precision
      implicit none
      integer :: nunit,nmodel
      real(double), dimension(:) :: rprs,wmod
   end subroutine
end interface
interface
   subroutine addshotnoise(xout,yout,opixels,seed)
      use precision
      implicit none
      integer :: xout,yout,seed
      real(double), dimension(:,:) :: opixels
   end subroutine
end interface

if(iargc().lt.3)then
   write(0,*) "Usage: spgen <specmodel> <noversample> <planetmodel> [b] [time]"
   write(0,*) "   <specmodel> - Atlas-9 stellar model"
   write(0,*) " <noversample> - is new sampling for Kernel (must be > 0)"
   write(0,*) " <planetmodel> - name of planet model (A, rprs)"
   write(0,*) "           [b] - impact parameter - optional (must be > 0)"
   write(0,*) "        [time] - observation timestamp to embed in header"
   write(0,*) " [output.fits] - filename for output"
   stop
endif

!image dimensions
xout=2048  !dimensions for output image.
yout=256

!parameters that control the simulation
snr=1000  !S/N of spectrum - move to commandline
rv=0.0 !radial velocity shift (m/s)

!parameter controling modeltype
nmodeltype=2 !1=BT-Settl, 2=Atlas-9+NL limbdarkening

if(iargc().ge.4)then
   call getarg(4,cline)
   read(cline,*) b
   if(b.lt.0.0d0)then
      write(0,*) "b must be positive"
      stop
   endif
else
   !default impact parameter
   b=2.0!0.3589
endif

if(iargc().ge.5)then
   call getarg(5,cline)
   read(cline,*) time
else
   time=0.0d0
endif
if(iargc().ge.6)then
   call getarg(6,prefix)
else
   prefix="spgen"
endif
fileout=trim(prefix)//".fits"
fileout_m=trim(prefix)//"_m.txt"
fileout_c=trim(prefix)//"_c.fits"

noversample=1 !now a commandline-parameter
!get oversampling from commandline
call getarg(2,cline)
read(cline,*) noversample !read in noversample
if(noversample.le.0)then
   write(0,*) "noversample must be greater than zero"
   stop
endif

!Initialization of random number
call itime(now)
seed=abs(now(3)+now(1)*now(2)+now(1)*now(3)+now(2)*now(3)*100)
dumr=ran2(-seed)

!read in Kernels
nrK=30 !number of Kernels to readin
nKs=64*noversample !natural size of Kernels times oversampling
allocate(rKernel(nrK,nKs,nKs))
call readKernels(nrK,nKs,rKernel,noversample)

!read in response
ntracemax=3 !number of traces used
call readresponse() !responce is returned via pointers from response.mod
!use global variables: nres,ld,res1,res2,res3 for response function
allocate(yres1(nres),yres2(nres),yres3(nres))
call spline(ld,res1,nres,1.d30,1.d30,yres1) !set up cubic splines
call spline(ld,res2,nres,1.d30,1.d30,yres2)
call spline(ld,res3,nres,1.d30,1.d30,yres3)

!read in a model spectrum
call getarg(1,modelfile)
nunit=11 !unit number for data spectrum
open(unit=nunit,file=modelfile,iostat=filestatus,status='old')
if(filestatus>0)then !trap missing file errors
   write(0,*) "Cannot open ",modelfile
   stop
endif

nmodelmax=2000000 !initital guess at the number of data points
allocate(wmod(nmodelmax),fmod(nmodelmax))
allocate(nll(nmodelmax,4)) !limb-darkening co-efficients

iflag=0 !flag traces data i/o
nmodel=0   !initalize counter for number of data points
do !we do a loop.  If there are memory errors, we can get more this way
   if(nmodeltype.eq.1)then
      call readmodel(nunit,nmodelmax,nmodel,wmod,fmod,iflag) !read in spectrum
      nll=0.0d0 !no limb-darkening
   elseif(nmodeltype.eq.2)then
      call readatlas(nunit,nmodelmax,nmodel,wmod,fmod,nll,iflag)
   endif
   if(iflag.eq.1) then !reallocate array space (we ran out of space)
      allocate(wmod2(nmodelmax),fmod2(nmodelmax),nll2(nmodelmax,4)) !allocate temp arrays
      wmod2=wmod   !copy over the data we read
      fmod2=fmod
      nll2=nll
      deallocate(wmod,fmod,nll) !deallocate data arrays
      nmodelmax=nmodelmax*2 !lets get more memory
      write(0,*) "warning, increasing nmodelmax: ",nmodelmax
      allocate(wmod(nmodelmax),fmod(nmodelmax),nll(nmodelmax,4)) !reallocate array
      do i=1,nmodelmax/2  !copy data back into data arrays
         wmod(i)=wmod2(i)
         fmod(i)=fmod2(i)
         do j=1,4
            nll(i,j)=nll2(i,j)
         enddo
      enddo
      deallocate(wmod2,fmod2,nll2) !deallocate temp arrays
      iflag=2  !set flag that we are continuing to read in data
      cycle !repeat data read loop
   endif
   exit !successively break from data read loop.
enddo
close(nunit) !close file.
write(0,*) "Number of star model points: ",nmodel  !report number of data points read.

fmod=fmod/maxval(fmod(1:nmodel))*65536d0 !scale input flux
!write(0,*) "fbounds: ",minval(fmod(1:nmodel)),maxval(fmod(1:nmodel))

!Now we readin the planet model and interpolate onto the spectral model grid
allocate(rprs(nmodel))

!read in a planet model spectrum
call getarg(3,pmodelfile)
nunit=11 !unit number for data spectrum
open(unit=nunit,file=pmodelfile,iostat=filestatus,status='old')
if(filestatus>0)then !trap missing file errors
   write(0,*) "Cannot open ",modelfile
   stop
endif
call readpmodel(nunit,nmodel,wmod,rprs)
close(nunit)

if(b.lt.maxval(rprs(1:nmodel))+1.0d0)then !do a check that we have a transit
   call tmodel(nmodel,fmod,rprs,nll,b)
endif

npt=200000 !this sets the number of spectral points when resampled
allocate(wv(npt),fmodbin(npt))
!resample model spectra on a uniform grid from 1000-40000 A
dnpt=dble(npt)
do i=1,npt
   wv(i)=1000.0+(40000.0-1000.0)/dnpt*dble(i) !make a wavelength grid
!   write(0,*) i,wv(i)
enddo
!read(5,*)
fmodbin=0.0d0 !initialize array
!resample with equal spacing
call binmodel(npt,wv,nmodel,wmod,fmod,fmodbin,rv)
!write(0,*) "Done binning model"
deallocate(wmod,fmod) !get rid of uneven sampled grid
allocate(wmod(npt),fmod(npt)) !make new array with equal spaced grid
nmodel=npt
wmod=wv !copy work arrays
fmod=fmodbin
deallocate(wv,fmodbin) !get rid of work arrays

!lets fill in pixel values
xmax=xout*noversample !size of over sampled detector array.
ymax=yout*noversample
!array to hold detector array values
allocate(pixels(xmax,ymax),wpixels(xmax,ymax))
pixels=0.0d0 !initialize array to zero
dxmaxp1=dble(xmax+1) !xmax+1 converted to double
dymaxp1=dble(ymax+1) !ymax+1 converted to double
!allocate array for convolved image
allocate(cpixels(xmax,ymax),wcpixels(xmax,ymax))
cpixels=0.0d0 !initialize array to zero

do ntrace=1,ntracemax !loop over all traces
   write(0,*) "Trace # ",ntrace
   wpixels=0.0d0 !initialize array to zero
   !trace parts of array used for spectrum (speeds up convolution later)
   ybounds(1)=ymax !initalize to bad bounds for max/min search
   ybounds(2)=1
   !j=0
   do i=1,nmodel
      px=w2p(wmod(i),noversample,ntrace) !get x-pixel value
      !is the wavelength on the detector?
      if((px.gt.1.0d0).and.(px.lt.dxmaxp1))then
         py=ptrace(px,noversample,ntrace) !get y-pixel value
!      write(0,*) px,py
         if((py.gt.1.0d0).and.(py.lt.dymaxp1))then !check y-pixel value
            npx=int(px) !convert pixel values to integer
            npy=int(py)
            !find extremes of CCD use to speed up later
            ybounds(1)=min(ybounds(1),npy)
            ybounds(2)=max(ybounds(2),npy)
!           wpixels(npx,npy)=wpixels(npx,npy)+fmod(i) !add flux to pixel
!           add in response.

!           wmod is in A.. convert to nm for easy comparision
            awmod=wmod(i)/10.0d0
            if((awmod.lt.500.0).or.(awmod.gt.5500.0))then
               respond=0.0d0
            else
            ! cubic interpolation of response along traces
               select case(ntrace)
                  case(1)
                     call splint(ld,res1,yres1,nres,awmod,respond)
                  case(2)
                     call splint(ld,res2,yres2,nres,awmod,respond)
                  case(3)
                     call splint(ld,res3,yres3,nres,awmod,respond)
               end select
            endif
            !the max statement makes sure we don't add negative flux.
            fmodres=fmod(i)*max(respond,0.0d0) !flux to add to pixel
            call addflux2pix(px,py,xmax,ymax,wpixels,fmodres)

!           j=j+1 !for counting gnumber of wavelength samples
         endif
      endif
   enddo
   !write(0,*) "nsamples: ",j

!  quick hack to dump the NIRISS native resolution model to a file
   if(ntrace.eq.1)then
      open(unit=10,file=fileout_m)
         do i=noversample,xmax,noversample
            write(10,*) p2w(dble(i-noversample/2),noversample,1),Sum(wpixels(i-noversample+1:i,1:ymax))
         enddo
      close(10)
   endif

   !Now we convolve the narrow spectra with the PSF kernel
   write(0,*) minval(wpixels),maxval(wpixels)
   wcpixels=0.0d0
!   call convolve(xmax,ymax,wpixels,nrK,nKs,rKernel,noversample,wcpixels,&
!      ybounds,ntrace)
   call convolveft(xmax,ymax,wpixels,nrK,nKs,rKernel,noversample,wcpixels, &
      ybounds,ntrace)
   write(0,*) minval(wcpixels),maxval(wcpixels)

   !copy trace to master array for output
   pixels=pixels+wpixels !unconvolved image
   cpixels=cpixels+wcpixels !convolved image
enddo
deallocate(wcpixels,wpixels,yres1,yres2,yres3) !work arrays no longer needed

allocate(opixels(xout,yout)) !we resample the array for output
opixels=0.0d0 !initalize the array
dnossq=noversample*noversample
do i=noversample,xmax,noversample
   do j=noversample,ymax,noversample
      opixels(i/noversample,j/noversample)=                             &
         Sum(pixels(i-noversample+1:i,j-noversample+1:j))
   enddo
enddo
!write out un-convolved 2D spectrum
call writefits(xout,yout,opixels,fileout,time) !make fits file.

opixels=0.0d0 !reinitialize the array
dnossq=noversample*noversample
do i=noversample,xmax,noversample  !resample (bin) the array.
   do j=noversample,ymax,noversample
      opixels(i/noversample,j/noversample)=                             &
         Sum(cpixels(i-noversample+1:i,j-noversample+1:j))
!      opixels(i/noversample,j/noversample)=                             &
!         opixels(i/noversample,j/noversample)/dnossq
   enddo
enddo
!Now we can add noise.
!call addshotnoise(xout,yout,opixels,seed)
!call addgnoise(xout,yout,opixels,snr,seed)

!Export final image to FITS
call writefits(xout,yout,opixels,fileout_c,time) !make fits file.

end program spgen

!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
function ptrace(px,noversample,ntrace)
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
use precision
implicit none
integer noversample,i,ntrace
integer, parameter :: nc=5
real(double) :: ptrace,px,opx
real(double), dimension(nc) :: c1,c2,c3,c
data c1/275.685,0.0587943,-0.000109117,1.06605d-7,-3.87d-11/
data c2/254.109,-0.00121072,-1.84106e-05,4.81603e-09,-2.14646e-11/
data c3/203.104,-0.0483124,-4.79001e-05,0.0,0.0/

select case(ntrace)
   case(1)
      c=c1
   case(2)
      c=c2
   case(3)
      c=c3
end select

opx=px/dble(noversample) !account for oversampling
ptrace=c(1)
do i=2,nc
   !polynomial fit to trace. Good to about 1-2 pix
   ptrace=ptrace+opx**dble(i-1)*c(i)
enddo
ptrace=(ptrace-80.0d0)*dble(noversample) !account for oversampling

return
end

!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
function p2w(p,noversample,ntrace)
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
!convert pixel to wavelength
! n=1 polynomial fit
!output is in Angstroms
use precision
implicit none
integer :: i,noversample,ntrace
integer, parameter :: nc=5
real(double) :: pix,p,p2w
real(double), dimension(nc) :: c1,c2,c3,c
data c1/2.60188,-0.000984839,3.09333e-08,-4.19166e-11,1.66371e-14/
data c2/1.30816,-0.000480837,-5.21539e-09,8.11258e-12,5.77072e-16/
data c3/0.880545,-0.000311876,8.17443e-11,0.0,0.0/

select case(ntrace)
   case(1)
      c=c1
   case(2)
      c=c2
   case(3)
      c=c3
end select

pix=p/dble(noversample)
p2w=c(1)
do i=2,nc
   p2w=p2w+pix**dble(i-1)*c(i)
enddo
p2w=p2w*10000.0 !um->A

!write(0,*) p2w,pix,p
!read(5,*)

return
end

!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
function w2p(w,noversample,ntrace)
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
!convert wavelength to pixel
! n=1 polynomial fit.
! input is in angtroms
use precision
implicit none
integer :: i,noversample,ntrace
integer, parameter :: nc=5
real(double) w2p,w,wum
real(double), dimension(nc) :: c1,c2,c3,c
data c1/2957.38,-1678.19,526.903,-183.545,23.4633/
data c2/3040.35,-2891.28,682.155,-189.996,0.0/
data c3/2825.46,-3211.14,2.69446,0.0,0.0/

select case(ntrace)
   case(1)
      c=c1
   case(2)
      c=c2
   case(3)
      c=c3
end select

wum=w/10000.0 !A->um
w2p=c(1)
do i=2,nc
   w2p=w2p+wum**dble(i-1)*c(i)  !polynomial fit to trace. Good to about 1-2 pix
enddo
w2p=w2p*dble(noversample) !account for oversampling
!write(0,*) w2p,w/10000.0d0
!read(5,*)

return
end