      SUBROUTINE zsrst(
       !------------------!
       ! file/record info !
       !------------------!
     * IFLTAB, ! file table
     * CPATH,  ! pathname
       !--------------!
       ! general info !
       !--------------!
     * CLOC,   ! location string
     * CATIM,  ! activated time string
     * CHPARM, ! height parameter string
     * CHUNIT, ! height units string
     * CFPARM, ! flow parameter string
     * CFUNIT, ! flow units string
     * CCMT,   ! comment string
     * COPT,   ! option string
     * LSNUM,  ! flag specifying if rating has serial number
     * ISNUM,  ! rating serial number
     * LDATUM, ! flag specifying if rating has datum elevation
     * DATUM,  ! rating datum elevation
       !------------------!
       ! base rating info !
       !------------------!
     * LSTAGE, ! flag for stage heights (vs elevation heights)
     * IBHI,   ! height interpolation type for base curve
     * IBHU,   ! height underflow handling type for base curve
     * HUV,    ! height underflow value (may or may not be used)
     * IBHO,   ! height overflow handling type for base curve
     * HOV,    ! height overflow value (may or may not be used)
     * IBFI,   ! flow interpolation type for base curve
     * IBFU,   ! flow underflow handling type for base curve
     * FUV,    ! flow underflow value (may or may not be used)
     * IBFO,   ! flow overflow handling type for base curve
     * FOV,    ! flow overflow value (may or may not be used)
     * NBASE,  ! number of points in base curve
     * HEIGHT, ! stages or elevations
     * FLOW,   ! flows
       !------------!
       ! shift info !
       !------------!
     * NSHIFT, ! number of constant or variable shifts
     * ISTI,   ! interpolation type for shift effective times
     * ISTU,   ! underflow handling type for shift effective times
     * ISTO,   ! overflow handling type for shift effective times
     * ISBI,   ! interpolation type for shift breakpoints for each
               ! shift
     * ISBU,   ! underflow handling type for shift breakpoints for each
               ! shift
     * SBUV,   ! shift breakpoints underflow values for each shift
     * ISBO,   ! overflow handling type for shift breakpoints for each
               ! shift
     * SBOV,   ! shift breakpoints overflow values for each shift
     * ISHI,   ! interpolation type for shift heights for each shift
     * ISHU,   ! underflow handling type for shift heights for each
               ! shift
     * SHUV,   ! shift heights underflow values for each shift
     * ISHO,   ! overflow handling type for shift heights for each shift
     * SHOV,   ! shift heights overflow values for each shift
     * LATMSK, ! masks specifying whether each shift has activated time
     * JBDATE, ! julian base date for shift times
     * IETIME, ! effective times for shifts (minutes relative to jbdate)
     * IATIME, ! activated times for shifts (minutes relative to jbdate)
     * NSHFTP, ! number of variable shift breakpoints for each shift
               ! (0 = constant shift)
     * SHIFTS, ! shift points (for each shift, constant shift or
               ! break(1), height(1),...break(n),height(n))
       !-------------!
       ! offset info !
       !-------------!
     * LCOFF,  ! flag specifying whether a constant offset is used
     * COFVAL, ! constant offset value
     * NOFF,   ! number of variable offset breakpoint, height pairs
     * IOBI,   ! interpolation type for variable offset breakpoints
     * IOBU,   ! underflow handling type for variable offset breakpoints
     * OBUV,   ! offset breakpoint underflow value (may/may not be used)
     * IOBO,   ! overflow handling type for variable offset breakpoints
     * OBOV,   ! offset breakpoint oferflow value (may/may not be used)
     * IOHI,   ! interpolation type for variable offset heights
     * IOHU,   ! underflow handling type for variable offset heights
     * OHUV,   ! offset height underflow value (may or may not be used)
     * IOHO,   ! overflow handling type for variable offset heights
     * OHOV,   ! offset height oferflow value (may or may not be used)
     * OFFSET, ! variable offset values (break(1), height(1),...
               ! break(n),height(n))
       !-----------!
       ! misc info !
       !-----------!
     * IHORIZ, ! horizontal axis
     * IPLAN,  ! overwrite plan
     * ISTAT   ! success/failure status
     * )
c
c     Store STREAM RATING
c
c     Mike Perryman
c     Nov, 2003
c
      PARAMETER (KUHEAD=400)

      INTEGER*4 IFLTAB(*), ISNUM, IBHI, IBHO, IBHU, IBFI, IBFO, IBFU,
     * NBASE, NSHIFT, ISTI, ISTU, ISTO, ISBI(*), ISBU(*), ISBO(*),
     * ISHI(*), ISHU(*), ISHO(*), JBDATE, IETIME(*), IATIME(*),
     * NSHFTP(*), NOFF, IOBI, IOBU, IOBO, IOHI, IOHU, IOHO, IHORIZ,
     * IPLAN, ISTAT, NPATH, NLOC, NATIM, NHPARM, NHUNIT, NFPARM,
     * NFUNIT, NCMT, EFFTIM, TMPTIM, NA, NB, NC, ND, NE, NF, NUHEAD,
     * IUHEAD(KUHEAD)

      CHARACTER CPATH*(*), CLOC*(*), CATIM*(*), CHPARM*(*), CHUNIT*(*),
     * CFPARM*(*), CFUNIT*(*), CCMT*(*), COPT*(*), CA*80, CB*80, CC*80,
     * CD*80, CE*80, CF*80, CTEMP1*80, CTEMP2*80

      LOGICAL*4 LSNUM, LDATUM, LSTAGE, LATMSK(*), LCOFF, LFOUND

      REAL*4 DATUM, HUV, HOV, FUV, FOV, HEIGHT(*), FLOW(*), SBUV(*),
     * SBOV(*), SHUV(*), SHOV(*), SHIFTS(*), COFVAL, OBUV, OBOV, OHUV,
     * OHOV, OFFSET(*), RUHEAD(KUHEAD)

      EQUIVALENCE (IUHEAD, RUHEAD)

      INCLUDE 'zdsskz.h'
      INCLUDE 'zdssiz.h'
      INCLUDE 'zdssmz.h'
      INCLUDE 'zdssbf.h'
      INCLUDE 'zdssrst.h'

      CALL CHRLNB(CPATH, NPATH)
      CALL CHRLNB(CLOC, NLOC)
      CALL CHRLNB(CATIM, NATIM)
      CALL CHRLNB(CHPARM, NHPARM)
      CALL CHRLNB(CHUNIT, NHUNIT)
      CALL CHRLNB(CFPARM, NFPARM)
      CALL CHRLNB(CFUNIT, NFUNIT)
      CALL CHRLNB(CCMT, NCMT)
      CALL CHRLNB(COPT, NOPT)

      !---------------------!
      ! debug entry message !
      !---------------------!
      IF (MLEVEL .GE. 7) THEN
         WRITE(MUNIT, 10) NBASE, NSHIFT, IHORIZ, LSTAGE, IPLAN,
     *    CPATH(1:NPATH)
      END IF
   10 FORMAT (T5, '----- Enter zsrst -----', /,
     * T11, 'NBASE:', I6, ', NSHIFT:', I4, ', IHORIZ:', I4, /,
     * T11, 'LSTAGE:', L1, ', IPLAN:', I3, /, T11, 'Pathname: ', A)

      !--------------------------------------------------------!
      ! get the effective time from the d part of the pathname !
      !--------------------------------------------------------!
      CALL zufpn(CA, NA, CB, NB, CC, NC, CD, ND, CE, NE, CF, NF,
     * CPATH, NPATH, ISTAT)
      IF (ISTAT .NE. 0 .OR. ND .LT. 7) GO TO 9880
      CALL RATTIM(CD, ND, EFFTIM, ISTAT)
      IF (ISTAT .NE. 0) GO TO 9880

      !----------------------------!
      ! check for error conditions !
      !----------------------------!
      IF (NBASE .LT. 1) GO TO 9990
