C$Procedure       TPARSE ( Parse a UTC time string )

       SUBROUTINE TPARSE ( STRING, SP2000, ERROR )
       IMPLICIT NONE

C$ Abstract
C
C      Parse a time string and return seconds past the J2000 epoch
C      on a formal calendar.
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     None.
C
C$ Keywords
C
C      PARSING, TIME
C
C$ Declarations

      CHARACTER*(*)      STRING
      DOUBLE PRECISION   SP2000
      CHARACTER*(*)      ERROR

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C      STRING     I   Input time string, UTC.
C      SP2000     O   Equivalent UTC seconds past J2000.
C      ERROR      O   Descriptive error message.
C
C$ Detailed_Input
C
C      STRING      is an input time string, containing a Calendar or
C                  Julian Date.  It may be in several different
C                  formats and can make use of abbreviations.
C                  Several example strings and
C                  the times that they translate to are listed below
C                  in the Examples section.
C
C$ Detailed_Output
C
C      SP2000      is the equivalent of UTC, expressed in UTC
C                  seconds past J2000. If an error occurs, or if
C                  UTC is ambiguous, SP2000 is not changed.
C
C      ERROR       is a descriptive error message, which is blank when
C                  no error occurs.
C
C$ Parameters
C
C      None.
C
C$ Exceptions
C
C      Error free.
C
C$ Files
C
C      None.
C
C$ Particulars
C
C      The input string is examined and the various components of
C      a date are identified: julian date, year, month, day of year,
C      day of month, hour, minutes, seconds.  These items are
C      assumed to be components on a calendar that contains no
C      leapseconds (i.e. every day is assumed to have exactly 86400
C      seconds).
C
C      TPARSE recognizes a wide range of standard time formats.
C      The examples section contains a list of several common
C      strings that are recognized and their interpretation.
C      TPARSE relies on the lower lever routine TPARTV to
C      interpret the input string.
C
C      Here is a brief summary of some of the basic rules used
C      in the interpretation of strings.
C
C      1)  Unless the substring JD or jd is present the string is
C          assumed to be a calendar format (day-month-year or year and
C          day of year).  If the substring JD or jd is present, the
C          string is assumed to represent a julian date.
C
C      2)  If the julian date specifier is not present, any integer
C          greater than 999 is regarded as being a year specification.
C
C      3)  A dash '-' can represent a minus sign only if it is precedes
C          the first digit in the string and the string contains
C          the julian date specifier (JD).  (No negative years,
C          months, days, etc are allowed).
C
C      4)  Numeric components of a time string must be separated
C          by a character that is not a digit or decimal point.
C          Only one decimal component is allowed.  For example
C          1994219.12819 is sometimes interpreted as the
C          219th day of 1994 + 0.12819 days.  TPARSE does not
C          support such strings.
C
C          No exponential components are allowed.  For example you
C          can't input 1993 Jun 23 23:00:01.202E-4 you have
C          to explicitly list all zeros that follow the decimal
C          point: i.e.  1993 Jun 23 23:00:00.0001202
C
C      5)  The single colon (:) when used to separate numeric
C          components of a string is interpreted as separating
C          Hours, Minutes, and Seconds of time.
C
C      6)  If a double slash (//) or double colon (::) follows
C          a pair of integers, those integers are assumed  to
C          represent the year and day of year.
C
C      7)  A quote followed by an integer less than 100 is regarded
C          as an abbreviated year.  For example: '93 would be regarded
C          as the 93rd year of the reference century.  See TEXPYR
C          for further discussion of abbreviated years.
C
C       8) An integer followed by 'B.C.' or 'A.D.' is regarded as
C          a year in the era associated with that abbreviation.
C
C       9) All dates are regarded as belonging to the extended
C          Gregorian Calendar (the Gregorian calendar is the calendar
C          currently used by western society).  See the routine JUL2GR
C          for  converting from Julian Calendar to the
C          Gregorian Calendar.
C          western society).
C
C      10) When the size of the integer components does not clearly
C          specify a year the following patterns are assumed
C
C          Calendar Format
C
C              Year Month Day
C              Month Day Year
C              Year Day Month
C
C              Where Month is the name of a month, not its numeric
C              value.
C
C              When integer components are separated by slashes (/)
C              as in 3/4/5.  Month, Day, Year is assumed (2005 March 4)
C
C           Day of Year Format.
C
C              If a day of year marker is present (// or ::) the
C              pattern
C
C              I-I// or I-I:: (where I stands for and integer)
C              is interpreted as Year Day-of-Year. However, I-I/ is
C              regarded as ambiguous.
C
C      To understand the complete list of strings that can be understood
C      by TPARSE you need to examine TPARTV and read the appendix to
C      the TIME required reading entitled "Parsing Time Strings"
C
C      TPARSE does not support the specification of time system
C      such as TDT or TDB; AM/PM specifications of time; or time
C      zones (such as PDT, UTC+7:20, etc.).
C
C      If some part of the time string is not recognized or if
C      the meaning of the components are not clear, an error string
C      is constructed that explains the problem with the string.
C
C      Since the routine is works by breaking the input string into
C      a sequence of tokens whose meanings are determined by position
C      and magnitude, you can supply strings such as 1993 FEB 35 and
C      have this correctly interpreted as March 7, 1993.  However,
C      this default action can be modified so that only "proper"
C      calendar dates and times are recognized.  To do this call
C      the routine TPARCH as shown below:
C
C         CALL TPARCH ( 'YES' )
C
C      This will cause the routine to treat dates and times with
C      components outside the normal range as errors.
C
C      To return to the default behavior
C
C         CALL TPARCH ( 'NO' )
C
C$ Examples
C
C      The following are examples of valid inputs to TPARSE:
C
C
C
C      ISO (T) Formats.
C
C      String                        Year Mon  DOY DOM  HR Min Sec
C      ----------------------------  ---- ---  --- ---  -- --- ------
C      1996-12-18T12:28:28           1996 Dec   na  18  12  28 28
C      1986-01-18T12                 1986 Jan   na  18  12  00 00
C      1986-01-18T12:19              1986 Jan   na  18  12  19 00
C      1986-01-18T12:19:52.18        1986 Jan   na  18  12  19 52.18
C      1995-08T18:28:12              1995  na  008  na  18  28 12
C      1995-18T                      1995  na  018  na  00  00 00
C
C
C      Calendar Formats.
C
C      String                        Year   Mon DOM  HR Min  Sec
C      ----------------------------  ----   --- ---  -- ---  ------
C      Tue Aug  6 11:10:57  1996     1996   Aug  06  11  10  57
C      1 DEC 1997 12:28:29.192       1997   Dec  01  12  28  29.192
C      2/3/1996 17:18:12.002         1996   Feb  03  17  18  12.002
C      Mar 2 12:18:17.287 1993       1993   Mar  02  12  18  17.287
C      1992 11:18:28  3 Jul          1992   Jul  03  11  18  28
C      June 12, 1989 01:21           1989   Jun  12  01  21  00
C      1978/3/12 23:28:59.29         1978   Mar  12  23  28  59.29
C      17JUN1982 18:28:28            1982   Jun  17  18  28  28
C      13:28:28.128 1992 27 Jun      1992   Jun  27  13  28  28.128
C      1972 27 jun 12:29             1972   Jun  27  12  29  00
C      '93 Jan 23 12:29:47.289       1993*  Jan  23  12  29  47.289
C      27 Jan 3, 19:12:28.182        2027*  Jan  03  19  12  28.182
C      23 A.D. APR 4, 18:28:29.29    0023** Apr  04  18  28  29.29
C      18 B.C. Jun 3, 12:29:28.291   -017** Jun  03  12  29  28.291
C      29 Jun  30 12:29:29.298       2029+  Jun  30  12  29  29.298
C      29 Jun '30 12:29:29.298       2030*  Jun  29  12  29  29.298
C
C      Day of Year Formats
C
C      String                        Year  DOY HR Min Sec
C      ----------------------------  ----  --- -- --- ------
C      1997-162::12:18:28.827        1997  162 12  18 28.827
C      162-1996/12:28:28.287         1996  162 12  28 28.287
C      1993-321/12:28:28.287         1993  231 12  28 28.287
C      1992 183// 12 18 19           1992  183 12  18 19
C      17:28:01.287 1992-272//       1992  272 17  28 01.287
C      17:28:01.282 272-1994//       1994  272 17  28 01.282
C      '92-271/ 12:28:30.291         1992* 271 12  28 30.291
C      92-182/ 18:28:28.281          1992* 182 18  28 28.281
C      182-92/ 12:29:29.192          0182+ 092 12  29 29.192
C      182-'92/ 12:28:29.182         1992  182 12  28 29.182
C
C
C      Julian Date Strings
C
C      jd 28272.291                  Julian Date   28272.291
C      2451515.2981 (JD)             Julian Date 2451515.2981
C      2451515.2981 JD               Julian Date 2451515.2981
C
C                                   Abbreviations Used in Tables
C
C                                      na    --- Not Applicable
C                                      Mon   --- Month
C                                      DOY   --- Day of Year
C                                      DOM   --- Day of Month
C                                      Wkday --- Weekday
C                                      Hr    --- Hour
C                                      Min   --- Minutes
C                                      Sec   --- Sec
C
C      * The default interpretation of a year that has been abbreviated
C      with a leading quote as in 'xy (such as '92) is to treat
C      the year as 19xy if xy > 68 and to treat it is 20xy otherwise.
C      Thus '70 is interpreted as 1970 and '67 is treated as 2067.
C      However, you may change the "split point" and centuries through
C      use of the SPICE routine TSETYR which is an entry point in
C      the SPICE module TEXPYR.  See that routine for a discussion of
C      how you may reset the split point.
C
C      ** All epochs are regarded as belonging to the Gregorian
C      calendar.  We formally extend the Gregorian calendar backward
C      and forward in time for all epochs.  If you have epochs belonging
C      to the Julian Calendar, consult the routines TPARTV and JUL2GR
C      for a discussion concerning conversions to the Gregorian
C      calendar and ET.
C
C      +  When a day of year format or calendar format string is
C      input and neither of integer components of the date
C      is greater than 1000, the first integer
C      is regarded as being the year.
C
C      Any integer greater than 1000
C      is regarded as a year specification. Thus 1001-1821//12:28:28
C      is interpreted as specifying two years and will be rejected
C      as ambiguous.
C
C$ Restrictions
C
C      None.
C
C$ Literature_References
C
C      None.
C
C$ Author_and_Institution
C
C      J.M. Lynch      (JPL)
C      W.M. Owen       (JPL)
C      M.J. Spencer    (JPL)
C      I.M. Underwood  (JPL)
C      W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 5.0.1, 18-MAY-2010 (BVS)
C
C        Removed "C$" marker from text in the header.
C
C-    SPICELIB Version 5.0.0, 30-DEC-1997 (WLT)
C
C        The routine was modified to compensate for the inability
C        of the Muller-Wimberly formula to handle negative years
C        (that is years prior to 1 AD.
C
C        Comments concerning the default century used for two
C        digit years were upgraded.
C
C-    SPICELIB Version 4.0.0, 8-APR-1996 (WLT)
C
C        All of the token recognition and parsing was moved
C        into the routine TPARTV.  The entry point TPARCH
C        was moved to the routine TCHECK.
C
C        This routine now merely assembles the
C        parsed components to produce SP2000.
C
C        The number of strings now recognized has been greatly
C        increased.  However, the interpretation given to
C        strings such as  31 Jan 32 has been changed.
C
C-    SPICELIB Version 3.0.0, 30-JUL-1993 (WLT)
C
C        The entry point TPARCH was added so that users may
C        restrict the set of input calendar strings to those
C        that are in proper form.
C
C-    SPICELIB Version 2.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 2.0.0, 18-NOV-1991 (MJS)
C
C        TPARSE no longer accepts a blank time string.
C
C-    SPICELIB Version 1.0.1, 26-MAR-1991 (JML)
C
C        In the Detailed_Input section of the header, the
C        description of how default values are assigned to
C        tokens in STRING was clarified.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WMO) (IMU)
C
C-&

C$ Index_Entries
C
C     parse a utc time string
C
C-&

