C$Procedure      CKR03 ( C-kernel, read pointing record, data type 3 )

      SUBROUTINE CKR03 ( HANDLE, DESCR, SCLKDP, TOL, NEEDAV,
     .                   RECORD, FOUND )
      IMPLICIT NONE

C$ Abstract
C
C     Read a pointing record from a CK segment, data type 3.
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     POINTING
C
C$ Declarations

      INTEGER               HANDLE
      DOUBLE PRECISION      DESCR  ( * )
      DOUBLE PRECISION      SCLKDP
      DOUBLE PRECISION      TOL
      LOGICAL               NEEDAV
      DOUBLE PRECISION      RECORD ( * )
      LOGICAL               FOUND

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     HANDLE     I   File handle.
C     DESCR      I   Segment descriptor.
C     SCLKDP     I   Pointing request time.
C     TOL        I   Time tolerance.
C     NEEDAV     I   Angular velocity request flag.
C     RECORD     O   Pointing data record.
C     FOUND      O   True when data is found.
C
C$ Detailed_Input
C
C     HANDLE     is the integer handle of the CK file containing the
C                segment.
C
C     DESCR      is the descriptor of the segment.
C
C     SCLKDP     is the encoded spacecraft clock time for which
C                pointing is being requested.
C
C     TOL        is a time tolerance, measured in the same units as
C                encoded spacecraft clock.
C
C                When SCLKDP falls within the bounds of one of the
C                interpolation intervals then the tolerance has no
C                effect because pointing will be returned at the
C                request time.
C
C                However, if the request time is not in one of the
C                intervals, then the tolerance is used to determine
C                if pointing at one of the interval endpoints should
C                be returned.
C
C     NEEDAV     is true if angular velocity is requested.
C
C$ Detailed_Output
C
C     RECORD     is the record that CKE03 will evaluate to determine
C                the pointing.
C
C                When the request time falls within an interval for
C                which linear interpolation is valid, the values of
C                the two pointing instances that bracket the request
C                time are returned in RECORD as follows:
C
C                   RECORD( 1  ) = Left bracketing SCLK time.
C
C                   RECORD( 2  ) = lq0  \
C                   RECORD( 3  ) = lq1   \    Left bracketing
C                   RECORD( 4  ) = lq2   /      quaternion.
C                   RECORD( 5  ) = lq3  /
C
C                   RECORD( 6  ) = lav1 \     Left bracketing
C                   RECORD( 7  ) = lav2       angular velocity
C                   RECORD( 8  ) = lav3 /       ( optional )
C
C                   RECORD( 9  ) = Right bracketing SCLK time.
C
C                   RECORD( 10 ) = rq0  \
C                   RECORD( 11 ) = rq1   \    Right bracketing
C                   RECORD( 12 ) = rq2   /       quaternion.
C                   RECORD( 13 ) = rq3  /
C
C                   RECORD( 14 ) = rav1 \     Right bracketing
C                   RECORD( 15 ) = rav2       angular velocity
C                   RECORD( 16 ) = rav3 /       ( optional )
C
C                   RECORD( 17 ) = pointing request time, SCLKDP.
C
C                The quantities lq0 - lq3 and rq0 - rq3 are the
C                components of the quaternions that represent the
C                C-matrices associated with the times that bracket
C                the requested time.
C
C                The quantities lav1, lav2, lav3 and rav1, rav2, rav3
C                are the components of the angular velocity vectors at
C                the respective bracketing times. The components of the
C                angular velocity vectors are specified relative to
C                the inertial reference frame of the segment.
C
C                If the request time does not fall within an
C                interpolation interval, but is within TOL of an
C                interval endpoint, the values of that pointing
C                instance are returned in both parts of RECORD
C                ( i.e. RECORD(1-9) and RECORD(10-16) ).
C
C     FOUND      is true if a record was found to satisfy the pointing
C                request.  This occurs when the time for which pointing
C                is requested falls inside one of the interpolation
C                intervals, or when the request time is within the
C                tolerance of an interval endpoint.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If the specified handle does not belong to an open DAF file,
C         an error is diagnosed by a routine that this routine calls.
C
C     2)  If DESCR is not a valid descriptor of a segment in the CK
C         file specified by HANDLE, the results of this routine are
C         unpredictable.
C
C     3)  If the segment is not of data type 3, as specified in the
C         third integer component of the segment descriptor, then
C         the error SPICE(WRONGDATATYPE) is signalled.
C
C     4)  If angular velocity data was requested but the segment
C         contains no such data, the error SPICE(NOAVDATA) is signalled.
C
C$ Files
C
C     The file containing the segment is specified by its handle and
C     should be opened for read or write access, either by CKLPF,
C     DAFOPR, or DAFOPW.
C
C$ Particulars
C
C     See the CK Required Reading file for a detailed description of
C     the structure of a type 3 pointing segment.
C
C     When the time for which pointing was requested falls within an
C     interpolation interval, then FOUND will be true and RECORD will
C     contain the pointing instances in the segment that bracket the
C     request time.  CKE03 will evaluate RECORD to give pointing at
C     the request time.
C
C     However, when the request time is not within any of the
C     interpolation intervals, then FOUND will be true only if the
C     interval endpoint closest to the request time is within the
C     tolerance specified by the user.  In this case both parts of
C     RECORD will contain this closest pointing instance, and CKE03
C     will evaluate RECORD to give pointing at the time associated
C     with the returned pointing instance.
C
C$ Examples
C
C     The CKRnn routines are usually used in tandem with the CKEnn
C     routines, which evaluate the record returned by CKRnn to give
C     the pointing information and output time.
C
C     The following code fragment searches through all of the segments
C     in a file applicable to the Mars Observer spacecraft bus that
C     are of data type 3, for a particular spacecraft clock time.
C     It then evaluates the pointing for that epoch and prints the
C     result.
C
C           CHARACTER*(20)        SCLKCH
C           CHARACTER*(20)        SCTIME
C           CHARACTER*(40)        IDENT
C
C           INTEGER               I
C           INTEGER               SC
C           INTEGER               INST
C           INTEGER               HANDLE
C           INTEGER               DTYPE
C           INTEGER               ICD      (    6 )
C
C           DOUBLE PRECISION      SCLKDP
C           DOUBLE PRECISION      TOL
C           DOUBLE PRECISION      CLKOUT
C           DOUBLE PRECISION      DESCR    (    5 )
C           DOUBLE PRECISION      DCD      (    2 )
C           DOUBLE PRECISION      RECORD   (   17 )
C           DOUBLE PRECISION      CMAT     ( 3, 3 )
C           DOUBLE PRECISION      AV       (    3 )
C
C           LOGICAL               NEEDAV
C           LOGICAL               FND
C           LOGICAL               SFND
C
C
C           SC     = -94
C           INST   = -94000
C           DTYPE  =  3
C           NEEDAV = .FALSE.
C
C     C
C     C     Load the MO SCLK kernel and the C-kernel.
C     C
C           CALL FURNSH ( 'MO_SCLK.TSC'       )
C           CALL DAFOPR ( 'MO_CK.BC',  HANDLE )
C     C
C     C     Get the spacecraft clock time. Then encode it for use
C     C     in the C-kernel.
C     C
C           WRITE (*,*) 'Enter spacecraft clock time string:'
C           READ (*,FMT='(A)') SCLKCH
C
C           CALL SCENCD ( SC, SCLKCH, SCLKDP )
C     C
C     C     Use a tolerance of 2 seconds ( half of the nominal
C     C     separation between MO pointing instances ).
C     C
C           CALL SCTIKS ( SC, '0000000002:000', TOL )
C
C     C
C     C     Search from the beginning of the CK file through all
C     C     of the segments.
C     C
C           CALL DAFBFS ( HANDLE )
C           CALL DAFFNA ( SFND   )
C
C           FND    = .FALSE.
C
C           DO WHILE ( ( SFND ) .AND. ( .NOT. FND ) )
C
C     C
C     C        Get the segment identifier and descriptor.
C     C
C
C              CALL DAFGN ( IDENT                 )
C              CALL DAFGS ( DESCR                 )
C     C
C     C        Unpack the segment descriptor into its integer and
C     C        double precision components.
C     C
C              CALL DAFUS ( DESCR, 2, 6, DCD, ICD )
C
C     C
C     C        Determine if this segment should be processed.
C     C
C              IF ( ( INST          .EQ. ICD( 1 ) ) .AND.
C          .        ( SCLKDP + TOL  .GE. DCD( 1 ) ) .AND.
C          .        ( SCLKDP - TOL  .LE. DCD( 2 ) ) .AND.
C          .        ( DTYPE         .EQ. ICD( 3 ) )      ) THEN
C
C
C                 CALL CKR03 ( HANDLE, DESCR, SCLKDP, TOL, NEEDAV,
C          .                   RECORD, FND )
C
C                 IF ( FND ) THEN
C
C                    CALL CKE03 (NEEDAV,RECORD,CMAT,AV,CLKOUT)
C
C                    CALL SCDECD ( SC, CLKOUT, SCTIME )
C
C                    WRITE (*,*)
C                    WRITE (*,*) 'Segment identifier: ', IDENT
C                    WRITE (*,*)
C                    WRITE (*,*) 'Pointing returned for time: ',
C          .                      SCTIME
C                    WRITE (*,*)
C                    WRITE (*,*) 'C-matrix:'
C                    WRITE (*,*)
C                    WRITE (*,*) ( CMAT(1,I), I = 1, 3 )
C                    WRITE (*,*) ( CMAT(2,I), I = 1, 3 )
C                    WRITE (*,*) ( CMAT(3,I), I = 1, 3 )
C                    WRITE (*,*)
C
C                 END IF
C
C              END IF
C
C              CALL DAFFNA ( SFND )
C
C           END DO
C
C$ Restrictions
C
C     1) The file containing the segment should be opened for read
C        or write access either by CKLPF, DAFOPR, or DAFOPW.
C
C     2) The record returned by this routine is intended to be
C        evaluated by CKE03.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     J.M. Lynch     (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.1, 22-AUG-2006 (EDW)
C
C        Replaced references to LDPOOL with references
C        to FURNSH.
C
C-    SPICELIB Version 1.1.0, 07-SEP-2001 (EDW)
C
C        Replaced DAFRDA call with DAFGDA.
C        Added IMPLICIT NONE.
C
C-    SPICELIB Version 1.0.0, 25-NOV-1992 (JML)
C
C-&

C$ Index_Entries
C
C     read ck type_3 pointing data record
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN
      LOGICAL               FAILED

      INTEGER               LSTLTD
      INTEGER               LSTLED

      DOUBLE PRECISION      DPMAX

C
C     Local parameters
C
C        DIRSIZ     is the directory size.
C
C        BUFSIZ     is the maximum number of double precision numbers
C                   that we will read from the DAF file at one time.
C                   BUFSIZ is normally set equal to DIRSIZ.
C
C        ND         is the number of double precision components in an
C                   unpacked C-kernel segment descriptor.
C
C        NI         is the number of integer components in an unpacked
C                   C-kernel segment descriptor.
C
C        QSIZ       is the number of double precision numbers making up
C                   the quaternion portion of a pointing record.
C
C        QAVSIZ     is the number of double precision numbers making up
C                   the quaternion and angular velocity portion of a
C                   pointing record.
C
C        DTYPE      is the data type of the segment that this routine
C                   operates on.
C
C
      INTEGER               DIRSIZ
      PARAMETER           ( DIRSIZ = 100 )

      INTEGER               BUFSIZ
      PARAMETER           ( BUFSIZ = 100 )

      INTEGER               ND
      PARAMETER           ( ND     = 2 )

      INTEGER               NI
      PARAMETER           ( NI     = 6 )

      INTEGER               QSIZ
      PARAMETER           ( QSIZ   = 4 )

      INTEGER               QAVSIZ
      PARAMETER           ( QAVSIZ = 7 )

      INTEGER               DTYPE
      PARAMETER           ( DTYPE =  3 )

C
C     Local variables
C
      INTEGER               ICD    ( NI )
      INTEGER               BEG
      INTEGER               END
      INTEGER               LBEG
      INTEGER               LEND
      INTEGER               LHAND
      INTEGER               NUMREC
      INTEGER               NUMINT
      INTEGER               NRDIR
      INTEGER               NIDIR
      INTEGER               GROUP
      INTEGER               DIRLOC
      INTEGER               REMAIN
      INTEGER               SKIP
      INTEGER               GRPADD
      INTEGER               ADDR
      INTEGER               LADDR
      INTEGER               RADDR
      INTEGER               PSIZ
      INTEGER               I
      INTEGER               N

      DOUBLE PRECISION      DCD    ( ND     )
      DOUBLE PRECISION      BUFFER ( BUFSIZ )
      DOUBLE PRECISION      LSCLK
      DOUBLE PRECISION      RSCLK
      DOUBLE PRECISION      RDIFF
      DOUBLE PRECISION      LDIFF
      DOUBLE PRECISION      START
      DOUBLE PRECISION      NSTART
      DOUBLE PRECISION      PREVS
      DOUBLE PRECISION      PREVN

      LOGICAL               FND

C
C     Saved variables.
C

      SAVE                  PREVS
      SAVE                  PREVN
      SAVE                  LHAND
      SAVE                  LBEG
      SAVE                  LEND

C
C     Initial values.
C
      DATA    PREVS   / -1.D0 /

      DATA    PREVN   / -1.D0 /

      DATA    LHAND   / 0     /

      DATA    LBEG    / -1    /

      DATA    LEND    / -1    /

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

C
C     Start off with FOUND equal to false just in case a SPICELIB error
C     is signalled and the return mode is not set to ABORT.
C
      FOUND = .FALSE.

C
C     We need to look at a few of the descriptor components.
C
C     The unpacked descriptor contains the following information
C     about the segment:
C
C        DCD(1)  Initial encoded SCLK
C        DCD(2)  Final encoded SCLK
C        ICD(1)  Instrument
C        ICD(2)  Inertial reference frame
C        ICD(3)  Data type
C        ICD(4)  Angular velocity flag
C        ICD(5)  Initial address of segment data
C        ICD(6)  Final address of segment data
C

      CALL DAFUS ( DESCR, ND, NI, DCD, ICD )

C
C     Check to make sure that the segment is type 3.
C
      IF ( ICD( 3 ) .NE. DTYPE ) THEN

         CALL SETMSG ( 'The segment is not a type 3 segment.  '   //
     .                 'Type is #'                                 )
         CALL ERRINT ( '#', ICD(3)                                 )
         CALL SIGERR ( 'SPICE(WRONGDATATYPE)'                      )
         CALL CHKOUT ( 'CKR03'                                     )
         RETURN

      END IF

C
C     Does this segment contain angular velocity?
C
      IF ( ICD ( 4 ) .EQ. 1 ) THEN

         PSIZ = QAVSIZ

      ELSE

         PSIZ = QSIZ

         IF ( NEEDAV ) THEN

            CALL SETMSG ( 'Segment does not contain angular velocity '//
     .                    'data.'                                      )
            CALL SIGERR ( 'SPICE(NOAVDATA)'                            )
            CALL CHKOUT ( 'CKR03'                                      )
            RETURN

         END IF

      END IF

C
C     The beginning and ending addresses of the segment are in the
C     descriptor.
C
      BEG = ICD( 5 )
      END = ICD( 6 )

C
C     The procedure used in finding a record to satisfy the request
C     for pointing is as follows:
C
C        1) Find the two pointing instances in the segment that bracket
C           the request time.
C
C           The pointing instance that brackets the request time on the
C           left is defined to be the one associated with the largest
C           time in the segment that is less than or equal to SCLKDP.
C
C           The pointing instance that brackets the request time on the
C           right is defined to be the one associated with the first
C           time in the segment greater than SCLKDP.
C
C           Since the times in the segment are strictly increasing the
C           left and right bracketing pointing instances are always
C           adjacent.
C
C        2) Determine if the bracketing times are in the same
C           interpolation interval.
C
C        3) If they are, then pointing at the request time may be
C           linearly interpolated from the bracketing times.
C
C        4) If the times that bracket the request time are not in the
C           same interval then, since they are adjacent in the segment
C           and since intervals begin and end at actual times, they must
C           both be interval endpoints.  Return the pointing instance
C           associated with the endpoint closest to the request time,
C           provided that it is within the tolerance.
C