C      IF (UBOUND(HEIGHT) .LT. NBASE) GO TO 9980
C      IF (UBOUND(FLOW) .LT. NBASE) GO TO 9970

      LFOUND = .FALSE.
      I = 1
      DO WHILE (.NOT. LFOUND .AND. (I .LE. NINTYP))
         IF (IBHI .EQ. IINTYP(I)) LFOUND = .TRUE.
         I = I + 1
      END DO
      IF (.NOT. LFOUND) GO TO 9960

      LFOUND = .FALSE.
      I = 1
      DO WHILE (.NOT. LFOUND .AND. (I .LE. NEXTYP))
         IF (IBHU .EQ. IEXTYP(I)) LFOUND = .TRUE.
         I = I + 1
      END DO
      IF (.NOT. LFOUND) GO TO 9950
      IF (IBHU .GE. 16) GO TO 9950 ! time-only extrapolation

      LFOUND = .FALSE.
      I = 1
      DO WHILE (.NOT. LFOUND .AND. (I .LE. NEXTYP))
         IF (IBHO .EQ. IEXTYP(I)) LFOUND = .TRUE.
         I = I + 1
      END DO
      IF (.NOT. LFOUND) GO TO 9940
      IF (IBHO .GE. 16) GO TO 9940 ! time-only extrapolation

      LFOUND = .FALSE.
      I = 1
      DO WHILE (.NOT. LFOUND .AND. (I .LE. NINTYP))
         IF (IBFI .EQ. IINTYP(I)) LFOUND = .TRUE.
         I = I + 1
      END DO
      IF (.NOT. LFOUND) GO TO 9960

      LFOUND = .FALSE.
      I = 1
      DO WHILE (.NOT. LFOUND .AND. (I .LE. NEXTYP))
         IF (IBFO .EQ. IEXTYP(I)) LFOUND = .TRUE.
         I = I + 1
      END DO
      IF (.NOT. LFOUND) GO TO 9930
      IF (IBFO .GE. 16) GO TO 9930 ! time-only extrapolation

      LFOUND = .FALSE.
      I = 1
      DO WHILE (.NOT. LFOUND .AND. (I .LE. NEXTYP))
         IF (IBFU .EQ. IEXTYP(I)) LFOUND = .TRUE.
         I = I + 1
      END DO
      IF (.NOT. LFOUND) GO TO 9920
      IF (IBFU .GE. 16) go to 9920 ! time-only extrapolation

      NSHVAL = 0
      IF (NSHIFT .LT. 0 .OR. NSHIFT .GT. MXSHF) GO TO 9910
      IF (NSHIFT .GT. 0) THEN
C         IF (UBOUND(NSHFTP) .LT. NSHIFT) GO TO 9900
C         IF (UBOUND(LATMSK) .LT. NSHIFT) GO TO 9890
C         IF (UBOUND(IETIME) .LT. NSHIFT) GO TO 9870
         DO I = 1, NSHIFT
            IF (NSHFTP(I) .LT. 0) GO TO 9860
            IF (NSHFTP(I) .EQ. 0) THEN
               NSHVAL = NSHVAL + 1
            ELSE
               NSHVAL = NSHVAL + 2 * NSHFTP(I)
            END IF
C            IF (LATMSK(I) .AND. UBOUND(IATIME) .LT. I) GO TO 9850
            TMPTIM = JBDATE + IETIME(I)
            IF (TMPTIM .LT. EFFTIM) GO TO 9840
         END DO