C$ Revisions
C
C-    SPICELIB Version 5.0.0, 30-DEC-1997 (WLT)
C
C        The routine was modified to compensate for the inability
C        of the Muller-Wimberly formula to handle negative years
C        (that is years prior to 1 AD.
C
C        Comments concerning the default century used for two
C        digit years were upgraded.
C
C-    SPICELIB Version 4.0.0, 8-APR-1996 (WLT)
C
C        All of the token recognition and parsing was moved
C        into the routine TPARTV.  The entry point TPARCH
C        was moved to the routine TCHECK.
C
C        This routine now merely assembles the
C        the parsed components to produce SP2000.
C
C-    SPICELIB Version 3.0.0, 30-JUL-1993 (WLT)
C
C        The entry point TPARCH was added so that users may
C        restrict the set of input calendar strings to those
C        that are in proper form.
C
C-    SPICELIB Version 2.0.0, 18-NOV-1991 (MJS)
C
C        TPARSE no longer accepts a blank time string. Prior to
C        this fix, TPARSE interpreted a blank time string to be
C        -1577880000.000 UTC seconds (1 JAN 1950 00:00:00).
C
C-    SPICELIB Version 1.0.1, 26-MAR-1991 (JML)
C
C        In the Detailed_Input section of the header, the
C        description of how default values are assigned to
C        tokens in STRING was clarified.
C
C        NAIFers are accustomed to specifying day of year
C        formats of UTC strings in the following form:
C
C           1986-247 // 12:00:00
C
C        This revision to the header states explicitly that
C        the // is a blank token which results in the default
C        value being assigned to the month token.  The previous
C        version of the header implied that tokens could be left
C        out or "missing" from the string, and that default values
C        would automatically be assigned.  This works only for
C        tokens missing from the right end of the string.  For
C        default values to be assigned to tokens missing from the
C        middle of a UTC string, consecutive delimiters such as
C        // or :: must be included.
C
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      J2000
      DOUBLE PRECISION      SPD

C
C     Parameters
C
      INTEGER               ERA
      PARAMETER           ( ERA    =  1 )

      INTEGER               WDAY
      PARAMETER           ( WDAY   = ERA    + 1 )

      INTEGER               ZONE
      PARAMETER           ( ZONE   = WDAY   + 1 )

      INTEGER               AMPM
      PARAMETER           ( AMPM   = ZONE   + 1 )

      INTEGER               SYSTEM
      PARAMETER           ( SYSTEM = AMPM   + 1 )

      INTEGER               LNSIZE
      PARAMETER           ( LNSIZE = 80 )

C
C     Local variables
C

      CHARACTER*(5)         TYPE
      CHARACTER*(8)         MODIFY   ( 5 )

      CHARACTER*(LNSIZE)    PICTUR

      DOUBLE PRECISION      TVEC     ( 10 )

      INTEGER               DAY
      INTEGER               MONTH
      INTEGER               NTVEC
      INTEGER               Q
      INTEGER               TEMP
      INTEGER               YEAR

      LOGICAL               ADJUST
      LOGICAL               MODS
      LOGICAL               OK
      LOGICAL               SUCCES
      LOGICAL               YABBRV

C
C     All the work of taking apart the string is handled
C     by TPARTV.
C
      ERROR  = ' '
      SUCCES = .TRUE.

      CALL TPARTV ( STRING,
     .              TVEC,   NTVEC, TYPE,
     .              MODIFY, MODS,  YABBRV, SUCCES,
     .              PICTUR, ERROR )

      IF ( .NOT. SUCCES ) THEN
         RETURN
      END IF

C
C     We are not going to support all of the various
C     time string modifiers that can be parsed.
C
      IF ( MODS ) THEN

         IF ( MODIFY(SYSTEM) .NE. ' ' ) THEN

            ERROR = 'TPARSE does not support the specification '
     .      //      'of a time system in a string.  The time '
     .      //      'system # was specified. '
            CALL REPMC ( ERROR, '#', MODIFY(SYSTEM), ERROR )
            RETURN

         ELSE IF ( MODIFY(ZONE) .NE. ' ' ) THEN

            ERROR = 'TPARSE does not support the specification '
     .      //      'of a time zone in a time string.  The time '
     .      //      'zone ''#'' was specified. '
            CALL REPMC ( ERROR, '#', MODIFY(ZONE), ERROR )
            RETURN

         ELSE IF ( MODIFY(AMPM) .NE. ' ' ) THEN

            ERROR = 'TPARSE does not support the AM/PM '
     .      //      'conventions for time strings. '
            RETURN

         END IF

      END IF

      IF ( TYPE .EQ. 'JD' ) THEN
C
C        Nothing to do but convert TVEC(1).
C

         SP2000 = (TVEC(1)-J2000()) * SPD()

      ELSE IF ( TYPE .EQ. 'YMD' .OR. TYPE .EQ. 'YD' ) THEN

         CALL TCHECK ( TVEC, TYPE, MODS, MODIFY, OK, ERROR )

         IF ( .NOT. OK ) THEN
            RETURN
         END IF
C
C        If we have day of year format, we move it into the
C        month-day of month format.
C
         IF ( TYPE .EQ. 'YD' ) THEN
            TVEC(6) = TVEC(5)
            TVEC(5) = TVEC(4)
            TVEC(4) = TVEC(3)
            TVEC(3) = TVEC(2)
            TVEC(2) = 1.0D0
         END IF
C
C        Get the year month and day as integers.
C
         YEAR   = NINT( TVEC(1) )
         MONTH  = NINT( TVEC(2) )
         DAY    = NINT( TVEC(3) )
C
C        Fix up the year as needed.
C
         IF ( MODIFY(ERA) .EQ. 'B.C.' ) THEN

            YEAR = 1 - YEAR

         ELSE IF ( MODIFY(ERA) .EQ. 'A.D.' ) THEN
C
C           Do nothing.
C
         ELSE IF ( YEAR .LT. 100 ) THEN

            CALL TEXPYR ( YEAR )

         END IF

C
C        Apply the Muller-Wimberly formula and then tack on
C        the seconds.
C
         IF ( YEAR .LT. 1 ) THEN
C
C           The Muller-Wimberly formula doesn't work for years
C           less than 0.  So we boost the year by an appropriate
C           multiple of 400 and then subtract the appropriate
C           number of days later.
C
            ADJUST = .TRUE.
            TEMP   =  YEAR

            CALL RMAINI ( TEMP, 400, Q, YEAR )

            YEAR = YEAR  + 400
            Q    = Q-1

         ELSE

            ADJUST = .FALSE.

         END IF

         DAY    = 367*YEAR - 7*(YEAR+(MONTH+9)/12)/4
     .                     - 3*((YEAR+(MONTH-9)/7)/100+1)/4
     .                     + 275*MONTH/9 + DAY - 730516

         IF ( ADJUST ) THEN
C
C           Adjust DAY by the appropriate multiple of 400 years.
C
            DAY = DAY + Q*(400*365 + 97)

         END IF

         SP2000 =  ( DBLE (DAY) - 0.5D0 ) * SPD()
     .            +  3600.0D0 * TVEC(4)
     .            +    60.0D0 * TVEC(5)
     .            +             TVEC(6)

      ELSE
C
C        We've already covered all the bases we are planning to
C        cover in this routine.  Any other case is regarded as an
C        error.
C

         ERROR = 'The only type of time strings that are handled '
     .   //      'by TPARSE are ''JD'', ''YMD'' and ''YD'' '
     .   //      '(year day-of-year).  You''ve entered a string '
     .   //      'of the type #. '

         CALL REPMC ( ERROR, '#', TYPE, ERROR )

      END IF

      RETURN

      END


      SUBROUTINE SHPMBW (HDING, WKID, REQMW, EXPMW, NOMMW, PFSW)

C  SHPMBW tests the rendering of a given marker size, and returns the
C  pass/fail result.
C
C  Input parameters:
C    HDING : Title for this test
C    WKID  : Workstation identifier
C    REQMW : The marker size (in DC) to be requested.
C    EXPMW : The expected marker size (in DC) - the one which should
C            be realized in order to pass.
C    NOMMW : The nominal marker size
C  Output parameters:
C    PFSW  : Result of the test - P for pass, F for fail, A for abort.

      COMMON /DIALOG/ DOUTYP, DINTYP, DSTDNR, DSTRID, PSTRID, DTCLIM,
     1                SCRMOD, DTXCI, SPECWT,
     2                DSIZE, EFRAC, DYXRAT, SYXRAT, MTRPDC, WCPDC, QVIS
      INTEGER         DOUTYP, DINTYP, DSTDNR, DSTRID, PSTRID, DTCLIM,
     1                SCRMOD, DTXCI, SPECWT
      REAL            DSIZE, EFRAC, DYXRAT, SYXRAT, MTRPDC, WCPDC, QVIS

C aspect source
C                bundled     individual
      INTEGER    PBUNDL,     PINDIV
      PARAMETER (PBUNDL = 0, PINDIV = 1)

C marker type
      INTEGER    PPOINT,   PPLUS,   PAST,   POMARK,   PXMARK
      PARAMETER (PPOINT=1, PPLUS=2, PAST=3, POMARK=4, PXMARK=5)

C text alignment horizontal
      INTEGER    PAHNOR,     PALEFT,     PACENT,     PARITE
      PARAMETER (PAHNOR = 0, PALEFT = 1, PACENT = 2, PARITE = 3)

C text alignment vertical
      INTEGER    PAVNOR,     PATOP,      PACAP,     PAHALF,
     1           PABASE,     PABOTT
      PARAMETER (PAVNOR = 0, PATOP  = 1, PACAP = 2, PAHALF = 3,
     1           PABASE = 4, PABOTT = 5)

      INTEGER    IX, NUMALT, RNDINT, ANS, PERM(20), WKID
      INTEGER    MKST, ERRIND, IDUM1,IDUM2,IDUM3

      REAL       REQMW, EXPMW, NOMMW, XA(60),YA(60), ALT(10)
      REAL       XLOC,YBASE, YLOC, XINCR, MSIZE
      REAL       PMX(1),PMY(1), YGAP, CENTX,CENTY
      REAL       SCRSIZ, SCRX,SCRY, MKRAD

      LOGICAL    DYN

      CHARACTER  PFSW*1, HDING*(*), MSG*300, DIGIT*1

C  can we fit 4 across in the picture area?
      IF (EXPMW * WCPDC .LT. 0.25) GOTO 50

C  can we fit on the screen as a whole? - if not, quit
      CALL PQDSP (SPECWT, ERRIND, IDUM1, SCRX,SCRY, IDUM2,IDUM3)
      CALL CHKINQ ('pqdsp', ERRIND)
      SCRSIZ = MIN(SCRX,SCRY)
      IF (EXPMW .GT. SCRSIZ) THEN
         PFSW = 'A'
         RETURN
      ENDIF

C  draw on full screen - override view #1
      CALL PSVWI (3)
C  use ASFs bundled
      CALL SETASF (PBUNDL)
C  attributes for actual marker, use index #13
      CALL PSPMR (WKID, 13, PPLUS, REQMW/NOMMW, 1)
      XA(1) = .5
      YA(1) = SYXRAT/2
      CALL PSPMI (13)
      CALL PPM (1, XA,YA)

C  MKRAD is simulated marker radius - this works because in
C  view #3, in x-dimension, WC:1 = DC:SCRX
      MKRAD = EXPMW / (2 * SCRX)
      CENTX = .5
      CENTY = SYXRAT/2
C  simulate circle to surround non-circle marker
      CALL SIMARK (POMARK, 1, MKRAD, CENTX,CENTY)

      IF (DYN('Does the marker fit exactly within the circle?')) THEN
         PFSW = 'P'
      ELSE
         PFSW = 'F'
      ENDIF
      GOTO 666

50    CONTINUE

C  alt = list of alternative operator choices for marker size
C  numalt = total number of alternative marker sizes generated
      CALL ALTSIZ (EXPMW, QVIS, 0.25 / WCPDC, 4, NUMALT,ALT)

      CALL RNPERM (NUMALT, PERM)

C  draw actual markers and simulate markers of various sizes
      XINCR = 1.0 / NUMALT
      XLOC  = XINCR/2
      YBASE = 0.375
      PMY(1) = YBASE
      YGAP = MAX(1.5 * EXPMW * WCPDC, 0.1)
      YLOC  = YBASE + YGAP
C  bundle for actual marker, use bundle 17
C  pick a marker between 2 and 4
      MKST = RNDINT(2,4)
      CALL PSPMR (WKID, 17, MKST, REQMW/NOMMW, 1)
      CALL PSPMI (17)
C  attributes for label
      CALL PSTXAL (PACENT,PAHALF)
      CALL PSCHH  (0.05)

      DO 500 IX = 1,NUMALT
C  reset  to bundled, since SIMARK uses individual
         CALL SETASF (PBUNDL)
C draw actual marker
         PMX(1) = XLOC
         CALL PPM (1, PMX,PMY)

C  simulate marker with polylines
         MSIZE = ALT(PERM(IX)) * WCPDC
         MKRAD = MSIZE / 2
         CALL SIMARK (MKST, 1, MKRAD, XLOC,YLOC)
C  now label
         WRITE (DIGIT, '(I1)') IX
         CALL PTX (XLOC, 0.175, DIGIT)

         XLOC = XLOC + XINCR
500   CONTINUE

      MSG = HDING // ': Which pair of markers has the same size?'
      CALL DCHOIC (MSG, 0,NUMALT, ANS)
      IF (ANS .EQ. 0) THEN
         CALL OPCOMT
         PFSW = 'F'
      ELSEIF (PERM(ANS) .EQ. 1) THEN
         PFSW = 'P'
      ELSE
         PFSW = 'F'
      ENDIF
666   CONTINUE
C  clear out last display from structure
      CALL PSEP (1)
      CALL PDELLB (1,2)

      END


c*************************************************************************
c                            RMVS_STEP_OUT.F
c*************************************************************************
c This subroutine takes a full dt step in helio coord for particles
c in the outer region of an encounter.  It will also remember
c where the planets are for the planocentric integration if necessary.
c
c             Input:
c                 i1st          ==>  = 0 if first step; = 1 not (int scalar)
c                 nbod          ==>  number of massive bodies (int scalar)
c                 ntp            ==>  number of massive bodies (int scalar)
c                 mass          ==>  mass of bodies (real array)
c                 j2rp2,j4rp4   ==>  J2*radii_pl^2 and  J4*radii_pl^4
c                                     (real scalars)
c                 xh,yh,zh      ==>  initial planet position in helio coord
c                                    (real arrays)
c                 vxh,vyh,vzh   ==>  initial planet velocity in helio coord
c                                    (real arrays)
c                 xht,yht,zht    ==>  initial tp position in helio coord
c                                      (real arrays)
c                 vxht,vyht,vzht ==>  initial tp velocity in helio coord
c                                        (real arrays)
c                 istat           ==>  status of the test paricles
c                                      (2d integer array)
c                                      istat(i,1) = 0 ==> active:  = 1 not
c                                      istat(i,2) = -1 ==> Danby did not work
c                 icflg         ==> ecounters? = 1 Yes, in outer region only
c                                              = -1 in inner region
c                 ienco         ==> ienco(j) = 0 if tp j not involved in enc
c                                   in outer region: = planet# if it is.
c                                     (integer array)
c                                              =  0 No (integer scalar)
c                 dt            ==>  time step (real sclar)
c             Output:
c                 xh,yh,zh      ==>  final planet position in helio coord
c                                       (real arrays)
c                 vxh,vyh,vzh   ==>  final planet velocity in helio coord
c                                       (real arrays)
c                 xht,yht,zht    ==>  final tp position in helio coord
c                                       (real arrays)
c                 vxht,vyht,vzht ==>  final tp position in helio coord
c                                       (real arrays)
c                                      NOTE: only the tp in the outer region
c                                            will have their x and v's changed
c                 xtmp,ytmp,ztmp  ==>  position of planet wrt time
c                                       (2d real arrays)
c
c
c Remarks: Adopted from martin's nbwh.f program
c Authors:  Hal Levison
c Date:    2/19/93
c Last revision: 2/24/94

      subroutine rmvs_step_out(i1st,nbod,ntp,mass,j2rp2,j4rp4,xh,yh,zh,
     &              vxh,vyh,vzh,xht,yht,zht,vxht,vyht,vzht,istat,
     &              icflg,ienco,dt,xtmp,ytmp,ztmp)

      include '../swift.inc'
      include 'rmvs.inc'

c...  Inputs Only:
      integer nbod,ntp,i1st
      real*8 mass(nbod),dt,j2rp2,j4rp4

c...  Inputs and Outputs:
      integer istat(NTPMAX,NSTAT)
      real*8 xh(nbod),yh(nbod),zh(nbod)
      real*8 vxh(nbod),vyh(nbod),vzh(nbod)
      real*8 xht(ntp),yht(ntp),zht(ntp)
      real*8 vxht(ntp),vyht(ntp),vzht(ntp)
      integer icflg,ienco(NTPMAX)

c...  Outputs only
      real*8 xtmp(NPLMAX,NTPENC),ytmp(NPLMAX,NTPENC)
      real*8 ztmp(NPLMAX,NTPENC)

c...  Internals
      integer i1sttp,nstep,i,j,k,ic,istattmp(NTPMAX,NSTAT)
      real*8 dto,dti
      real*8 xbeg(NPLMAX),ybeg(NPLMAX),zbeg(NPLMAX)
      real*8 xend(NPLMAX),yend(NPLMAX),zend(NPLMAX)

c----
c...  Executable code

      i1sttp = i1st

      dto = dt/float(NTENC)
      if(icflg.le.-1) then    ! need high t resolution of planocentric
        nstep = NTPHENC
        dti = dt/float(NTPENC)
      else
        nstep = 1
        dti = dt/float(NTENC)
      endif

c...  We only want to integrate the position of test particles in outer region
c...  make a temporary istat array ao only they are active
      do i=1,ntp
         if(ienco(i).eq.0) then
            istattmp(i,1) = 1       ! don't integrate it
          else
            istattmp(i,1) = 0       ! integrate it
          endif
          do j=2,NSTAT
             istattmp(i,j) = 0
          enddo
       enddo

c...  do integration of outer loop
       ic = 0
       do i=1,NTENC

c...      remember the current position of the planets
          do j=1,nbod
             xbeg(j) = xh(j)
             ybeg(j) = yh(j)
             zbeg(j) = zh(j)
          enddo

          do j=1,nstep
            call step_kdk_pl(i1st,nbod,mass,j2rp2,j4rp4,xh,yh,zh,
     &            vxh,vyh,vzh,dti)
            if(icflg.le.-1) then
               ic = ic + 1
               do k=1,nbod
                  xtmp(k,ic) = xh(k)
                  ytmp(k,ic) = yh(k)
                  ztmp(k,ic) = zh(k)
               enddo
            endif
          enddo

c...      remember these positions
          do j=1,nbod
             xend(j) = xh(j)
             yend(j) = yh(j)
             zend(j) = zh(j)
          enddo

          call step_kdk_tp(i1sttp,nbod,ntp,mass,j2rp2,j4rp4,
     &              xbeg,ybeg,zbeg,xend,yend,zend,
     &              xht,yht,zht,vxht,vyht,vzht,istattmp,dto)

       enddo

c...   Have to update istat just in case damby had problems
      do i=1,ntp
         if( (ienco(i).ne.0) .and. (istattmp(i,1).ne.0) ) then
            istat(i,1) = 1       ! it had problems
            do j=2,NSTAT
                 istat(i,j) = istattmp(i,j)
            enddo
         endif
       enddo

       return
       end     ! rmvs_step_out
c----------------------------------------------------------------


module da_transfer_model

   !---------------------------------------------------------------------------
   ! Purpose: Transfer model states between different models
   !---------------------------------------------------------------------------

   use module_configure, only : grid_config_rec_type, model_config_rec
   use module_date_time, only : geth_julgmt, current_date, start_date
   use module_domain, only : domain, domain_clock_get, x_type, vp_type, ep_type
   use module_io_domain, only : open_r_dataset, close_dataset, input_auxinput17, &
      output_auxinput7, open_w_dataset
   use module_state_description, only : dyn_em_ad, dyn_em, dyn_em_tl, &
      p_qv, p_qr, p_qi, p_qs, p_qg, p_qc, param_first_scalar, num_moist, &
      p_g_qv, p_g_qr, p_g_qi, p_g_qs, p_g_qg, p_g_qc, &
      p_a_qv, p_a_qr, p_a_qi, p_a_qs, p_a_qg, p_a_qc, num_g_moist, num_a_moist, &
      f_qc, f_qr, f_qi, f_qs, f_qg, f_g_qc, f_g_qr, f_g_qi, f_g_qs, f_g_qg, &
      f_a_qc, f_a_qr, f_a_qi, f_a_qs, f_a_qg, warmrain_ad
   use module_dm, only : wrf_dm_sum_real, wrf_dm_sum_reals
#ifdef DM_PARALLEL
   use module_dm, only : local_communicator, &
      ntasks_x, ntasks_y, data_order_xyz, mytask, &
      ntasks, data_order_xy
   use module_comm_dm, only : halo_xa_sub, halo_init_sub, halo_psichi_uv_adj_sub, &
                              halo_xb_sub, halo_xb_uv_sub, halo_em_c_sub, halo_em_c_tl_sub, &
                              halo_xa_a_sub, halo_x6a_a_sub, halo_em_bdy_sub, halo_em_e_tl_sub, &
                              halo_em_e_sub
#endif

   use da_control, only : cos_xls, sin_xls, cos_xle, sin_xle, trace_use, &
      coarse_jy, coarse_ix, cone_factor, delt_lon, delt_lat, gas_constant, &
      map_projection,earth_omega,mix,pi,phic,mkz,start_lon,start_lat, &
      start_x,xlonc,start_y,mjy, global, rad_to_deg, deg_to_rad, earth_radius, &
      var4d,var4d_lbc,analysis_date,coarse_ds,analysis_accu,dsm,pole, fg_format_kma_global, &
      fg_format, fg_format_wrf_arw_regional, fg_format_wrf_nmm_regional, &
      print_detail_map,stdout,truelat1_3dv, base_pres, fg_format_wrf_arw_global, &
      truelat2_3dv, periodic_x,write_increments,max_ext_its, gravity, &
      kappa, print_detail_xa,rd_over_rv,t0, print_detail_xa, check_rh, adj_sens,&
      print_detail_xb,test_dm_exact,base_lapse,base_temp,vertical_ip,ptop, &
      use_gpsztdobs, use_ssmitbobs, use_radarobs, use_radar_rf, use_radar_rhv,&
      dt_cloud_model, cp, use_ssmiretrievalobs, var4d_detail_out, &
      vertical_ip_sqrt_delta_p, vertical_ip_delta_p,check_rh_simple, check_rh_tpw, &
      t_kelvin, num_fgat_time, num_pseudo, iso_temp, interval_seconds, trajectory_io, &
      ids,ide,jds,jde,kds,kde, ims,ime,jms,jme,kms,kme, num_fft_factors, &
      its,ite,jts,jte,kts,kte, ips,ipe,jps,jpe,kps,kpe, qlimit, &
      update_sfcdiags, use_wrf_sfcinfo, use_radar_rqv, cloudbase_calc_opt, use_gpsephobs, &
      cloud_cv_options
   use da_control, only: base_pres_strat, base_lapse_strat
   use da_control, only: c1f, c2f, c1h, c2h, c3f, c3h, c4f, c4h
   use da_define_structures, only : xbx_type, be_type
   use da_par_util, only : da_patch_to_global
   use da_physics, only : da_check_rh_simple,da_roughness_from_lanu, &
      da_sfc_wtq,da_tpq_to_rh,da_trh_to_td,da_wrf_tpq_2_slp,da_integrat_dz, &
      da_tp_to_qs, da_check_rh,da_transform_xtogpsref, da_transform_xtoztd, &
      sfclayinit
   use da_reporting, only : da_error,message, da_message, da_warning
   use da_setup_structures, only : da_setup_runconstants,da_write_increments, &
      da_write_kma_increments,da_cloud_model, da_write_increments_for_wrf_nmm_regional
   use da_ssmi, only : da_transform_xtotb
   use da_tools, only : map_info, proj_merc, proj_ps,proj_lc,proj_latlon, &
      da_llxy_default,da_llxy_wrf,da_xyll,da_diff_seconds,da_map_set, &
      da_set_boundary_xb
   use da_tracing, only : da_trace_entry, da_trace_exit, da_trace
   use da_vtox_transforms, only : da_get_vpoles
   use da_radar, only : zlcl_mean
   use da_gpseph, only : da_gpseph_init
   use da_wrf_interfaces, only : wrf_dm_bcast_real
#ifdef VAR4D
   use da_4dvar, only : model_grid, push_ad_forcing, push_tl_pert, pop_tl_pert, kj_swap, &
       kj_swap_reverse, model_config_flags, g_couple, g_stuff_bdy, a_couple, a_stuff_bdy, &
       g_stuff_bdytend, a_stuff_bdytend_old, a_stuff_bdytend_new, decouple, da_calc_2nd_fg, &
       ubdy3dtemp1 , vbdy3dtemp1 , tbdy3dtemp1 , pbdy3dtemp1 , qbdy3dtemp1, mbdy2dtemp1, &
       ubdy3dtemp2 , vbdy3dtemp2 , tbdy3dtemp2 , pbdy3dtemp2 , qbdy3dtemp2, mbdy2dtemp2, &
       wbdy3dtemp1,  wbdy3dtemp2, da_bdy_fields_halo
   use module_bc, only : set_physical_bc2d
   use module_big_step_utilities_em, only : calc_mu_uv
   use g_module_big_step_utilities_em, only : g_calc_mu_uv
   use a_module_big_step_utilities_em, only : a_calc_mu_uv
   USE module_io_wrf, only : auxinput8_alarm, auxhist8_alarm, auxhist7_alarm
#ifdef DM_PARALLEL
   use mediation_pertmod_io, only : da_halo_em_e_ad
#endif
#endif

   implicit none

   contains

#include "da_transfer_wrftoxb.inc"
#include "da_transfer_wrf_nmm_regional_toxb.inc"
#include "da_transfer_kmatoxb.inc"
#include "da_transfer_xatowrf.inc"
#include "da_transfer_xatowrf_nmm_regional.inc"
#include "da_transfer_xatokma.inc"
#include "da_transfer_wrftltoxa.inc"
#include "da_transfer_wrftltoxa_adj.inc"
#include "da_transfer_xatowrftl.inc"
#include "da_transfer_xatowrftl_lbc.inc"
#include "da_transfer_wrftl_lbc_t0.inc"
#include "da_transfer_xatowrftl_adj.inc"
#include "da_transfer_xatowrftl_adj_lbc.inc"
#include "da_transfer_wrftl_lbc_t0_adj.inc"
#include "da_transfer_xatoanalysis.inc"
#include "da_setup_firstguess.inc"
#include "da_setup_firstguess_wrf.inc"
#include "da_setup_firstguess_wrf_nmm_regional.inc"
#include "da_setup_firstguess_kma.inc"
#include "da_get_2nd_firstguess.inc"

end module da_transfer_model


      subroutine inv_op(ninp,label_inp,nlist,label_inv,mode,
     &     op_info,orb_info,str_info,strmap_info)
*----------------------------------------------------------------------*
*     Wrapper subroutine used in the inversion of the matrix
*     representation of an operator, op_inp.
*     The resultant is op_inv.
*     Optionally, the unitary matrix is returned on a second output list
*     GWR November 2007.
*----------------------------------------------------------------------*

      implicit none

      integer, parameter ::
     &     ntest = 00

      include 'stdunit.h'
      include 'opdim.h'
      include 'def_orbinf.h'
      include 'mdef_operator_info.h'
      include 'def_graph.h'
      include 'def_strinf.h'
      include 'def_strmapinf.h'
      include 'ifc_memman.h'
      include 'par_opnames_gen.h'

      integer, intent(in) ::
     &     ninp, nlist
      character(*), intent(in) ::
     &     label_inp(ninp), label_inv(nlist)
      type(operator_info), intent(inout) ::
     &     op_info
      type(orbinf), intent(in) ::
     &     orb_info
      type(strinf), intent(in) ::
     &     str_info
      type(strmapinf), intent(in) ::
     &     strmap_info
      character(len=*), intent(in) ::
     &     mode

      type(me_list), pointer ::
     &     me_inp, me_inv, me_u, me_spc

      integer ::
     &     idx_inp, idx_inv, idx_u, idx_spc,
     &     njoined, join_off, idx, nocc_cls, iocc_cls
      integer ::
     &     opinp_temp(ngastp,2), opinv_temp(ngastp,2)
      logical ::
     &     open_close_inv, open_close_inp, open_close_u, open_close_spc
      real(8) ::
     &     cpu, sys, wall, cpu0, sys0, wall0

      logical, external ::
     &     iocc_equal
      integer, external ::
     &     idx_mel_list

      call atim_csw(cpu0,sys0,wall0)

      if (ntest.ge.100) then
        write(lulog,*) '===================='
        write(lulog,*) ' Operator inversion '
        write(lulog,*) '===================='
        write(lulog,*) 'To be inverted: ',trim(label_inp(1))
        write(lulog,*) 'The inverse: ',trim(label_inv(1))
        if (nlist.eq.2)write(lulog,*)'Unitary mat.: ',trim(label_inv(2))
        if (ninp.eq.2) write(lulog,*) 'Spec. mat.: ',trim(label_inp(2))
      end if

      idx_inp = idx_mel_list(label_inp(1),op_info)
      idx_inv = idx_mel_list(label_inv(1),op_info)
      if (ninp.gt.2.or.nlist.gt.2)
     &   call quit(1,'inv_op','too many lists given!')
      if (ninp.eq.2)
     &   idx_spc = idx_mel_list(label_inp(2),op_info)
      if (nlist.eq.2)
     &   idx_u = idx_mel_list(label_inv(2),op_info)

      if (idx_inp.lt.0.or.idx_inv.lt.0
     &    .or.nlist.eq.2.and.idx_u.lt.0
     &    .or.ninp.eq.2.and.idx_spc.lt.0) then
        write(lulog,*) '"',label_inv,'" "',label_inp,'"'
        write(lulog,*) idx_inv, idx_inp, idx_u, idx_spc
        call quit(1,'inv_op','label not on list')
      end if

      ! Point to the relevant operators and their associated files.
      me_inv => op_info%mel_arr(idx_inv)%mel
      me_inp => op_info%mel_arr(idx_inp)%mel
      if (nlist.eq.2) then
        me_u => op_info%mel_arr(idx_u)%mel
      else
        me_u => me_inv
      end if
      if (ninp.eq.2) then
        me_spc => op_info%mel_arr(idx_spc)%mel
      else
        me_spc => me_inv ! dummy, just to avoid problems
      end if

      if (.not.associated(me_inv%fhand))
     &     call quit(1,'inv_op','no file handle defined for '//
     &                  trim(me_inv%label))
      if (.not.associated(me_inp%fhand))
     &     call quit(1,'inv_op','no file handle defined for '//
     &                  trim(me_inp%label))
      if (nlist.eq.2.and..not.associated(me_u%fhand))
     &     call quit(1,'inv_op','no file handle defined for '//
     &                  trim(me_u%label))

      if(ntest.ge.1000)then
        write(lulog,*) 'input mat on ',trim(me_inp%op%name)
        call wrt_mel_file(lulog,5,me_inp,1,
     &       me_inp%op%n_occ_cls,str_info,orb_info)
      end if

      open_close_inv = me_inv%fhand%unit.le.0
      open_close_u = .false.
      open_close_spc = .false.
      if (nlist.eq.2) open_close_u = me_u%fhand%unit.le.0
      if (ninp.eq.2) open_close_spc = me_spc%fhand%unit.le.0
      if(open_close_inv)then
        call file_open(me_inv%fhand)
      endif
      open_close_inp = me_inp%fhand%unit.le.0
      if(open_close_inp)then
        call file_open(me_inp%fhand)
      endif
      if (open_close_u) call file_open(me_u%fhand)
      if (open_close_spc) call file_open(me_spc%fhand)

      ! Check that the two operators have the same shape.
      ! not necessarily: in principle, the inverse is the
      ! contravariant operator with a different shape!
      njoined = me_inp%op%njoined
      if(njoined.ne.me_inv%op%njoined
     &   .or.nlist.eq.2.and.njoined.ne.me_u%op%njoined)
     &     call quit(1,'inv_op','in and out incompatible: njoined')
      nocc_cls = me_inp%op%n_occ_cls
      if(nocc_cls.ne.me_inv%op%n_occ_cls
     &   .or.nlist.eq.2.and.mode(1:7).ne.'invdiag'
     &   .and.nocc_cls.ne.me_u%op%n_occ_cls)
     &     call quit(1,'inv_op','in and out incompatible: nocc_cls')

      ! Compare the block structures of the operators. The assumption is
      ! that the comparable blocks are in the same order.
      opinp_temp(1:ngastp,1:2)=0
      opinv_temp(1:ngastp,1:2)=0

      do iocc_cls = 1, nocc_cls
        join_off = (iocc_cls-1)*njoined
        do idx=1,njoined
          opinp_temp(1:ngastp,1:2) =
     &         me_inp%op%ihpvca_occ(1:ngastp,1:2,join_off+idx)
          opinv_temp(1:ngastp,1:2) =
     &         me_inv%op%ihpvca_occ(1:ngastp,1:2,join_off+idx)

          if (.not.iocc_equal(opinp_temp,me_inp%op%dagger,
     &         opinv_temp,me_inv%op%dagger)) then
            call quit(1,'inv_op','in and out incompatible: occs.')
          endif
          if (nlist.eq.2.and.mode(1:7).ne.'invdiag') then
            opinv_temp(1:ngastp,1:2) =
     &           me_u%op%ihpvca_occ(1:ngastp,1:2,join_off+idx)
            if (.not.iocc_equal(opinp_temp,me_inp%op%dagger,
     &         opinv_temp,me_u%op%dagger))
     &         call quit(1,'inv_op','in and out incompatible: occs.(2)')
          end if

        enddo
      enddo

      ! NOTE:
      ! actually, we should check whether the input operator consists
      ! of diagonal blocks only (N(A)==N(C) in each of HPVX)
      ! (or that any off-diagonal block is zero)

      ! Call the actual inversion routine.
      if (mode(1:7).eq.'invsqrt') then
        write(lulog,*) 'Calculating square root of inverse'
        call invsqrt(me_inp,me_inv,nocc_cls,mode(8:11).eq.'half',
     &       nlist.eq.2,me_u,ninp.eq.2,me_spc,.false.,
     &       op_info,orb_info,str_info,strmap_info)
      else if (mode(1:9).eq.'pseudoinv') then
        if (nlist.eq.2) call warn('inv_op','Unitary matrix unavailable')
        call pseudoinv(me_inp,me_inv,nocc_cls,
     &                 op_info,orb_info)
      else if (mode(1:7).eq.'invdiag') then
        ! diagonalize matrix and get unitary matrix
        call invsqrt(me_inp,me_inv,nocc_cls,.true.,
     &       .false.,me_u,.false.,me_u,.true., ! dummies, special mode
     &       op_info,orb_info,str_info,strmap_info)
        if (mode(8:11).eq.'mult') then
          if (nlist.ne.2)
     &       call quit(1,'inv_op','Provide list for unitary matrix!')
          ! now multiply previous transformation list with
          call mult_trafmats(me_u,me_inv,
     &         op_info,orb_info,str_info)
        end if
      else
        if (nlist.eq.2) call warn('inv_op','Unitary matrix unavailable')
        call invert(me_inp,me_inv,nocc_cls,
     &              op_info,orb_info)
      end if

      if(ntest.ge.1000)then
        write(lulog,*) 'output mat on ',trim(me_inv%op%name)
        call wrt_mel_file(lulog,5,me_inv,1,
     &       me_inv%op%n_occ_cls,str_info,orb_info)
        write(lulog,*) 'output mat on ',trim(me_inp%op%name)
        call wrt_mel_file(lulog,5,me_inp,1,
     &       me_inp%op%n_occ_cls,str_info,orb_info)
      endif

      if (open_close_u)
     &     call file_close_keep(me_u%fhand)
      if (open_close_spc)
     &     call file_close_keep(me_spc%fhand)
      if (open_close_inv)
     &     call file_close_keep(me_inv%fhand)
      if (open_close_inp)
     &     call file_close_keep(me_inp%fhand)

      call atim_csw(cpu,sys,wall)
      call prtim(lulog,'time for inversion',
     &     cpu-cpu0,sys-sys0,wall-wall0)

      return
      end


	program gmecoords
c
C	A PROGRAM TO WRITE ORBIT PARAMETERS IN GSM, SAME AS MAKEFILE19
C
C	 PERIODS WHEN WIND IS MORE THAN
C		100 RE UPSTREAM
C		1996 MAY 19 TO AUG 12   =   5252  to  5336
C		1997 JAN 12 TO JUL 4    =   5490  to  5663
C		1997 NOV 2  TO FEB 20   =   5784  to  5893
C
	integer*4 ch,ok,okt,OK1,OK2,SCETI4(2)
	INTEGER*4 W_CHANNEL_CLOSE,W_EVENT,RET_SIZE,W_MESSAGES_OFF
	INTEGER*4 W_ITEM_I4,W_ITEM_R4,W_ITEM_R8,W_CHANNEL_POSITION
	INTEGER*4 W_CHANNEL_OPEN,GET_STREAM_NAME
	INTEGER*4 YYYY,MON,DD,HH,MM,TMCHANNEL
	REAL*8 SCET8,RGSM,SCETSTR,SCETEND
	character*32 ITEM
        character*80    stream
	character*4 event
	DATA NERR /0/
	DATA RE /6.378E3/
	DATA TWOPI /6.2831853/
C	data event /'TDSF'/
C	data event /'FILL'/
	data event /'HK'/
C
C
        READ(5,*) SCETSTR,SCETEND
        SCET8 = SCETSTR
        PRINT*,'DAYS',SCET8,SCETEND
c       OPEN(UNIT=90,FILE='MAKEFILE5.RESULTS',STATUS='OLD',ACCESS='OLD')
        call w_ur8_to_ymd(scet8,yyyy,mon,dd,hh,mm,ss,ms)
        PRINT*,'YMD',YYYY,MON,DD,HH,MM
        WRITE(stream,30) YYYY,MON,DD
 30     FORMAT(I4.4,I2.2,I2.2)
        OK = GET_STREAM_NAME(stream)
C
C       call w_ur8_to_ydoy(scet8,yyyy,idoy,msec)
C
       print*,'in main, after get_stream_name, stream=',stream
C
        ok = w_channel_open(tmchannel,stream)
C
       print*,'open, TMCHANNEL,ok=',TMCHANNEL,ok
        if (ok.ne.1) stop 'Cannot open t/m channel'
c
        scet = 0.
        call w_channel_position(tmchannel,scet)
        print*,'t/m file starts at scet',scet
        dds = scet
C
        ok = w_channel_open(tmchannel,stream)
C
C       print*,'open, TMCHANNEL,ok=',TMCHANNEL,ok
        if (ok.ne.1) stop 'Cannot open t/m channel'
	CH = TMCHANNEL
c
        scet = 0.
        call w_channel_position(tmchannel,scet)
        print*,'t/m file starts at scet',scet
        dds = scet
C
	OKT = W_MESSAGES_OFF(ch)
C
 100	ok = w_event(ch,event)
C
C	CHECK FOR END OF RECORD
C
	if (ok.ne.1) then
		write(6,*) 'cannot open ',event, ', ok=', ok
		NERR = NERR + 1
	        IF(NERR.LT.10) GO TO 100
		STOP
        ELSE
	   	NERR = 0
	endif
C
C
	ITEM = 'EVENT_SCET'
	ok = W_ITEM_I4(ch, item, SCETI4, 2, ret_size)
C
	ITEM = 'WIND_ORBIT_X(GSM)_R8'
	ok = W_ITEM_R8(ch, item, RGSM, 1, ret_size)
	XGSM = RGSM/RE
	ITEM = 'WIND_ORBIT_Y(GSM)_R8'
	ok = W_ITEM_R8(ch, item, RGSM, 1, ret_size)
	YGSM = RGSM/RE
	ITEM = 'WIND_ORBIT_Z(GSM)_R8'
	ok = W_ITEM_R8(ch, item, RGSM, 1, ret_size)
	ZGSM = RGSM/RE
	ITEM = 'EVENT_SCET_R8'
	OK = W_ITEM_R8(ch, item, SCET8, 1, ret_size)
	RRE = SQRT(XGSM**2 + YGSM**2 + ZGSM**2)
C
	PRINT*,'SCETI4 ',SCETI4(1)
	PRINT*,'SCETI4 ',SCETI4(2)
	WRITE(77,1077) SCET8,SCETI4(1),SCETI4(2),XGSM,YGSM,ZGSM,RRE
 1077	FORMAT(F11.3,I10,I8,4F9.3)
C
C	ENDDO
C
C	ITEM = 'WIND_MFI_BPHI(GSE)_R4'
C	ok = W_ITEM_R4(ch, item, AZMAG, 1, ret_size)
C	ITEM = 'MAG_ELEVATION'
C	ok = W_ITEM_I4(ch, item, MAGEL, 1, ret_size)
C	ITEM = 'SUN_ANGLE'
C	ok = W_ITEM_I4(ch, item, SUNCLOCK, 1, ret_size)
C	ITEM = 'WIND_3DP_E_TEMP_R4'
C	ok = W_ITEM_R4(ch, item, TEMPE, 1, ret_size)
C	ITEM = 'WIND_3DP_ION_TEMP_R4'
C	ok = W_ITEM_R4(ch, item, TEMPI, 1, ret_size)
C	ITEM = 'WIND_3DP_ION_DENSITY_R4'
C	ok = W_ITEM_R4(ch, item, DENS, 1, ret_size)
C	ITEM = 'WIND_3DP_ION_VX(GSE)_R4'
C	ok = W_ITEM_R4(ch, item, VX, 1, ret_size)
C	ITEM = 'WIND_3DP_ION_VY(GSE)_R4'
C	ok = W_ITEM_R4(ch, item, VY, 1, ret_size)
C	ITEM = 'WIND_MFI_BMAG_R4'
C	ok = W_ITEM_R4(ch, item, BMAG, 1, ret_size)
C	ITEM = 'WIND_SPIN_RATE_R4'
C	ok = W_ITEM_R4(ch, item, SPINRATE, 1, ret_size)
C	if(ok.ne.1) then
C	  spinrate = 2.
C	endif
	IF(SCET8.LT.SCETEND) GO TO 100
C
	ok = w_channel_close(ch)
	STOP
	end
        options/extend_source
!------------------------------------------------------------------------------
        integer*4       function        get_stream_name(stream)
! This routine gets the user's TM stream type specification.
!
        implicit        none
        character*(*)   stream
        CHARACTER*80    YYYYMMDD
        integer*4       iq
        DATA IQ /1/
C
           YYYYMMDD = STREAM(1:8)
           WRITE(STREAM,30) YYYYMMDD
 30        FORMAT('wi_lz_wav_',A8,'_v*.dat')
           PRINT*,'in get_stream_name, file= ',STREAM
c       end if

        get_stream_name = 1

 20     return
c
  5     format(q,a)
  7     format(1x,'or type desired time as YYYYMMDD, e.g. 19961113  ',$)
c
        end


*----------------------------------------------------------------------*
      subroutine reo_blk_wmaps_c(fac,xop_reo,xop_ori,
     &     len_reo,len_ori,
     &     sign_reo,
     &     tra_opreo,tra_opori,
     &     ms_op_c,ms_op_a,gm_op_c,gm_op_a,
     &     ms_i_dis_c,ms_i_dis_a,gm_i_dis_c,gm_i_dis_a,
     &     ncblk_opori,nablk_opori,
     &     cinfo_opori_c,cinfo_opori_a,
     &     lstr_opori,
     &     me_opreo, iblk_opreo,
     &     ncblk_opreo,nablk_opreo,
     &     cinfo_opreo_c,cinfo_opreo_a,
     &     ncblk_k,nablk_k,
     &     cinfo_k_c,cinfo_k_a,
     &     ncblk_i0,nablk_i0,
     &     cinfo_i0_c,cinfo_i0_a,
     &     map_info_to_ori_c, map_info_to_ori_a,
     &     map_info_to_reo_c, map_info_to_reo_a,
     &     nsym,str_info,strmap_info)
*----------------------------------------------------------------------*
*
*     reorder  OP([I1][I2]...) -> OP([I1'][I2']...)
*
*     initial version
*     andreas, oct 2007
*
*----------------------------------------------------------------------*
      implicit none

      include 'opdim.h'
      include 'stdunit.h'
      include 'ioparam.h'
      include 'multd2h.h'
      include 'hpvxseq.h'
      include 'def_filinf.h'
      include 'def_graph.h'
      include 'def_strinf.h'
      include 'def_strmapinf.h'
      include 'def_operator.h'
      include 'def_me_list.h'
      include 'ifc_memman.h'

      integer, parameter ::
     &     ntest = 00

      ! buffer with originally ordered elements
      ! (single distribution, see below)
      real(8), intent(in) ::
     &     xop_ori(*), fac
      ! buffer with ALL distributions of current MS, IRREP
      real(8), intent(inout) ::
     &     xop_reo(*)
      ! global sign factor, and lengthes of buffers
      integer, intent(in) ::
     &     sign_reo, len_reo, len_ori
      ! transposed addressing?
      logical, intent(in) ::
     &     tra_opreo, tra_opori

      ! info about operator block in original order
      integer, intent(in) ::
     &     ncblk_opori, nablk_opori,
     &     ms_op_c, ms_op_a, gm_op_c, gm_op_a,
     &     ms_i_dis_c(ncblk_opori), ms_i_dis_a(nablk_opori), ! dis(MS)
     &     gm_i_dis_c(ncblk_opori), gm_i_dis_a(nablk_opori), ! dis(IRREP)
     &     cinfo_opori_c(ncblk_opori,3), cinfo_opori_a(nablk_opori,3),
     &     lstr_opori(ncblk_opori+nablk_opori)

      ! info about reordered operator block
      ! ms_opreo_c == ms_op_c etc.
      ! but we must loop over different distributions
      integer, intent(in) ::
     &     ncblk_opreo, nablk_opreo,
     &     cinfo_opreo_c(ncblk_opreo,3), cinfo_opreo_a(nablk_opreo,3)

      ! info about strings with resolved occupations [I0], [K]
      type(me_list), intent(in) ::
     &     me_opreo
      integer, intent(in) ::
     &     iblk_opreo,
     &     ncblk_k, nablk_k, ncblk_i0, nablk_i0,
     &     cinfo_k_c(ncblk_k,3), cinfo_k_a(nablk_k,3),
     &     cinfo_i0_c(ncblk_i0,3), cinfo_i0_a(nablk_i0,3)
      ! reorder mappings for (condensed) occupations:
      integer, intent(in) ::
     &     map_info_to_ori_c(*), map_info_to_ori_a(*),
     &     map_info_to_reo_c(*), map_info_to_reo_a(*)

      integer, intent(in) ::
     &     nsym
      type(strinf), intent(in) ::
     &     str_info
      type(strmapinf), intent(inout) ::
     &     strmap_info

      logical ::
     &     first, possible, fix_success
      integer ::
     &     ms_k_c_max, ms_k_a_max, ms_i0_c_max, ms_i0_a_max,
     &     ms_k_c,     ms_k_a,     ms_i0_c,     ms_i0_a,
     &     gm_k_c,     gm_k_a,     gm_i0_c,     gm_i0_a
      integer ::
     &     ngraph, lenmap, ifree
      integer ::
     &     istr_k_a, istr_k_c, istr_i0_a, istr_i0_c,
     &     nstr_k_c_tot, nstr_k_a_tot,
     &     nstr_i0_c_tot, nstr_i0_a_tot,
     &     idxms_op_a, idxdis,
     &     idx00opreo, idxst_opreo,
     &     idx0opreo, idx_opreo, ioff, istr1, istr2, idiv1, idiv2,
     &     isgnt, isgna, ii,
     &     idx0opori, idx_opori, icmp, ielmap, idx, idx1, idx2

      integer ::
     &     ms_k_dis_c(ncblk_k), ms_k_dis_a(nablk_k),
     &     idxms_k_dis_c(ncblk_k), idxms_k_dis_a(nablk_k),
     &     gm_k_dis_c(ncblk_k), gm_k_dis_a(nablk_k),
     &     ms_i0_dis_c(ncblk_i0), ms_i0_dis_a(nablk_i0),
     &     idxms_i0_dis_c(ncblk_i0), idxms_i0_dis_a(nablk_i0),
     &     gm_i0_dis_c(ncblk_i0), gm_i0_dis_a(nablk_i0),
     &     idxms_ip_dis_c(ncblk_opreo), idxms_ip_dis_a(nablk_opreo),
     &     ms_ip_dis_c(ncblk_opreo), ms_ip_dis_a(nablk_opreo),
     &     gm_ip_dis_c(ncblk_opreo), gm_ip_dis_a(nablk_opreo),
     &     lstr_k(ncblk_k+nablk_k), lstr_i0(ncblk_i0+nablk_i0),
     &     lstr_opreo(ncblk_opreo+nablk_opreo),
     &     nstr_opreo_c(ncblk_opreo), nstr_opreo_a(nablk_opreo),
     &     nstr_opori_c(ncblk_opori), nstr_opori_a(nablk_opori),
     &     ldim_opreo_c(ncblk_opreo), ldim_opreo_a(nablk_opreo),
     &     ldim_opori_c(ncblk_opori), ldim_opori_a(nablk_opori),
     &     nstr_i0c1(ncblk_opori), nstr_i0a1(nablk_opori),
     &     nstr_i0c2(ncblk_opreo), nstr_i0a2(nablk_opreo),
     &     nstr_k_c1(ncblk_opori), nstr_k_a1(nablk_opori),
     &     nstr_k_c2(ncblk_opreo), nstr_k_a2(nablk_opreo),
     &     ireo_i0c1(ncblk_i0), ireo_i0a1(nablk_i0),
     &     ireo_i0c2(ncblk_i0), ireo_i0a2(nablk_i0),
     &     ireo_k_c1(ncblk_k), ireo_k_a1(nablk_k),
     &     ireo_k_c2(ncblk_k), ireo_k_a2(nablk_k),
     &     istr_i0c1(ncblk_opori), istr_i0a1(nablk_opori),
     &     istr_i0c2(ncblk_opreo), istr_i0a2(nablk_opreo),
     &     istr_k_c1(ncblk_opori), istr_k_a1(nablk_opori),
     &     istr_k_c2(ncblk_opreo), istr_k_a2(nablk_opreo)

      integer, pointer ::
     &     map_to_ori_c(:), map_to_ori_a(:),
     &     map_to_reo_c(:), map_to_reo_a(:)

      integer, pointer ::
     &     ndis_opreo(:,:), d_gam_ms_opreo(:,:,:),
     &     mapca(:), diag_idx(:), diag_ca(:)

      type(graph), pointer ::
     &     graphs(:)

      type(operator), pointer ::
     &     opreo
c dbg
c      logical ::
c     &     first_element
c dbg
      logical ::
     &     ms_fix

      logical, external ::
     &     next_msgamdist2, check_ms, check_gm, nondia_blk, nondia_distr
      integer, external ::
     &     get_lenmap, ielprd, idx_msgmdst2, idxlist,
     &     msa2idxms4op

c dbg
c      print *,'gm_op_c/a: ',gm_op_c,gm_op_a
c dbg

      if (ntest.ge.1000) then
        call write_title(lulog,wst_dbg_subr,'reo_blk_wmaps_c')
        write(lulog,*) 'sign_reo = ',sign_reo
      end if

      graphs => str_info%g
      ngraph =  str_info%ngraph
      opreo => me_opreo%op

      ms_fix = me_opreo%fix_vertex_ms

      if (me_opreo%diag_type.ne.0) then
        allocate(mapca(ncblk_opreo),diag_idx(ncblk_opreo),
     &           diag_ca(ncblk_opreo))
        if (nondia_blk(mapca,diag_idx,diag_ca,
     &                 opreo%ihpvca_occ(1,1,
     &                        (iblk_opreo-1)*opreo%njoined+1),
     &                 opreo%njoined,ncblk_opreo,
     &                 nablk_opreo,me_opreo%diag_type))
     &       call quit(1,'reo_blk_wmaps_c','non-diagonal block!')
      end if

      idxst_opreo = me_opreo%off_op_occ(iblk_opreo)
      ndis_opreo  => me_opreo%off_op_gmox(iblk_opreo)%ndis
      d_gam_ms_opreo  => me_opreo%off_op_gmox(iblk_opreo)%d_gam_ms

      call sum_occ(ms_k_c_max,cinfo_k_c,ncblk_k)
      call sum_occ(ms_k_a_max,cinfo_k_a,nablk_k)
      call sum_occ(ms_i0_c_max,cinfo_i0_c,ncblk_i0)
      call sum_occ(ms_i0_a_max,cinfo_i0_a,nablk_i0)

cmh      idxms_op_a = (ms_k_a_max+ms_i0_a_max - ms_op_a)/2 + 1
      ! also for msa_max.ne.msc_max:
      idxms_op_a = msa2idxms4op(ms_op_a,ms_op_c-ms_op_a,
     &             ms_k_a_max+ms_i0_a_max,ms_k_c_max+ms_i0_c_max)

      do ms_k_a = ms_k_a_max, -ms_k_a_max, -2
        ms_i0_a = ms_op_a - ms_k_a
        if (abs(ms_i0_a).gt.ms_i0_a_max) cycle

        do ms_k_c = ms_k_c_max, -ms_k_c_max, -2
          ms_i0_c = ms_op_c - ms_k_c
          if (abs(ms_i0_c).gt.ms_i0_c_max) cycle

          do gm_k_a = 1, nsym
            gm_i0_a = multd2h(gm_k_a,gm_op_a)
            do gm_k_c = 1, nsym
              gm_i0_c = multd2h(gm_k_c,gm_op_c)
c dbg
c              print *,'ms_k_a,ms_k_c: ',ms_k_a,gm_k_c
c              print *,'ms_i0_a,ms_i0_c: ',ms_i0_a,gm_i0_c
c              print *,'gm_k_a,gm_k_c: ',gm_k_a,gm_k_c
c              print *,'gm_i0_a,gm_i0_c: ',gm_i0_a,gm_i0_c
c dbg

               ! loop over symmetry and ms-distributions of shift string K
              first = .true.
              dis_loop: do
                if (.not.next_msgamdist2(first,
     &             ms_k_dis_c,ms_k_dis_a,gm_k_dis_c,gm_k_dis_a,
     &             ncblk_k,nablk_k,
     &             cinfo_k_c,cinfo_k_a,
     &             ms_k_c,ms_k_a,gm_k_c,gm_k_a,nsym,
     &             ms_fix,fix_success))
     &             exit dis_loop

                first = .false.
                if(ms_fix.and..not.fix_success)cycle dis_loop

                ! get symmetry and ms-distr. of I0
                call split_msgmdis(ms_i0_dis_c,gm_i0_dis_c,
     &                             possible,
     &                             ms_k_dis_c,gm_k_dis_c,
     &                             ms_i_dis_c,gm_i_dis_c,
     &                             ncblk_opori,
     &                             map_info_to_ori_c,.false.)
                if (.not.possible) cycle dis_loop

                call split_msgmdis(ms_i0_dis_a,gm_i0_dis_a,
     &                             possible,
     &                             ms_k_dis_a,gm_k_dis_a,
     &                             ms_i_dis_a,gm_i_dis_a,
     &                             nablk_opori,
     &                             map_info_to_ori_a,.true.)
                if (.not.possible) cycle dis_loop

c dbg
c                  write(lulog,*) '            I   GMD C',
c     &                 gm_i_dis_c(1:ncblk_opori)
c                  write(lulog,*) '            K   GMD C',
c     &                 gm_k_dis_c(1:ncblk_k)
c                  write(lulog,*) '            I0  GMD C',
c     &                 gm_i0_dis_c(1:ncblk_i0)
c                  write(lulog,*) '            I   GMD A',
c     &                 gm_i_dis_a(1:nablk_opori)
c                  write(lulog,*) '            K   GMD A',
c     &                 gm_k_dis_a(1:nablk_k)
c                  write(lulog,*) '            I0  GMD A',
c     &                 gm_i0_dis_a(1:nablk_i0)
c                  write(lulog,*) '            I   MSD C',
c     &                 ms_i_dis_c(1:ncblk_opori)
c                  write(lulog,*) '            K   MSD C',
c     &                 ms_k_dis_c(1:ncblk_k)
c                  write(lulog,*) '            I0  MSD C',
c     &                 ms_i0_dis_c(1:ncblk_i0)
c                  write(lulog,*) '            I   MSD A',
c     &                 ms_i_dis_a(1:nablk_opori)
c                  write(lulog,*) '            K   MSD A',
c     &                 ms_k_dis_a(1:nablk_k)
c                  write(lulog,*) '            I0  MSD A',
c     &                 ms_i0_dis_a(1:nablk_i0)
c                  write(lulog,*) ' possible: ',possible
c dbg
                if (ntest.ge.1500) then
                  write(lulog,*) '               I  MS',ms_op_c,ms_op_a
                  write(lulog,*) '               MSD C',
     &                 ms_i_dis_c(1:ncblk_opori)
                  write(lulog,*) '               MSD A',
     &                 ms_i_dis_a(1:nablk_opori)
                  write(lulog,*) 'current block: I0 MS',ms_i0_c,ms_i0_a
                  write(lulog,*) '               IRREP',gm_i0_c,gm_i0_a
                  write(lulog,*) '               MSD C',
     &                 ms_i0_dis_c(1:ncblk_i0)
                  write(lulog,*) '               MSD A',
     &                 ms_i0_dis_a(1:nablk_i0)
                  write(lulog,*) '               GMD C',
     &                 gm_i0_dis_c(1:ncblk_i0)
                  write(lulog,*) '               GMD A',
     &                 gm_i0_dis_a(1:nablk_i0)
                  write(lulog,*) '               K MS ',ms_k_c,ms_k_a
                  write(lulog,*) '               IRREP',gm_k_c,gm_k_a
                  write(lulog,*) '               MSD C',
     &                 ms_k_dis_c(1:ncblk_k)
                  write(lulog,*) '               MSD A',
     &                 ms_k_dis_a(1:nablk_k)
                  write(lulog,*) '               GMD C',
     &                 gm_k_dis_c(1:ncblk_k)
                  write(lulog,*) '               GMD A',
     &                 gm_k_dis_a(1:nablk_k)
                end if

                if (.not.check_ms(ms_i0_dis_c,cinfo_i0_c,ncblk_i0))
     &               cycle dis_loop
                if (.not.check_ms(ms_i0_dis_a,cinfo_i0_a,nablk_i0))
     &               cycle dis_loop
                if (.not.check_gm(gm_i0_dis_c,cinfo_i0_c,ncblk_i0))
     &               cycle dis_loop
                if (.not.check_gm(gm_i0_dis_a,cinfo_i0_a,nablk_i0))
     &               cycle dis_loop
c dbg
c                print *,'ACCEPTED'
c                first_element = .true.
c dbg

                ! get symmetry and ms-dist. of reordered operator I'
c dbg
c                print *,'merge_map1:',map_info_to_ori_c(1:8)
c                print *,'merge_map2:',map_info_to_reo_c(1:8)
c dbg
                call merge_msgmdis(ms_ip_dis_c,gm_ip_dis_c,
     &                             ncblk_opreo,
     &                             ms_i0_dis_c,gm_i0_dis_c,
     &                             ms_k_dis_c,gm_k_dis_c,
     &                             map_info_to_reo_c)
                call merge_msgmdis(ms_ip_dis_a,gm_ip_dis_a,
     &                             nablk_opreo,
     &                             ms_k_dis_a,gm_k_dis_a,
     &                             ms_i0_dis_a,gm_i0_dis_a,
     &                             map_info_to_reo_a)
c dbg
c                write(lulog,*) '            I''  MSD C',
c     &                 ms_ip_dis_c(1:ncblk_opreo)
c                write(lulog,*) '            I''  MSD A',
c     &                 ms_ip_dis_a(1:nablk_opreo)
c
c dbg

                ! reform MS-(times two)-values to idxms
c                call ms2idxms(idxms_k_dis_c,ms_k_dis_c,
c     &               cinfo_k_c,ncblk_k)
                do ii = 1, ncblk_k
                  idxms_k_dis_c(ii)=
     &            ishft(cinfo_k_c(ii,1)-ms_k_dis_c(ii),-1)+1
                end do
c                call ms2idxms(idxms_k_dis_a,ms_k_dis_a,
c     &               cinfo_k_a,nablk_k)
                do ii = 1, nablk_k
                  idxms_k_dis_a(ii)=
     &            ishft(cinfo_k_a(ii,1)-ms_k_dis_a(ii),-1)+1
                end do

c                call ms2idxms(idxms_i0_dis_c,ms_i0_dis_c,
c     &               cinfo_i0_c,ncblk_i0)
                do ii = 1, ncblk_i0
                  idxms_i0_dis_c(ii)=
     &            ishft(cinfo_i0_c(ii,1)-ms_i0_dis_c(ii),-1)+1
                end do
c                call ms2idxms(idxms_i0_dis_a,ms_i0_dis_a,
c     &               cinfo_i0_a,nablk_i0)
                do ii = 1, nablk_i0
                  idxms_i0_dis_a(ii)=
     &            ishft(cinfo_i0_a(ii,1)-ms_i0_dis_a(ii),-1)+1
                end do

c dbg
c                print *,'cinfo_opreo_c: ',
c     &               cinfo_opreo_c(1:ncblk_opreo,1)
c                print *,'cinfo_opreo_a: ',
c     &               cinfo_opreo_a(1:nablk_opreo,1)
c                print *,'gm_ip_dis_c: ',gm_ip_dis_c(1:ncblk_opreo)
c                print *,'gm_ip_dis_a: ',gm_ip_dis_a(1:nablk_opreo)
c                print *,'gm_i0_dis_c: ',gm_i0_dis_c(1:ncblk_i0)
c                print *,'gm_i0_dis_a: ',gm_i0_dis_a(1:nablk_i0)
c                print *,'gm_k_dis_c:  ',gm_k_dis_c(1:ncblk_k)
c                print *,'gm_k_dis_a:  ',gm_k_dis_a(1:nablk_k)
c dbg
c                call ms2idxms(idxms_ip_dis_c,ms_ip_dis_c,
c     &               cinfo_opreo_c,ncblk_opreo)
                do ii = 1, ncblk_opreo
                  idxms_ip_dis_c(ii)=
     &            ishft(cinfo_opreo_c(ii,1)-ms_ip_dis_c(ii),-1)+1
                end do
c                call ms2idxms(idxms_ip_dis_a,ms_ip_dis_a,
c     &               cinfo_opreo_a,nablk_opreo)
                do ii = 1, nablk_opreo
                  idxms_ip_dis_a(ii)=
     &            ishft(cinfo_opreo_a(ii,1)-ms_ip_dis_a(ii),-1)+1
                end do

                call set_len_str(lstr_k,ncblk_k,nablk_k,
     &               graphs,
     &               cinfo_k_c(1,2),idxms_k_dis_c,
     &                               gm_k_dis_c,cinfo_k_c(1,3),
     &               cinfo_k_a(1,2),idxms_k_dis_a,
     &                               gm_k_dis_a,cinfo_k_a(1,3),
     &               hpvxseq,.false.)

                if (ncblk_k+nablk_k.gt.0 .and.
     &              idxlist(0,lstr_k,ncblk_k+nablk_k,1).gt.0) cycle

                call set_len_str(lstr_i0,ncblk_i0,nablk_i0,
     &               graphs,
     &               cinfo_i0_c(1,2),idxms_i0_dis_c,
     &                               gm_i0_dis_c,cinfo_i0_c(1,3),
     &               cinfo_i0_a(1,2),idxms_i0_dis_a,
     &                               gm_i0_dis_a,cinfo_i0_a(1,3),
     &               hpvxseq,.false.)

                if (ncblk_i0+nablk_i0.gt.0 .and.
     &              idxlist(0,lstr_i0,ncblk_i0+nablk_i0,1).gt.0) cycle
c dbg
c                print *,'cinfo_i0_c: ',cinfo_i0_c(1:ncblk_i0,1)
c                print *,'cinfo_i0_a: ',cinfo_i0_a(1:nablk_i0,1)
c                print *,'cinfo_i0_c: ',cinfo_i0_c(1:ncblk_i0,2)
c                print *,'cinfo_i0_a: ',cinfo_i0_a(1:nablk_i0,2)
c                print *,'cinfo_i0_c: ',cinfo_i0_c(1:ncblk_i0,3)
c                print *,'cinfo_i0_a: ',cinfo_i0_a(1:nablk_i0,3)
c                print *,'lstr_i0:',lstr_i0
c                print *,'lstr_k:',lstr_k
c dbg

                call set_len_str(lstr_opreo,ncblk_opreo,nablk_opreo,
     &               graphs,
     &               cinfo_opreo_c(1,2),idxms_ip_dis_c,
     &                               gm_ip_dis_c,cinfo_opreo_c(1,3),
     &               cinfo_opreo_a(1,2),idxms_ip_dis_a,
     &                               gm_ip_dis_a,cinfo_opreo_a(1,3),
     &               hpvxseq,.false.)
c dbg
c                print *,'cinfo_opreo_c:',cinfo_opreo_c(1:ncblk_opreo,2)
c                print *,'cinfo_opreo_a:',cinfo_opreo_a(1:nablk_opreo,2)
c                print *,'lstr_opreo:   ',lstr_opreo
c dbg

                if (ncblk_opreo+nablk_opreo.gt.0 .and.
     &              idxlist(0,lstr_opreo,
     &                        ncblk_opreo+nablk_opreo,1).gt.0) cycle

                call set_strmapdim_c2(
     &                 nstr_opori_c,nstr_i0c1,nstr_k_c1,
     &                 ireo_i0c1,ireo_k_c1,
     &                 ncblk_opori,
     &                 lstr_i0,lstr_k,map_info_to_ori_c)
                call set_strmapdim_c2(
     &                 nstr_opori_a,nstr_k_a1,nstr_i0a1,
     &                 ireo_k_a1,ireo_i0a1,
     &                 nablk_opori,
     &                 lstr_k(ncblk_k+1),
     &                       lstr_i0(ncblk_i0+1),map_info_to_ori_a)

                call set_strmapdim_c2(
     &                 nstr_opreo_c,nstr_i0c2,nstr_k_c2,
     &                 ireo_i0c2,ireo_k_c2,
     &                 ncblk_opreo,
     &                 lstr_i0,lstr_k,map_info_to_reo_c)
                call set_strmapdim_c2(
     &                 nstr_opreo_a,nstr_k_a2,nstr_i0a2,
     &                 ireo_k_a2,ireo_i0a2,
     &                 nablk_opreo,
     &                 lstr_k(ncblk_k+1),
     &                       lstr_i0(ncblk_i0+1),map_info_to_reo_a)
c dbg
c                write(*,'(a,10i4)') 'ireo_k_c1: ',ireo_k_c1
c                write(*,'(a,10i4)') 'ireo_k_c2: ',ireo_k_c2
c                write(*,'(a,10i4)') 'ireo_k_a1: ',ireo_k_a1
c                write(*,'(a,10i4)') 'ireo_k_a2: ',ireo_k_a2
c                write(*,'(a,10i4)') 'ireo_i0c1: ',ireo_i0c1
c                write(*,'(a,10i4)') 'ireo_i0c2: ',ireo_i0c2
c                write(*,'(a,10i4)') 'ireo_i0a1: ',ireo_i0a1
c                write(*,'(a,10i4)') 'ireo_i0a2: ',ireo_i0a2
c dbgend

                nstr_k_c_tot  = ielprd(lstr_k,ncblk_k)
                nstr_k_a_tot  = ielprd(lstr_k(ncblk_k+1),nablk_k)
                nstr_i0_c_tot = ielprd(lstr_i0,ncblk_i0)
                nstr_i0_a_tot = ielprd(lstr_i0(ncblk_i0+1),nablk_i0)
c dbg
c                print *,'nstr_k_c_tot:  ',nstr_k_c_tot
c                print *,'nstr_k_a_tot:  ',nstr_k_a_tot
c                print *,'nstr_i0_c_tot: ',nstr_i0_c_tot
c                print *,'nstr_i0_a_tot: ',nstr_i0_a_tot
c dbg
c                print *,'ncblk_k:  ',ncblk_k
c                print *,'nablk_k:  ',nablk_k
c                print *,'ncblk_i0: ',ncblk_i0
c                print *,'nablk_i0: ',nablk_i0
c                write(*,'(a,10i4)') 'lstr_i0: ',lstr_i0
c                write(*,'(a,10i4)') 'lstr_k:  ',lstr_k
c                write(*,'(a,10i4)')'map_info_to_ori_c:',
c     &            map_info_to_ori_c(1:10)
c                write(*,'(a,10i4)')'map_info_to_ori_a:',
c     &            map_info_to_ori_a(1:10)
c                write(*,'(a,10i4)')'map_info_to_reo_c:',
c     &            map_info_to_reo_c(1:10)
c                write(*,'(a,10i4)')'map_info_to_reo_a:',
c     &            map_info_to_reo_a(1:10)
c dbgend
c dbg

                call set_op_ldim_c(ldim_opori_c,ldim_opori_a,
     &                 cinfo_opori_c(1,3),cinfo_opori_a(1,3),
     &                 lstr_opori,ncblk_opori,nablk_opori,tra_opori)
                call set_op_ldim_c(ldim_opreo_c,ldim_opreo_a,
     &                 cinfo_opreo_c(1,3),cinfo_opreo_a(1,3),
     &                 lstr_opreo,ncblk_opreo,nablk_opreo,tra_opreo)

                ifree = mem_setmark('reostr')
                lenmap = get_lenmap(lstr_i0,lstr_k,
     &               map_info_to_ori_c,ncblk_opori)
                ifree = mem_alloc_int(map_to_ori_c,lenmap,'orimap_c')
                lenmap = get_lenmap(
     &               lstr_k(ncblk_k+1),lstr_i0(ncblk_i0+1),
     &               map_info_to_ori_a,nablk_opori)
                ifree = mem_alloc_int(map_to_ori_a,lenmap,'orimap_a')
                lenmap = get_lenmap(lstr_i0,lstr_k,
     &               map_info_to_reo_c,ncblk_opreo)
                ifree = mem_alloc_int(map_to_reo_c,lenmap,'reomap_c')
                lenmap = get_lenmap(
     &               lstr_k(ncblk_k+1),lstr_i0(ncblk_i0+1),
     &               map_info_to_reo_a,nablk_opreo)
                ifree = mem_alloc_int(map_to_reo_a,lenmap,'reomap_a')

                call get_strmap_blk_c(map_to_ori_c,
     &                 ncblk_i0,ncblk_k,ncblk_opori,
     &                 cinfo_i0_c,cinfo_k_c,lstr_i0,lstr_k,
     &                 cinfo_i0_c(1,2),cinfo_k_c(1,2),
     &                                 cinfo_opori_c(1,2),
     &                 idxms_i0_dis_c,idxms_k_dis_c,
     &                 gm_i0_dis_c,gm_k_dis_c,map_info_to_ori_c,
     &                 strmap_info,nsym,ngraph)
                call get_strmap_blk_c(map_to_ori_a,
     &                 nablk_k,nablk_i0,nablk_opori,
     &                 cinfo_k_a,cinfo_i0_a,
     &                    lstr_k(ncblk_k+1),lstr_i0(ncblk_i0+1),
     &                 cinfo_k_a(1,2),cinfo_i0_a(1,2),
     &                                cinfo_opori_a(1,2),
     &                 idxms_k_dis_a,idxms_i0_dis_a,
     &                 gm_k_dis_a,gm_i0_dis_a,map_info_to_ori_a,
     &                 strmap_info,nsym,ngraph)

                call get_strmap_blk_c(map_to_reo_c,
     &                 ncblk_i0,ncblk_k,ncblk_opreo,
     &                 cinfo_i0_c,cinfo_k_c,lstr_i0,lstr_k,
     &                 cinfo_i0_c(1,2),cinfo_k_c(1,2),
     &                                 cinfo_opreo_c(1,2),
     &                 idxms_i0_dis_c,idxms_k_dis_c,
     &                 gm_i0_dis_c,gm_k_dis_c,map_info_to_reo_c,
     &                 strmap_info,nsym,ngraph)
                call get_strmap_blk_c(map_to_reo_a,
     &                 nablk_k,nablk_i0,nablk_opreo,
     &                 cinfo_k_a,cinfo_i0_a,
     &                   lstr_k(ncblk_k+1),lstr_i0(ncblk_i0+1),
     &                 cinfo_k_a(1,2),cinfo_i0_a(1,2),
     &                                cinfo_opreo_a(1,2),
     &                 idxms_k_dis_a,idxms_i0_dis_a,
     &                 gm_k_dis_a,gm_i0_dis_a,map_info_to_reo_a,
     &                 strmap_info,nsym,ngraph)
c dbg
c                write(*,'(a,10i4)') 'map_to_ori_c: ',map_to_ori_c
c                write(*,'(a,10i4)') 'map_to_ori_a: ',map_to_ori_a
c                write(*,'(a,10i4)') 'map_to_reo_c: ',map_to_reo_c
c                write(*,'(a,10i4)') 'map_to_reo_a: ',map_to_reo_a
c dbgend

                if (me_opreo%diag_type.ne.0) then
                  ! skip non-diagonal distributions ...
                  if (nondia_distr(mapca,diag_idx,diag_ca,
     &                   ms_ip_dis_c,ms_ip_dis_a,
     &                   gm_ip_dis_c,gm_ip_dis_a,
     &                   ncblk_opreo,me_opreo%msdiag,
     &                   me_opreo%gamdiag)) then
                    ifree = mem_flushmark('reostr')
                    cycle
                  end if
                end if

                ! --> offset in xop_reo
                if (ndis_opreo(gm_op_a,idxms_op_a).gt.1) then
                  idxdis =
     &                 idx_msgmdst2(.true.,
     &                 iblk_opreo,idxms_op_a,gm_op_a,
     &                 cinfo_opreo_c,idxms_ip_dis_c,
     &                               gm_ip_dis_c,ncblk_opreo,
     &                 cinfo_opreo_a,idxms_ip_dis_a,
     &                               gm_ip_dis_a,nablk_opreo,
     &                 tra_opreo,-1,-1,me_opreo,nsym)
c     &                 .false.,me_opreo,nsym)
                  idx00opreo =
     &                 d_gam_ms_opreo(idxdis,gm_op_a,idxms_op_a) + 1
     &                                           - idxst_opreo