C
C     Get the number of intervals and pointing instances ( records )
C     in this segment, and from that determine the number of respective
C     directory epochs.
C
      CALL DAFGDA ( HANDLE, END - 1, END, BUFFER )

      NUMINT  = NINT ( BUFFER ( 1 ) )
      NUMREC  = NINT ( BUFFER ( 2 ) )

      NIDIR   = ( NUMINT - 1 ) / DIRSIZ
      NRDIR   = ( NUMREC - 1 ) / DIRSIZ

C
C     Check the FAILED flag just in case HANDLE is not attached to
C     any DAF file and the error action is not set to ABORT. You need
C     need to do this only after the first call to DAFGDA.
C
      IF ( FAILED() ) THEN
         CALL CHKOUT ( 'CKR03' )
         RETURN
      END IF

C
C     To find the times that bracket the request time we will first
C     find the greatest directory time less than the request time.
C     This will narrow down the search to a group of DIRSIZ or fewer
C     times where the Jth group is defined to contain SCLK times
C     ((J-1)*DIRSIZ + 1) through (J*DIRSIZ).
C
C     For example if DIRSIZ = 100 then:
C
C                         group   first time #     last time #
C                         -----  ---------------   ------------
C                           1            1             100
C                           2          101             200
C                           .            .               .
C                           .            .               .
C                          10          901            1000
C                           .            .               .
C                           .            .               .
C                     NRDIR+1     (NRDIR)*100+1     NUMREC
C
C
C     Thus if the Ith directory time is the largest one less than
C     our request time SCLKDP, then we know that:
C
C       SCLKS ( DIRSIZ * I ) <  SCLKDP  <= SCLKS ( DIRSIZ * (I+1) )
C
C     where SCLKS is taken to be the array of NUMREC times associated
C     with the pointing instances.
C
C     Therefore, at least one of the bracketing times will come from
C     the (I+1)th group.
C

C
C     There is only one group if there are no directory epochs.
C
      IF ( NRDIR .EQ. 0 ) THEN

         GROUP = 1

      ELSE
C
C        Compute the location of the first directory epoch.  From the
C        beginning of the segment, we need to go through all of the
C        pointing numbers (PSIZ*NUMREC of them) and then through all of
C        the NUMREC SCLK times.
C
         DIRLOC = BEG + ( PSIZ + 1 ) * NUMREC
C
C        Search through the directory times.  Read in as many as BUFSIZ
C        directory epochs at a time for comparison.
C
         FND    = .FALSE.
         REMAIN =  NRDIR
         GROUP  =  0

         DO WHILE ( .NOT. FND )
C
C           The number of records to read into the buffer.
C
            N = MIN( REMAIN, BUFSIZ )

            CALL DAFGDA ( HANDLE, DIRLOC, DIRLOC + N - 1, BUFFER )

            REMAIN = REMAIN - N
C
C           Determine the last directory element in BUFFER that's less
C           than SCLKDP.
C
            I = LSTLTD( SCLKDP, N, BUFFER )

            IF ( I .LT. N ) THEN

               GROUP =  GROUP + I + 1
               FND   = .TRUE.

            ELSE IF ( REMAIN .EQ. 0 ) THEN
C
C              The request time is greater than the last directory time
C              so we want the last group in the segment.
C
               GROUP =  NRDIR + 1
               FND   = .TRUE.

            ELSE
C
C              Need to read another block of directory times.
C
               DIRLOC = DIRLOC + N
               GROUP  = GROUP  + N

            END IF

         END DO

      END IF

C
C     Now we know which group of DIRSIZ (or less) times to look at.
C     Out of the NUMREC SCLK times, the number that we should skip over
C     to get to the proper group is DIRSIZ * ( GROUP - 1 ).
C
      SKIP = DIRSIZ * ( GROUP - 1 )

C
C     From this we can compute the address in the segment of the group
C     of times we want.  From the beginning, we need to pass through
C     PSIZ * NUMREC pointing numbers to get to the first SCLK time.
C     Then we skip over the number just computed above.
C
      GRPADD = BEG  +  ( NUMREC * PSIZ )  +  SKIP

C
C     The number of times that we have to look at may be less than
C     DIRSIZ.  However many there are, go ahead and read them into the
C     buffer.
C
      N = MIN ( DIRSIZ, NUMREC - SKIP )

      CALL DAFGDA ( HANDLE, GRPADD, GRPADD + N - 1, BUFFER )

C
C     Find the largest time in the group less than or equal to the input
C     time.
C
      I = LSTLED ( SCLKDP, N, BUFFER )

C
C     Find the pointing instances in the segment that bracket the
C     request time and calculate the addresses for the pointing data
C     associated with these times. For cases in which the request time
C     is equal to one of the times in the segment, that time will be
C     the left bracketing time of the returned pair.
C
C     Need to handle the cases when the request time is greater than
C     the last or less than the first time in the segment separately.
C

      IF ( I .EQ. 0 ) THEN

         IF ( GROUP .EQ. 1 ) THEN
C
C           The time occurs before the first time in the segment. Since
C           this time cannot possibly be in any of the intervals, the
C           first time can satisfy the request for pointing only if it
C           is within the tolerance of the request time.
C
            IF ( ( BUFFER(1) - SCLKDP ) .LE. TOL ) THEN

               RECORD ( 1 ) = BUFFER(1)
               RECORD ( 9 ) = BUFFER(1)
C
C              Calculate the address of the quaternion and angular
C              velocity data.  Then read it from the file.
C
               CALL DAFGDA ( HANDLE, BEG, BEG + PSIZ - 1, BUFFER )

               CALL MOVED ( BUFFER, PSIZ, RECORD ( 2  ) )
               CALL MOVED ( BUFFER, PSIZ, RECORD ( 10 ) )

               RECORD ( 17 ) = SCLKDP

               FOUND = .TRUE.

            END IF

            CALL CHKOUT ( 'CKR03' )
            RETURN

         ELSE

C
C           The first time in the current group brackets the request
C           time on the right and the last time from the preceding
C           group brackets on the left.
C
            RSCLK = BUFFER ( 1 )

            RADDR = BEG  +  SKIP * PSIZ

            CALL DAFGDA ( HANDLE, GRPADD - 1, GRPADD - 1, LSCLK )

            LADDR = RADDR - PSIZ

         END IF

      ELSE  IF ( I .EQ. N ) THEN

C
C        There are two possible cases, but the same action can handle
C        both.
C
C        1) If this is the last group ( NRDIR + 1 ) then the request
C           time occurs on or after the last time in the segment.
C           In either case this last time can satisfy the request for
C           pointing only if it is within the tolerance of the request
C           time.
C
C        2) The request time is greater than or equal to the last time
C           in this group. Since this time is the same as the (I+1)th
C           directory time, and since the search on the directory times
C           used a strictly less than test, we know that the request
C           time must be equal to this time.  Just return the pointing
C           instance associated with the request time.  ( Note that
C           SCLKDP - BUFFER(N) will be zero in this case. )
C

         IF ( ( SCLKDP - BUFFER(N) ) .LE. TOL ) THEN

            RECORD ( 1 ) = BUFFER(N)
            RECORD ( 9 ) = BUFFER(N)
C
C           Calculate the address of the quaternion and angular
C           velocity data.  Then read it from the file.
C
            ADDR = BEG + PSIZ * ( SKIP + N - 1 )

            CALL DAFGDA ( HANDLE, ADDR, ADDR + PSIZ - 1, BUFFER )

            CALL MOVED ( BUFFER, PSIZ, RECORD ( 2  ) )
            CALL MOVED ( BUFFER, PSIZ, RECORD ( 10 ) )

            RECORD ( 17 ) = SCLKDP

            FOUND = .TRUE.

         END IF

         CALL CHKOUT ( 'CKR03' )
         RETURN

      ELSE

C
C        The bracketing times are contained in this group.
C
         LSCLK = BUFFER ( I     )
         RSCLK = BUFFER ( I + 1 )

         LADDR = BEG  +  ( SKIP + I - 1 ) * PSIZ

         RADDR = LADDR + PSIZ

      END IF

C
C     At this point we have the two times in the segment that bracket
C     the request time.  We also have the addresses of the pointing
C     data associated with those times. The task now is to determine
C     if the bracketing times fall in the same interval.  If so then
C     we can interpolate between them.  If they don't then return
C     pointing for whichever of the two times is closest to the
C     request time, provided that it is within the tolerance.
C

C
C     Find the interpolation interval that the request time is in and
C     determine if the bracketing SCLK's are both in it.
C
C     First check if the request time falls in the same interval as
C     it did last time.  We need to make sure that we are dealing
C     with the same segment as well as the same time range.
C
C
C     PREVS      is the start time of the interval that satisfied
C                the previous request for pointing.
C
C     PREVN      is the start time of the interval that followed
C                the interval specified above.
C
C     LHAND      is the handle of the file that PREVS and PREVN
C                were found in.
C
C     LBEG,      are the beginning and ending addresses of the
C     LEND       segment in the file LHAND that PREVS and PREVN
C                were found in.
C
      IF (  ( HANDLE .EQ. LHAND ) .AND.
     .      ( BEG    .EQ. LBEG  ) .AND.
     .      ( END    .EQ. LEND  ) .AND.
     .      ( SCLKDP .GE. PREVS ) .AND.
     .      ( SCLKDP .LT. PREVN )      ) THEN

         START  = PREVS
         NSTART = PREVN

      ELSE

C
C        The START times of all of the intervals are stored in the
C        segment and a directory of every hundredth START is also
C        stored. The procedure to find the bracketing interval start
C        times is identical to the one used above for finding the
C        bracketing times.
C
C        The directory epochs narrow down the search for the times that
C        bracket the request time to a group of DIRSIZ or fewer records.
C

C
C        There is only one group if there are no directory epochs.
C
         IF ( NIDIR .EQ. 0 ) THEN

            GROUP = 1

         ELSE
C
C           Compute the location of the first directory epoch.  From the
C           beginning of the segment, we need to go through all of the
C           pointing numbers (PSIZ*NUMREC of them), then through all of
C           the NUMREC SCLK times and NRDIR directory times, and then
C           finally through the NUMINT interval start times.
C
            DIRLOC = BEG + ( PSIZ + 1 ) * NUMREC  +  NRDIR  +  NUMINT

C
C           Locate the largest directory time less than the
C           request time SCLKDP.
C
C           Read in as many as BUFSIZ directory epochs at a time for
C           comparison.
C
            FND    = .FALSE.
            REMAIN =  NIDIR
            GROUP  =  0

            DO WHILE ( .NOT. FND )
C
C              The number of records to read into the buffer.
C
               N = MIN( REMAIN, BUFSIZ )

               CALL DAFGDA ( HANDLE, DIRLOC, DIRLOC + N - 1, BUFFER )

               REMAIN = REMAIN - N