C         IF (NSHVAL .GT. UBOUND(SHIFTS)) GO TO 9830

         LFOUND = .FALSE.
         I = 1
         DO WHILE (.NOT. LFOUND .AND. (I .LE. NINTYP))
            IF (ISTI .EQ. IINTYP(I)) LFOUND = .TRUE.
            I = I + 1
         END DO
         IF (.NOT. LFOUND) GO TO 9820

         LFOUND = .FALSE.
         I = 1
         DO WHILE (.NOT. LFOUND .AND. (I .LE. NEXTYP))
            IF (ISTU .EQ. IEXTYP(I)) LFOUND = .TRUE.
            I = I + 1
         END DO
         IF (.NOT. LFOUND) GO TO 9810

         LFOUND = .FALSE.
         I = 1
         DO WHILE (.NOT. LFOUND .AND. (I .LE. NEXTYP))
            IF (ISTO .EQ. IEXTYP(I)) LFOUND = .TRUE.
            I = I + 1
         END DO
         IF (.NOT. LFOUND) GO TO 9800

         DO I = 1, NSHIFT
            LFOUND = .FALSE.
            J = 1
            DO WHILE (.NOT. LFOUND .AND. (J .LE. NINTYP))
               IF (ISBI(I) .EQ. IINTYP(J)) LFOUND = .TRUE.
               J = J + 1
            END DO
            IF (.NOT. LFOUND) GO TO 9790

            LFOUND = .FALSE.
            J = 1
            DO WHILE (.NOT. LFOUND .AND. (J .LE. NEXTYP))
               IF (ISBU(I) .EQ. IEXTYP(J)) THEN
                  LFOUND = .TRUE.
                  IF (ISBU(I) .GE. 16) GO TO 9780 ! time-only extrap
               END IF
               J = J + 1
            END DO
            IF (.NOT. LFOUND) GO TO 9780

            LFOUND = .FALSE.
            J = 1
            DO WHILE (.NOT. LFOUND .AND. (J .LE. NEXTYP))
               IF (ISBO(I) .EQ. IEXTYP(J)) THEN
                  LFOUND = .TRUE.
                  IF (ISBO(I) .GE. 16) GO TO 9770 ! time-only extrap
               END IF
               J = J + 1
            END DO
            IF (.NOT. LFOUND) GO TO 9770

            LFOUND = .FALSE.
            J = 1
            DO WHILE (.NOT. LFOUND .AND. (J .LE. NINTYP))
               IF (ISHI(I) .EQ. IINTYP(J)) LFOUND = .TRUE.
               J = J + 1
            END DO
            IF (.NOT. LFOUND) GO TO 9760

            LFOUND = .FALSE.
            J = 1
            DO WHILE (.NOT. LFOUND .AND. (J .LE. NEXTYP))
               IF (ISHU(I) .EQ. IEXTYP(J)) THEN
                  LFOUND = .TRUE.
                  IF (ISHU(I) .GE. 16) GO TO 9750 ! time-only extrap
               END IF
               J = J + 1
            END DO
            IF (.NOT. LFOUND) GO TO 9750

            LFOUND = .FALSE.
            J = 1
            DO WHILE (.NOT. LFOUND .AND. (J .LE. NEXTYP))
               IF (ISHO(I) .EQ. IEXTYP(J)) THEN
                  LFOUND = .TRUE.
                  IF (ISHO(I) .GE. 16) GO TO 9740 ! time-only extrap
               END IF
               J = J + 1
            END DO
            IF (.NOT. LFOUND) GO TO 9740
         END DO

      END IF

      !------------------------------!
      ! stuff the record user header !
      !------------------------------!
      NUHEAD = 0

      IF (NLOC .GT. 0) THEN
         CALL STUFFUSERHEADER('LOC', CLOC, RUHEAD, KUHEAD, NUHEAD,
     *        ISTAT)
      END IF
      IF (NATIM .GT. 0) THEN
         CALL STUFFUSERHEADER('ATIM', CATIM, RUHEAD, KUHEAD, NUHEAD,
     *        ISTAT)
      END IF

      IF (NHPARM .GT. 0) THEN
         CALL STUFFUSERHEADER('HPARM', CHPARM, RUHEAD, KUHEAD, NUHEAD,
     *        ISTAT)
      END IF

      IF (NHUNIT .GT. 0) THEN
         CALL STUFFUSERHEADER('HUNIT', CHUNIT, RUHEAD, KUHEAD, NUHEAD,
     *        ISTAT)
      END IF

      IF (NFPARM .GT. 0) THEN
         CALL STUFFUSERHEADER('FPARM', CFPARM, RUHEAD, KUHEAD, NUHEAD,
     *        ISTAT)
      END IF

      IF (NFUNIT .GT. 0) THEN
         CALL STUFFUSERHEADER('FUNIT', CFUNIT, RUHEAD, KUHEAD, NUHEAD,
     *        ISTAT)
      END IF

      IF (NCMT .GT. 0) THEN
         CALL STUFFUSERHEADER('COMMENT', CCMT, RUHEAD, KUHEAD, NUHEAD,
     *        ISTAT)
      END IF

      IF (NOPT .GT. 0) THEN
         CALL STUFFUSERHEADER('OPTION', COPT, RUHEAD, KUHEAD, NUHEAD,
     *        ISTAT)
      END IF

      IF (LSNUM) THEN
         CTEMP1 = ''
         WRITE(CTEMP1, *) ISNUM
         CALL STUFFUSERHEADER('SERIAL', CTEMP1, RUHEAD, KUHEAD, NUHEAD,
     *        ISTAT)
      END IF

      IF (LDATUM) THEN
         CTEMP1 = ''
         WRITE(CTEMP1, *) DATUM
         CALL CHRLNB(CTEMP1, NTEMP1)
         IPOINT = INDEX(CTEMP1, '.')
         ILAST = NINDXR(CTEMP1(IPOINT+1:NTEMP1), '0')
         CALL STUFFUSERHEADER('DATUM', CTEMP1(1:IPOINT+ILAST), RUHEAD,
     *        KUHEAD, NUHEAD, ISTAT)
      END IF

      IF (LCOFF) THEN
         CTEMP1 = ''
         WRITE(CTEMP1, *) COFVAL
         CALL CHRLNB(CTEMP1, NTEMP1)
         IPOINT = INDEX(CTEMP1, '.')
         ILAST = NINDXR(CTEMP1(IPOINT+1:NTEMP1), '0')
         CALL STUFFUSERHEADER('OFFSET', CTEMP1(1:IPOINT+ILAST), RUHEAD,
     *        KUHEAD, NUHEAD, ISTAT)
      END IF

      !----------------------------------!
      ! stuff the record internal header !
      !----------------------------------!
      IGBUFF(1) = NBASE
      IGBUFF(2) = NSHIFT
      ICOUNT = 0
      ILAST = -1
      DO I = 1, NSHIFT
         IBIT = I - 1
         IDX = IBIT / 32
         NATMSK = IDX + 1
         IF (IDX .NE. ILAST) THEN
            IATMSK(NATMSK) = 0
            ILAST = IDX
         END IF
         IBIT = IBIT - IDX * 32
         IF (LATMSK(I)) THEN
            ICOUNT = ICOUNT + 1
            IATIMS(ICOUNT) = IATIME(I)
            IATMSK(NATMSK) = IOR(IATMSK(NATMSK), 2 ** IBIT)
         END IF
      END DO
      IGBUFF(3) = ICOUNT
      IF (IHORIZ .EQ. 2) THEN
         IGBUFF(4) = 2
      ELSE
         IGBUFF(4) = 1
      END IF
      IF (LSTAGE) THEN
         IGBUFF(5) = 1
      ELSE
         IGBUFF(5) = 0
      END IF
      IGBUFF(6) = IBHI
      IGBUFF(7) = IBHO
      IGBUFF(8) = IBHU
      IGBUFF(9) = IBFI
      IGBUFF(10) = IBFO
      IGBUFF(11) = IBFU
      IGBUFF(12) = ISTI
      IGBUFF(13) = ISTU
      IGBUFF(14) = ISTO
      IGBUFF(15) = JBDATE
      IF (.NOT. LCOFF .AND. (NOFF .GT. 0)) THEN
         IGBUFF(16) = NOFF
      ELSE
         IGBUFF(16) = 0
      END IF

      !--------------------------------!
      ! arrange the record data values !
      !--------------------------------!
      NVALS = 7 + NBASE * 2 + NATMSK + IGBUFF(3) + NSHIFT * 12 + NSHVAL
      IF (IGBUFF(16) .GT. 0) THEN
         NVALS = NVALS + 10 + IGBUFF(16) * 2
      END IF

      RVALS(1) = HUV
      RVALS(2) = HOV
      RVALS(3) = FUV
      RVALS(4) = FOV
      IF (LSNUM)  IVALS(5) = ISNUM
      IF (LDATUM) RVALS(6) = DATUM
      IF (LCOFF)  RVALS(7) = COFVAL
      IDX = 8

      IF (NVALS .GT. MXVAL) GO TO 9730
      DO I = 1, NBASE
         RVALS(IDX+2*(I-1)+0) = HEIGHT(I)
         RVALS(IDX+2*(I-1)+1) = FLOW(I)
      END DO
      IDX = IDX + NBASE * 2

      DO I = 1, NATMSK
         IVALS(IDX+I-1) = IATMSK(I)
      END DO
      IDX = IDX + NATMSK

      DO I = 1, IGBUFF(3)
         IVALS(IDX+I-1) = IATIMS(I)
      END DO
      IDX = IDX + IGBUFF(3)

      DO I = 1, NSHIFT
         IVALS(IDX+12*(I-1)+0)  = IETIME(I)
         IVALS(IDX+12*(I-1)+1)  = NSHFTP(I)
         IVALS(IDX+12*(I-1)+2)  = ISBI(I)
         IVALS(IDX+12*(I-1)+3)  = ISBU(I)
         RVALS(IDX+12*(I-1)+4)  = SBUV(I)
         IVALS(IDX+12*(I-1)+5)  = ISBO(I)
         RVALS(IDX+12*(I-1)+6)  = SBOV(I)
         IVALS(IDX+12*(I-1)+7)  = ISHI(I)
         IVALS(IDX+12*(I-1)+8)  = ISHU(I)
         RVALS(IDX+12*(I-1)+9)  = SHUV(I)
         IVALS(IDX+12*(I-1)+10) = ISHO(I)
         RVALS(IDX+12*(I-1)+11) = SHOV(I)
      END DO
      IDX = IDX + NSHIFT * 12

      DO I = 1, NSHVAL
         RVALS(IDX+I-1) = SHIFTS(I)
      END DO
      IDX = IDX + NSHVAL

      IF (IGBUFF(16) .GT. 0) THEN
         IVALS(IDX+0) = IOBI
         IVALS(IDX+1) = IOBU
         RVALS(IDX+2) = OBUV
         IVALS(IDX+3) = IOBO
         RVALS(IDX+4) = OBOV
         IVALS(IDX+5) = IOHI
         IVALS(IDX+6) = IOHU
         RVALS(IDX+7) = OHUV
         IVALS(IDX+8) = IOHO
         RVALS(IDX+9) = OHOV
         IDX = IDX + 10
         DO I = 1, IGBUFF(16) * 2
            RVALS(IDX+I-1) = OFFSET(I)
         END DO
      END IF

      !------------------!
      ! write the record !
      !------------------!
      ISTAT = 0
      CALL zwritex(IFLTAB, CPATH, NPATH, IGBUFF, 16, ICHEAD, 0, IUHEAD,
     * NUHEAD, RVALS, NVALS, 560, IPLAN, ISTAT, LFOUND)
      GO TO 9999

      !----------------!
      ! error handlers !
      !----------------!
 9730 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9731) NVALS, MXVAL,
     * CPATH(1:NPATH)

 9731 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Number of Values',
     * ' Required to Store the Record is Out of Range', /,
     * ' Number Required:', I6, /, ' Maximum:', I6, /,
     * ' Pathname: ', A, /)
      ISTAT = -9
      GO TO 9999

 9740 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9741) I, ISHO(I), CPATH(1:NPATH)
 9741 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Overflow Handling',
     * ' Method Supplied for the Shift Heights is Invalid.', /,
     * 'Shift: ', I2, /, ' Method: ', I2, /, ' Pathname: ', A, /)
      ISTAT = -27
      GO TO 9999

 9750 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9751) I, ISHU(I), CPATH(1:NPATH)
 9751 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Underflow Handling',
     * ' Method Supplied for the Shift Heights is Invalid.', /,
     * 'Shift: ', I2, /, ' Method: ', I2, /, ' Pathname: ', A, /)
      ISTAT = -26
      GO TO 9999

 9760 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9761) I, ISHI(I), CPATH(1:NPATH)
 9761 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Interpolation Method',
     * ' Supplied for the Shift Heights is Invalid.', /,
     * 'Shift: ', I2, /, ' Method: ', I2, /, ' Pathname: ', A, /)
      ISTAT = -25
      GO TO 9999

 9770 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9771) I, ISBO(I), CPATH(1:NPATH)
 9771 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Overflow Handling',
     * ' Method Supplied for the Shift Breakpoints is Invalid.', /,
     * 'Shift: ', I2, /, ' Method: ', I2, /, ' Pathname: ', A, /)
      ISTAT = -24
      GO TO 9999

 9780 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9781) I, ISBU(I), CPATH(1:NPATH)
 9781 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Underflow Handling',
     * ' Method Supplied for the Shift Breakpoints is Invalid.', /,
     * 'Shift: ', I2, /, ' Method: ', I2, /, ' Pathname: ', A, /)
      ISTAT = -23
      GO TO 9999

 9790 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9791) I, ISBI(I), CPATH(1:NPATH)
 9791 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Interpolation Method',
     * ' Supplied for the Shift Breakpoints is Invalid.', /,
     * 'Shift: ', I2, /, ' Method: ', I2, /, ' Pathname: ', A, /)
      ISTAT = -22
      GO TO 9999

 9800 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9801) ISTO, CPATH(1:NPATH)
 9801 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Overflow Handling',
     * ' Method Supplied for the Shift Effective Times is Invalid.', /,
     * ' Method Supplied: ', I2, /, ' Pathname: ', A, /)
      ISTAT = -21
      GO TO 9999

 9810 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9811) ISTU, CPATH(1:NPATH)
 9811 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Underflow Handling',
     * ' Method Supplied for the Shift Effective Times is Invalid.',
     *  /, ' Method Supplied: ', I2, /, ' Pathname: ', A, /)
      ISTAT = -20
      GO TO 9999

 9820 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9821) ISTI, CPATH(1:NPATH)
 9821 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Interpolation Method',
     * ' Supplied for the Shift Effective Times is Invalid.', /,
     * ' Method Supplied: ', I2, /, ' Pathname: ', A, /)
      ISTAT = -19
      GO TO 9999