c dbg
c                  print *,'idxms_ip_dis_c: ',idxms_ip_dis_c
c                  print *,'idxms_ip_dis_a: ',idxms_ip_dis_a
c                  print *,'REO: ',idxdis,gm_op_a,idxms_op_a,'->',
c     &                 idx00opreo
c dbg
                else
                  idx00opreo =
     &                 d_gam_ms_opreo(1,gm_op_a,idxms_op_a) + 1
     &                                           - idxst_opreo
c dbg
c                  idxdis = 1
c                  print *,'REO: ',idxdis,gm_op_a,idxms_op_a,'->',
c     &                 idx00opreo
c dbg
                end if
c dbg
c                print *,'idx00opreo:',idx00opreo
c dbg

                ! loop over A strings
                k_a: do istr_k_a = 1, nstr_k_a_tot

                  ! break down into components
                  istr_k_a1(1:nablk_opori) = 1
                  istr_k_a2(1:nablk_opreo) = 1
                  istr1 = istr_k_a-1
                  do icmp = 1, nablk_k
                    idx1 = mod(istr1,lstr_k(ncblk_k+icmp))+1
                    istr_k_a1(ireo_k_a1(icmp)) = idx1
                    istr_k_a2(ireo_k_a2(icmp)) = idx1
                    istr1 = istr1/lstr_k(ncblk_k+icmp)
                  end do

                  i0_a: do istr_i0_a = 1, nstr_i0_a_tot

                    ! break down into components
                    istr_i0a1(1:nablk_opori) = 1
                    istr_i0a2(1:nablk_opreo) = 1
                    istr1 = istr_i0_a-1
                    do icmp = 1, nablk_i0
                      idx1 = mod(istr1,lstr_i0(ncblk_i0+icmp))+1
                      istr_i0a1(ireo_i0a1(icmp)) = idx1
                      istr_i0a2(ireo_i0a2(icmp)) = idx1
                      istr1 = istr1/lstr_i0(ncblk_i0+icmp)
                    end do

                    ! map K,I0 -> I
                    idx0opori = 1
                    ioff = 0
                    isgna = sign_reo