C
C              Determine the last directory element in BUFFER that's
C              less than SCLKDP.
C
               I = LSTLTD ( SCLKDP, N, BUFFER )

               IF ( I .LT. N ) THEN

                  GROUP =  GROUP + I + 1
                  FND   = .TRUE.

               ELSE IF ( REMAIN .EQ. 0 ) THEN
C
C                 The request time is greater than the last directory
C                 time so we want the last group in the segment.
C
                  GROUP =  NIDIR + 1
                  FND   = .TRUE.

               ELSE
C
C                 Need to read another block of directory times.
C
                  DIRLOC = DIRLOC + N
                  GROUP  = GROUP  + N

               END IF

            END DO

         END IF

C
C        Now we know which group of DIRSIZ (or less) times to look at.
C        Out of the NUMINT SCLK START times, the number that we should
C        skip over to get to the proper group is DIRSIZ * ( GROUP - 1 ).
C
         SKIP = DIRSIZ * ( GROUP - 1 )

C
C        From this we can compute the address in the segment of the
C        group of times we want.  To get to the first interval start
C        time we must pass over PSIZ * NUMREC pointing numbers, NUMREC
C        SCLK times, and NRDIR SCLK directory times.  Then we skip
C        over the number just computed above.
C

         GRPADD = BEG  +  ( PSIZ + 1 ) * NUMREC  +  NRDIR  +  SKIP

C
C        The number of times that we have to look at may be less than
C        DIRSIZ.  However many there are, go ahead and read them into
C        the buffer.
C
         N = MIN ( DIRSIZ, NUMINT - SKIP )

         CALL DAFGDA ( HANDLE, GRPADD, GRPADD + N - 1, BUFFER )
C
C        Find the index of the largest time in the group that is less
C        than or equal to the input time.
C
         I = LSTLED ( SCLKDP, N, BUFFER )

         IF ( I .EQ. 0 ) THEN
C
C           The first start time in the buffer is the start of the
C           interval following the one containing the request time.
C
C           We don't need to check if GROUP = 1 because the case of
C           the request time occurring before the first time in the
C           segment has already been handled.
C
            NSTART = BUFFER (1)

            ADDR = GRPADD - 1

            CALL DAFGDA ( HANDLE, ADDR, ADDR, START )

         ELSE  IF ( I .EQ. N ) THEN

            IF ( GROUP .EQ. ( NIDIR + 1 ) ) THEN
C
C              This is the last interval in the segment.
C
               START = BUFFER ( N )

               NSTART = DPMAX ()

            ELSE
C
C              The last START time in this group is equal to the
C              request time.
C
               START = BUFFER ( N )

               ADDR = GRPADD + N

               CALL DAFGDA ( HANDLE, ADDR, ADDR, NSTART )

            END IF

         ELSE
C
C           The bracketing START times are contained in this group.
C
            START  = BUFFER ( I     )
            NSTART = BUFFER ( I + 1 )

         END IF

C
C        Save the information about the interval and segment.
C
         LHAND = HANDLE
         LBEG  = BEG
         LEND  = END
         PREVS = START
         PREVN = NSTART

      END IF

C
C     Check and see if the bracketing pointing instances belong
C     to the same interval.  If they do then we can interpolate
C     between them, if not then check to see if the closer of
C     the two to the request time lies within the tolerance.
C
C     The left bracketing time will always belong to the same
C     interval as the request time, therefore we need to check
C     only that the right bracketing time is less than the start
C     time of the next interval.
C

      IF ( RSCLK .LT. NSTART ) THEN

         RECORD ( 1 ) = LSCLK

         CALL DAFGDA ( HANDLE, LADDR, LADDR + PSIZ - 1, RECORD ( 2 ) )

         RECORD ( 9 ) = RSCLK

         CALL DAFGDA ( HANDLE, RADDR, RADDR + PSIZ - 1, RECORD ( 10 ) )

         RECORD ( 17 ) = SCLKDP

         FOUND = .TRUE.

      ELSE

         LDIFF = SCLKDP - LSCLK
         RDIFF = RSCLK  - SCLKDP

         IF ( ( LDIFF .LE. TOL ) .OR. ( RDIFF .LE. TOL ) ) THEN
C
C           Return the pointing instance closest to the request time.
C
C           If the request time is midway between LSCLK and RSCLK then
C           grab the pointing instance associated with the greater time.
C
            IF ( LDIFF .LT. RDIFF ) THEN

               RECORD ( 1 ) = LSCLK
               RECORD ( 9 ) = LSCLK

               CALL DAFGDA ( HANDLE, LADDR, LADDR+PSIZ-1, BUFFER )

               CALL MOVED ( BUFFER, PSIZ, RECORD ( 2  ) )
               CALL MOVED ( BUFFER, PSIZ, RECORD ( 10 ) )

            ELSE

               RECORD ( 1 ) = RSCLK
               RECORD ( 9 ) = RSCLK

               CALL DAFGDA ( HANDLE, RADDR, RADDR+PSIZ-1, BUFFER )

               CALL MOVED ( BUFFER, PSIZ, RECORD ( 2  ) )
               CALL MOVED ( BUFFER, PSIZ, RECORD ( 10 ) )

            END IF

            RECORD ( 17 ) = SCLKDP

            FOUND = .TRUE.

         END IF

      END IF

      CALL CHKOUT ( 'CKR03' )

      RETURN
      END


      subroutine pot(symb,x,y,z,v,dvdx,dvdy,dvdz,natom,maxatom)

      implicit real*8(a-h,o-z)
      dimension x(maxatom),y(maxatom),z(maxatom)
      dimension x2(maxatom),y2(maxatom),z2(maxatom)
      dimension x3(maxatom),y3(maxatom),z3(maxatom)
      dimension dvdx(maxatom),dvdy(maxatom),dvdz(maxatom)
      dimension dvdx2(maxatom),dvdy2(maxatom),dvdz2(maxatom)
      dimension dvdx3(maxatom),dvdy3(maxatom),dvdz3(maxatom)
      parameter(autoev=27.2113961d0)
      parameter(autocmi=219474.63067d0)
      parameter(autoang=0.529177249d0)
      character*2 symb(maxatom),symb2(maxatom),symb3(maxatom)
      integer at(maxatom),at2(maxatom),at3(maxatom)

      dimension tmpprint(50)
      common/tmp/tmpprint

      v=0.d0
      v2=0.d0
      v3=0.d0
      do i=1,natom
      symb2(i)="xx"
      symb3(i)="xx"
      x2(i)=0.d0
      y2(i)=0.d0
      z2(i)=0.d0
      x3(i)=0.d0
      y3(i)=0.d0
      z3(i)=0.d0
      dvdz2(i)=0.d0
      dvdy2(i)=0.d0
      dvdx2(i)=0.d0
      dvdz3(i)=0.d0
      dvdy3(i)=0.d0
      dvdx3(i)=0.d0
      dvdz(i)=0.d0
      dvdy(i)=0.d0
      dvdx(i)=0.d0
      enddo

      do i=1,natom
      at(i)=0
      if ((symb(i).eq."H").or.
     &    (symb(i).eq."h"))  at(i)=1       ! hydrogen
      if ((symb(i).eq."C").or.
     &    (symb(i).eq."c"))  at(i)=2       ! carbon
      if ((symb(i).eq."N").or.
     &    (symb(i).eq."n"))  at(i)=3       ! nitrogen
      if ((symb(i).eq."O").or.
     &    (symb(i).eq."o"))  at(i)=4       ! oxygen
      if ((symb(i).eq."He").or.
     &    (symb(i).eq."he").or.
     &    (symb(i).eq."HE")) at(i)=21      ! helium
      if ((symb(i).eq."Ne").or.
     &    (symb(i).eq."ne").or.
     &    (symb(i).eq."NE")) at(i)=22      ! neon
      if ((symb(i).eq."Ar").or.
     &    (symb(i).eq."ar").or.
     &    (symb(i).eq."AR")) at(i)=23      ! argon
      if ((symb(i).eq."Kr").or.
     &    (symb(i).eq."kr").or.
     &    (symb(i).eq."KR")) at(i)=24      ! krypton
      if ((symb(i).eq."H2").or.
     &    (symb(i).eq."h2")) at(i)=25      ! H2  ! label your bath atoms H2, not H
      if ((symb(i).eq."N2").or.
     &    (symb(i).eq."n2")) at(i)=26      ! N2  ! label your bath atoms N2, not N
      if ((symb(i).eq."C2").or.
     &    (symb(i).eq."c2")) at(i)=27      ! CO bath ! label atoms C2 and O2
      if ((symb(i).eq."O2").or.
     &    (symb(i).eq."c2")) at(i)=28      ! CO bath ! label atoms C2 and O2
      if ((symb(i).eq."O3").or.
     &    (symb(i).eq."o3")) at(i)=29      ! O2 bath ! label atoms O3, not O (the numbers are just labels; yes, it is confusing)
      if (at(i).eq.0) then ! atom not found
           write(6,*)"Atom # ",i," (",symb(i),") not found"
           stop
      endif
      enddo

      natom2=0
      natom3=0
      do i=1,natom
        if (at(i).le.20) then ! collect target atoms
          natom2=natom2+1
          x2(natom2)=x(i)
          y2(natom2)=y(i)
          z2(natom2)=z(i)
          symb2(natom2)=symb(i)
          at2(natom2)=at(i)
        else ! collect bath atoms
          natom3=natom3+1
          x3(natom3)=x(i)
          y3(natom3)=y(i)
          z3(natom3)=z(i)
          symb3(natom3)=symb(i)
          at3(natom3)=at(i)
        endif
      enddo
c      print *,natom,natom2,natom3
      if (natom3.ne.0) then
c        call bath(at3,x3,y3,z3,v3,dvdx3,dvdy3,dvdz3,natom3,maxatom)
        call rgexp(at,x,y,z,v,dvdx,dvdy,dvdz,natom,maxatom)
      endif
      if (natom2.ne.0) then
        call imlspot(symb2,x2,y2,z2,v2,dvdx2,dvdy2,dvdz2,natom2,maxatom)
      endif

      tmpprint(1)=v

c      print *,'vplus',v,v2,v3

      v=v+v2+v3

      natom2=0
      natom3=0
      do i=1,natom
        if (at(i).le.20) then
        natom2=natom2+1
        dvdx(i)=dvdx(i)+dvdx2(natom2)
        dvdy(i)=dvdy(i)+dvdy2(natom2)
        dvdz(i)=dvdz(i)+dvdz2(natom2)
        else
        natom3=natom3+1
        dvdx(i)=dvdx(i)+dvdx3(natom3)
        dvdy(i)=dvdy(i)+dvdy3(natom3)
        dvdz(i)=dvdz(i)+dvdz3(natom3)
        endif
      enddo

      return

      end

      subroutine bath(at,x,y,z,v,dvdx,dvdy,dvdz,natom,maxatom)

      implicit real*8(a-h,o-z)
      dimension x(maxatom),y(maxatom),z(maxatom)
      dimension dvdx(maxatom),dvdy(maxatom),dvdz(maxatom)
      integer at(maxatom)
      parameter(autocmi=219474.63067d0)
      parameter(autoang=0.529177249d0)
      parameter(autoev=27.2113961d0)

      v=0.
      do i=1,natom
        dvdx(i)=0.d0
        dvdy(i)=0.d0
        dvdz(i)=0.d0
      enddo

      if (natom.eq.1) return

      if (natom.gt.2) then
         print *,"Can't handle more than 2 bath atoms"
         stop
      endif

      if (natom.eq.2) then
      dx=x(1)-x(2)
      dy=y(1)-y(2)
      dz=z(1)-z(2)
      rr=dsqrt(dx*dx+dy*dy+dz*dz)

        if (at(1).eq.25.and.at(2).eq.25) then
! H2 bath
!       From Hack's fit (eq 8 in Hack, Truhlar, JCP 110, 4315 (1999))
!                        to Kolos and Wolniewicz JCP 43, 2429 (1965)
!       Rmin = 1.40121 au, Vmin = -4.74772265 eV relative to H+H
        c1=139.7160d0        ! eV
        c2=-123.8978d0       ! eV / bohr
        c3=3.4031d0          ! 1 / bohr
        c4=-6.8725d0         ! eV / bohr**2
        c5=-23.0440d0        ! eV / bohr**3
        c6=2.032d0           ! 1 / bohr

        v=(c1+c2*rr)*dexp(-c3*rr)
     &   +(c4+c5*rr)*dexp(-c6*rr)*rr**2
c       move zero from asymptote to minimum
        v=v+4.74772265
c        print *,rr,v
        v=v/autoev

        dvdr=((c1+c2*rr)*(-c3)+c2)*dexp(-c3*rr)
     &      +((c4+c5*rr)*(-c6)+c5)*dexp(-c6*rr)*rr**2
     &       +(c4+c5*rr)*dexp(-c6*rr)*rr*2.d0
        dvdr=dvdr/autoev

        elseif (at(1).eq.29.and.at(2).eq.29) then
! O2 bath
!       fit to MRCI+Q/CBS(AQZ,A5Z) full valence
!       Jasper April 3, 2012
        de=42046.5d0 ! exp De in cm-1
        re=1.2075d0 ! exp in A
        c1= 2.6938139d0 ! my fit
        c2= 0.384763939d0
        c3= 0.812506485d0

        yy=rr*autoang-re
        beta = c1+c2*yy+c3*yy**2
        v = de*(1.d0-dexp(-beta*yy))**2    ! A and cm-1
        v=v/autocmi  ! convert to au