C 9830 CONTINUE
C      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9831) ICOUNT, UBOUND(SHIFTS),
C     * CPATH(1:NPATH)
C 9831 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Length of the Array',
C     * ' Containing the Shifts is Less than',
C     * ' Indicated by the Array Containing the Number of Shift ', /,
C     * ' Points per Shift. *** ',
C     * ' Indicated Array Length:', I6, /, ' Array Length:', I6, /,
C     * ' Pathname: ', A, /)
C      ISTAT = -18
C      GO TO 9999

 9840 CONTINUE
      !WRITE(*, *) TMPTIM
      !WRITE(*, *) EFFTIM
      IF (MLEVEL .GT. 1) THEN
         IMIN = MOD(TMPTIM, 1440)
         IHR = IMIN / 60
         IMIN = MOD(IMIN, 60)
         CALL JULDAT(TMPTIM / 1440 + 1, 7, CTEMP1, NTEMP1)
         WRITE (CTEMP1(NTEMP1+1:), '(A,I2.2,A,I2.2)') ', ',IHR, ':',
     *    IMIN
         IMIN = MOD(EFFTIM, 1440)
         IHR = IMIN / 60
         IMIN = MOD(IMIN, 60)
         CALL JULDAT(EFFTIM / 1440 + 1, 7, CTEMP2, NTEMP2)
         WRITE (CTEMP2(NTEMP2+1:), '(A,I2.2,A,I2.2)') ', ',IHR, ':',
     *    IMIN
         WRITE (MUNIT, 9841) I, CTEMP1, CTEMP2, CPATH(1:NPATH)
      END IF
 9841 FORMAT (/, ' -----DSS---zsrst:  ERROR;  Effective Time for Shift',
     * ' preceeds Effective Time for Base Curve.',
     * ' Shift Number:', I6, /,
     * ' Shift Effective Time:', A, /,
     * ' Base Curve Effective Time:', A, /,
     * ' Pathname: ', A, /)
      ISTAT = -17
      GO TO 9999

C 9850 CONTINUE
C      IF (MLEVEL .GT. 1) THEN
C         IMAX = I
C         DO I = I, NSHIFT
C            IF (LATMSK(I)) IMAX = I
C         END DO
C         WRITE (MUNIT, 9851) IMAX, UBOUND(IATIME), CPATH(1:NPATH)
C      END IF
C 9851 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Length of the Array',
C     * ' Containing the Activated Times is less than required by',
C     * ' the Activated Time Mask Array.', /,
C     * ' Required by Mask Array:', I6, /, ' Array Length:', I6, /,
C     * ' Pathname: ', A, /)
C      ISTAT = -16
C      GO TO 9999

 9860 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9861) I, NSHFTP(I),
     * CPATH(1:NPATH)
 9861 FORMAT (/, ' -----DSS---zsrst:  ERROR;  Number of Shift Points',
     * ' Indicated is Less than One.', /, ' Shift Number:', I6, /,
     * ' Number of Points Indicated:', I6, /, ' Pathname: ', A, /)
      ISTAT = -15
      GO TO 9999

C 9870 CONTINUE
C      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9871) NSHIFT, UBOUND(IETIME),
C     * CPATH(1:NPATH)
C 9871 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Length of the Array',
C     * ' Containing the Effective Times is less than',
C     * ' the Number of Shifts Indicated.', /,
C     * ' Number of Shifts Indicated:', I6, /, ' Array Length:', I6, /,
C     * ' Pathname: ', A, /)
C      ISTAT = -13
C      GO TO 9999

 9880 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9881) CPATH(1:NPATH)
 9881 FORMAT (/, ' -----DSS---zsrst:  ERROR;  Cannot Determine the',
     * ' Effective Time of the Rating from the Pathname.', /,
     * ' Pathname: ', A, /)
      ISTAT = -12
      GO TO 9999

C 9890 CONTINUE
C      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9891) NSHIFT, UBOUND(NSHFTP),
C     * CPATH(1:NPATH)
C 9891 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Length of the Array',
C     * ' Containing the Activated Time Flags is less than',
C     * ' the Number of Shifts Indicated.', /,
C     * ' Number of Shifts Indicated:', I6, /, ' Array Length:', I6, /,
C     * ' Pathname: ', A, /)
C      ISTAT = -11
C      GO TO 9999