c dbg
c                    print *,'+-------------ORI-A----------------+'
c dbg
                    do icmp = 1, nablk_opori
                      idx1 = istr_i0a1(icmp)
                      idx2 = istr_k_a1(icmp)
                      idx  = (idx1-1)*nstr_k_a1(icmp)+idx2
c dbg
c                      print *,'icmp, ioff, idx:',icmp,ioff,idx
c dbgend
                      ielmap = map_to_ori_a(ioff+idx)
                      if (ielmap.eq.0) cycle i0_a
                      isgna = isgna*sign(1,ielmap)
                      idx0opori = idx0opori
     &                     + (abs(ielmap)-1)*ldim_opori_a(icmp)
c dbg
c                      print *,'icmp, idx_i0a, idx_k_a: ',icmp,idx1,idx2
c                      print *,'    ->idx_i_a: ',ielmap
c dbg
                      ioff = ioff + nstr_opori_a(icmp)
                    end do

                    ! map K,I0 -> I'
                    idx0opreo = idx00opreo
                    ioff = 0
c                    do icmp = 1, nablk_opreo
c                      idiv2 = idiv2*nstr_k_a2(icmp)
c                    end do

c dbg
c                    print *,'+-------------REO-A----------------+'
c dbg
                    do icmp = 1, nablk_opreo
                      idx1 = istr_i0a2(icmp)
                      idx2 = istr_k_a2(icmp)
                      idx  = (idx1-1)*nstr_k_a2(icmp)+idx2