c        print *,rr,yy,beta,v

        dvdr=c1+2.d0*c2*yy+3.d0*c3*yy**2
        dvdr=dvdr*2.d0*de*(1.d0-dexp(-beta*yy))*dexp(-beta*yy)
        dvdr=dvdr*autoang/autocmi  ! convert to au

c        print *,dvdr

        elseif (at(1).eq.26.and.at(2).eq.26) then
! N2 bath
!       fit to MRCI+Q/CBS(AQZ,A5Z) full valence
!       agrees reasonably well with more complicated form of LeRoy (JCP 125, 164310 (2006))
!       Jasper June 9, 2010
        de=79845.d0 ! exp De in cm-1 (Ronin, Luanay, Larzillier,
!                                     PRL 53, 159 (1984), as quoted by LeRoy)
        re=1.097679d0 ! exp in A
        c1=2.68872341 ! my fit
        c2=0.240070803
        c3=0.472261727

        yy=rr*autoang-re
        beta = c1+c2*yy+c3*yy**2
        v = de*(1.d0-dexp(-beta*yy))**2    ! A and cm-1
        v=v/autocmi  ! convert to au

c        print *,rr,yy,beta,v

        dvdr=c1+2.d0*c2*yy+3.d0*c3*yy**2
        dvdr=dvdr*2.d0*de*(1.d0-dexp(-beta*yy))*dexp(-beta*yy)
        dvdr=dvdr*autoang/autocmi  ! convert to au

c        print *,dvdr

        elseif ((at(1).eq.27.and.at(2).eq.28).or.
     &          (at(1).eq.28.and.at(2).eq.27)) then
! CO bath
!       Morse. Fit to RKR data of PAUL H. KRUPENIE and STANLEY WEISSMAN, J. CHEM. PHYS. 43, 1529 (1965)
!       with De = 11.06 eV
        de=11.06d0    ! exp De in eV
        de=de/autoev
        re=1.128322d0 ! exp in A
        re=re/autoang
        beta=1.d0/0.428d0  ! my fit in 1/A
        beta=beta*autoang

        yy=rr-re
        v = de*(1.d0-dexp(-beta*yy))**2
        dvdr=2.d0*de*(1.d0-dexp(-beta*yy))*dexp(-beta*yy)*beta

!       elseif (at(1).eq.??.and.at(2).eq.??) then
! OTHER DIATOMIC BATHS HERE
        else
        print *,"Don't know this diatomic bath"
        stop
        endif

      dvdx(1) =  dvdr*dx/rr
      dvdx(2) = -dvdr*dx/rr
      dvdy(1) =  dvdr*dy/rr
      dvdy(2) = -dvdr*dy/rr
      dvdz(1) =  dvdr*dz/rr
      dvdz(2) = -dvdr*dz/rr

      endif

      return
      end

      subroutine rgexp(at,x,y,z,v,dvdx,dvdy,dvdz,natom,maxatom)
c Rare Gas exp6 potential subroutine
c loops over geometry and looks for Rg-X interactions
c returns the full Rg-target intermolecular potential and its derivatives

      implicit real*8(a-h,o-z)
      dimension x(maxatom),y(maxatom),z(maxatom)
      dimension dvdx(maxatom),dvdy(maxatom),dvdz(maxatom)
      parameter(autoev=27.2113961d0)
      parameter(autocmi=219474.63067d0)
      parameter(autokcal=627.509d0)
      parameter(autoang=0.529177249d0)
      integer at(maxatom)
      logical troya,cutoff

      v1=0.d0
      v=0.d0
      do i=1,natom
      dvdz(i)=0.d0
      dvdy(i)=0.d0
      dvdx(i)=0.d0
      enddo

      do 1 i=1,natom
      do 2 j=i+1,natom

      m1=min(at(i),at(j))
      m2=max(at(i),at(j))
      troya=.false.   ! do or don't use Troya's form
      cutoff=.false.   ! do or don't use cutoff

      if (m1.ge.21) then ! two rare gases, skip this pair
         go to 2
      endif
      if (m2.le.20) then ! no rare gas, skip this pair
         go to 2
      endif

      if (m2.eq.24) then  ! Kr-
        if (m1.eq.2) then !    C
c        aa=ccc(1)
c        bb=ccc(2)
c        cc=ccc(3)
c        rrc=ccc(4)
        aa=7.75022431
        bb=0.259142125
        cc=7.87899411
        rrc=2.21254921
        cutoff=.true.
        aa=10.d0**aa
        elseif (m1.eq.4) then !    O
c        aa=ccc(5)
c        bb=ccc(6)
c        cc=ccc(7)
c        rrc=ccc(8)
        aa=7.72470473
        bb=0.271240883
        cc=8.65068819
        rrc=2.25741142
        cutoff=.true.
        aa=10.d0**aa
        else
          write(6,*)"Cant find a Kr-? interaction"
          stop
        endif
      else
          write(6,*)"Cant find a ?-? interaction"
          stop
      endif
      dx=x(i)-x(j)
      dy=y(i)-y(j)
      dz=z(i)-z(j)
      rr=dsqrt(dx*dx+dy*dy+dz*dz)
      rra=rr*autoang

! NOTE CANNOT HAVE BOTH TROYA FORM AND CUTOFF FORM

      if (troya) then   ! Troya uses different form & units
        v=aa*dexp(-rra*bb)+cc/rra**6
        v=v/autokcal
        dvdr = -aa*bb*dexp(-rra*bb)-6.d0*cc/rra**7
        dvdr=dvdr/autokcal*autoang
      elseif (cutoff) then  ! cutoff 1/R**-6 at short distances
        v=aa*dexp(-rra/bb)-(cc**6/(rra**6+rrc**6))
        v=v/autocmi
        dvdr = -aa/bb*dexp(-rra/bb)
     &      +6.d0*(cc**6)*(rra**5)/(rra**6+rrc**6)**2
        dvdr=dvdr/autocmi*autoang
      else
        v=aa*dexp(-rra/bb)-(cc/rra)**6
        v=v/autocmi
        dvdr = -aa/bb*dexp(-rra/bb)+(6.d0/rra)*(cc/rra)**6
        dvdr=dvdr/autocmi*autoang
      endif
        v1=v1+v

c      print *,m1,m2,rra,v*autocmi,v1*autocmi

c derivs = sum over all bonds (DV/DRij * DRij/DXi = DV/DRij * (Xi-Xj)/Rij)
      dvdx(i) = dvdx(i) + dvdr*dx/rr
      dvdx(j) = dvdx(j) - dvdr*dx/rr
      dvdy(i) = dvdy(i) + dvdr*dy/rr
      dvdy(j) = dvdy(j) - dvdr*dy/rr
      dvdz(i) = dvdz(i) + dvdr*dz/rr
      dvdz(j) = dvdz(j) - dvdr*dz/rr

    2 continue
    1 continue
      v=v1
c      print *,'rgexp',v1
      return
      end


module iteration_lucy

  use core_lib, only : idp, dp, random_exp, random, error, warn

  use type_photon, only : photon

  use sources, only : emit, energy_current, energy_total

  use mpi_core, only : main_process, mp_join
  use mpi_routines, only : mp_reset_first, &
       &                   mp_n_photons, &
       &                   mp_sync, &
       &                   mp_collect_physical_arrays, &
       &                   mp_broadcast_specific_energy

  use peeled_images, only : make_peeled_images, &
       &                    peeloff_photon, &
       &                    peeled_images_adjust_scale
  use binned_images, only : make_binned_images, &
       &                    binned_images_bin_photon, &
       &                    binned_images_adjust_scale

  use dust_interact, only : interact

  use grid_geometry, only : escaped

  use grid_generic, only : grid_reset_energy

  use grid_physics, only : tau_inv_planck_to_closest_wall, &
       &                   precompute_jnu_var, &
       &                   update_alpha_inv_planck, &
       &                   update_energy_abs, &
       &                   sublimate_dust

  use grid_propagate, only : grid_escape_tau, &
       &                     grid_integrate

  use grid_mrw, only : prepare_mrw, &
       &               grid_do_mrw

  use grid_pda, only : solve_pda

  use settings, only : kill_on_absorb, kill_on_scatter, &
       &               n_inter_max, &
       &               n_inter_max_warn, &
       &               mrw_gamma, &
       &               n_mrw_max, &
       &               n_mrw_max_warn, &
       &               n_reabs_max, &
       &               n_reabs_max_warn, &
       &               use_mrw, &
       &               use_pda

  use performance, only : perf_header, perf_footer

  use counters, only : killed_photons_int

  implicit none
  save

  private
  public :: do_lucy

contains

  subroutine do_lucy(n_photons_tot,n_photons_chunk)

    implicit none

    ! Number of photons to run, and max size of chunk to use
    integer(idp),intent(in) :: n_photons_tot, n_photons_chunk

    ! Number of photons to run in chunk, and number of photons emitted so far
    integer(idp) :: n_photons, n_photons_curr

    ! Photon object and variable to loop over photons
    integer :: ip, ia
    type(photon) :: p

    ! Number of interactions
    integer :: interactions,mrw_steps

    ! Optical depth to travel
    real(dp) :: tau

    ! REMOVE
    real(dp) :: tau_achieved

    if(n_photons_tot == 0) then
       if(main_process()) then
          write(*,*)
          write(*,'("      ------------------ Skipping ------------------")')
          write(*,*)
       end if
       return
    end if

    n_photons_curr = 0

    ! Reset iteration-specific summation variables
    call grid_reset_energy()
    energy_current = 0._dp

    ! Tell multi-process routines that this is the start of an iteration
    call mp_reset_first()

    call precompute_jnu_var()

    if(use_mrw) then
       call update_alpha_inv_planck()
       call prepare_mrw()
    end if

    call mp_join()

    if(main_process()) call perf_header()

    ! Start loop over chunks of photons
    do

       ! Find out how many photons to run
       call mp_n_photons(n_photons_tot, n_photons_curr, n_photons_chunk, n_photons)

       if(n_photons==0) exit

       ! Compute all photons in chunk
       do ip=1,n_photons

          ! Emit photon
          call emit(p)

          ! Propagate photon
          do interactions=1, n_inter_max+1

             ! If this is not the first interaction, and the user requested to
             ! use the MRW, do the MRW to get out of the optically thick region

             if(use_mrw.and.interactions > 1) then
                do mrw_steps=1,n_mrw_max
                   if(tau_inv_planck_to_closest_wall(p) > mrw_gamma) then
                      call grid_do_mrw(p)
                   else
                      exit
                   end if
                end do
                if(mrw_steps == n_mrw_max + 1) then
                   if(n_mrw_max_warn) call warn("do_lucy","maximum number of MRW steps exceeded - killing")
                   killed_photons_int = killed_photons_int + 1
                   p%killed = .true.
                   exit
                end if
             end if

             ! Sample a random optical depth and propagate that optical depth
             call random_exp(tau)
             call grid_integrate(p,tau,tau_achieved)

             if(p%reabsorbed) then

                ! Loop until the photon finally escapes interacting with sources
                do ia=1,n_reabs_max

                   ! The parentheses are required in the following expression to
                   ! force the evaluation of the option (otherwise it gets reset
                   ! because p has intent(out) from emit)
                   call emit(p, reemit=.true., reemit_id=(p%reabsorbed_id), reemit_energy=(p%energy))

                   ! Sample optical depth and travel
                   call random_exp(tau)
                   call grid_integrate(p,tau,tau_achieved)

                   ! If we haven't intersected another source, we can proceed
                   if(.not.p%reabsorbed) exit

                end do

                ! Check that we haven't reached the maximum number of successive reabsorptions
                if(ia == n_reabs_max + 1) then
                   if(n_reabs_max_warn) call warn('do_lucy', 'maximum number of successive re-absorptions exceeded')
                   killed_photons_int = killed_photons_int + 1
                   p%killed = .true.
                   exit
                end if

             end if

             ! Check whether the photon has escaped the grid or was killed
             if(p%killed.or.escaped(p)) exit

             ! We do the following check here rather than after the loop,
             ! because if we limit for example to one interaction, we need to
             ! allow propagation, interaction, propagation.
             if(interactions==n_inter_max + 1) then
                if(n_inter_max_warn) call warn("do_lucy","photon exceeded maximum number of interactions - killing")
                killed_photons_int = killed_photons_int + 1
                p%killed = .true.
                exit
             end if

             ! Absorb & re-emit, or scatter
             call interact(p)
             p%killed = (kill_on_scatter .and. p%scattered) .or. (kill_on_absorb .and. .not.p%scattered)
             if(p%killed) exit

          end do

       end do

    end do

    call mp_join()

    if(main_process()) call perf_footer()

    ! Collect all summation arrays in main process
    call mp_collect_physical_arrays()

    ! Sync energy emitted
    call mp_sync(energy_current)

    if(main_process()) then

       ! Scale the energy so the total is the total requested
       call update_energy_abs(energy_total/energy_current)

       ! Run PDA
       if(use_pda) call solve_pda()

    end if

    ! Broadcast specific energy out to processes
    call mp_broadcast_specific_energy()

    ! Sublimate dust if needed
    call sublimate_dust()

  end subroutine do_lucy

end module iteration_lucy