C 9900 CONTINUE
C      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9901) NSHIFT, UBOUND(NSHFTP),
C     * CPATH(1:NPATH)
C 9901 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Length of the Array',
C     * ' Containing the Number of Shift Points per Shift is less than',
C     * ' the Number of Shifts Indicated.', /,
C     * ' Number of Shifts Indicated:', I6, /, ' Array Length:', I6, /,
C     * ' Pathname: ', A, /)
C      ISTAT = -10
C      GO TO 9999

 9910 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9911) NSHIFT, MXSHF,
     * CPATH(1:NPATH)
 9911 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Number of Shifts',
     * ' Supplied is Out of Range', /,
     * ' Number Supplied:', I6, /, ' Maximum:', I6, /,
     * ' Pathname: ', A, /)
      ISTAT = -9
      GO TO 9999

 9920 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9921) IBFO, CPATH(1:NPATH)
 9921 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Overflow Handling',
     * ' Method Supplied for the Base Curve Flows is Invalid.', /,
     * ' Method Supplied: ', I2, /, ' Pathname: ', A, /)
      ISTAT = -8
      GO TO 9999

 9930 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9931) IBFU, CPATH(1:NPATH)
 9931 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Underflow Handling',
     * ' Method Supplied for the Base Curve Flows is Invalid.', /,
     * ' Method Supplied: ', I2, /, ' Pathname: ', A, /)
      ISTAT = -7
      GO TO 9999

 9940 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9941) IBHO, CPATH(1:NPATH)
 9941 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Overflow Handling',
     * ' Method Supplied for the Base Curve Heights is Invalid.', /,
     * ' Method Supplied: ', I2, /, ' Pathname: ', A, /)
      ISTAT = -6
      GO TO 9999

 9950 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9951) IBHU, CPATH(1:NPATH)
 9951 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Underflow Handling',
     * ' Method Supplied for the Base Curve Heights is Invalid.', /,
     * ' Method Supplied: ', I2, /, ' Pathname: ', A, /)
      ISTAT = -5
      GO TO 9999

 9960 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9961) IBHI, IBFI, CPATH(1:NPATH)
 9961 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Interpolation Method',
     * ' Supplied for the Base Curve is Invalid.', /,
     * ' Method Supplied: ', I2, ', ',I2 /, ' Pathname: ', A, /)
      ISTAT = -4
      GO TO 9999

C9970 CONTINUE
C     IF (MLEVEL .GT. 1) WRITE (MUNIT, 9971) NBASE, UBOUND(FLOWS),
C    * CPATH(1:NPATH)
C9971 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Number of Flows',
C    * ' Supplied for the Base Curve is Less than the Coordinate',
C    * ' Count.', / 'Number Supplied:', I6, /, ' Coordinate Count:', I6,
C    *  /, ' Pathname: ', A, /)
C     ISTAT = -3
C     GO TO 9999

C9980 CONTINUE
C     IF (MLEVEL .GT. 1) WRITE (MUNIT, 9981) NBASE, UBOUND(HEIGHTS),
C    * CPATH(1:NPATH)
C9981 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Number of Heights',
C    * ' Supplied for the Base Curve is Less than the Coordinate',
C    * ' Count.', /, ' Number Supplied:', I6, /, ' Coordinate Count:',
C    * I6, /, ' Pathname: ', A, /)
C     ISTAT = -2
C     GO TO 9999

 9990 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9991) NBASE, CPATH(1:NPATH)
 9991 FORMAT (/, ' -----DSS---zsrst:  ERROR;  The Number of',//
     * ' Coordinates Supplied for the Base Curve is Less than One',  /,
     * ' Number Supplied:', I6, /, ' Pathname: ', A, /)
      ISTAT = -1
      GO TO 9999

 9998 FORMAT (T5, '----- Exit zsrst, Number data values stored:', I5,
     * ', Number shifts stored:', I4, ', Status:', I4, /)

      !-------------------!
      ! normal exit point !
      !-------------------!
 9999 CONTINUE
      !--------------------!
      ! debug exit message !
      !--------------------!
      IF (MLEVEL .GT. 7) WRITE (MUNIT, 9998) NBASE, NSHIFT, ISTAT
      RETURN
      END

C=======================================================================
      SUBROUTINE STUFFUSERHEADER(LABEL, ITEM, RUHEAD, KUHEAD, NUHEAD,
     * ISTAT)

      CHARACTER LABEL*(*), ITEM*(*), LOCALLABEL*60, LOCALITEM*512,
     * CCHUNK*60
      REAL*4 RUHEAD(*)
      INTEGER*4 KUHEAD, NUHEAD, ISTAT

      CALL CHRLNB(ITEM, NITEM)
      LOCALITEM = ITEM(1:NITEM)
      DO I = 1, NITEM
         IF (LOCALITEM(I:I) .EQ. ':') LOCALITEM(I:I) = '~'
         IF (LOCALITEM(I:I) .EQ. ';') LOCALITEM(I:I) = '`'
      END DO

      NCHUNKS = (NITEM - 1) / 60 + 1
      IF (NCHUNKS .EQ. 1) THEN
         CALL zstfh(LABEL, LOCALITEM, 1, RUHEAD, KUHEAD, NUHEAD, ISTAT)
      ELSE
         DO I = 1, NCHUNKS
            CCHUNK = LOCALITEM((I-1)*60+1:I*60)
            IF (I .EQ. 1) THEN
               LOCALLABEL = LABEL
            ELSE
               WRITE(LOCALLABEL(1:), *)LABEL, I
            END IF
            CALL zstfh(LOCALLABEL, CCHUNK, 1, RUHEAD, KUHEAD, NUHEAD,
     *       ISTAT)
         END DO
      END IF
      RETURN
      END


C
C $Id: tdttri.f,v 1.3 2008-07-27 00:17:33 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE TDTTRI (UCRA,VCRA,WCRA,NCRA,IMRK,RMRK,SMRK,RTRI,MTRI,
     +                        NTRI,IRST,UMIN,VMIN,WMIN,UMAX,VMAX,WMAX)
C
C The routine TDTTRI, given a trajectory defined by a series of points,
C calls TDMTRI to create markers showing the trajectory.  The arguments
C are as follows:
C
C   UCRA is a real array of U coordinates of points on the trajectory.
C
C   VCRA is a real array of V coordinates of points on the trajectory.
C
C   WCRA is a real array of W coordinates of points on the trajectory.
C
C   NCRA is an integer expression whose value is the number of points on
C   the trajectory.
C
C   IMRK is an integer expression whose absolute value may be from 1 to
C   5, inclusive, to select markers that are tetrahedrons, octahedrons,
C   cubes, icosahedrons, or elaborated icosahedrons (effectively,
C   spheres), respectively.  If IMRK is less than zero, the marks are
C   not clipped at the faces of the box defined by the last six
C   arguments; otherwise, they are.
C
C   RMRK is a real expression whose value is the desired radius of each
C   mark.  Its value must be greater than zero.
C
C   SMRK is a real expression whose value is the desired gap between two
C   marks along the trajectory.  A negative value can be used if it is
C   desired that the marks should overlap.  However, don't try to make
C   SMRK negative and larger in absolute value than 2.*RMRK.
C
C   RTRI is a real array in which a list of triangles is being
C   generated; it is dimensioned 10 x MTRI.  Each 10-word entry in
C   the list consists of the U, V, and W coordinates of each of three
C   points, followed by a rendering style index.
C
C   MTRI is an input integer specifying the second dimension of the
C   array RTRI: the maximum number of triangles the list will hold.
C
C   NTRI is an input/output integer specifying the number of triangles
C   currently in the array RTRI.  Initially, NTRI must be zeroed by the
C   user.  Each call to one of the routines TDSTRI or TDITRI updates the
C   value of NTRI to reflect the number of triangles added to the list.
C
C   IRST is an input integer specifying the rendering style index to be
C   used for all the triangles generated by a particular call to TDTTRI.
C   Note that more than one surface can be represented by the triangles
C   in the triangle list and that each surface can be rendered in its
C   own particular style.
C
C   UMIN, VMIN, WMIN, UMAX, VMAX, and WMAX define the clipping box for
C   the marks generated by TDTTRI.
C
C The distance from the center of one mark to the center of the next one
C will be approximately 2.*RMRK + SMRK, but a slightly adjusted value of
C SMRK is used in order to make the spacing come out even.
C
        DIMENSION UCRA(NCRA),VCRA(NCRA),WCRA(NCRA)