c dbg
c                      if (idx00opreo.eq.1) then
c                      print *,'istr2,idiv2,idx2:',istr2,idiv2,idx2
c                      print *,'idx1,idx2,idx,ioff:',idx1,idx2,idx,ioff
c                      print *,'map = ',map_to_reo_a(ioff+idx)
c                      end if
c dbg
c dbg
c                      print *,'icmp, ioff, idx:',icmp,ioff,idx
c dbgend
                      ielmap = map_to_reo_a(ioff+idx)
                      if (ielmap.eq.0) cycle i0_a
                      isgna = isgna*sign(1,ielmap)
                      idx0opreo = idx0opreo
     &                     + (abs(ielmap)-1)*ldim_opreo_a(icmp)
c dbg
c                      print *,'icmp, idx_i0a, idx_k_a: ',icmp,idx1,idx2
c                      print *,'    ->idx_ipa: ',ielmap
c dbg
                      ioff = ioff + nstr_opreo_a(icmp)
                    end do
c dbg
c                    print *,'+----------------------------------+'
c
c                    if (idx0opreo.eq.1.or.idx0opreo.eq.779)
c     &                   print *,'HIER HIER HIER: idx0opreo = ',
c     &                   idx0opreo
c dbg
c dbg
c                    print *,'idx0opreo: ',idx0opreo
c                    print *,'idx0opori: ',idx0opori
c dbg

                    ! loop over C strings
                    k_c: do istr_k_c = 1, nstr_k_c_tot