Subroutine htop
  Parameter (maxstr=150001)
  Parameter (maxptn=400001)
  Parameter (maxidl=4001)
  Double Precision gx0, gy0, gz0, ft0, px0, py0, pz0, e0, xmass0
  Double Precision pxsgs, pysgs, pzsgs, pesgs, pmsgs, gxsgs, gysgs, gzsgs, ftsgs, ptwo, xmdq, ptwox, ptwoy, ptwoz
  Dimension it(4)
  Common /hmain2/katt(maxstr, 4), patt(maxstr, 4)
  Common /hmain1/eatt, jatt, natt, nt, np, n0, n01, n10, n11
  Common /para1/mul
  Common /prec1/gx0(maxptn), gy0(maxptn), gz0(maxptn), ft0(maxptn), px0(maxptn), py0(maxptn), pz0(maxptn), e0(maxptn), xmass0(maxptn), ityp0(maxptn)
  Common /ilist7/lstrg0(maxptn), lpart0(maxptn)
  Common /arprc/itypar(maxstr), gxar(maxstr), gyar(maxstr), gzar(maxstr), ftar(maxstr), pxar(maxstr), pyar(maxstr), pzar(maxstr), pear(maxstr), xmar(maxstr)
  Common /decom/ptwo(2, 5)
  Common /rndf77/nseed
  Common /noprec/nnozpc, itypn(maxidl), gxn(maxidl), gyn(maxidl), gzn(maxidl), ftn(maxidl), pxn(maxidl), pyn(maxidl), pzn(maxidl), een(maxidl), xmn(maxidl)
  Common /hparnt/hipr1(100), ihpr2(50), hint1(100), ihnt2(50)
  Common /soft/pxsgs(maxstr, 3), pysgs(maxstr, 3), pzsgs(maxstr, 3), pesgs(maxstr, 3), pmsgs(maxstr, 3), gxsgs(maxstr, 3), gysgs(maxstr, 3), gzsgs(maxstr, 3), ftsgs(maxstr, 3), k1sgs(maxstr, 3), k2sgs(maxstr, 3), njsgs(maxstr)
  Common /anim/nevent, isoft, isflag, izpc
  Double Precision vxp0, vyp0, vzp0, xstrg0, ystrg0, xstrg, ystrg
  Common /precpa/vxp0(maxptn), vyp0(maxptn), vzp0(maxptn), xstrg0(maxptn), ystrg0(maxptn), xstrg(maxptn), ystrg(maxptn), istrg0(maxptn), istrg(maxptn)
  Common /para7/ioscar, nsmbbbar, nsmmeson
  Common /arevt/iaevt, iarun, miss
  Common /snn/efrm, npart1, npart2, epsipz, epsipt, pzproj, pztarg
  Save
  npar = 0
  nnozpc = 0
  If ((isoft==4 .Or. isoft==5) .And. (ioscar==2 .Or. ioscar==3)) Then
     nsmbbbar = 0
     nsmmeson = 0
     Do i = 1, natt
        id = itypar(i)
        idabs = iabs(id)
        i2 = mod(idabs/10, 10)
        If (abs(pxar(i))<=epsipt .And. abs(pyar(i))<=epsipt .And. (pzar(i)>amax1(0.,pzproj-epsipz) .Or. pzar(i)<(-pztarg+epsipz)) .And. (id==2112 .Or. id==2212)) Then
        Else If (idabs>1000 .And. i2/=0) Then
           nsmbbbar = nsmbbbar + 1
        Else If ((idabs>100 .And. idabs<1000) .Or. idabs>10000) Then
           nsmmeson = nsmmeson + 1
        End If
     End Do
     If (ioscar==2 .Or. ioscar==3) Then
        Write (92, *) iaevt, miss, 3*nsmbbbar + 2*nsmmeson, nsmbbbar, nsmmeson, natt, natt - nsmbbbar - nsmmeson
     End If
  End If
  Do i = 1, natt
     id = itypar(i)
     idabs = iabs(id)
     i4 = mod(idabs/1000, 10)
     i3 = mod(idabs/100, 10)
     i2 = mod(idabs/10, 10)
     i1 = mod(idabs, 10)
     rnum = ranart(nseed)
     ftime = 0.197*pear(i)/(pxar(i)**2+pyar(i)**2+xmar(i)**2)
     inozpc = 0
     it(1) = 0
     it(2) = 0
     it(3) = 0
     it(4) = 0
     If (abs(pxar(i))<=epsipt .And. abs(pyar(i))<=epsipt .And. (pzar(i)>amax1(0.,pzproj-epsipz) .Or. pzar(i)<(-pztarg+epsipz)) .And. (id==2112 .Or. id==2212)) Then
        inozpc = 1
     Else If (idabs>1000 .And. i2/=0) Then
        If (((i4==1 .Or. i4==2) .And. i4==i3) .Or. (i4==3 .And. i3==3)) Then
           If (i1==2) Then
              If (rnum<=(1./2.)) Then
                 it(1) = i4
                 it(2) = i3*1000 + i2*100 + 1
              Else If (rnum<=(2./3.)) Then
                 it(1) = i4
                 it(2) = i3*1000 + i2*100 + 3
              Else
                 it(1) = i2
                 it(2) = i4*1000 + i3*100 + 3
              End If
           Else If (i1==4) Then
              If (rnum<=(2./3.)) Then
                 it(1) = i4
                 it(2) = i3*1000 + i2*100 + 3
              Else
                 it(1) = i2
                 it(2) = i4*1000 + i3*100 + 3
              End If
           End If
        Else If (i4==1 .Or. i4==2) Then
           If (i1==2) Then
              If (rnum<=(1./2.)) Then
                 it(1) = i2
                 it(2) = i4*1000 + i3*100 + 1
              Else If (rnum<=(2./3.)) Then
                 it(1) = i2
                 it(2) = i4*1000 + i3*100 + 3
              Else
                 it(1) = i4
                 it(2) = i3*1000 + i2*100 + 3
              End If
           Else If (i1==4) Then
              If (rnum<=(2./3.)) Then
                 it(1) = i2
                 it(2) = i4*1000 + i3*100 + 3
              Else
                 it(1) = i4
                 it(2) = i3*1000 + i2*100 + 3
              End If
           End If
        Else If (i4>=3) Then
           it(1) = i4
           If (i3<i2) Then
              it(2) = i2*1000 + i3*100 + 1
           Else
              it(2) = i3*1000 + i2*100 + 3
           End If
        End If
        If (id<0) Then
           it(1) = -it(1)
           it(2) = -it(2)
        End If
        If (isoft==4 .Or. isoft==5) Then
           it(3) = mod(it(2)/1000, 10)
           it(4) = mod(it(2)/100, 10)
        End If
     Else If ((idabs>100 .And. idabs<1000) .Or. idabs>10000) Then
        If (i3==i2) Then
           If (i3==1 .Or. i3==2) Then
              If (rnum<=0.5) Then
                 it(1) = 1
                 it(2) = -1
              Else
                 it(1) = 2
                 it(2) = -2
              End If
           Else
              it(1) = i3
              it(2) = -i3
           End If
        Else
           If ((isign(1,id)*(-1)**i3)==1) Then
              it(1) = i3
              it(2) = -i2
           Else
              it(1) = i2
              it(2) = -i3
           End If
        End If
     Else
        inozpc = 1
     End If
     If (inozpc==1) Then
        njsgs(i) = 0
        nnozpc = nnozpc + 1
        itypn(nnozpc) = itypar(i)
        pxn(nnozpc) = pxar(i)
        pyn(nnozpc) = pyar(i)
        pzn(nnozpc) = pzar(i)
        een(nnozpc) = pear(i)
        xmn(nnozpc) = xmar(i)
        gxn(nnozpc) = gxar(i)
        gyn(nnozpc) = gyar(i)
        gzn(nnozpc) = gzar(i)
        ftn(nnozpc) = ftar(i)
     Else
        njsgs(i) = 2
        ptwo(1, 5) = dble(ulmass(it(1)))
        ptwo(2, 5) = dble(ulmass(it(2)))
        Call decomp(dble(patt(i,1)), dble(patt(i,2)), dble(patt(i,3)), dble(xmar(i)), i, it(1))
        ipamax = 2
        If ((isoft==4 .Or. isoft==5) .And. iabs(it(2))>1000) ipamax = 1
        Do ipar = 1, ipamax
           npar = npar + 1
           ityp0(npar) = it(ipar)
           px0(npar) = ptwo(ipar, 1)
           py0(npar) = ptwo(ipar, 2)
           pz0(npar) = ptwo(ipar, 3)
           e0(npar) = ptwo(ipar, 4)
           xmass0(npar) = ptwo(ipar, 5)
           gx0(npar) = dble(gxar(i))
           gy0(npar) = dble(gyar(i))
           gz0(npar) = dble(gzar(i))
           ft0(npar) = dble(ftime)
           lstrg0(npar) = i
           lpart0(npar) = ipar
           vxp0(npar) = dble(patt(i,1)/patt(i,4))
           vyp0(npar) = dble(patt(i,2)/patt(i,4))
           vzp0(npar) = dble(patt(i,3)/patt(i,4))
           xstrg(npar) = xstrg0(i)
           ystrg(npar) = ystrg0(i)
           istrg(npar) = istrg0(i)
        End Do
        If ((isoft==4 .Or. isoft==5) .And. iabs(it(2))>1000) Then
           njsgs(i) = 3
           xmdq = ptwo(2, 5)
           ptwo(1, 5) = dble(ulmass(it(3)))
           ptwo(2, 5) = dble(ulmass(it(4)))
           ptwox = ptwo(2, 1)
           ptwoy = ptwo(2, 2)
           ptwoz = ptwo(2, 3)
           Call decomp(ptwox, ptwoy, ptwoz, xmdq, i, it(1))
           Do ipar = 1, 2
              npar = npar + 1
              ityp0(npar) = it(ipar+2)
              px0(npar) = ptwo(ipar, 1)
              py0(npar) = ptwo(ipar, 2)
              pz0(npar) = ptwo(ipar, 3)
              e0(npar) = ptwo(ipar, 4)
              xmass0(npar) = ptwo(ipar, 5)
              gx0(npar) = dble(gxar(i))
              gy0(npar) = dble(gyar(i))
              gz0(npar) = dble(gzar(i))
              ft0(npar) = dble(ftime)
              lstrg0(npar) = i
              lpart0(npar) = ipar + 1
              vxp0(npar) = dble(patt(i,1)/patt(i,4))
              vyp0(npar) = dble(patt(i,2)/patt(i,4))
              vzp0(npar) = dble(patt(i,3)/patt(i,4))
              xstrg(npar) = xstrg0(i)
              ystrg(npar) = ystrg0(i)
              istrg(npar) = istrg0(i)
           End Do
        End If
     End If
  End Do
  mul = npar
  If ((isoft==4 .Or. isoft==5) .And. (ioscar==2 .Or. ioscar==3)) Then
     If ((natt-nsmbbbar-nsmmeson)/=nnozpc) Write (92, *) 'Problem with the total # of initial particles (gamma,e,muon,...) not entering ZPC'
     If ((3*nsmbbbar+2*nsmmeson)/=npar) Write (92, *) 'Problem with the total # of initial partons   after string melting'
  End If
  Return
200 Format (I6, 2(1X,F8.3), 1X, F10.3, 1X, F6.3, 4(1X,F8.2))
201 Format (I6, 2(1X,F8.3), 1X, F10.3, 1X, F6.3, 4(1X,E8.2))
End Subroutine htop


!Constant Variable
program Constant_Variable
    implicit none
    INTEGER, PARAMETER:: a = 6

    print *, a

    !a = 5 !will throw error
end program Constant_Variable


module da_radiance

   !---------------------------------------------------------------------------
   ! Purpose: module for radiance data assimilation.
   !---------------------------------------------------------------------------

#if defined(HDF5)
   use hdf5
#endif

#if defined(RTTOV) || defined(CRTM)

   use module_domain, only : xb_type, domain
   use module_radiance, only : satinfo, &
      i_kind,r_kind, r_double, &
       one, zero, three,deg2rad,rad2deg, &
      q2ppmv, &
      init_constants_derived, &
      rttov_platform_name, rttov_inst_name, crtm_sensor_name  ! names used by both RTTOV and CRTM
#ifdef RTTOV
   use module_radiance, only : coefs, rttov_coefs, rttov_profile, rttov_radiance, &
      rttov_transmission,errorstatus_success,gas_id_watervapour,rttov_emissivity
#endif
#ifdef CRTM
   use module_radiance, only : crtm_channelinfo_type, crtm_platform_name, crtm_init, &
   CRTM_Planck_Radiance, CRTM_Planck_Temperature
#endif