C
        TLEN=0.
C
C Compute the total length of the trajectory.
C
        DO 101 I=2,NCRA
          TLEN=TLEN+SQRT((UCRA(I)-UCRA(I-1))*(UCRA(I)-UCRA(I-1))+
     +                   (VCRA(I)-VCRA(I-1))*(VCRA(I)-VCRA(I-1))+
     +                   (WCRA(I)-WCRA(I-1))*(WCRA(I)-WCRA(I-1)))
  101   CONTINUE
C
C Determine how many marks will be required along the trajectory and
C quit if the number turns out to be less than or equal to zero.
C
        NMKS=INT(1.+TLEN/(RMRK+RMRK+SMRK))
        IF (NMKS.LE.0) RETURN
C
C Compute a slightly adjusted value of SMRK that will allow us to put
C marks at the beginning and end of the trajectory, with the ones in
C between evenly spaced.
C
        SADJ=(TLEN-.01*RMRK)/REAL(NMKS-1)-RMRK-RMRK
C
C Initialize.  IONP is the index of the next point on the trajectory
C and DTNM is the distance along the trajectory to the next mark.
C DTNP is the distance to the next point on the trajectory.
C
        IONP=1
        DTNM=0.
C
C Do it.  This loop is not well-protected against bad user input, so
C there is some chance it could turn into an infinite loop.  In time,
C perhaps, I will fix that ...
C
  102   IF (IONP.LT.NCRA) THEN
          IOLP=IONP
          IONP=IONP+1
          DTNP=SQRT((UCRA(IONP)-UCRA(IOLP))*(UCRA(IONP)-UCRA(IOLP))+
     +              (VCRA(IONP)-VCRA(IOLP))*(VCRA(IONP)-VCRA(IOLP))+
     +              (WCRA(IONP)-WCRA(IOLP))*(WCRA(IONP)-WCRA(IOLP)))
  103     IF (DTNP.LT.DTNM) THEN
            DTNM=DTNM-DTNP
            GO TO 102
          ELSE
            UMRK=UCRA(IOLP)+(DTNM/DTNP)*(UCRA(IONP)-UCRA(IOLP))
            VMRK=VCRA(IOLP)+(DTNM/DTNP)*(VCRA(IONP)-VCRA(IOLP))
            WMRK=WCRA(IOLP)+(DTNM/DTNP)*(WCRA(IONP)-WCRA(IOLP))
            CALL TDMTRI (IMRK,UMRK,VMRK,WMRK,RMRK,RTRI,MTRI,NTRI,IRST,
     +                                  UMIN,VMIN,WMIN,UMAX,VMAX,WMAX)
            DTNM=DTNM+RMRK+RMRK+SADJ
            GO TO 103
          END IF
        END IF
C
C Done.
C
        RETURN
C
      END


      subroutine xpegat(iopt)
c     implicit double precision (a-h,o-z)                                    dp
       use mod_parameters
      common/bk01/h4(4,5),p14(4,5),p24(4,5)
      common/bk02/ioofc,iphase,imass,lpar(9)
      common/range/mft,mlt,lft,llt,nftm1
      common/intgrt/ipt
      common/xcom25/ipcmp(7,10),ipmcmp(10,10),ipecmp(10,10),
     1              xpcmp(2,10),npcmp,ipcm
      common/vect6/
     1 cg11(nelemg),cg21(nelemg),cg12(nelemg),cg22(nelemg),
     2 cg13(nelemg),cg23(nelemg),cg14(nelemg),cg24(nelemg),
     3 ch11(nelemg),ch21(nelemg),ch12(nelemg),ch22(nelemg),
     4 ch13(nelemg),ch23(nelemg),ch14(nelemg),ch24(nelemg),
     5 ci11(nelemg),ci21(nelemg),ci12(nelemg),ci22(nelemg),
     6 ci13(nelemg),ci23(nelemg),ci14(nelemg),ci24(nelemg)
      common/vect12/svvol(nelemg,4),
     1 spy1(nelemg,4),spy2(nelemg,4),spy3(nelemg,4),spy4(nelemg,4),
     2 spz1(nelemg,4),spz2(nelemg,4),spz3(nelemg,4),spz4(nelemg,4),
     3 sph1(nelemg,4),sph2(nelemg,4),sph3(nelemg,4),sph4(nelemg,4)
      common/vect91/xargat(nelemg),exx(nelemg,4),eps(nelemg,5),
     > sa(nelemg),
     1 sb(nelemg),sc(nelemg),ang1(nelemg),ang2(nelemg)
      if(npcmp.eq.0)return
      if(iopt.eq.1)then
      do 10 i=1,npcmp
      nortyp=ipcmp(4,i)
      if(nortyp.eq.1.or.nortyp.eq.2)then
      xpcmp(1,i)=0.
      xpcmp(2,i)=0.
      elseif(nortyp.eq.3)then
      xpcmp(1,i)=-1.e20
      elseif(nortyp.eq.4)then
      xpcmp(1,i)=1.e20
      endif
   10 continue
      elseif(iopt.lt.0)then
      do 30 i=1,npcmp
      nmat=ipcmp(5,i)
      if(nmat.ne.0)then
      do 40 j=1,nmat
      if(ipmcmp(j,i).eq.-iopt)then
      call xecomp(ipcmp(3,i),mft,mlt)
      nortyp=ipcmp(4,i)
      if(nortyp.eq.1.and.lpar(5).eq.0)then
      do 50 k=mft,mlt
      radius=h4(1,ipt)*ch11(k)+h4(2,ipt)*ch12(k)+
     1       h4(3,ipt)*ch13(k)+h4(4,ipt)*ch14(k)
      vol=radius*svvol(k,ipt)
      xpcmp(1,i)=xpcmp(1,i)+xargat(k)*vol
      xpcmp(2,i)=xpcmp(2,i)+vol
   50 continue
      elseif(nortyp.le.2)then
      do 55 k=mft,mlt
      xpcmp(1,i)=xpcmp(1,i)+xargat(k)*svvol(k,ipt)
      xpcmp(2,i)=xpcmp(2,i)+svvol(k,ipt)
   55 continue
      elseif(nortyp.eq.3)then
      do 60 k=mft,mlt
      if(xargat(k).gt.xpcmp(1,i))xpcmp(1,i)=xargat(k)
   60 continue
      elseif(nortyp.eq.4)then
      do 65 k=mft,mlt
      if(xargat(k).lt.xpcmp(1,i))xpcmp(1,i)=xargat(k)
   65 continue
      endif
      goto 30
      endif
   40 continue
      endif
   30 continue
      elseif(iopt.eq.3)then
      do 100 i=1,npcmp
      if(ipcmp(5,i).eq.0.and.ipcmp(6,i).eq.0)then
      call xecomp(ipcmp(3,i),lft,llt)
      nortyp=ipcmp(4,i)
      if(nortyp.eq.1.and.lpar(5).eq.0)then
      do 80 k=lft,llt
      radius=h4(1,ipt)*ch11(k)+h4(2,ipt)*ch12(k)+
     1       h4(3,ipt)*ch13(k)+h4(4,ipt)*ch14(k)
      vol=radius*svvol(k,ipt)
      xpcmp(1,i)=xpcmp(1,i)+xargat(k)*vol
      xpcmp(2,i)=xpcmp(2,i)+vol
   80 continue
      elseif(nortyp.le.2)then
      do 85 k=lft,llt
      xpcmp(1,i)=xpcmp(1,i)+xargat(k)*svvol(k,ipt)
      xpcmp(2,i)=xpcmp(2,i)+svvol(k,ipt)
   85 continue
      elseif(nortyp.eq.3)then
      do 90 k=lft,llt
      if(xargat(k).gt.xpcmp(1,i))xpcmp(1,i)=xargat(k)
   90 continue
      elseif(nortyp.eq.4)then
      do 95 k=lft,llt
      if(xargat(k).lt.xpcmp(1,i))xpcmp(1,i)=xargat(k)
   95 continue
      endif
      elseif(ipcmp(6,i).ne.0)then
      nele=ipcmp(6,i)
      do 110 j=1,nele
      ielem=ipecmp(j,i)-nftm1
      if(ielem.ge.lft.and.ielem.le.llt)then
      call xecomp(ipcmp(3,i),ielem,ielem)
      nortyp=ipcmp(4,i)
      if(nortyp.eq.1.and.lpar(5).eq.0)then
      radius=h4(1,ipt)*ch11(ielem)+h4(2,ipt)*ch12(ielem)+
     1       h4(3,ipt)*ch13(ielem)+h4(4,ipt)*ch14(ielem)
      vol=radius*svvol(ielem,ipt)
      xpcmp(1,i)=xpcmp(1,i)+xargat(ielem)*vol
      xpcmp(2,i)=xpcmp(2,i)+vol
      elseif(nortyp.le.2)then
      xpcmp(1,i)=xpcmp(1,i)+xargat(ielem)*svvol(ielem,ipt)
      xpcmp(2,i)=xpcmp(2,i)+svvol(ielem,ipt)
      elseif(nortyp.eq.3)then
      if(xargat(ielem).gt.xpcmp(1,i))xpcmp(1,i)=xargat(ielem)
      elseif(nortyp.eq.4)then
      if(xargat(ielem).lt.xpcmp(1,i))xpcmp(1,i)=xargat(ielem)
      endif
      endif
  110 continue
      endif
  100 continue

      elseif(iopt.eq.4)then
      do 20 i=1,npcmp
      nortyp=ipcmp(4,i)
      if(nortyp.eq.1.or.nortyp.eq.2)then
      xpcmp(1,i)=xpcmp(1,i)/xpcmp(2,i)
      endif
   20 continue
      endif
      return
      end