c dbg
c                      print *,'istr_k_c = ',istr_k_c
c dbgend

                      ! break down into components
                      istr_k_c1(1:ncblk_opori) = 1
                      istr_k_c2(1:ncblk_opreo) = 1
                      istr1 = istr_k_c-1
                      do icmp = 1, ncblk_k
                        idx1 = mod(istr1,lstr_k(icmp))+1
                        istr_k_c1(ireo_k_c1(icmp)) = idx1
                        istr_k_c2(ireo_k_c2(icmp)) = idx1
                        istr1 = istr1/lstr_k(icmp)
c dbg
c                        print *,'icmp/idx1: ',icmp,idx1
c dbgend
                      end do

                      i0_c: do istr_i0_c = 1, nstr_i0_c_tot
c dbg
c                        print *,'istr_i0_c = ',istr_i0_c
c dbgend

                        ! break down into components
                        istr_i0c1(1:ncblk_opori) = 1
                        istr_i0c2(1:ncblk_opreo) = 1
                        istr1 = istr_i0_c-1
                        do icmp = 1, ncblk_i0
                          idx1 = mod(istr1,lstr_i0(icmp))+1
                          istr_i0c1(ireo_i0c1(icmp)) = idx1
                          istr_i0c2(ireo_i0c2(icmp)) = idx1
                          istr1 = istr1/lstr_i0(icmp)
                        end do

                        ! map K,I0 -> I
                        idx_opori = idx0opori
                        ioff = 0
                        isgnt = isgna