#ifdef DM_PARALLEL
!  use mpi, only : mpi_integer, mpi_status_size, mpi_min, mpi_max, mpi_minloc, &
!      mpi_2double_precision
#endif

   use da_control, only : max_ob_levels,missing_r, &
      v_interp_p, v_interp_h, trace_use_dull, &
      missing, max_error_uv, max_error_t, rootproc, &
      max_error_p,max_error_q, radiance, &
      max_stheight_diff,missing_data,max_error_bq,max_error_slp, &
      max_error_bt, max_error_buv, rtminit_platform,rtminit_satid, &
      rtminit_nsensor,rtminit_sensor,filename_len,read_biascoef,analysis_date, &
      time_window_max,time_window_min,print_detail_obs,use_hsbobs,use_msuobs, &
      use_amsubobs,use_eos_amsuaobs,use_amsuaobs,use_hirs2obs,rtm_option, &
      rtm_option_rttov,rtm_option_crtm,use_airsobs,use_kma1dvar,use_hirs3obs, &
      use_ssmisobs,use_iasiobs,use_seviriobs,use_filtered_rad,print_detail_rad,stderr, mw_emis_sea, &
      rtminit_print, rttov_scatt,comm,root,ierr,biasprep, qc_rad, num_procs, &
      tovs_min_transfer,use_error_factor_rad,num_fgat_time,stdout,trace_use, &
      qc_good, qc_bad,myproc,biascorr,thinning,thinning_mesh, &
      rad_monitoring, monitor_on, kts, kte, kms, kme, calc_weightfunc, &
      use_mwtsobs, use_mwhsobs, use_mwhs2obs, use_atmsobs, use_amsr2obs, use_ahiobs, &
      use_hirs4obs, use_mhsobs,bufr_year, bufr_month,bufr_day,bufr_hour, &
      bufr_minute, bufr_second,bufr_solzen, bufr_station_height, &
      bufr_landsea_mask,bufr_solazi,tovs_end, max_tovs_input, bufr_satzen, nchan_mhs, &
      nchan_msu, nchan_amsua,nchan_hirs2, nchan_hirs3, nchan_hirs4, nchan_airs, &
      bufr_lon, bufr_satellite_id, bufr_ifov,nchan_amsub, tovs_start, bufr_lat, &
      use_pseudo_rad, pseudo_rad_platid,pseudo_rad_satid, pseudo_rad_senid, &
      pseudo_rad_ichan, pseudo_rad_inv, pseudo_rad_lat,pseudo_rad_lon, &
      pseudo_rad_err, use_simulated_rad,use_rttov_kmatrix, use_crtm_kmatrix , &
      use_rad,crtm_cloud, DT_cloud_model, global, use_varbc, freeze_varbc, &
      airs_warmest_fov, time_slots, interp_option, ids, ide, jds, jde, &
      ips, ipe, jps, jpe, simulated_rad_ngrid, obs_qc_pointer, use_blacklist_rad, use_satcv, &
      use_goesimgobs, pi, earth_radius, satellite_height,use_clddet_zz, ahi_superob_halfwidth

#ifdef CRTM
   use da_crtm, only : da_crtm_init, da_get_innov_vector_crtm
#endif
   use da_define_structures, only : maxmin_type, iv_type, y_type, jo_type, j_type, &
      bad_data_type, x_type, number_type, bad_data_type, &
      airsr_type,info_type, model_loc_type, varbc_info_type, varbc_type,clddet_geoir_type, superob_type
   use da_interpolation, only : da_to_zk, da_to_zk_new
   use da_tools_serial, only : da_get_unit, da_free_unit
   use da_par_util1, only : da_proc_sum_int,da_proc_sum_ints
#ifdef DM_PARALLEL
   use da_par_util, only :  da_proc_stats_combine, true_mpi_real
#else
   use da_par_util, only :  da_proc_stats_combine
#endif
   use da_physics, only : da_sfc_pre, da_transform_xtopsfc, &
      da_transform_xtopsfc_adj,da_tpq_to_slp_lin,da_tpq_to_slp_adj
   use da_radiance1, only : num_tovs_before,num_tovs_after,tovs_copy_count, &
      tovs_send_pe, tovs_recv_pe, tovs_send_start, tovs_send_count, &
      tovs_recv_start,con_vars_type,aux_vars_type, datalink_type,da_qc_amsub, &
      da_qc_amsua,da_biascorr, da_detsurtyp,da_biasprep, &
      da_qc_rad, da_cld_eff_radius, da_read_biascoef
   use da_reporting, only : da_message, da_warning, message, da_error
#ifdef RTTOV
   use da_rttov, only : da_rttov_init, da_get_innov_vector_rttov
#endif
   use da_statistics, only : da_stats_calculate
   use da_tools, only : da_residual, da_obs_sfc_correction, &
      da_llxy, da_llxy_new, da_togrid_new, da_get_julian_time, da_get_time_slots, &
      da_xyll, map_info
   use da_tracing, only : da_trace_entry, da_trace_exit, da_trace, &
      da_trace_int_sort
   use da_varbc, only : da_varbc_direct,da_varbc_coldstart,da_varbc_precond, &
      da_varbc_pred
   use da_wrf_interfaces, only : wrf_dm_bcast_real
   use gsi_thinning, only : r999,r360,rlat_min,rlat_max,rlon_min,rlon_max, &
                            dlat_grid,dlon_grid,thinning_grid, &
                            makegrids,map2grids, &
                            destroygrids
   use mod_clddet_geoir, only: qc_SDob,qc_RTCT,qc_rtmt,qc_cwvt,qc_tit, &
                    find_std,calc_rtmt,calc_correlation

   implicit none

   include 'netcdf.inc'

#ifdef DM_PARALLEL
   include 'mpif.h'
#endif

contains

#include "da_calculate_grady_rad.inc"
#include "da_read_filtered_rad.inc"
#include "da_read_simulated_rad.inc"
#include "da_write_filtered_rad.inc"
#include "da_read_obs_bufrtovs.inc"
#include "da_read_obs_fy3.inc"
#include "da_read_obs_hdf5mwhs2.inc"
#include "da_read_obs_bufratms.inc"
#include "ATMS_Spatial_Average.inc"
#include "da_read_obs_bufrairs.inc"
#include "da_read_obs_bufrssmis.inc"
#include "da_read_obs_bufriasi.inc"
#include "da_read_obs_bufrseviri.inc"
#include "da_read_obs_hdf5amsr2.inc"
#include "da_read_obs_hdf5ahi.inc"
#include "da_read_obs_netcdf4ahi_geocat.inc"
#include "da_read_obs_netcdf4ahi_jaxa.inc"
#include "da_read_obs_ncgoesimg.inc"
#include "da_get_satzen.inc"
#include "da_allocate_rad_iv.inc"
#include "da_initialize_rad_iv.inc"
#include "da_read_kma1dvar.inc"
#include "da_sort_rad.inc"
#include "da_setup_radiance_structures.inc"
#include "da_radiance_init.inc"
#include "da_get_innov_vector_radiance.inc"
#include "da_read_pseudo_rad.inc"
#include "da_blacklist_rad.inc"
#include "da_deallocate_radiance.inc"

#endif

end module da_radiance


PROGRAM sort4
!
!  Purpose:
!    To read in a character input data set, sort it into ascending
!    order using the selection sort algorithm, and to write the
!    sorted data to the standard output device.  This program calls
!    subroutine "sortc" to do the actual sorting.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/25/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare constants
INTEGER, PARAMETER :: MAX_SIZE = 10     ! Max number to sort

! Data dictionary: declare variable types & definitions
CHARACTER(len=20), DIMENSION(MAX_SIZE) :: a
                                 ! Data array to sort
LOGICAL :: exceed = .FALSE.      ! Logical indicating that array
                                 !   limits are exceeded.
CHARACTER(len=20) :: filename    ! Input data file name
INTEGER :: i                     ! Loop index
INTEGER :: nvals = 0             ! Number of data values to sort
INTEGER :: status                ! I/O status: 0 for success
CHARACTER(len=20) :: temp        ! Temporary variable for reading

! Get the name of the file containing the input data.
WRITE (*,*) 'Enter the file name with the data to be sorted: '
READ (*,'(A20)') filename

! Open input data file.  Status is OLD because the input data must
! already exist.
OPEN ( UNIT=9, FILE=filename, STATUS='OLD', ACTION='READ', &
       IOSTAT=status )

! Was the OPEN successful?
fileopen: IF ( status == 0 ) THEN       ! Open successful

   ! The file was opened successfully, so read the data to sort
   ! from it, sort the data, and write out the results.
   ! First read in data.
   DO
      READ (9, *, IOSTAT=status) temp      ! Get value
      IF ( status /= 0 ) EXIT              ! Exit on end of data
      nvals = nvals + 1                    ! Bump count
      size: IF ( nvals <= MAX_SIZE ) THEN  ! Too many values?
         a(nvals) = temp                   ! No: Save value in array
      ELSE
         exceed = .TRUE.                   ! Yes: Array overflow
      END IF size
   END DO

   ! Was the array size exceeded?  If so, tell user and quit.
   toobig: IF ( exceed ) THEN
      WRITE (*,1010) nvals, MAX_SIZE
      1010 FORMAT (' Maximum array size exceeded: ', I6, ' > ', I6 )
   ELSE

      ! Limit not exceeded: sort the data.
      CALL sortc (a, nvals)

      ! Now write out the sorted data.
      WRITE (*,*) 'The sorted output data values are: '
      WRITE (*,'(4X,A)') ( a(i), i = 1, nvals )

   END IF toobig

ELSE fileopen

   ! Else file open failed.  Tell user.
   WRITE (*,1020) status
   1020 FORMAT (1X,'File open failed--status = ', I6)

END IF fileopen

END PROGRAM sort4

SUBROUTINE sortc (array, n )
!
!  Purpose:
!    To sort a character array into ascending order using a
!    selection sort.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/25/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare calling parameter types & definitions
INTEGER, INTENT(IN) :: n                  ! Number of values
CHARACTER(len=20), DIMENSION(n), INTENT(INOUT) :: array
                                          ! Array to be sorted
! Data dictionary: declare local variable types & definitions
INTEGER :: i                  ! Loop index
INTEGER :: iptr               ! Pointer to smallest value
INTEGER :: j                  ! Loop index
CHARACTER(len=20) :: temp     ! Temp variable for swaps

! Sort the array
outer: DO i = 1, n-1

   ! Find the minimum value in array(i) through array(n)
   iptr = i
   inner: DO j = i+1, n
      minval: IF ( array(j) < array(iptr) ) THEN
         iptr = j
      END IF minval
   END DO inner

   ! iptr now points to the minimum value, so swap array(iptr)
   ! with array(i) if i /= iptr.
   swap: IF ( i /= iptr ) THEN
      temp        = array(i)
      array(i)    = array(iptr)
      array(iptr) = temp
   END IF swap

END DO outer

END SUBROUTINE sortc


C
C $Id: mdutin.f,v 1.4 2008-07-27 00:17:09 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE MDUTIN (IPRJ,IZON,ISPH,PADP,UMIN,UMAX,VMIN,VMAX)
C
        DOUBLE PRECISION PADP(15),UMIN,UMAX,VMIN,VMAX
C
        REAL PASP(15)
C
C Declare common blocks required to communicate with USGS code.
C
        COMMON /USGSC1/  UTPA(15),UUMN,UUMX,UVMN,UVMX,IPRF
        DOUBLE PRECISION UTPA,UUMN,UUMX,UVMN,UVMX
        INTEGER IPRF
        SAVE   /USGSC1/
C
C Declare some double precision variables that we need.
C
        DOUBLE PRECISION UVDP,VVDP,DTMP
C
C Declare arrays in which to put State Plane limit information.
C
        DIMENSION IZN0(139),IZN8(139),ILM0(139,4),ILM8(139,4)
C
C Define State Plane limit information.
C
        DATA (IZN0(I),IZN8(I),ILM0(I,1),ILM0(I,2),ILM0(I,3),ILM0(I,4),
     +                        ILM8(I,1),ILM8(I,2),ILM8(I,3),ILM8(I,4),
     +                                                     I=  1, 10)/
     +              0101,0101,   0, 260,  30, 520,  48, 308,  30, 520,
     +              0102,0102,  40, 300,  10, 580, 488, 748,  10, 580,
     +              5001,5001, 380,1080, 300,1000, 380,1080, 300,1000,
     +              5002,5002,   0, 300, 580,1830, 348, 648, 580,1830,
     +              5003,5003,   0, 300, 630,1860, 348, 648, 630,1860,
     +              5004,5004,   0, 300, 360,1910, 348, 648, 360,1910,
     +              5005,5005,   0, 300, 250,1960, 348, 648, 250,1960,
     +              5006,5006,   0, 300, 160,1950, 348, 648, 160,1950,
     +              5007,5007,   0, 340,  20,1960, 287, 627,  20,1960,
     +              5008,5008,   0, 300,-100,1820, 348, 648,-100,1820/
C
        DATA (IZN0(I),IZN8(I),ILM0(I,1),ILM0(I,2),ILM0(I,3),ILM0(I,4),
     +                        ILM8(I,1),ILM8(I,2),ILM8(I,3),ILM8(I,4),
     +                                                     I= 11, 20)/
     +              5009,5009,   0, 320,-160,1480, 317, 637,-160,1480,
     +              5010,5010,  50,1250,   0, 400, 120,1320,   0, 400,
     +              0201,0201,   0, 280,  10, 690,  61, 341,  10, 690,
     +              0202,0202,   0, 300,  10, 690,  61, 361,  10, 690,
     +              0203,0203,  30, 300,  40, 690,  91, 361,  40, 690,
     +              0301,0301, 360, 840,  20, 260, 150, 630,  20, 260,
     +              0302,0302, 360, 800,  20, 290, 150, 590, 420, 690,
     +              0401,0401, 390, 800,   0, 330,1780,2190, 500, 830,
     +              0402,0402, 390, 960,   0, 320,1780,2350, 500, 820,
     +              0403,0403, 310, 980,   0, 280,1700,2370, 500, 780/
C
        DATA (IZN0(I),IZN8(I),ILM0(I,1),ILM0(I,2),ILM0(I,3),ILM0(I,4),
     +                        ILM8(I,1),ILM8(I,2),ILM8(I,3),ILM8(I,4),
     +                                                     I= 21, 30)/
     +              0404,0404, 280, 980,   0, 280,1670,2370, 500, 780,
     +              0405,0405, 280, 990,   0, 280,1670,2380, 500, 780,
     +              0406,0406, 200, 830,   0, 260,1590,2220, 500, 760,
     +              0407,   0, 970,1700,1070,1470,   0,   0,   0,   0,
     +              0501,0501, 280, 930,   0, 210, 584,1234, 305, 515,
     +              0502,0502, 280, 930,  40, 240, 584,1234, 345, 545,
     +              0503,0503, 280, 930,  20, 240, 584,1234, 325, 545,
     +              0600,0600,  80, 280,   0, 160, 202, 402, 152, 312,
     +              0700,0700,  90, 210,  30, 230, 138, 258,  30, 230,
     +              1901,1901, 226, 254, 103, 131, 383, 411, 122, 150/