module da_test

   !---------------------------------------------------------------------------
   ! Purpose: Collection of routines associated with minimisation.
   !---------------------------------------------------------------------------

   use module_configure, only : grid_config_rec_type
   use module_dm, only : wrf_dm_sum_real, wrf_dm_sum_integer

#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_psichi_uv_adj_sub, halo_xa_sub, &
      halo_sfc_xa_sub, halo_ssmi_xa_sub, halo_radar_xa_w_sub
!  use mpi, only : mpi_sum
#endif

   use da_control, only : num_procs, var4d_bin, var4d_lbc
   use module_domain, only : vp_type, xb_type, x_type, ep_type, &
      domain, domain_clock_get, domain_clock_set, domain_clockprint, domain_clockadvance
   use module_state_description, only : dyn_em,dyn_em_tl,dyn_em_ad,p_a_qv

   use da_control, only : trace_use,ierr, trace_use_dull, comm,global,stdout,rootproc, &
      sfc_assi_options,typical_qrn_rms,typical_qci_rms,typical_qsn_rms,typical_qgr_rms,jcdfi_use, jcdfi_diag, &
      typical_u_rms,typical_v_rms,typical_w_rms,typical_t_rms, typical_p_rms, typical_rain_rms, &
      typical_q_rms,typical_qcw_rms,print_detail_testing,typical_rh_rms, &
      fg_format, fg_format_wrf_arw_global, fg_format_wrf_arw_regional,fg_format_wrf_nmm_regional, &
      typical_rf_rms,typical_rv_rms, typical_thickness_rms, typical_tb19v_rms,typical_tb37h_rms, &
      typical_tb85h_rms,typical_tb37v_rms,typical_tb85v_rms,typical_tb22v_rms, &
      typical_tb19h_rms,typical_speed_rms,typical_tpw_rms,typical_ref_rms, &
      cv_options_hum,inv_typ_vp5_sumsq,inv_typ_vp1_sumsq, trajectory_io, &
      inv_typ_vp3_sumsq,inv_typ_vp2_sumsq,inv_typ_vpalpha_sumsq, &
      inv_typ_vp4_sumsq,typical_rho_rms,balance_geo,balance_cyc,balance_type, &
      balance_geocyc, var4d, num_fgat_time,cv_options_hum_specific_humidity, &
      cv_options_hum_relative_humidity, ids, ide, jds, jde, kds, kde, &
      sound, sonde_sfc, mtgirs, synop, profiler, gpsref, gpspw, polaramv, geoamv, ships, metar, &
      satem, radar, ssmi_rv, ssmi_tb, ssmt1, ssmt2, airsr, pilot, airep, tamdar, tamdar_sfc, rain, &
      bogus, buoy, qscat, pseudo, radiance, use_radarobs, use_ssmiretrievalobs,use_rainobs, &
      use_gpsrefobs, use_ssmt1obs, use_ssmitbobs, use_ssmt2obs, use_gpspwobs, &
      use_gpsztdobs, use_radar_rf, use_radar_rhv, use_rad, crtm_cloud, cloud_cv_options, &
      ids,ide,jds,jde,kds,kde, ims,ime,jms,jme,kms,kme, fgat_rain_flags, &
      its,ite,jts,jte,kts,kte, ips,ipe,jps,jpe,kps,kpe, cv_options, cv_size, &
      cloud_cv_options, cp, gas_constant, test_dm_exact, cv_size_domain, &
      its_int, ite_int, jts_int, jte_int, kts_int, kte_int, &
      ims_int, ime_int, jms_int, jme_int, kms_int, kme_int
   use da_control, only : use_cv_w
   use da_control, only : typical_eph_rms, gpseph, use_gpsephobs, missing_r

   use da_define_structures, only : da_zero_x,da_zero_vp_type,da_allocate_y, &
      da_deallocate_y,be_type, xbx_type, iv_type, y_type, j_type, da_initialize_cv
   use da_dynamics, only : da_uv_to_divergence,da_uv_to_vorticity, &
      da_psichi_to_uv, da_psichi_to_uv_adj, da_uv_to_divergence_adj, &
      da_divergence_constraint, da_divergence_constraint_adj
   use da_ffts, only : da_solve_poissoneqn_fct
   use da_minimisation, only : da_transform_vtoy_adj,da_transform_vtoy, da_swap_xtraj, &
       da_read_basicstates, da_calculate_j, da_calculate_gradj
   use da_obs, only : da_transform_xtoy,da_transform_xtoy_adj
   use da_par_util, only : da_patch_to_global, da_system, da_cv_to_global
#ifdef DM_PARALLEL
   use da_par_util1, only : true_mpi_real