c dbg
c                        print *,'+-------------ORI-C----------------+'
c dbg
                        do icmp = 1, ncblk_opori
                          idx1 = istr_k_c1(icmp)
                          idx2 = istr_i0c1(icmp)
                          idx = (idx1-1)*nstr_i0c1(icmp)+idx2
c dbg
c                          print *,'icmp, ioff, idx:',icmp,ioff,idx
c dbgend
                          ielmap = map_to_ori_c(ioff+idx)
                          if (ielmap.eq.0) cycle i0_c
                          isgnt = isgnt*sign(1,ielmap)
                          idx_opori = idx_opori +
     &                         (abs(ielmap)-1)*ldim_opori_c(icmp)
c dbg
c                          print *,'    ->idx_i_c: ',ielmap
c dbgend
                          ioff = ioff + nstr_opori_c(icmp)
                        end do
                        ! map K,I0 -> I'
                        idx_opreo = idx0opreo
                        ioff = 0
c dbg
c                        print *,'+-------------REO-C----------------+'
c dbg
                        do icmp = 1, ncblk_opreo
                          idx1 = istr_k_c2(icmp)
                          idx2 = istr_i0c2(icmp)
                          idx = (idx1-1)*nstr_i0c2(icmp)+idx2
c dbg
c                          print *,'icmp, ioff, idx:',icmp,ioff,idx
c dbgend
                          ielmap = map_to_reo_c(ioff+idx)
                          if (ielmap.eq.0) cycle i0_c
                          isgnt = isgnt*sign(1,ielmap)
                          idx_opreo = idx_opreo +
     &                         (abs(ielmap)-1)*ldim_opreo_c(icmp)