C
        DATA (IZN0(I),IZN8(I),ILM0(I,1),ILM0(I,2),ILM0(I,3),ILM0(I,4),
     +                        ILM8(I,1),ILM8(I,2),ILM8(I,3),ILM8(I,4),
     +                                                     I= 31, 40)/
     +              0901,0901,   0, 270,   0, 740,  48, 318,   0, 740,
     +              0902,0902,  40, 300,   0, 740,  88, 348,   0, 740,
     +              0903,0903, 290, 980,  20, 240, 280, 970,  20, 240,
     +              1001,1001,   0, 300,  20, 580,  48, 348,  20, 580,
     +              1002,1002,   0, 300,  40, 580, 548, 848,  40, 580,
     +              5101,5101,  60, 240,   0, 180, 408, 588,   0, 180,
     +              5102,5102,  70, 240,   0, 120, 418, 588,   0, 120,
     +              5103,5103, 110, 200,   0,  70, 458, 548,   0,  70,
     +              5104,5104, 110, 180,   0,  50, 458, 528,   0,  50,
     +              5105,5105, 130, 175,   5,  50, 478, 523,   5,  50/
C
        DATA (IZN0(I),IZN8(I),ILM0(I,1),ILM0(I,2),ILM0(I,3),ILM0(I,4),
     +                        ILM8(I,1),ILM8(I,2),ILM8(I,3),ILM8(I,4),
     +                                                     I= 41, 50)/
     +              1101,1101,   0, 260,  20, 470,  48, 308,  20, 470,
     +              1102,1102,   0, 300,  20, 720, 348, 648,  20, 720,
     +              1103,1103,  10, 300,  20, 840, 658, 948,  20, 840,
     +              1201,1201,   0, 250,  20, 670, 148, 398,  20, 670,
     +              1202,1202,  20, 300,  20, 670, 568, 848,  20, 670,
     +              1301,1301,   0, 250,  10, 500, -52, 198, 260, 750,
     +              1302,1302,  40, 300,  10, 500, 788,1048, 260, 750,
     +              1401,1401, 330, 910,  20, 240,1220,1800,1020,1240,
     +              1402,1402, 350, 910,  20, 250, 240, 800,  20, 250,
     +              1501,1501, 230, 930,   0, 210,  20, 720,   0, 210/
C
        DATA (IZN0(I),IZN8(I),ILM0(I,1),ILM0(I,2),ILM0(I,3),ILM0(I,4),
     +                        ILM8(I,1),ILM8(I,2),ILM8(I,3),ILM8(I,4),
     +                                                     I= 51, 60)/
     +              1502,1502, 280, 970,  20, 260,  70, 760, 420, 660,
     +              1601,1601, 210, 830, -20, 200, 100, 720, -20, 200,
     +              1602,1602, 260, 960,   0, 230, 150, 850, 500, 730,
     +              1701,1701, 440, 890,   0, 280, 830,1280,  20, 300,
     +              1702,1702, 340, 860,  10, 280, 730,1250,  30, 300,
     +              1703,1703, 340, 860,   0, 520, 730,1250,  20, 540,
     +              1801,1801,   0, 300, -40, 420, 148, 448, -20, 440,
     +              1802,1802,  60, 300,   0, 540, 808,1048,   0, 540,
     +              1900,1900,  10, 430, -10, 230, 166, 586,  10, 250,
     +              2001,2001,   0, 330,  10, 230,  17, 347, 760, 980/
C
        DATA (IZN0(I),IZN8(I),ILM0(I,1),ILM0(I,2),ILM0(I,3),ILM0(I,4),
     +                        ILM8(I,1),ILM8(I,2),ILM8(I,3),ILM8(I,4),
     +                                                     I= 61, 70)/
     +              2002,2002,   0, 140,  10, 110, 439, 579,  10, 110,
     +              2101,   0,   0, 300,   0, 610,   0,   0,   0,   0,
     +              2102,   0,   0, 300,   0, 620,   0,   0,   0,   0,
     +              2103,   0,   0, 300, 380, 760,   0,   0,   0,   0,
     +              2111,2111, 320, 920,  10, 320,7710,8310,  10, 320,
     +              2112,2112, 220, 780,  30, 330,5610,6170,  30, 330,
     +              2113,2113, 380, 790,   0, 310,3770,4180,   0, 310,
     +              2201,2201, 290, 900,   0, 350, 480,1090, 100, 450,
     +              2202,2202, 390, 900,   0, 300, 580,1090, 100, 400,
     +              2203,2203, 370, 850,  30, 300, 560,1040, 130, 400/
C
        DATA (IZN0(I),IZN8(I),ILM0(I,1),ILM0(I,2),ILM0(I,3),ILM0(I,4),
     +                        ILM8(I,1),ILM8(I,2),ILM8(I,3),ILM8(I,4),
     +                                                     I= 71, 80)/
     +              2301,2301,   0, 240,  40, 610, 148, 388,  60, 630,
     +              2302,2302,   0, 300, -50, 520, 548, 848,  60, 630,
     +              2401,2401,   0, 300,   0, 550,  98, 398,   0, 550,
     +              2402,2402,   0, 300,  50, 550, 348, 648,  50, 550,
     +              2403,2403,  20, 300,  20, 510, 718, 998,  20, 510,
     +                 0,2500,   0,   0,   0,   0,  90,1050,   0, 560,
     +              2501,   0, 100,1040,  40, 260,   0,   0,   0,   0,
     +              2502,   0, 100,1050,  20, 280,   0,   0,   0,   0,
     +              2503,   0, 190,1060,  20, 340,   0,   0,   0,   0,
     +                 0,2600,   0,   0,   0,   0, 140, 920,   0, 380/
C
        DATA (IZN0(I),IZN8(I),ILM0(I,1),ILM0(I,2),ILM0(I,3),ILM0(I,4),
     +                        ILM8(I,1),ILM8(I,2),ILM8(I,3),ILM8(I,4),
     +                                                     I= 81, 90)/
     +              2601,   0, 250, 970,   0, 220,   0,   0,   0,   0,
     +              2602,   0, 210, 990,  20, 280,   0,   0,   0,   0,
     +              2701,2701,   0, 310,  10, 830,  48, 358,8010,8830,
     +              2702,2702,   0, 300,  50, 830, 348, 648,6050,6830,
     +              2703,2703,   0, 300, 200, 830, 648, 948,4200,4830,
     +              2800,2800,  60, 250,   0, 340, 208, 398,   0, 340,
     +              2900,2900, 510, 690, -10, 300,  40, 220, -10, 300,
     +              3001,3001,   0, 300,  90, 690,  13, 313,  90, 690,
     +              3002,3002,   0, 300,  60, 690, 348, 648,  60, 690,
     +              3003,3003,  10, 300,  20, 690, 688, 978,  20, 690/
C
        DATA (IZN0(I),IZN8(I),ILM0(I,1),ILM0(I,2),ILM0(I,3),ILM0(I,4),
     +                        ILM8(I,1),ILM8(I,2),ILM8(I,3),ILM8(I,4),
     +                                                     I= 91,100)/
     +              3101,3101,   0, 260,  40, 580,  -2, 258, 170, 710,
     +              3102,3102,   0, 300, 140, 580,  98, 398, 140, 580,
     +              3103,3103,  20, 300, 200, 400, 218, 498, 200, 400,
     +              3104,3104, 570, 810,  20, 110, 260, 500,  30, 120,
     +              3200,3200, 100, 950, -10, 340, 100, 950, -10, 340,
     +              3301,3301, 320, 910, -10, 250, 310, 900, -10, 250,
     +              3302,3302, 310, 940,  10, 250, 300, 930,  10, 250,
     +              3401,3401, 390, 800,  40, 280, 380, 790,  40, 280,
     +              3402,3402, 390, 790,  20, 290, 380, 780,  20, 290,
     +              3501,3501, 140, 960,  10, 250, 130, 950,  10, 250/
C
        DATA (IZN0(I),IZN8(I),ILM0(I,1),ILM0(I,2),ILM0(I,3),ILM0(I,4),
     +                        ILM8(I,1),ILM8(I,2),ILM8(I,3),ILM8(I,4),
     +                                                     I=101,110)/
     +              3502,3502, 400, 960,  20, 260, 390, 950,  20, 260,
     +              3601,3601, 290, 950,  20, 310,2180,2840,  20, 310,
     +              3602,3602, 260, 920,  20, 310,1150,1810,  20, 310,
     +              3701,3701, 350, 880,  20, 260, 340, 870,  20, 260,
     +              3702,3702, 350, 890,  20, 230, 340, 880,  20, 230,
     +              3800,3800, 102, 202, -10, 120,  50, 150, -10, 120,
     +                 0,3900,   0,   0,   0,   0, 370, 860,   0, 400,
     +              3901,   0, 370, 860,  40, 260,   0,   0,   0,   0,
     +              3902,   0, 430, 860,   0, 260,   0,   0,   0,   0,
     +              4001,4001, 260, 920,  10, 260, 250, 910,  10, 260/
C
        DATA (IZN0(I),IZN8(I),ILM0(I,1),ILM0(I,2),ILM0(I,3),ILM0(I,4),
     +                        ILM8(I,1),ILM8(I,2),ILM8(I,3),ILM8(I,4),
     +                                                     I=111,120)/
     +              4002,4002, 280, 950,   0, 280, 270, 940,   0, 280,
     +              4100,4100, 200,1020,  40, 270, 190,1010,  50, 280,
     +              4201,4201, 440, 850,  20, 300,  30, 440,1020,1300,
     +              4202,4202,  60, 980,  10, 300, 150,1070,2010,2300,
     +              4203,4203, -10,1280,   0, 300,  80,1370,3000,3300,
     +              4204,4204,  30,1140,  10, 310,  20,1130,4010,4310,
     +              4205,4205, 420, 820,   0, 290, 110, 510,5000,5290,
     +              4301,4301, 370, 840, -10, 210, 260, 730, 990,1210,
     +              4302,4302, 370, 840,  30, 310, 260, 730,2030,2310,
     +              4303,4303, 360, 850,  20, 240, 250, 740,3020,3240/
C
        DATA (IZN0(I),IZN8(I),ILM0(I,1),ILM0(I,2),ILM0(I,3),ILM0(I,4),
     +                        ILM8(I,1),ILM8(I,2),ILM8(I,3),ILM8(I,4),
     +                                                     I=121,130)/
     +              4400,4400,  60, 240,  10, 300, 408, 588,  10, 300,
     +              4501,4501, 430, 830, -10, 220,3320,3720,1990,2220,
     +              4502,4502, 130, 910,   0, 230,3020,3800,1000,1230,
     +              4601,4601, 300, 920,   0, 250, 190, 810,   0, 250,
     +              4602,4602, 300, 910,   0, 280, 190, 800,   0, 280,
     +              4701,4701, 340, 780,   0, 260, 330, 770,   0, 260,
     +              4702,4702, 440, 860,   0, 270, 430, 850,   0, 270,
     +              4801,4801, 360, 880, -20, 240, 350, 870, -20, 240,
     +              4802,4802, 360, 880,   0, 230, 350, 870,   0, 230,
     +              4803,4803, 410, 830,  30, 280, 400, 820,  30, 280/
C
        DATA (IZN0(I),IZN8(I),ILM0(I,1),ILM0(I,2),ILM0(I,3),ILM0(I,4),
     +                        ILM8(I,1),ILM8(I,2),ILM8(I,3),ILM8(I,4),
     +                                                     I=131,139)/
     +              4901,4901,  30, 270,  20, 500,  78, 318,  40, 520,
     +              4902,4902,   0, 300,  20, 500, 248, 548, 140, 620,
     +              4903,4903,   0, 300,  20, 500, 448, 748,  40, 520,
     +              4904,4904,  50, 250,  20, 500, 698, 898, 140, 620,
     +              5201,5200,   0, 390, -80, 140,  48, 438, 120, 340,
     +              5201,5200,   0, 390, -80, 140,  48, 438, 120, 340,
     +              5202,5200,   0, 390, -50, 170,  48, 438, 120, 340,
     +              5300,   0,   0, 800,   0, 800,   0,   0,   0,   0,
     +              5400,   0,   0, 800,   0, 800,   0,   0,   0,   0/
C
C Do a call forcing a BLOCKDATA to be loaded from a binary library.
C
        CALL GTPZBD
C
C Set the value of the projection selector to be passed to PJIN[SD]P.
C
        JPRJ=MAX(1,MIN(23,IPRJ))
C
C Set the value of the zone number to be passed to PJIN[SD]P.  UTM zone
C numbers are limited to the legal range.  For State Plane Zone number
C "1901" (the District of Columbia), we use "1900" (Maryland).
C
        IF (JPRJ.EQ.1) THEN
          JZON=SIGN(MAX(1,MIN(60,ABS(IZON))),IZON)
        ELSE IF (JPRJ.EQ.2) THEN
          JZON=IZON
          IF (JZON.EQ.1901) JZON=1900
        ELSE
          JZON=0
        END IF