#endif
   use da_physics, only : da_transform_xtopsfc,da_transform_xtopsfc_adj, &
      da_pt_to_rho_lin,da_transform_xtotpw,da_transform_xtogpsref_lin, &
      da_transform_xtowtq, da_transform_xtowtq_adj,da_pt_to_rho_adj, &
      da_transform_xtotpw_adj, da_transform_xtoztd_lin, da_transform_xtoztd_adj, &
      da_moist_phys_lin, da_moist_phys_adj, da_uvprho_to_w_lin, da_uvprho_to_w_adj
   use da_reporting, only : da_error, message, da_message
   use da_spectral, only : da_test_spectral
   use da_ssmi, only : da_transform_xtoseasfcwind_lin, &
      da_transform_xtoseasfcwind_adj
   use da_statistics, only : da_correlation_coeff1d,da_correlation_coeff2d
   use da_tools_serial, only : da_get_unit,da_free_unit
   use da_tracing, only : da_trace_entry,da_trace_exit
   use da_transfer_model, only : da_transfer_wrftltoxa,da_transfer_xatowrftl, &
      da_transfer_xatowrftl_adj,da_transfer_wrftltoxa_adj,da_transfer_wrftoxb
   use da_wrf_interfaces, only : wrf_dm_bcast_real
   use da_wrf_interfaces, only : wrf_debug, wrf_shutdown
   use da_wrfvar_io, only : da_med_initialdata_output,da_med_initialdata_input
   use da_vtox_transforms, only : da_transform_xtotb_lin, &
      da_transform_xtotb_adj, da_vertical_transform, da_transform_vptox, &
      da_transform_xtogpsref_adj,da_transform_vptox_adj,da_transform_vtox, &
      da_transform_vtox_adj,da_transform_vtovv,da_transform_vtovv_global, &
      da_transform_vtovv_global_adj, da_transform_vtovv_adj, da_transform_xtoxa, &
      da_transform_xtoxa_adj, da_apply_be, da_apply_be_adj, da_transform_bal, &
      da_transform_bal_adj
#ifdef VAR4D
   use da_transfer_model, only : da_transfer_xatowrftl_lbc, da_transfer_xatowrftl_adj_lbc, da_get_2nd_firstguess
   use da_4dvar, only : model_grid, da_tl_model, da_ad_model, input_nl_xtraj, upsidedown_ad_forcing, &
       u6_2, v6_2, w6_2, t6_2, ph6_2, p6, mu6_2, psfc6, moist6
   use da_rain, only : da_transform_xtoy_rain, da_transform_xtoy_rain_adj
#endif

   implicit none

   private :: da_dot_cv, da_dot

#ifdef DM_PARALLEL
   include 'mpif.h'
#endif

contains

#include "da_check_balance.inc"
#include "da_check_cvtovv_adjoint.inc"
#include "da_check_vtox_adjoint.inc"
#include "da_check_vptox_adjoint.inc"
#include "da_check_vp_errors.inc"
#include "da_check_vvtovp_adjoint.inc"
#include "da_check_xtovptox_errors.inc"
#include "da_check_xtoy_adjoint.inc"
#include "da_check_xtoy_adjoint_airep.inc"
#include "da_check_xtoy_adjoint_gpspw.inc"
#include "da_check_xtoy_adjoint_gpsref.inc"
#include "da_check_xtoy_adjoint_gpseph.inc"
#include "da_check_xtoy_adjoint_metar.inc"
#include "da_check_xtoy_adjoint_pilot.inc"
#include "da_check_xtoy_adjoint_ssmi_rv.inc"
#include "da_check_xtoy_adjoint_ssmi_tb.inc"
#include "da_check_xtoy_adjoint_satem.inc"
#include "da_check_xtoy_adjoint_geoamv.inc"
#include "da_check_xtoy_adjoint_polaramv.inc"
#include "da_check_xtoy_adjoint_ships.inc"
#include "da_check_xtoy_adjoint_radar.inc"
#include "da_check_xtoy_adjoint_rain.inc"
#include "da_check_xtoy_adjoint_bogus.inc"
#include "da_check_xtoy_adjoint_sound.inc"
#include "da_check_xtoy_adjoint_sonde_sfc.inc"
#include "da_check_xtoy_adjoint_mtgirs.inc"
#include "da_check_xtoy_adjoint_tamdar.inc"
#include "da_check_xtoy_adjoint_tamdar_sfc.inc"
#include "da_check_xtoy_adjoint_synop.inc"
#include "da_check_xtoy_adjoint_rad.inc"
#include "da_transform_xtovp.inc"
#include "da_check.inc"
#include "da_dot.inc"
#include "da_dot_cv.inc"
#include "da_check_xtoy_adjoint_pseudo.inc"
#include "da_check_xtoy_adjoint_qscat.inc"
#include "da_check_xtoy_adjoint_ssmt1.inc"
#include "da_check_xtoy_adjoint_ssmt2.inc"
#include "da_check_xtoy_adjoint_profiler.inc"
#include "da_check_xtoy_adjoint_buoy.inc"
#include "da_setup_testfield.inc"
#include "da_check_sfc_assi.inc"
#include "da_check_psfc.inc"
#include "da_set_tst_trnsf_fld.inc"
#include "da_check_vtoy_adjoint.inc"
#include "da_get_y_lhs_value.inc"
#include "da_check_gradient.inc"
#include "da_check_dynamics_adjoint.inc"

end module da_test


!-----------------------------------------------------------------------
!     Module:        beams3d_lines
!     Authors:       S. Lazerson (lazerson@pppl.gov)
!     Date:          02/21/2012
!     Description:   This module contains the FIELDLINES field line
!                    variables.
!-----------------------------------------------------------------------
      MODULE beams3d_lines
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stel_kinds, ONLY: rprec

!-----------------------------------------------------------------------
!     Module Variables
!          myline    Dummy index
!          nparticles    Number of Particles
!          nsteps    Number of integration steps along fieldline
!          R_lines   Radial locations along fieldline [m] (npoinc per field period)
!          Z_lines   Vertical locations along field line [m]
!          PHI_lines Toroidal locations along field line [radians]
!-----------------------------------------------------------------------
      IMPLICIT NONE
      LOGICAL  ::  ltherm
      INTEGER  ::  ns_prof1, ns_prof2, ns_prof3, ns_prof4, ns_prof5, nsh_prof4
      INTEGER  :: nparticles, nsteps, myline, mybeam, mytdex, myend, mystart_save, myend_save
      INTEGER  :: win_epower, win_ipower, win_ndot, win_dense, win_jprof, win_dist5d
      REAL(rprec) :: xlast,ylast,zlast ! for storing position
      REAL(rprec) :: moment, mycharge, myZ, mymass, myv_neut(3), my_end, &
                     rand_prob, cum_prob, tau, next_t, &
                     partvmax, fact_crit, fact_pa, fact_vsound, fact_kick, &
                     fact_coul, &
                     partpmax, h2_prof, h3_prof, h4_prof, h5_prof
      LOGICAL, ALLOCATABLE     :: neut_lines(:,:)
      INTEGER, ALLOCATABLE     :: end_state(:)
      REAL(rprec), ALLOCATABLE :: shine_through(:), shine_port(:), GFactor(:)
      REAL(rprec), DIMENSION(:,:), POINTER :: ndot_prof(:,:),epower_prof(:,:), &
                                  ipower_prof(:,:),j_prof(:,:), dense_prof(:,:)
      REAL(rprec), DIMENSION(:,:,:,:,:,:), POINTER :: dist5d_prof
      REAL(rprec), ALLOCATABLE :: R_lines(:,:),Z_lines(:,:),PHI_lines(:,:),vll_lines(:,:),moment_lines(:,:),&
                                  S_lines(:,:),U_lines(:,:),B_lines(:,:)

      END MODULE beams3d_lines