c dbg
c                          print *,'    ->idx_ipc: ',ielmap
c dbgend
                          ioff = ioff + nstr_opreo_c(icmp)
                        end do
c dbg
c                        if (!first_element ) then!.or.
c     &                       idx_opreo.eq.64 .or.
c     &                       idx_opreo.eq.253) then
c                          print *,'ori, reo, +/-A, +/-CA, val: ',
c     &                         idx_opori,idx_opreo,
c     &                         isgna,isgnt,xop_ori(idx_opori)
c                          first_element = .false.
c                        end if
c dbg
c dbg
c                        print *,'idx_opreo, idx_opori: ',
c     &                          idx_opreo,idx_opori
c dbgend

c dbg
c                        if (idx_opreo.lt.0.or.idx_opreo.gt.len_reo.or.
c     &                      idx_opori.lt.0.or.idx_opori.gt.len_ori) then
c                          print *,'RANGE dx_opreo/ori: ',
c     &                            idx_opreo,idx_opori
c                          print *,'max: ',len_reo,len_ori
c                        end if
c dbg
                        xop_reo(idx_opreo) = xop_reo(idx_opreo)
     &                       + fac*dble(isgnt)*xop_ori(idx_opori)

                      end do i0_c
                    end do k_c

                  end do i0_a
                end do k_a

                ifree = mem_flushmark('reostr')

              end do dis_loop

            end do
          end do

        end do
      end do

      if (me_opreo%diag_type.ne.0) deallocate(mapca,diag_idx,diag_ca)

      return
      end


      X = 1
100   PRINT Z
      X = X + 1
      Z = X * X
      GOTO 100
      END


	SUBROUTINE TI_RANG  ( dattim, strtim, endtim, mrange, iret )
C************************************************************************
C* TI_RANG								*
C*									*
C* This subroutine computes the range of the input time in minutes.	*
C*									*
C* TI_RANG  ( DATTIM, STRTIM, ENDTIM, MRANGE, IRET )			*
C*									*
C* Input parameters:							*
C*	DATTIM		CHAR*72		Date/time input			*
C*									*
C* Output parameters:							*
C*	STRTIM		CHAR*		Start time			*
C*	ENDTIM		CHAR*		End time			*
C*	MRANGE		INTEGER		Time range in minutes		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -1 = invalid time		*
C**									*
C* Log:									*
C* T. Lee/GSC		 5/01						*
C* B. Yin/SAIC           3/04   Changed SS_GTIM to CSS_GTIM             *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)   dattim, strtim, endtim
	CHARACTER	tarr(2)*20, systim*20
	INTEGER		itype
C------------------------------------------------------------------------
	iret = 0
	strtim = ' '
	endtim = ' '
	mrange = 0
C
	IF  ( dattim .eq. ' ' )  RETURN
C
C*	Parse the date/time input.
C
        CALL ST_CLST ( dattim, '-', ' ', 2, tarr, ntarr, iret )
        strtim = tarr (1)
	IF  ( ntarr .lt. 2 )  THEN
	    endtim = strtim
	  ELSE
	    endtim = tarr (2)
	END IF
C
C*	Create standard GEMPAK time.
C
	itype = 1
        CALL CSS_GTIM ( itype, systim, ier )
        CALL TI_STAN ( strtim, systim, strtim, ier )
        CALL TI_STAN ( endtim, strtim, endtim, ier )
        CALL TI_STAN ( endtim, systim, endtim, ier )
C
C*      Compute time range.
C
        CALL TI_DIFF ( endtim, strtim, mrange, iret )
C*
	RETURN
	END


c                                                   01/13/94 - dupelim.f
c  07oct94 - A. da S. - introduced tolerance (TOL) to compare lat/lon/lev
c                       this fix needed because CRAY was missing duplicates
c                       because of its IEEE conversion to 64 bits.
c  05oct94 - A. da S. - eliminated 'nobs' from parameter list; now
c                       nnobs is reset if duplicates are found.
c
c  1/23 - pass 'kl' flag to main routine -mes-
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c.... Eliminate duplicate observations and readjust region pointers

      subroutine DUPELIM (verbose, luverb,  nnobs,   kx,    kt,   kl,
     $                    rlats,   rlons,   rlevs,   del,sigU,sigO,sigF,
     $                    tstamp,  maxreg,  iregbeg, ireglen,
     $                    ktmax, ityplen )

	use m_stdio, only : stdout

*     Argument declarations.
*     ----------------------
      logical      verbose
      integer      luverb
      integer      nnobs
      integer      kx(nnobs)
      integer      kt(nnobs)
      logical      kl(nnobs)
      real         rlats(nnobs)
      real         rlons(nnobs)
      real         rlevs(nnobs)
      real         del(nnobs)
      real         sigU(nnobs)
      real         sigO(nnobs)
      real         sigF(nnobs)
      real         tstamp(nnobs)
c-    real         qcflag(*)		! no longer used
      integer      maxreg
      integer      iregbeg(maxreg)
      integer      ireglen(maxreg)
      integer      ktmax
      integer      ityplen(ktmax,maxreg)

*     Tolerance to define a duplicate
*     NOTE: This is important because of CRAY's IEEE conversion
*     ---------------------------------------------------------
      parameter ( tol = 1.E-4 )

*     Local storage.
*     --------------
      logical      kflag

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c  input at this pt is sorted by region, type, kx, lat, lon, and level
c  scan through all regions
c  mark kl as .true. if it does not duplicate previous ob.
c  mark duplicates as .false., and decrement 'ityplen', 'ireglen'
c  (ireglen of current region, ityplen of type kx of that region)
c
c  when completed, call tofront to shift data around
c  then redo 'iregbeg' count (code from regsort)
c.......................................................................

      itot = 0
      nobs = nnobs

*     Loop over the regions.
*     ----------------------
      do 500 ireg = 1, maxreg

*        Check whether there is data in the current region.
*        --------------------------------------------------
         if( ireglen(ireg).eq.0 ) goto 500

         ibeg = iregbeg(ireg)
         ilen = ireglen(ireg)

         kl(ibeg) = .true.

         do 200 n = ibeg+1, ibeg+ilen-1
            n1 = n - 1
            kflag = ( (abs(rlevs(n)-rlevs(n1)) .gt. TOL) .or.
     $                (abs(rlons(n)-rlons(n1)) .gt. TOL) .or.
     $                (abs(rlats(n)-rlats(n1)) .gt. TOL) .or.
     $                kx(n)    .ne. kx(n1)    .or.
     $                kt(n)    .ne. kt(n1) )

            if ( .not. kflag ) then
               ireglen(ireg) = ireglen(ireg) - 1
               ityplen(kt(n),ireg) = ityplen(kt(n),ireg) - 1
               itot = itot + 1
            endif
            kl(n) = kflag

  200    continue

  500 continue

*     Report number of duplicate found
*     --------------------------------
      if ( itot .eq. 0 )  then
          return
      end if

*     Slide the non-duplicate data to the front of the arrays.
*     -------------------------------------------------------
      call TOFRONT ( nnobs, kx,    kt,    kl,
     $               rlats, rlons, rlevs,
     $               del,   sigU,sigO,  sigF,  tstamp, nobs  )

      if ( verbose ) then
          write(luverb, *) '   dupelim: ', itot,' duplicate obs found'
          write(luverb, *) '   dupelim: nobs reset from ', nnobs,
     .                     ' to ', nobs
          if ( luverb .ne. stdout ) then
            write(stdout, *) '   dupelim: ', itot,' duplicate obs found'
            write(stdout, *) '   dupelim: nobs reset from ', nnobs,
     .                     ' to ', nobs
          end if
      end if

*     Reset number of observations
*     ----------------------------
      nnobs = nobs

*     Update region pointers
*     ----------------------
      ksofar = 0
      do 600 ireg = 1, maxreg
         if( ireglen(ireg).gt.0 ) then
            iregbeg(ireg) = ksofar + 1
            ksofar = ksofar + ireglen(ireg)
         endif
  600 continue

*     All done.
*     ---------
      return
      end