C
C Set the value of the spheroid selector to be passed to PJIN[SD]P.
C
        IF (JPRJ.EQ.2) THEN
          IF (ISPH.EQ.0) THEN
            JSPH=0
          ELSE
            JSPH=8
          END IF
        ELSE IF (JPRJ.EQ.23) THEN
          JSPH=0
        ELSE
          JSPH=MAX(-1,MIN(19,ISPH))
        END IF
C
C Decide whether to use real or double-precision arithmetic and call the
C appropriate initialization routine.
C
        CALL MDPIN2 (TST1,TST2,TST3)
C
        IF (TST1.NE.TST2.AND.TST2.NE.TST3) THEN
C
          IROD=0
C
          DO 101 I=1,15
            PASP(I)=REAL(PADP(I))
  101     CONTINUE
C
          CALL PJINSP (JPRJ,JZON,JSPH,PASP)
C
          DO 102 I=1,15
            PADP(I)=DBLE(PASP(I))
  102     CONTINUE
C
        ELSE
C
          IROD=1
C
          CALL PJINDP (JPRJ,JZON,JSPH,PADP)
C
        END IF
C
C Initialize minimum and maximum values in the USGS code's common block.
C
        IF (UMIN.LT.UMAX.AND.VMIN.LT.VMAX) THEN
C
          UUMN=UMIN
          UUMX=UMAX
          UVMN=VMIN
          UVMX=VMAX
C
        ELSE IF (JPRJ.EQ.1) THEN
C
          UUMN=0.D0
          UUMX=1.D6
          UVMN=0.D0
          UVMX=1.D7
C
        ELSE IF (JPRJ.EQ.2) THEN
C
          UUMN=0.D0
          UUMX=1.D6
          UVMN=0.D0
          UVMX=1.D6
C
          IF (JSPH.EQ.0) THEN
            DO 103 I=1,139
              IF (IZON.EQ.IZN0(I)) THEN
                UUMN=1.D3*DBLE(ILM0(I,1))
                UUMX=1.D3*DBLE(ILM0(I,2))
                UVMN=1.D3*DBLE(ILM0(I,3))
                UVMX=1.D3*DBLE(ILM0(I,4))
                GO TO 107
              END IF
  103       CONTINUE
          ELSE
            DO 104 I=1,139
              IF (IZON.EQ.IZN8(I)) THEN
                UUMN=1.D3*DBLE(ILM8(I,1))
                UUMX=1.D3*DBLE(ILM8(I,2))
                UVMN=1.D3*DBLE(ILM8(I,3))
                UVMX=1.D3*DBLE(ILM8(I,4))
                GO TO 107
              END IF
  104       CONTINUE
          END IF
C
        ELSE IF (JPRJ.EQ. 4.OR.
     +           JPRJ.EQ. 6.OR.
     +           JPRJ.EQ.10.OR.
     +           JPRJ.EQ.13    ) THEN
C
          UUMN=PADP(7)-PADP(1)
          UUMX=PADP(7)+PADP(1)
          UVMN=PADP(8)-PADP(1)
          UVMX=PADP(8)+PADP(1)
C
        ELSE IF (JPRJ.EQ.9) THEN
C
          UUMN=PADP(7)- .0873D0*PADP(1)
          UUMX=PADP(7)+ .0873D0*PADP(1)
          UVMN=PADP(8)-1.3963D0*PADP(1)
          UVMX=PADP(8)+1.4661D0*PADP(1)
C
        ELSE IF (JPRJ.EQ.22) THEN
C
          UUMN=PADP(7)+1.68D0*PADP(1)
          UUMX=PADP(7)+4.74D0*PADP(1)
          UVMN=PADP(8)-0.75D0*PADP(1)
          UVMX=PADP(8)+0.75D0*PADP(1)
C
        ELSE IF (JPRJ.EQ.23) THEN
C
          UUMN=PADP(7)-1.75D6
          UUMX=PADP(7)+1.75D6
          UVMN=PADP(8)-1.75D6
          UVMX=PADP(8)+1.75D6
C
        ELSE
C
C JPRJ is in the group {3,5,7,8,11,12,14,15,16,17,18,19,20,21}.
C
          UUMN=+1.D12
          UUMX=-1.D12
          UVMN=+1.D12
          UVMX=-1.D12
C
          DO 106 I=-90,90
            DO 105 J=-180,180
              IF (IROD.EQ.0) THEN
                CALL MDUTFS (REAL(I),REAL(J),UVSP,VVSP)
                IF (ABS(UVSP).LT.1.E12) THEN
                  IF ((JPRJ.EQ.5.OR.JPRJ.EQ.20).AND.
     +                (UVSP-PASP(7))**2+(VVSP-PASP(7))**2.GT.
     +                9.8696E0*PASP(1)**2) GO TO 105
                  UUMN=MIN(UUMN,DBLE(UVSP))
                  UUMX=MAX(UUMX,DBLE(UVSP))
                  UVMN=MIN(UVMN,DBLE(VVSP))
                  UVMX=MAX(UVMX,DBLE(VVSP))
                END IF
              ELSE
                CALL MDUTFD (DBLE(I),DBLE(J),UVDP,VVDP)
                IF (ABS(UVDP).LT.1.D12) THEN
                  IF ((JPRJ.EQ.5.OR.JPRJ.EQ.20).AND.
     +                (UVDP-PADP(7))**2+(VVDP-PADP(7))**2.GT.
     +                9.8696D0*PADP(1)**2) GO TO 105
                  UUMN=MIN(UUMN,UVDP)
                  UUMX=MAX(UUMX,UVDP)
                  UVMN=MIN(UVMN,VVDP)
                  UVMX=MAX(UVMX,VVDP)
                END IF
              END IF
  105       CONTINUE
  106     CONTINUE
C
          IF (UUMX-UUMN.LT.UVMX-UVMN) THEN
            DTMP=.5D0*(UVMX-UVMN-UUMX+UUMN)
            UUMN=UUMN-DTMP
            UUMX=UUMX+DTMP
          ELSE IF (UUMX-UUMN.GT.UVMX-UVMN) THEN
            DTMP=.5D0*(UUMX-UUMN-UVMX+UVMN)
            UVMN=UVMN-DTMP
            UVMX=UVMX+DTMP
          END IF
C
          DTMP=.01*(UUMX-UUMN)
C
          UUMN=UUMN-DTMP
          UUMX=UUMX+DTMP
          UVMN=UVMN-DTMP
          UVMX=UVMX+DTMP
C
        END IF
C
C Initialize EZMAP.
C
  107   CALL MDPINT
C
C Done.
C
        RETURN
C
      END


program do_loop
    integer :: i

    print *, ''
    print *, 'PRINT 1 through 10'
    do i=1,10
        print *, i
    end do

    print *, ''
    print *, 'PRINT ODDS 1 through 10'
    do i=1,10,2
        print *, i    ! Print odd numbers
    end do

    print *, ''
    print *, 'PRINT WHILE i LESS THAN 40.'
    i = 1
    do while (i<40)
        print *, i
        i = i + 1
    end do

end program do_loop


Subroutine inirec
  Implicit Double Precision (A-H, O-Z)
  External ran1
  Parameter (maxptn=400001)
  Common /para1/mul
  Common /para4/iftflg, ireflg, igeflg, ibstfg
  Common /para5/iconfg, iordsc
  Common /prec1/gx0(maxptn), gy0(maxptn), gz0(maxptn), ft0(maxptn), px0(maxptn), py0(maxptn), pz0(maxptn), e0(maxptn), xmass0(maxptn), ityp0(maxptn)
  Common /prec2/gx(maxptn), gy(maxptn), gz(maxptn), ft(maxptn), px(maxptn), py(maxptn), pz(maxptn), e(maxptn), xmass(maxptn), ityp(maxptn)
  Common /prec3/gxs(maxptn), gys(maxptn), gzs(maxptn), fts(maxptn), pxs(maxptn), pys(maxptn), pzs(maxptn), es(maxptn), xmasss(maxptn), ityps(maxptn)
  Common /prec4/vx(maxptn), vy(maxptn), vz(maxptn)
  Common /prec5/eta(maxptn), rap(maxptn), tau(maxptn)
  Common /prec6/etas(maxptn), raps(maxptn), taus(maxptn)
  Common /ilist4/ifmpt, ichkpt, indx(maxptn)
  Common /ilist7/lstrg0(maxptn), lpart0(maxptn)
  Common /ilist8/lstrg1(maxptn), lpart1(maxptn)
  Common /smearz/smearp, smearh
  Common /precpb/vxp(maxptn), vyp(maxptn), vzp(maxptn)
  Common /precpa/vxp0(maxptn), vyp0(maxptn), vzp0(maxptn), xstrg0(maxptn), ystrg0(maxptn), xstrg(maxptn), ystrg(maxptn), istrg0(maxptn), istrg(maxptn)
  Common /anim/nevent, isoft, isflag, izpc
  Common /frzprc/gxfrz(maxptn), gyfrz(maxptn), gzfrz(maxptn), ftfrz(maxptn), pxfrz(maxptn), pyfrz(maxptn), pzfrz(maxptn), efrz(maxptn), xmfrz(maxptn), tfrz(302), ifrz(maxptn), idfrz(maxptn), itlast
  Common /rndm3/iseedp
  Common /para7/ioscar, nsmbbbar, nsmmeson
  Common /arevt/iaevt, iarun, miss
  Save
  iseed = iseedp
  If (isoft==5) Then
     itlast = 0
     Call inifrz
  End If
  Do i = 1, mul
     indxi = indx(i)
     ityp(i) = ityp0(indxi)
     gx(i) = gx0(indxi)
     gy(i) = gy0(indxi)
     gz(i) = gz0(indxi)
     ft(i) = ft0(indxi)
     px(i) = px0(indxi)
     py(i) = py0(indxi)
     pz(i) = pz0(indxi)
     e(i) = e0(indxi)
     xmass(i) = xmass0(indxi)
     lstrg1(i) = lstrg0(indxi)
     lpart1(i) = lpart0(indxi)
     vxp(i) = vxp0(indxi)
     vyp(i) = vyp0(indxi)
     vzp(i) = vzp0(indxi)
     xstrg0(i) = xstrg(indxi)
     ystrg0(i) = ystrg(indxi)
     istrg0(i) = istrg(indxi)
     If (isoft==5) Then
        idfrz(i) = ityp(i)
        gxfrz(i) = gx(i)
        gyfrz(i) = gy(i)
        gzfrz(i) = gz(i)
        ftfrz(i) = ft(i)
        pxfrz(i) = px(i)
        pyfrz(i) = py(i)
        pzfrz(i) = pz(i)
        efrz(i) = e(i)
        xmfrz(i) = xmass(i)
        ifrz(i) = 0
     End If
  End Do
  Do i = 1, mul
     ityps(i) = ityp(i)
     gxs(i) = gx(i)
     gys(i) = gy(i)
     gzs(i) = gz(i)
     fts(i) = ft(i)
     pxs(i) = px(i)
     pys(i) = py(i)
     pzs(i) = pz(i)
     es(i) = e(i)
     xmasss(i) = xmass(i)
  End Do
  If (isoft==1 .And. (ioscar==2 .Or. ioscar==3)) Write (92, *) iaevt, miss, mul
  Do i = 1, mul
     energy = e(i)
     vx(i) = px(i)/energy
     vy(i) = py(i)/energy
     vz(i) = pz(i)/energy
     If (iftflg==0) Then
        formt = ft(i)
        If (isoft==3 .Or. isoft==4 .Or. isoft==5) Then
           gx(i) = gx(i) + vxp(i)*formt
           gy(i) = gy(i) + vyp(i)*formt
           gz(i) = gz(i) + vzp(i)*formt
        Else
           gx(i) = gx(i) + vx(i)*formt
           gy(i) = gy(i) + vy(i)*formt
           gz(i) = gz(i) + vz(i)*formt
        End If
     End If
     If (ioscar==2 .Or. ioscar==3) Then
        If (dmax1(abs(gx(i)),abs(gy(i)),abs(gz(i)),abs(ft(i)))<9999) Then
           Write (92, 200) ityp(i), px(i), py(i), pz(i), xmass(i), gx(i), gy(i), gz(i), ft(i), istrg0(i), xstrg0(i), ystrg0(i)
        Else
           Write (92, 201) ityp(i), px(i), py(i), pz(i), xmass(i), gx(i), gy(i), gz(i), ft(i), istrg0(i), xstrg0(i), ystrg0(i)
        End If
     End If
  End Do
  If (iconfg<=3) Then
     Do i = 1, mul
        If (ft(i)<=abs(gz(i))) Then
           eta(i) = 1000000.D0
        Else
           eta(i) = 0.5D0*log((ft(i)+gz(i))/(ft(i)-gz(i)))
        End If
        If (e(i)<=abs(pz(i))) Then
           rap(i) = 1000000.D0
        Else
           rap(i) = 0.5D0*log((e(i)+pz(i))/(e(i)-pz(i)))
        End If
        If (eta(i)<1000000.D0) Then
           tau(i) = ft(i)/cosh(eta(i))
        Else
           tau(i) = 1D-10
        End If
     End Do
     Do i = 1, mul
        etas(i) = eta(i)
        raps(i) = rap(i)
        taus(i) = tau(i)
     End Do
  End If
  Return
200 Format (I3, 2(1X,F7.2), 1X, F8.2, 1X, F6.3, 4(1X,F8.2), 1X, I5, 2(1X,F7.2))
201 Format (I3, 2(1X,F7.2), 1X, F8.2, 1X, F6.3, 4(1X,E8.2), 1X, I5, 2(1X,F7.2))
End Subroutine inirec