      PROGRAM RELAX_FLAT_RIVERS
      USE MOD_ZA  ! HYCOM array I/O interface
      IMPLICIT NONE
C
C     DIAGNOSTIC/DEBUGGING VARIABLES.
C
      INTEGER        ITEST,JTEST
      COMMON/DEBUGI/ ITEST,JTEST
      SAVE  /DEBUGI/
C
C     BLKDAT VARIABLES.
C
      CHARACTER*79 CTITLE
      CHARACTER*40 SIGFMT
      INTEGER      IVERSN,IEXPT,YRFLAG,KDM,MONTH,SIGVER,THFLAG
      REAL*4       SIGMA(99),THBASE,THKMIN
      REAL*4       RK(99),SK(99),TK(99),PK(99)
      INTEGER      IRF(99),IRL(99),JRF(99),JRL(99),NRIVER
C
C     I/O VARIABLES.
C
      CHARACTER PREAMBL(5)*79,CLINE*80
      REAL*4    HMINA,HMINB,HMAXA,HMAXB
C
C     OUTPUT ARRAYS
C
      REAL*4,  ALLOCATABLE :: PMIX(:,:),PM(:,:),TM(:,:),SM(:,:),RM(:,:)
C
C     OTHER ARRAYS.
C
      INTEGER, ALLOCATABLE :: MSK(:,:)
      REAL*4,  ALLOCATABLE :: DEPTH(:,:),PLAT(:,:),
     +                        PKM1(:,:),RKM1(:,:),PKM2(:,:),WORK(:,:)
C
C**********
C*
C 1)  CREATE A "CLIMATOLOGY", BASED ON FLAT CONSTANT LAYERS,
C      SUITABLE FOR INPUT TO HYCOM.  ADD RIVERS (S=0) ALONG
C      SELECTED LINE SEGMENTS.
C
C      ONLY FOR USE WITH HYCOM 2.0.00 OR LATER.
C
C 2)  PARAMETERS:
C
C     MODEL GRID SPECIFICATION (W.R.T. PRESSURE GRID):
C
C        IDM    = 1ST DIMENSION OF MAJOR (HYCOM) MODEL ARRAYS
C        JDM    = 2ND DIMENSION OF MAJOR (HYCOM) MODEL ARRAYS
C
C 3)  INPUT:
C        ON UNIT 51:  BATHYMETRY FILE
C        ON UNIT 51A: BATHYMETRY FILE
C        ON UNIT 99:  A SUBSET OF blkdat.input FROM TARGET SIMULATION,
C                     FOLLOWED BY THE RIVER LOCATIONS,
C                     FOLLOWED BY THE REQUIRED PROFILE
C     OUTPUT:
C        ON UNIT 10:  TEMP. LAYER CLIM FILE
C        ON UNIT 10A: TEMP. LAYER CLIM FILE
C        ON UNIT 11:  SALN. LAYER CLIM FILE
C        ON UNIT 11A: SALN. LAYER CLIM FILE
C        ON UNIT 12:  INTF. LAYER CLIM FILE
C        ON UNIT 12A: INTF. LAYER CLIM FILE
C        ON UNIT 21:  DUMMY HYCOM ARCHIVE FILE
C        ON UNIT 21A: DUMMY HYCOM ARCHIVE FILE
C
C 4)  THE PROFILE IS INPUT LAYER BY LAYER.
C
C 5)  ALAN J. WALLCRAFT,  NAVAL RESEARCH LABORATORY, MARCH 2001.
C*
C**********
C
      REAL*4     ZERO,ONE,RADIAN
      PARAMETER (ZERO=0.0, ONE=1.0, RADIAN=57.2957795)
C
      INTEGER I,ITYPE,J,K,L
      REAL*4  TIME,PSUM,THIKMN,
     +        PAVE,XAVE,XMAX,XMIN,TMIN,SMIN,PMIN,ZJ,ZZ,Q,
     +        PINTEG,SIGMAA,SIGMAB,ZBOT,ZTOP
C
      REAL*4  SIG_V,SOFSIG_V,TOFSIG_V
C
      CALL XCSPMD  !defines idm,jdm
C
      ALLOCATE(    PMIX(IDM,JDM) )
      ALLOCATE(      PM(IDM,JDM) )
      ALLOCATE(      TM(IDM,JDM) )
      ALLOCATE(      SM(IDM,JDM) )
      ALLOCATE(      RM(IDM,JDM) )
      ALLOCATE(   DEPTH(IDM,JDM) )
      ALLOCATE(    PLAT(IDM,JDM) )
      ALLOCATE(    PKM1(IDM,JDM) )
      ALLOCATE(    RKM1(IDM,JDM) )
      ALLOCATE(    PKM2(IDM,JDM) )
      ALLOCATE(    WORK(IDM,JDM) )
      ALLOCATE(     MSK(IDM,JDM) )
C
C     BLKDAT INPUT.
C
      CALL ZHOPEN(99, 'FORMATTED', 'OLD', 0)
C
C --- 'ctitle' = climatology title
C
      WRITE(6,*)
      READ(99,'(A79)') CTITLE
      WRITE(6,'(A79)') CTITLE
C
C --- 'month'  = month (1 to 12)
C --- 'sigver' = version of the equation of state
C --- 'iversn' = hycom version number x10
C --- 'iexpt'  = experiment number x10
C --- 'yrflag' = days in year flag (0=360,1=366,2=366Jan1)
C --- 'idm   ' = longitudinal array size
C --- 'jdm   ' = latitudinal  array size
C --- 'itest ' = longitudinal test location
C --- 'jtest ' = latitudinal  test location
C --- 'kdm   ' = layer        array size
C
      WRITE(6,*)
      CALL BLKINI(MONTH, 'month ')
      CALL BLKINI(SIGVER,'sigver')
      WRITE(6,*)
      CALL BLKINI(IVERSN,'iversn')
      CALL BLKINI(IEXPT, 'iexpt ')
      CALL BLKINI(YRFLAG,'yrflag')
      WRITE(6,*)
      CALL BLKINI(I,     'idm   ')
      CALL BLKINI(J,     'jdm   ')
      CALL BLKINI(ITEST, 'itest ')
      CALL BLKINI(JTEST, 'jtest ')
      CALL BLKINI(KDM,   'kdm   ')
C
C --- 'thflag' = reference pressure flag (0=Sigma-0, 2=Sigma-2)
      WRITE(6,*)
      CALL BLKINI(THFLAG,'thflag')
      IF     (THFLAG.EQ.0) THEN
        WRITE(SIGFMT,'(A,I2,A)')
     &    '(a6," =",f10.4," sigma-0 (sigver=',SIGVER,')")'
        IF     (MOD(SIGVER,2).NE.1 .OR. SIGVER.GE.40) THEN
          WRITE(6,*)
          WRITE(6,*) 'ERROR - thflag=0 not compatible with sigver =',
     &               SIGVER
          WRITE(6,*)
          CALL ZHFLSH(6)
          STOP
        ENDIF
      ELSEIF (THFLAG.EQ.2) THEN
        WRITE(SIGFMT,'(A,I2,A)')
     &    '(a6," =",f10.4," sigma-2 (sigver=',SIGVER,')")'
        IF     (MOD(SIGVER,2).NE.0 .OR. SIGVER.GE.40) THEN
          WRITE(6,*)
          WRITE(6,*) 'ERROR - thflag=2 not compatible with sigver =',
     &               SIGVER
          WRITE(6,*)
          CALL ZHFLSH(6)
          STOP
        ENDIF
      ELSEIF (THFLAG.EQ.4) THEN
        WRITE(SIGFMT,'(A,I2,A)')
     &    '(a6," =",f10.4," sigma-4 (sigver=',SIGVER,')")'
        IF     (SIGVER.LT.40) THEN
          WRITE(6,*)
          WRITE(6,*) 'ERROR - thflag=4 not compatible with sigver =',
     &               SIGVER
          WRITE(6,*)
          CALL ZHFLSH(6)
          STOP
        ENDIF
      ELSE
        WRITE(6,*)
        WRITE(6,*) 'ERROR - thflag must be 0 or 2 or 4'
        WRITE(6,*)
        CALL ZHFLSH(6)
        STOP
      ENDIF
C
C --- 'thbase' = reference density (sigma units)
      WRITE(6,*)
      CALL BLKINR(THBASE,'thbase',SIGFMT)
      WRITE(6,*)
      DO K=1,KDM
C ---   'sigma ' = layer densities (sigma units)
        CALL BLKINR(SIGMA(K),'sigma ',SIGFMT)
      ENDDO
C
C --- 'thkmin' = minimum mixed-layer thickness (m)
      WRITE(6,*)
      CALL BLKINR(THKMIN,'thkmin','(a6," =",f10.4," m")')
      WRITE(6,*)
C
C     RIVER INPUT.
C
C --- 'nriver' = number of river sections
      WRITE(6,*)
      CALL BLKINI(NRIVER,'nriver')
      DO L= 1,NRIVER
C ---  'irf   ' first i-point in section
C ---  'irl   ' last  i-point in section
C ---  'jrf   ' first j-point in section
C ---  'jrl   ' last  j-point in section
        WRITE(6,*)
        CALL BLKINI(IRF(L),'irf   ')
        CALL BLKINI(IRL(L),'irl   ')
        CALL BLKINI(JRF(L),'jrf   ')
        CALL BLKINI(JRL(L),'jrl   ')
      ENDDO
C
C     PROFILE INPUT.
C
      DO K= 1,KDM
C ---  'p_sal ' profile layer salinity    in psu   (-99 to calculate)
C ---  'p_tem ' profile layer temperature in degC  (-99 to calculate)
C ---  'p_den ' profile layer density     in sigma (-99 to calculate)
C ---  'p_thk ' profile layer thickness   in m
        CALL BLKINR(SK(K),'p_sal ','(a6," =",f10.4," psu")')
        CALL BLKINR(TK(K),'p_tem ','(a6," =",f10.4," degC")')
        CALL BLKINR(RK(K),'p_den ',SIGFMT)
        CALL BLKINR(PK(K),'p_thk ','(a6," =",f10.4," m")')
        WRITE(6,*)
C
        ITYPE = 0
        IF     (SK(K).LT.-98.0) THEN
          ITYPE = ITYPE + 1
        ENDIF
        IF     (TK(K).LT.-98.0) THEN
          ITYPE = ITYPE + 2
        ENDIF
        IF     (RK(K).LT.-98.0) THEN
          ITYPE = ITYPE + 4
        ENDIF
        IF     (ITYPE.NE.1 .AND. ITYPE.NE.2 .AND.ITYPE.NE.4) THEN
          WRITE(6,'(/a/)')
     +      'ERROR - exactly one of p_sal,p_tem,p_den must be -99'
          CALL ZHFLSH(6)
          STOP
        ENDIF
C
        IF     (ITYPE.EQ.1) THEN
          SK(K) = SOFSIG_V( RK(K),TK(K),SIGVER )
        ELSEIF (ITYPE.EQ.2) THEN
          TK(K) = TOFSIG_V( RK(K),SK(K),SIGVER )
        ELSE
          RK(K) =    SIG_V( TK(K),SK(K),SIGVER )
        ENDIF
      ENDDO
C
      CLOSE(UNIT=99)
C
      IF     (I.NE.IDM) THEN
        WRITE(6,*)
        WRITE(6,*) 'ERROR - wrong IDM'
        WRITE(6,*)
        CALL ZHFLSH(6)
        STOP
      ELSEIF (J.NE.JDM) THEN
        WRITE(6,*)
        WRITE(6,*) 'ERROR - wrong JDM'
        WRITE(6,*)
        CALL ZHFLSH(6)
        STOP
      ENDIF
C
C     TOPOGRAPHY INPUT.
C
      CALL ZAIOST
C
      CALL ZHOPEN(51, 'FORMATTED', 'OLD', 0)
      READ (51,'(A79)') PREAMBL
      READ (51,'(A)')   CLINE
      CLOSE(UNIT=51)
      WRITE(6,'(/(1X,A79))') PREAMBL,CLINE
C
      I = INDEX(CLINE,'=')
      READ (CLINE(I+1:),*)   HMINB,HMAXB
C
      CALL ZAIOPN('OLD', 51)
      CALL ZAIORD(DEPTH,MSK,.FALSE., HMINA,HMAXA, 51)
      CALL ZAIOCL(51)
C
      IF     (ABS(HMINA-HMINB).GT.ABS(HMINB)*1.E-4 .OR.
     &        ABS(HMAXA-HMAXB).GT.ABS(HMAXB)*1.E-4     ) THEN
        WRITE(6,'(/ a / a,1p3e14.6 / a,1p3e14.6 /)')
     &    'error - .a and .b topography files not consistent:',
     &    '.a,.b min = ',HMINA,HMINB,HMINA-HMINB,
     &    '.a,.b max = ',HMAXA,HMAXB,HMAXA-HMAXB
        CALL ZHFLSH(6)
        STOP
      ENDIF
C
C     INITIALIZE LAND MASK.
C
      DO J= 1,JDM
        DO I= 1,IDM
          IF     (DEPTH(I,J).LT.2.0**99) THEN
            MSK(  I,J) = 1
          ELSE
            MSK(  I,J) = 0
            DEPTH(I,J) = ZERO
          ENDIF
        ENDDO
      ENDDO
C
C     LATITUDE GRID INPUT.
C
      CALL ZHOPNC(31, 'regional.grid.b', 'FORMATTED', 'OLD', 0)
      CALL ZAIOPF('regional.grid.a', 'OLD', 31)
C
      READ(31,*) ! skip idm
      READ(31,*) ! skip jdm
      READ(31,*) ! skip mapflg
      READ(31,*) ! skip plon
      CALL ZAIOSK(31)
      READ(31,'(A)') CLINE
      I = INDEX(CLINE,'=')
      READ (CLINE(I+1:),*)   HMINB,HMAXB
      CALL ZAIORD(PLAT,MSK,.FALSE., HMINA,HMAXA, 31)
      IF     (ABS(HMINA-HMINB).GT.ABS(HMINB)*1.E-4 .OR.
     &        ABS(HMAXA-HMAXB).GT.ABS(HMAXB)*1.E-4     ) THEN
        WRITE(6,'(/ a / a,1p3e14.6 / a,1p3e14.6 /)')
     &    'error - .a and .b grid files not consistent (plat):',
     &    '.a,.b min = ',HMINA,HMINB,HMINA-HMINB,
     &    '.a,.b max = ',HMAXA,HMAXB,HMAXA-HMAXB
        CALL ZHFLSH(6)
        STOP
      ENDIF
C
C     INITIALIZE CLIMATOLOGY OUTPUT.
C
      CALL ZAIOPN('NEW', 10)
      CALL ZAIOPN('NEW', 11)
      CALL ZAIOPN('NEW', 12)
C
      CALL ZHOPEN(10, 'FORMATTED', 'NEW', 0)
      CALL ZHOPEN(11, 'FORMATTED', 'NEW', 0)
      CALL ZHOPEN(12, 'FORMATTED', 'NEW', 0)
C
      PREAMBL(1) = CTITLE
C
      WRITE(PREAMBL(2),4000) IEXPT/10,MOD(IEXPT,10)
C
      IF     (THFLAG.EQ.0) THEN
        PREAMBL(3) = 'Constant layers w.r.t. Sigma-0'
      ELSEIF (THFLAG.EQ.2) THEN
        PREAMBL(3) = 'Constant layers w.r.t. Sigma-2'
      ENDIF
C
      WRITE(PREAMBL(5),'(A,2I5,I3,F9.3,F9.2,2F6.3)')
     +        'i/jdm =',
     +       IDM,JDM
C
      PREAMBL(4) = 'Potential Temperature'
      WRITE(10,4101) PREAMBL
C
      PREAMBL(4) = 'Salinity'
      WRITE(11,4101) PREAMBL
C
      PREAMBL(4) = 'Interface Depths'
      WRITE(12,4101) PREAMBL
C
      WRITE(6,*)
      PREAMBL(4) = 'Potential Temperature, or ' //
     +             'Salinity, or ' //
     +             'Interface Depths'
      WRITE(6, 4101) PREAMBL
      WRITE(6,*)
C
C     INITIALIZE DUMMY ARCHIVE OUTPUT.
C
      CALL ZAIOPN('NEW', 21)
      CALL ZHOPEN(21, 'FORMATTED', 'NEW', 0)
      YRFLAG = MAX(0,MIN(2,YRFLAG))
      WRITE(21,4200) MONTH,PREAMBL(1),PREAMBL(2),
     &               IVERSN,IEXPT,YRFLAG,IDM,JDM

      IF     (YRFLAG.EQ.0) THEN  ! 360 days, starting Jan 16
        TIME = (MONTH-1)*30.0
      ELSEIF (YRFLAG.EQ.1) THEN  ! 366 days, starting Jan 16
        TIME = (MONTH-1)*30.5
      ELSEIF (YRFLAG.EQ.2) THEN  ! 366 days, starting Jan 1
        TIME = (MONTH-1)*30.5 + 15.0
      ENDIF
C
C     FIRST INTERFACE IS AT SURFACE.
C     MIXED LAYER AVERAGE TEMPERATURE IS NOMINALLY SST-0.25 DEG.
C     THIS IS EQUIVALENT TO A 0.5 DEG CHANGE ACROSS THE MIXED
C     LAYER, WHICH IS LARGER THAN TYPICALLY USED FOR ACTUAL
C     PROFILES BECAUSE THIS IS A SMOOTH CLIMATOLOGICAL PROFILE.
C
      DO J= 1,JDM
        DO I= 1,IDM
          IF     (DEPTH(I,J).GT.ZERO) THEN
            PKM2(I,J) = ZERO
            PKM1(I,J) = ZERO
            TM(  I,J) = TK(1)-0.25
            SM(  I,J) = SK(1)
            SIGMAA    = SIG_V( TK(1)-0.5,SK(1),SIGVER )
            PMIX(I,J) = 400.0
            DO K= 2,KDM
              IF     (RK(K).GE.SIGMAA) THEN
                SIGMAB = RK(K)-RK(K-1)
                IF     (SIGMAB.GT.1.E-4) THEN
                  Q = (RK(K)-SIGMAA)/SIGMAB
                  PMIX(I,J) = PK(K-1) + (1.0-Q)*(PK(K)-PK(K-1))
                ELSE
                  PMIX(I,J) = PK(K)
                ENDIF
                EXIT
              ENDIF
              IF     (PK(K).GE.400.0) THEN
                EXIT
              ENDIF
            ENDDO
            PMIX(I,J) = MAX( THKMIN, MIN( PMIX(I,J), DEPTH(I,J) ) )
          ELSE
            PKM2(I,J) = ZERO
            PKM1(I,J) = ZERO
            PMIX(I,J) = THKMIN
            TM(  I,J) = ZERO
            SM(  I,J) = ZERO
            RM(  I,J) = ZERO
C
            PM(  I,J) = ZERO
C
            DEPTH(I,J) = ZERO  ! should already be zero
          ENDIF
        ENDDO
      ENDDO
C
      DO L= 1,NRIVER
        DO J= JRF(L),JRL(L)
          DO I= IRF(L),IRL(L)
            IF     (DEPTH(I,J).GT.ZERO) THEN
              SM(I,J) = 0.0  !river
            ENDIF
          ENDDO !I
        ENDDO !J
      ENDDO !L
C
C     PUT "SURFACE" FIELDS IN THE THE DUMMY ARCHIVE.
C
      DO J= 1,JDM
        DO I= 1,IDM
          WORK(I,J) = ZERO
        ENDDO
      ENDDO
      CALL ZAIOWR(WORK,MSK,.TRUE.,  XMIN,XMAX, 21, .FALSE.)
      WRITE(21,4201) 'montg1  ',MONTH,TIME,0,ZERO,XMIN,XMAX
      CALL ZAIOWR(WORK,MSK,.TRUE.,  XMIN,XMAX, 21, .FALSE.)
      WRITE(21,4201) 'srfhgt  ',MONTH,TIME,0,ZERO,XMIN,XMAX
      CALL ZAIOWR(WORK,MSK,.TRUE.,  XMIN,XMAX, 21, .FALSE.)
      WRITE(21,4201) 'surflx  ',MONTH,TIME,0,ZERO,XMIN,XMAX
      CALL ZAIOWR(WORK,MSK,.TRUE.,  XMIN,XMAX, 21, .FALSE.)
      WRITE(21,4201) 'salflx  ',MONTH,TIME,0,ZERO,XMIN,XMAX
C
      DO J= 1,JDM
        DO I= 1,IDM
          IF     (DEPTH(I,J).GT.ZERO) THEN
            WORK(I,J) = PMIX(I,J)*9806.0
          ENDIF
        ENDDO
      ENDDO
      CALL ZAIOWR(WORK,MSK,.TRUE.,  XMIN,XMAX, 21, .FALSE.)
      WRITE(21,4201) 'bl_dpth ',MONTH,TIME,0,ZERO,XMIN,XMAX
      CALL ZAIOWR(WORK,MSK,.TRUE.,  XMIN,XMAX, 21, .FALSE.)
      WRITE(21,4201) 'mix_dpth',MONTH,TIME,0,ZERO,XMIN,XMAX
      DO J= 1,JDM
        DO I= 1,IDM
          IF     (DEPTH(I,J).GT.ZERO) THEN
            TM(  I,J) = TK(1)-0.25
            SM(  I,J) = SK(1)
            WORK(I,J) = SIG_V( TM(  I,J),SM(  I,J),SIGVER ) - THBASE
          ELSE
            TM(  I,J) = ZERO
            SM(  I,J) = ZERO
            WORK(I,J) = ZERO
          ENDIF
        ENDDO
      ENDDO
      DO L= 1,NRIVER
        DO J= JRF(L),JRL(L)
          DO I= IRF(L),IRL(L)
            IF     (DEPTH(I,J).GT.ZERO) THEN
              SM(  I,J) = 0.0  !river
              WORK(I,J) = SIG_V( TM(  I,J),SM(  I,J),SIGVER ) - THBASE
            ENDIF
          ENDDO !I
        ENDDO !J
      ENDDO !L
      CALL ZAIOWR(TM,  MSK,.TRUE.,  XMIN,XMAX, 21, .FALSE.)
      WRITE(21,4201) 'tmix    ',MONTH,TIME,0,ZERO,XMIN,XMAX
      CALL ZAIOWR(SM,  MSK,.TRUE.,  XMIN,XMAX, 21, .FALSE.)
      WRITE(21,4201) 'smix    ',MONTH,TIME,0,ZERO,XMIN,XMAX
      CALL ZAIOWR(WORK,MSK,.TRUE.,  XMIN,XMAX, 21, .FALSE.)
      WRITE(21,4201) 'thmix   ',MONTH,TIME,0,ZERO,XMIN,XMAX
C
      DO J= 1,JDM
        DO I= 1,IDM
          WORK(I,J) = ZERO
        ENDDO
      ENDDO
      CALL ZAIOWR(WORK,MSK,.FALSE., XMIN,XMAX, 21, .FALSE.)
      WRITE(21,4201) 'umix    ',MONTH,TIME,0,ZERO,XMIN,XMAX
      CALL ZAIOWR(WORK,MSK,.FALSE., XMIN,XMAX, 21, .FALSE.)
      WRITE(21,4201) 'vmix    ',MONTH,TIME,0,ZERO,XMIN,XMAX
      CALL ZAIOWR(WORK,MSK,.FALSE., XMIN,XMAX, 21, .FALSE.)
      WRITE(21,4201) 'u_btrop ',MONTH,TIME,0,ZERO,XMIN,XMAX
      CALL ZAIOWR(WORK,MSK,.FALSE., XMIN,XMAX, 21, .FALSE.)
      WRITE(21,4201) 'v_btrop ',MONTH,TIME,0,ZERO,XMIN,XMAX
C
C     PROCESS ALL THE LAYERS.
C
      DO J= 1,JDM
        DO I= 1,IDM
          IF     (DEPTH(I,J).GT.ZERO) THEN
            RKM1(I,J) = ZERO
            PKM1(I,J) = ZERO
            PKM2(I,J) = ZERO
          ENDIF
        ENDDO
      ENDDO
      PSUM = 0.0
      DO 810 K= 1,KDM
        PSUM = PSUM + PK(K)
        DO J= 1,JDM
          DO I= 1,IDM
            IF     (DEPTH(I,J).GT.ZERO) THEN
              RM(I,J) = RK(K)
              TM(I,J) = TK(K)
              SM(I,J) = SK(K)
              IF     (K.NE.KDM) THEN
                PM(I,J) = MIN( DEPTH(I,J), PSUM )
              ELSE
                PM(I,J) =      DEPTH(I,J)
              ENDIF
            ENDIF  !DEPTH>0
          ENDDO  !J=1,JDM
        ENDDO  !I=1,IDM
        DO L= 1,NRIVER
          DO J= JRF(L),JRL(L)
            DO I= IRF(L),IRL(L)
              IF     (DEPTH(I,J).GT.ZERO) THEN
                SM(I,J) = 0.0  !river
                RM(I,J) = SIG_V( TM(I,J),SM(I,J),SIGVER )
              ENDIF
            ENDDO !I
          ENDDO !J
        ENDDO !L
C
C       STATISTICS
C
        DO J= 1,JDM
          DO I= 1,IDM
            IF     (DEPTH(I,J).LE.ZERO) THEN
              RM(I,J) = SIGMA(K)
            ENDIF
            WORK(I,J) = PM(I,J) - PKM1(I,J)
          ENDDO
        ENDDO
        CALL LAYSTAT(TM, DEPTH,IDM,JDM, TMIN,XAVE,XMAX)
        WRITE(6,8100) ' tem', TMIN,XAVE,XMAX
        CALL LAYSTAT(SM, DEPTH,IDM,JDM, SMIN,XAVE,XMAX)
        WRITE(6,8100) ' sal', SMIN,XAVE,XMAX
        CALL LAYSTAT(RM, DEPTH,IDM,JDM, XMIN,XAVE,XMAX)
        WRITE(6,8100) ' den', XMIN,XAVE,XMAX
        CALL LAYSTAT(PKM1,DEPTH,IDM,JDM, PMIN,XAVE,XMAX)
        WRITE(6,8100) ' inf', PMIN,XAVE,XMAX
        CALL LAYSTAT(WORK,DEPTH,IDM,JDM, XMIN,XAVE,XMAX)
        WRITE(6,8100) ' thk', XMIN,XAVE,XMAX
C
C       DIAGNOSTIC PRINTOUT.
C
        IF     (MIN(ITEST,JTEST).GT.0) THEN
          WRITE(6,*)
          WRITE(6,'(A,2I5,I3,A,F9.2,F8.2,A,3F7.3)')
     +     'I,J,K =',ITEST,JTEST,K,
     +     '   INF,THK =',PKM1(ITEST,JTEST),
     +                    WORK(ITEST,JTEST),
     +     '   R,T,S =',    RM(ITEST,JTEST),
     +                      TM(ITEST,JTEST),
     +                      SM(ITEST,JTEST)
          WRITE(6,*)
          CALL ZHFLSH(6)
        ENDIF
C
C       WRITE OUT CLIMS.
C
        CALL ZAIOWR(TM,MSK,.TRUE., XMIN,XMAX, 10, .FALSE.)
        WRITE(10,4102) ' tem',MONTH,K,SIGMA(K),XMIN,XMAX
C
        CALL ZAIOWR(SM,MSK,.TRUE., XMIN,XMAX, 11, .FALSE.)
        WRITE(11,4102) ' sal',MONTH,K,SIGMA(K),XMIN,XMAX
C
C       ONEM IN HYCOM MKS PRESSURE UNITS IS 9806.
C
        DO J= 1,JDM
          DO I= 1,IDM
            IF     (DEPTH(I,J).GT.ZERO) THEN
              WORK(I,J) = PKM1(I,J)*9806.0
            ENDIF
          ENDDO
        ENDDO
        CALL ZAIOWR(WORK,MSK,.TRUE., XMIN,XMAX, 12, .FALSE.)
        WRITE(12,4102) ' int',MONTH,K,SIGMA(K),XMIN,XMAX
C
C       WRITE OUT DUMMY ARCHIVE.
C
        DO J= 1,JDM
          DO I= 1,IDM
            WORK(I,J) = ZERO
          ENDDO
        ENDDO
        CALL ZAIOWR(WORK,MSK,.FALSE., XMIN,XMAX, 21, .FALSE.)
        WRITE(21,4201) 'u-vel.  ',MONTH,TIME,K,SIGMA(K),XMIN,XMAX
        CALL ZAIOWR(WORK,MSK,.FALSE., XMIN,XMAX, 21, .FALSE.)
        WRITE(21,4201) 'v-vel.  ',MONTH,TIME,K,SIGMA(K),XMIN,XMAX
        DO J= 1,JDM
          DO I= 1,IDM
            WORK(I,J) = (PM(I,J) - PKM1(I,J))*9806.0
          ENDDO
        ENDDO
        CALL ZAIOWR(WORK,MSK,.TRUE.,  XMIN,XMAX, 21, .FALSE.)
        WRITE(21,4201) 'thknss  ',MONTH,TIME,K,SIGMA(K),XMIN,XMAX
        CALL ZAIOWR(TM,  MSK,.TRUE.,  XMIN,XMAX, 21, .FALSE.)
        WRITE(21,4201) 'temp    ',MONTH,TIME,K,SIGMA(K),XMIN,XMAX
        CALL ZAIOWR(SM,  MSK,.TRUE.,  XMIN,XMAX, 21, .FALSE.)
        WRITE(21,4201) 'salin   ',MONTH,TIME,K,SIGMA(K),XMIN,XMAX
        DO J= 1,JDM
          DO I= 1,IDM
            WORK(I,J) = RM(I,J) - THBASE
          ENDDO
        ENDDO
        CALL ZAIOWR(WORK,MSK,.TRUE.,  XMIN,XMAX, 21, .FALSE.)
        WRITE(21,4201) 'density ',MONTH,TIME,K,SIGMA(K),XMIN,XMAX
C
        WRITE(6,6300) K,SIGMA(K)
        CALL ZHFLSH(6)
C
C       PREPARE FOR NEXT K-LOOP
C
        DO J= 1,JDM
          DO I= 1,IDM
            IF     (DEPTH(I,J).GT.ZERO) THEN
              PKM2(I,J) = PKM1(I,J)
              PKM1(I,J) = PM(  I,J)
              RKM1(I,J) = RM(  I,J)
            ENDIF
          ENDDO
        ENDDO
C
 810  CONTINUE  !K=1,KDM
      STOP
C
 4000 FORMAT('Expt ',I2.2,'.',I1.1)
 4101 FORMAT(A79)
 4102 FORMAT(A,': month,layer,dens,range = ',I2.2,I4.2,F7.3,1P2E16.7)
 4200 FORMAT(
     + 'Dummy HYCOM archive from climatology for month ',I2.2,'.' /
     + A80/A80/
     + '1234567890123456789012345678901234567890',
     + '1234567890123456789012345678901234567890'/
     & I5,4X,'''iversn'' = hycom version number x10'/
     & I5,4X,'''iexpt '' = experiment number x10'/
     & I5,4x,'''yrflag'' = days in year flag'/
     & I5,4x,'''idm   '' = longitudinal array size'/
     & I5,4x,'''jdm   '' = latitudinal  array size'/
     & 'field       time step  model day',
     & '  k  dens        min              max')
 4201 FORMAT(a8,' =',i11,f11.2,i3,f7.3,1p2e16.7)
 5000 FORMAT(A40)
 5500 FORMAT(6E13.6)
 6200 FORMAT(/ 1X,'MIN,MAX I COORDS = ',F8.2,',',F8.2
     +       / 1X,'MIN,MAX J COORDS = ',F8.2,',',F8.2 /)
 6300 FORMAT(10X,'WRITING CLIM LAYER',I3,'     SIGMA =',F7.3 /)
 8100 FORMAT(1X,A,': min=',F9.2,' ave=',F9.2,' max=',F9.2)
 8200 FORMAT(' k =',I3.2,' j = ',I4.4,' to ',I4.4,
     +       ' sig =',F7.3,' lat =',F6.1,' inf =',F8.2)
C     END OF PROGRAM WNDINT.
      END
      SUBROUTINE LAYSTAT(PM, DEPTH, IDM,JDM, PMIN,PAVE,PMAX)
      IMPLICIT NONE
C
      INTEGER IDM,JDM
      REAL*4  PM(IDM,JDM),DEPTH(IDM,JDM), PMIN,PAVE,PMAX
C
C --- CALCULATE STATISTICS FOR PM.
C --- AVERAGE DOES NOT ALLOW FOR VARIATION IN GRID CELL SIZE.
C
      REAL*4     ZERO
      PARAMETER (ZERO=0.0)
C
      INTEGER I,J,IJSUM
      REAL*4  PPMIN,PPMAX
      REAL*8  PPSUM
C
      PPMIN =  1.E10
      PPMAX = -1.E10
      IJSUM =  0
      PPSUM =  0.0D0
      DO J= 1,JDM
        DO I= 1,IDM
          IF     (DEPTH(I,J).GT.ZERO) THEN
            PPMIN = MIN( PPMIN, PM(I,J) )
            PPMAX = MAX( PPMAX, PM(I,J) )
            IJSUM = IJSUM + 1
            PPSUM = PPSUM + PM(I,J)
          ENDIF
        ENDDO
      ENDDO
      IF     (IJSUM.NE.0) THEN
        PMIN = PPMIN
        PMAX = PPMAX
        PAVE = PPSUM / IJSUM
      ELSE
        PMIN = 99.9
        PMAX = 99.9
        PAVE = 99.9
      ENDIF
      RETURN
C     END OF LAYSTAT.
      END
      REAL*4 FUNCTION SIG_V(TT,SS,SIGVER)
      IMPLICIT NONE
      INTEGER SIGVER
      REAL*4  TT,SS
C
C     SIGVER WRAPPER FOR SIG
C
      REAL*8 SS8,TT8
      REAL*8 SIG_1,SIG_2,SIG_3,SIG_4,SIG_5,SIG_6,SIG_7,SIG_8,
     &       SIG_46,SIG_48
C
      TT8 = TT
      SS8 = SS
      IF     (SIGVER.GT.40) THEN
        IF     (SIGVER.EQ.46) THEN
          SIG_V = SIG_46(TT8,SS8)
        ELSEIF (SIGVER.EQ.48) THEN
          SIG_V = SIG_48(TT8,SS8)
        ENDIF
      ELSEIF (MOD(SIGVER,2).EQ.1) THEN
        IF     (SIGVER.EQ.1) THEN
          SIG_V = SIG_1(TT8,SS8)
        ELSEIF (SIGVER.EQ.3) THEN
          SIG_V = SIG_3(TT8,SS8)
        ELSEIF (SIGVER.EQ.5) THEN
          SIG_V = SIG_5(TT8,SS8)
        ELSEIF (SIGVER.EQ.7) THEN
          SIG_V = SIG_7(TT8,SS8)
        ENDIF
      ELSE
        IF     (SIGVER.EQ.2) THEN
          SIG_V = SIG_2(TT8,SS8)
        ELSEIF (SIGVER.EQ.4) THEN
          SIG_V = SIG_4(TT8,SS8)
        ELSEIF (SIGVER.EQ.6) THEN
          SIG_V = SIG_6(TT8,SS8)
        ELSEIF (SIGVER.EQ.8) THEN
          SIG_V = SIG_8(TT8,SS8)
        ENDIF
      ENDIF
      RETURN
      END
      REAL*4 FUNCTION SOFSIG_V(RR,TT,SIGVER)
      IMPLICIT NONE
      INTEGER SIGVER
      REAL*4  RR,TT
C
C     SIGVER WRAPPER FOR SOFSIG
C
      REAL*8 RR8,TT8
      REAL*8 SOFSIG_1,SOFSIG_2,SOFSIG_3,SOFSIG_4,
     &       SOFSIG_5,SOFSIG_6,SOFSIG_7,SOFSIG_8,
     &       SOFSIG_46,SOFSIG_48
C
      RR8 = RR
      TT8 = TT
      IF     (SIGVER.GT.40) THEN
        IF     (SIGVER.EQ.46) THEN
          SOFSIG_V = SOFSIG_46(RR8,TT8)
        ELSEIF (SIGVER.EQ.48) THEN
          SOFSIG_V = SOFSIG_48(RR8,TT8)
        ENDIF
      ELSEIF (MOD(SIGVER,2).EQ.1) THEN
        IF     (SIGVER.EQ.1) THEN
          SOFSIG_V = SOFSIG_1(RR8,TT8)
        ELSEIF (SIGVER.EQ.3) THEN
          SOFSIG_V = SOFSIG_3(RR8,TT8)
        ELSEIF (SIGVER.EQ.5) THEN
          SOFSIG_V = SOFSIG_5(RR8,TT8)
        ELSEIF (SIGVER.EQ.7) THEN
          SOFSIG_V = SOFSIG_7(RR8,TT8)
        ENDIF
      ELSE
        IF     (SIGVER.EQ.2) THEN
          SOFSIG_V = SOFSIG_2(RR8,TT8)
        ELSEIF (SIGVER.EQ.4) THEN
          SOFSIG_V = SOFSIG_4(RR8,TT8)
        ELSEIF (SIGVER.EQ.6) THEN
          SOFSIG_V = SOFSIG_6(RR8,TT8)
        ELSEIF (SIGVER.EQ.8) THEN
          SOFSIG_V = SOFSIG_8(RR8,TT8)
        ENDIF
      ENDIF
      RETURN
      END
      REAL*4 FUNCTION TOFSIG_V(RR,SS,SIGVER)
      IMPLICIT NONE
      INTEGER SIGVER
      REAL*4  RR,SS
C
C     SIGVER WRAPPER FOR TOFSIG
C
      REAL*8 RR8,SS8
      REAL*8 TOFSIG_1,TOFSIG_2,TOFSIG_3,TOFSIG_4,
     &       TOFSIG_5,TOFSIG_6,TOFSIG_7,TOFSIG_8,
     &       TOFSIG_46,TOFSIG_48
C
      RR8 = RR
      SS8 = SS
      IF     (SIGVER.GT.40) THEN
        IF     (SIGVER.EQ.46) THEN
          TOFSIG_V = TOFSIG_46(RR8,SS8)
        ELSEIF (SIGVER.EQ.48) THEN
          TOFSIG_V = TOFSIG_48(RR8,SS8)
        ENDIF
      ELSEIF (MOD(SIGVER,2).EQ.1) THEN
        IF     (SIGVER.EQ.1) THEN
          TOFSIG_V = TOFSIG_1(RR8,SS8)
        ELSEIF (SIGVER.EQ.3) THEN
          TOFSIG_V = TOFSIG_3(RR8,SS8)
        ELSEIF (SIGVER.EQ.5) THEN
          TOFSIG_V = TOFSIG_5(RR8,SS8)
        ELSEIF (SIGVER.EQ.7) THEN
          TOFSIG_V = TOFSIG_7(RR8,SS8)
        ENDIF
      ELSE
        IF     (SIGVER.EQ.2) THEN
          TOFSIG_V = TOFSIG_2(RR8,SS8)
        ELSEIF (SIGVER.EQ.4) THEN
          TOFSIG_V = TOFSIG_4(RR8,SS8)
        ELSEIF (SIGVER.EQ.6) THEN
          TOFSIG_V = TOFSIG_6(RR8,SS8)
        ELSEIF (SIGVER.EQ.8) THEN
          TOFSIG_V = TOFSIG_8(RR8,SS8)
        ENDIF
      ENDIF
      RETURN
      END
      REAL*8 FUNCTION SIG_1(TT8,SS8)
      IMPLICIT NONE
      REAL*8  TT8,SS8
      INCLUDE '../../include/stmt_fns_SIGMA0_7term.h'
      SIG_1 = SIG(TT8,SS8)
      END
      REAL*8 FUNCTION SOFSIG_1(RR8,TT8)
      IMPLICIT NONE
      REAL*8  RR8,TT8
      INCLUDE '../../include/stmt_fns_SIGMA0_7term.h'
      SOFSIG_1 = SOFSIG(RR8,TT8)
      END
      REAL*8 FUNCTION TOFSIG_1(RR8,SS8)
      IMPLICIT NONE
      REAL*8  RR8,SS8
      INCLUDE '../../include/stmt_fns_SIGMA0_7term.h'
      TOFSIG_1 = TOFSIG(RR8,SS8)
      END
      REAL*8 FUNCTION SIG_3(TT8,SS8)
      IMPLICIT NONE
      REAL*8  TT8,SS8
      INCLUDE '../../include/stmt_fns_SIGMA0_9term.h'
      SIG_3 = SIG(TT8,SS8)
      END
      REAL*8 FUNCTION SOFSIG_3(RR8,TT8)
      IMPLICIT NONE
      REAL*8  RR8,TT8
      INCLUDE '../../include/stmt_fns_SIGMA0_9term.h'
      SOFSIG_3 = SOFSIG(RR8,TT8)
      END
      REAL*8 FUNCTION TOFSIG_3(RR8,SS8)
      IMPLICIT NONE
      REAL*8  RR8,SS8
      INCLUDE '../../include/stmt_fns_SIGMA0_9term.h'
      TOFSIG_3 = TOFSIG(RR8,SS8)
      END
      REAL*8 FUNCTION SIG_5(TT8,SS8)
      IMPLICIT NONE
      REAL*8  TT8,SS8
      INCLUDE '../../include/stmt_fns_SIGMA0_17term.h'
      SIG_5 = SIG(TT8,SS8)
      END
      REAL*8 FUNCTION SOFSIG_5(RR8,TT8)
      IMPLICIT NONE
      REAL*8  RR8,TT8
      REAL*8, PARAMETER :: TOL=1.D-6
      INTEGER NN
      REAL*8  SN,SO
      REAL*8  SOFSIG_7
      INCLUDE '../../include/stmt_fns_SIGMA0_17term.h'
C     sofsig via Newton iteration from a 12-term 1st guess
      SN = SOFSIG_7(RR8,TT8)  !non-negative
      DO NN= 1,10
        SO = SN
        SN = SO - (SIG(TT8,SO)-RR8)/DSIGDS(TT8,SO)
        IF     (NN.EQ.10 .OR. ABS(SN-SO).LT.TOL) THEN
          EXIT
        ENDIF
      ENDDO !nn
      SOFSIG_5 = SN
      END
      REAL*8 FUNCTION TOFSIG_5(RR8,SS8)
      IMPLICIT NONE
      REAL*8  RR8,SS8
      REAL*8, PARAMETER :: TOL=1.D-6
      INTEGER NN
      REAL*8  TN,TO
      REAL*8  TOFSIG_7
      INCLUDE '../../include/stmt_fns_SIGMA0_17term.h'
C     sofsig via Newton iteration from a 12-term 1st guess
      TN = TOFSIG_7(RR8,SS8)  !non-negative
      DO NN= 1,10
        TO = TN
        TN = TO - (SIG(TO,SS8)-RR8)/DSIGDT(TO,SS8)
        IF     (NN.EQ.10 .OR. ABS(TN-TO).LT.TOL) THEN
          EXIT
        ENDIF
      ENDDO !nn
      TOFSIG_5 = TN
      END
      REAL*8 FUNCTION SIG_7(TT8,SS8)
      IMPLICIT NONE
      REAL*8  TT8,SS8
      INCLUDE '../../include/stmt_fns_SIGMA0_12term.h'
      SIG_7 = SIG(TT8,SS8)
      END
      REAL*8 FUNCTION SOFSIG_7(RR8,TT8)
      IMPLICIT NONE
      REAL*8  RR8,TT8
      INCLUDE '../../include/stmt_fns_SIGMA0_12term.h'
      SOFSIG_7 = SOFSIG(RR8,TT8)
      END
      REAL*8 FUNCTION TOFSIG_7(RR8,SS8)
      IMPLICIT NONE
      REAL*8  RR8,SS8
      INCLUDE '../../include/stmt_fns_SIGMA0_12term.h'
      TOFSIG_7 = TOFSIG(RR8,SS8)
      END
      REAL*8 FUNCTION SIG_2(TT8,SS8)
      IMPLICIT NONE
      REAL*8  TT8,SS8
      INCLUDE '../../include/stmt_fns_SIGMA2_7term.h'
      SIG_2 = SIG(TT8,SS8)
      END
      REAL*8 FUNCTION SOFSIG_2(RR8,TT8)
      IMPLICIT NONE
      REAL*8  RR8,TT8
      INCLUDE '../../include/stmt_fns_SIGMA2_7term.h'
      SOFSIG_2 = SOFSIG(RR8,TT8)
      END
      REAL*8 FUNCTION TOFSIG_2(RR8,SS8)
      IMPLICIT NONE
      REAL*8  RR8,SS8
      INCLUDE '../../include/stmt_fns_SIGMA2_7term.h'
      TOFSIG_2 = TOFSIG(RR8,SS8)
      END
      REAL*8 FUNCTION SIG_4(TT8,SS8)
      IMPLICIT NONE
      REAL*8  TT8,SS8
      INCLUDE '../../include/stmt_fns_SIGMA2_9term.h'
      SIG_4 = SIG(TT8,SS8)
      END
      REAL*8 FUNCTION SOFSIG_4(RR8,TT8)
      IMPLICIT NONE
      REAL*8  RR8,TT8
      INCLUDE '../../include/stmt_fns_SIGMA2_9term.h'
      SOFSIG_4 = SOFSIG(RR8,TT8)
      END
      REAL*8 FUNCTION TOFSIG_4(RR8,SS8)
      IMPLICIT NONE
      REAL*8  RR8,SS8
      INCLUDE '../../include/stmt_fns_SIGMA2_9term.h'
      TOFSIG_4 = TOFSIG(RR8,SS8)
      END
      REAL*8 FUNCTION SIG_6(TT8,SS8)
      IMPLICIT NONE
      REAL*8  TT8,SS8
      INCLUDE '../../include/stmt_fns_SIGMA2_17term.h'
      SIG_6 = SIG(TT8,SS8)
      END
      REAL*8 FUNCTION SOFSIG_6(RR8,TT8)
      IMPLICIT NONE
      REAL*8  RR8,TT8
      REAL*8, PARAMETER :: TOL=1.D-6
      INTEGER NN
      REAL*8  SN,SO
      REAL*8  SOFSIG_8
      INCLUDE '../../include/stmt_fns_SIGMA2_17term.h'
C     sofsig via Newton iteration from a 12-term 1st guess
      SN = SOFSIG_8(RR8,TT8)  !non-negative
      DO NN= 1,10
        SO = SN
        SN = SO - (SIG(TT8,SO)-RR8)/DSIGDS(TT8,SO)
        IF     (NN.EQ.10 .OR. ABS(SN-SO).LT.TOL) THEN
          EXIT
        ENDIF
      ENDDO !nn
      SOFSIG_6 = SN
      END
      REAL*8 FUNCTION TOFSIG_6(RR8,SS8)
      IMPLICIT NONE
      REAL*8  RR8,SS8
      REAL*8, PARAMETER :: TOL=1.D-6
      INTEGER NN
      REAL*8  TN,TO
      REAL*8  TOFSIG_8
      INCLUDE '../../include/stmt_fns_SIGMA2_17term.h'
C     sofsig via Newton iteration from a 12-term 1st guess
      TN = TOFSIG_8(RR8,SS8)  !non-negative
      DO NN= 1,10
        TO = TN
        TN = TO - (SIG(TO,SS8)-RR8)/DSIGDT(TO,SS8)
        IF     (NN.EQ.10 .OR. ABS(TN-TO).LT.TOL) THEN
          EXIT
        ENDIF
      ENDDO !nn
      TOFSIG_6 = TN
      END
      REAL*8 FUNCTION SIG_8(TT8,SS8)
      IMPLICIT NONE
      REAL*8  TT8,SS8
      INCLUDE '../../include/stmt_fns_SIGMA2_12term.h'
      SIG_8 = SIG(TT8,SS8)
      END
      REAL*8 FUNCTION SOFSIG_8(RR8,TT8)
      IMPLICIT NONE
      REAL*8  RR8,TT8
      INCLUDE '../../include/stmt_fns_SIGMA2_12term.h'
      SOFSIG_8 = SOFSIG(RR8,TT8)
      END
      REAL*8 FUNCTION TOFSIG_8(RR8,SS8)
      IMPLICIT NONE
      REAL*8  RR8,SS8
      INCLUDE '../../include/stmt_fns_SIGMA2_12term.h'
      TOFSIG_8 = TOFSIG(RR8,SS8)
      END
      REAL*8 FUNCTION SIG_46(TT8,SS8)
      IMPLICIT NONE
      REAL*8  TT8,SS8
      INCLUDE '../../include/stmt_fns_SIGMA4_17term.h'
      SIG_46 = SIG(TT8,SS8)
      END
      REAL*8 FUNCTION SOFSIG_46(RR8,TT8)
      IMPLICIT NONE
      REAL*8  RR8,TT8
      REAL*8, PARAMETER :: TOL=1.D-6
      INTEGER NN
      REAL*8  SN,SO
      REAL*8  SOFSIG_48
      INCLUDE '../../include/stmt_fns_SIGMA4_17term.h'
C     sofsig via Newton iteration from a 12-term 1st guess
      SN = SOFSIG_48(RR8,TT8)  !non-negative
      DO NN= 1,10
        SO = SN
        SN = SO - (SIG(TT8,SO)-RR8)/DSIGDS(TT8,SO)
        IF     (NN.EQ.10 .OR. ABS(SN-SO).LT.TOL) THEN
          EXIT
        ENDIF
      ENDDO !nn
      SOFSIG_46 = SN
      END
      REAL*8 FUNCTION TOFSIG_46(RR8,SS8)
      IMPLICIT NONE
      REAL*8  RR8,SS8
      REAL*8, PARAMETER :: TOL=1.D-6
      INTEGER NN
      REAL*8  TN,TO
      REAL*8  TOFSIG_48
      INCLUDE '../../include/stmt_fns_SIGMA4_17term.h'
C     sofsig via Newton iteration from a 12-term 1st guess
      TN = TOFSIG_48(RR8,SS8)  !non-negative
      DO NN= 1,10
        TO = TN
        TN = TO - (SIG(TO,SS8)-RR8)/DSIGDT(TO,SS8)
        IF     (NN.EQ.10 .OR. ABS(TN-TO).LT.TOL) THEN
          EXIT
        ENDIF
      ENDDO !nn
      TOFSIG_46 = TN
      END
      REAL*8 FUNCTION SIG_48(TT8,SS8)
      IMPLICIT NONE
      REAL*8  TT8,SS8
      INCLUDE '../../include/stmt_fns_SIGMA4_12term.h'
      SIG_48 = SIG(TT8,SS8)
      END
      REAL*8 FUNCTION SOFSIG_48(RR8,TT8)
      IMPLICIT NONE
      REAL*8  RR8,TT8
      INCLUDE '../../include/stmt_fns_SIGMA4_12term.h'
      SOFSIG_48 = SOFSIG(RR8,TT8)
      END
      REAL*8 FUNCTION TOFSIG_48(RR8,SS8)
      IMPLICIT NONE
      REAL*8  RR8,SS8
      INCLUDE '../../include/stmt_fns_SIGMA4_12term.h'
      TOFSIG_48 = TOFSIG(RR8,SS8)
      END


*-----------------------------------------------------------------------
*     R E A D W T
*-----------------------------------------------------------------------
*
*     This subroutine reads the J dependent weights of the configura-
*     tions. If the wavefunction expansion has been obtained from an
*     MCHF calculation, the weights are J independent and are read from
*     the file <name>.c . If the wavefunction expansion has been
*     obtained from a CI calculation, the weights are J dependent and
*     are read from the file <name>.j .NR is the ordernumber of the
*     main cfg component in the CI expansion
*     and determines where in the file the weights are read.
*     The weights are saved in an array WT(K,J) where K is the number of
*     the configurations in the expansion and J defines the J
*     quantumnumber.

      SUBROUTINE  READWT(MAXORB,IMCHF,NCFG,NR,JJMAX,JJMIN)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER CFGNR
      CHARACTER*80 LINE

      POINTER(QWT,WT(20,1))

      COMMON /NAN/ QWT
      COMMON/INFORM/IREADC,IWRITE,IOUT,IREADJ,IREADW,ISC(6),ISCW

*     J independent weights. Read from <name>.c

*     allocate memory

      call alloc(qwt,20*ncfg,8)

      MAX=JJMAX
      MIN=JJMIN

      IF (IMCHF.EQ.1) THEN
         REWIND(UNIT=IREADC)
         DO 5 K=1,3+((MAXORB-1)/20)
            READ(IREADC,*)
5        CONTINUE
         DO 10 K=1,NCFG
            READ(IREADC,100) WT(1,K)
            READ(IREADC,*)
10       CONTINUE
100      FORMAT(T65,F11.8)
cww100      FORMAT(T65,F10.7)
         RETURN
      ENDIF

*     Weights from CI calc. If IMCHF=2 read from <name>.l
*     else if IMCHF=3 read from <name>.j

      J=0
      READ(IREADJ,200) NNCFG
200   FORMAT(T40,I7)
Cww old ci format 200   FORMAT(T38,I4)
      IF (NNCFG.NE.NCFG) THEN
         WRITE(0,*) ' Unequal numer of cfg in <name>.c and <name>.j(l)'
         STOP
      ENDIF

*     Determine how many lines the array of weights occupy
*     and the number of weights on the last line.

      IF (MOD(NNCFG,7).EQ.0) THEN
         NRLINES=NNCFG/7
         NRLL=0
      ELSE
         NRLINES=NNCFG/7+1
         NRLL=MOD(NNCFG,7)
      ENDIF

*     Find the right array of weights in the file.
*     Firstly the right J quantum number should be found.

20    READ(IREADJ,*,end=888)
      READ(IREADJ,*,end=888)
      READ(IREADJ,300,end=888) JJ,NUMBER
300   FORMAT(T8,I6,T23,I4)

      IF (IMCHF.EQ.2) THEN
         MAX=0
         MIN=0
      ENDIF
      IF (JJ.GT.MAX) THEN
         DO 30 K=1,NUMBER*(NRLINES+2)
            READ(IREADJ,*)
30       CONTINUE
         GO TO 20
      ENDIF

      J=J+1
      N=0

*     Secondly the right configuration should be found.

      DO 40 I=1,NUMBER
      READ(IREADJ,*)
      READ(IREADJ,400) CFGNR
      IF (CFGNR.EQ.NR) THEN
         N=N+1
         DO 50 K=1,NNCFG/7
                  READ(IREADJ,500) (WT(J,L),L=7*(K-1)+1,7*K)
                  WRITE(*,*) (WT(J,L),L=7*(K-1)+1,7*K)
50       CONTINUE
         IF (NRLL.NE.0) THEN
                 READ(IREADJ,500) (WT(J,L),L=NNCFG-NRLL+1,NNCFG)
                 write(*,*) (WT(J,L),L=NNCFG-NRLL+1,NNCFG)
         ENDIF
      ELSE
         DO 60 K=1,NRLINES
            READ(IREADJ,*)
60       CONTINUE
      ENDIF
40    CONTINUE
400   FORMAT(I6)
500   FORMAT(7F11.8)
cww500   FORMAT(7F10.7)
6     FORMAT(A,I4,A)
      IF (N.EQ.0) THEN
         IF (IMCHF.EQ.2) THEN
         WRITE(0,*) 'There is no eigenvector in the file <name>.l that'
         WRITE(0,6) 'has cfg',NR,' as the dominating component.'
         WRITE(0,*) 'Change the number of the dominating component in'
         WRITE(0,*) 'the wanted eigenvector to the right one according'
         WRITE(0,*) 'to your identification and rerun the program.'
         STOP
         ELSE
         WRITE(0,6) 'There is no eigenvector with 2*J=',JJ,' in the'
        WRITE(0,6) 'file <name>.j that has cfg',NR,' as the dominating'
         WRITE(0,*) 'component. Change the number of the dominating'
         WRITE(0,*) 'component in the wanted eigenvector to the right'
         WRITE(0,*) 'one according to your identification and rerun'
         WRITE(0,*) 'the program.'
         STOP
         ENDIF
      ENDIF
      IF (N.GT.1) THEN
         IF (IMCHF.EQ.2) THEN
         WRITE(0,*) 'There is more than one eigenvector in the file'
         WRITE(0,6) '<name>.l that has cfg',NR,' as the dominating'
         WRITE(0,*) 'component. Discard the unwanted eigenvectors'
         WRITE(0,*) 'and change the digit giving the number of eigen-'
         WRITE(0,*) 'vectors to the right one and rerun the program.'
         STOP
         ELSE
         WRITE(0,6) 'There is more than one eigenvector with 2*J=',JJ
         WRITE(0,6) 'in the file <name>.j that has cfg',NR,' as'
         WRITE(0,*) 'the dominating component. Discard the unwanted'
         WRITE(0,*) 'eigenvectors and change the digit giving the'
         WRITE(0,*) 'number of eigenvectors to the right one and'
         WRITE(0,*) 'rerun the program.'
         STOP
         ENDIF
      ENDIF
      IF (JJ.EQ.MIN) THEN
         GO TO 999
      ENDIF
      GO TO 20
888   if(n.eq.0) then
        write(0,*) 'I have searched the .j file, and did not find'
        write(0,*) 'any Eigenvalue with ',nr,' as major component.'
        stop
      end if
999   RETURN
      END


module timedisc_evolve_mod

use constants_mod

# if DO_PROFILING
integer, save :: prof_rkstep
# endif

contains

subroutine hook_init_399

# if DO_PROFILING
    use profiler_mod, only: profiler_init
    prof_rkstep = profiler_init('rkstep')
# endif

end subroutine

subroutine hook_evolve_500

    use share_mod, only: mesh
    use share_mod, only: rt => runtime
    use mesh_utils_mod, only: mesh_iterate_quads

    use hook_pre_timestep_mod, only: hook_pre_timestep

    use hook_pre_rk_timestep_mod, only: hook_pre_rk_timestep
    use hook_mid_rk_timestep_mod, only: hook_mid_rk_timestep
    use hook_post_rk_timestep_mod, only: hook_post_rk_timestep

    use hook_post_timestep_mod, only: hook_post_timestep

    use mpi_f08, only: MPI_Allreduce, MPI_SUM, MPI_INTEGER
    use status_mod, only: raise_error

    use timedisc_const_mod, only: nstages
    use timedisc_const_mod, only: dt_coeffs

# if DO_PROFILING
    use profiler_mod, only: profiler_start, profiler_stop
# endif

    logical :: ok
    integer :: stage

    integer :: locstat,glostat !! local and global status code

    call hook_pre_timestep()

    do stage = 1,nstages
        rt%rkstage    = stage
        rt%rktimestep = rt%timestep * dt_coeffs(stage)
        rt%rksimtime  = rt%simtime  + rt%rktimestep

        call hook_pre_rk_timestep()
# if DO_PROFILING
        call profiler_start(prof_rkstep)
# endif
        call hook_mid_rk_timestep
# if DO_PROFILING
        call profiler_stop(prof_rkstep)
# endif
        call hook_post_rk_timestep

        ! call raise_error('Debugging.')

        if (rt%mpi%size > 1) then
            locstat = merge(0,1,rt%stat%ok)
            glostat = 0
            call MPI_Allreduce(locstat,glostat,1,MPI_INTEGER,MPI_SUM,rt%mpi%comm)

            if (glostat > 0) then
                if (rt%stat%ok) call raise_error('An error on another MPI rank occurred.')
                return
            end if
        else
            if (.not.rt%stat%ok) return
        end if
    end do

    call hook_post_timestep

end subroutine

end module


	SUBROUTINE GDMPLT  ( grid, kx, ky, ix1, iy1, ix2, iy2, ixinc,
     +			     istag, iyinc, color, positn, rmind, rmaxd,
     +			     iret )
C************************************************************************
C* GDMPLT								*
C*									*
C* This subroutine plots grid data for GDMAP.				*
C*									*
C* GDMPLT  ( GRID, KX, KY, IX1, IY1, IX2, IY2, IXINC, ISTAG, IYINC, 	*
C*	     COLOR, POSITN, RMIND, RMAXD, IRET )			*
C*									*
C* Input parameters:							*
C*	GRID (KX, KY)	REAL		Grid data			*
C*	KX		INTEGER		Number of points in x dir	*
C*	KY		INTEGER		Number of points in y dir	*
C*	IX1		INTEGER		First point in x dir		*
C*	IY1		INTEGER		First point in y dir		*
C*	IX2		INTEGER		Last point in x dir		*
C*	IY2		INTEGER		Last point in y dir		*
C*	IXINC		INTEGER		Increment in x dir		*
C*	ISTAG		INTEGER		Increment for stagger		*
C*	IYINC		INTEGER		Increment in y dir		*
C*	COLOR		CHAR*		Color				*
C*	POSITN	        CHAR*		Position number	   		*
C*	RMIND		REAL		Minimum valid value		*
C*	RMAXD		REAL		Maximum valid value		*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 4/85						*
C* G. Huffman/GSC	 1/89	Don't plot colors less than 1		*
C* M. desJardins/GSFC	 2/91	Added valid range			*
C* S. Jacobs/NMC	 9/94	Added staggered plotting		*
C* J. Wu/GSC            07/00   Moved INCLUDE 'ERMISS.FNC' before the   *
C*                              DATA statement                          *
C* R. Jones/NCEP         6/05	Added code to support temperature plots *
C*				for WAF charts				*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		grid ( kx, ky )
	CHARACTER*(*)	color, positn
C*
	CHARACTER	pstr*10, cpos(2)*12, ptype*12
C*
	INTEGER		iposx (9), iposy (9)
	INCLUDE		'ERMISS.FNC'
	DATA		iposx  / 0, -1, -1, 3, 3, -1,  3, 0,  0 /
	DATA		iposy  / 0,  2,  0, 2, 0, -2, -2, 4, -4 /
C*
C------------------------------------------------------------------------
	iret  = 0
C
C*	Set the color for the plot.
C
	CALL IN_COLR  ( color, 1, icolor, ier )
C
C*	Only plot data if color is positive.
C
	IF  ( icolor .gt. 0 )  THEN
	    CALL GSCOLR  ( icolor, ier )
C
C*	    Get the offsets for the position number.
C
	    CALL ST_CLST  ( positn, '/', ' ', 2, cpos, n, ier )
            CALL ST_NUMB ( cpos(1), ipos, ier )
	    CALL ST_LCUC ( cpos(2), ptype, ier )
C
	    IF  ( ( ipos .lt. 0 ) .or. ( ipos .gt. 8 ) )  ipos = 0
	    iyoff = iposy ( ipos + 1 )
	    ixoff = iposx ( ipos + 1 )
	    ix    = ixoff
C
C*	    Loop through the grid.
C
	    ixstrt = ix1
	    DO  j = iy1, iy2, iyinc
		fy = FLOAT (j)
C*
		DO  i = ixstrt, ix2, ixinc
		    fx = FLOAT (i)
		    d  = grid ( i, j )
		    IF  ( ( .not. ERMISS (d) ) .and.
     +			  ( d .ge. rmind ) .and. ( d .le. rmaxd ) )
     +								THEN
	                IF ( ptype .eq. 'WAFT' ) THEN
                            CALL WAFST ( d, pstr )
                        ELSE
		            id = NINT (d)
			    CALL ST_INCH  ( id, pstr, ier )
			END IF
			CALL ST_LSTR  ( pstr, len, ier )
			IF  ( ( ipos .eq. 0 ) .or. ( ipos .eq. 7 ) .or.
     +			      ( ipos .eq. 8 ) )  THEN
			    ix = ixoff - len + 1
			ELSE IF  ( (ipos.eq.1) .or. (ipos.eq.2) .or.
     +			   	   ( ipos.eq.5) )  THEN
			    ix = ixoff - 2 * len
			END IF
			CALL GTEXT  ( 'G', fx, fy, pstr, 0.0, ix, iyoff,
     +				      ier )
		    END IF
		END DO
		IF  ( ixstrt .eq. ix1 )  THEN
		    ixstrt = ixstrt + istag
		ELSE
		    ixstrt = ix1
		END IF
	    END DO
	END IF
C*
	RETURN
	END
C*=======================================================================
	SUBROUTINE WAFST ( val, pstr )
C************************************************************************
C*  WAFST								*
C*									*
C*  This subroutine produces a character string that reflects the WAF	*
C*  convention for plotting temperature values.				*
C*									*
C*  WAFST ( VAL, PSTR )							*
C*									*
C*  Input parameters:							*
C*	VAL		REAL		Value to be checked		*
C*									*
C*  Output parameters:							*
C*	PSTR		CHAR*		Value as a character		*
C**									*
C*  Log:								*
C*  R. Jones/NCEP	6/05	Original code				*
C************************************************************************
       CHARACTER 	pstr*10, tstr*10
C------------------------------------------------------------------------
C*	Test for sign of number
C
	kval = NINT ( ABS (val) )
	CALL ST_INCH ( kval, pstr, ier )
C
	IF  ( val .gt. 0.0 )  THEN
	    tstr = '+' // pstr
	    pstr = tstr
	END IF
C*
	RETURN
	END


      subroutine rzbrick_lg(imsgin,xmsgin,cmsgin,msgtype,nwds,ierr)
C#######################################################################
C
C     PURPOSE -
C
C
C     Wrapper ROUTINE to rzbrick3
C
C#######################################################################
      implicit none
      include 'chydro.h'
      integer ierr, nwds, imsgin(*),msgtype(*)
      real*8 xmsgin(*)
      character*(*) cmsgin(nwds)
      character*32 cmo,isubname
      integer ierror,npoints,ilen,ityp,ntets,ipointi,ipointj,
     *  icscode,npoints_save
C
C#######################################################################
      isubname='rzbrick3'
      ierr=0
c
      call cmo_get_name(cmo,ierror)
c
      call cmo_get_intinfo('nnodes',cmo,npoints,ilen,ityp,ierror)
      call cmo_get_intinfo('nelements',cmo,ntets,ilen,ityp,ierror)
      call cmo_get_intinfo('ipointi',cmo,
     *                      ipointi,ilen,ityp,icscode)
      if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info')
      call cmo_get_intinfo('ipointj',cmo,
     *                      ipointj,ilen,ityp,icscode)
      if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info')
C
      npoints_save=ipointj
C
C        ---------------------------------------------------------------
C           TRANSFORM POINTS AND VELOCITIES TO LOCAL COORD. SYSTEM
C
      if (normflgc .gt. 0) call chglocl(1,npoints,1)
C
      call rzbrick3(imsgin(2),xmsgin(2),cmsgin(2),
     *                    msgtype(2),nwds-1,ierr)
C
C        ---------------------------------------------------------------
C           TRANSFORM POINTS AND VELOCITIES TO NORMAL COORD. SYSTEM
C
      if (normflgc .gt. 0) call chgnorm(1,npoints,1)
C
C
C        ******************************************************************
      call cmo_get_name(cmo,ierror)
      call cmo_get_intinfo('nnodes',cmo,npoints,ilen,ityp,ierror)
      call cmo_get_intinfo('nelements',cmo,ntets,ilen,ityp,ierror)
C
      if(npoints.gt.npoints_save) then
          ipointi=npoints_save+1
          ipointj=npoints
          call cmo_get_name(cmo,ierror)
C
          call cmo_set_info('ipointi',cmo,
     *                         ipointi,1,1,icscode)
          if (icscode .ne. 0) call x3d_error(isubname,'cmo_set_info')
          call cmo_set_info('ipointj',cmo,
     *                         ipointj,1,1,icscode)
          if (icscode .ne. 0) call x3d_error(isubname,'cmo_set_info')
      endif
      return
      end
C
      subroutine rzbrick3(imsgin,xmsgin,cmsgin,msgtype,nwds,ierr2)
C#######################################################################
C
C      PURPOSE -
C
C
C
C      INPUT ARGUMENTS -
C
C
C
C      OUTPUT ARGUMENTS -
C
C
C
C      CHANGE HISTORY -
C
C         $Log: rzbrick3.f,v $
C         Revision 2.00  2007/11/09 20:04:02  spchu
C         Import to CVS
C
CPVCS
CPVCS       Rev 1.27   07 May 2003 14:36:40   gable
CPVCS    Added options, fixed bugs, documented functionality in rzinterp
CPVCS    sections of the code. This piece of code is nearly the same as
CPVCS    the point interpolation code used in extrude, but since it required
CPVCS    a lot of changes to get it working, I decided not to touch the
CPVCS    code that extrude uses.
CPVCS
CPVCS       Rev 1.26   22 Mar 2001 16:15:20   gable
CPVCS    Remove some print statements, modify standard screen
CPVCS    output to include number of nodes and number of elements.
CPVCS
CPVCS       Rev 1.25   03 Oct 2000 09:43:40   dcg
CPVCS    remove references to ialias
CPVCS
CPVCS       Rev 1.24   08 Sep 2000 09:48:04   dcg
CPVCS    use cmo_get_intinfo for accessing INT attributes
CPVCS    call cmo_get_name before using the cmo name
CPVCS
CPVCS       Rev 1.23   21 Apr 2000 07:08:44   gable
CPVCS    Made setting and getting of mbndry value dynamic and problem size dependent.
CPVCS
CPVCS       Rev 1.22   Thu Apr 06 14:13:54 2000   dcg
CPVCS    replace get_info_i set_info_i calls
CPVCS
CPVCS       Rev 1.21   Wed Apr 05 13:35:00 2000   nnc
CPVCS    Minor source modifications required by the Absoft compiler.
CPVCS
CPVCS       Rev 1.20   Mon Dec 13 11:41:12 1999   dcg
CPVCS    check nwds before setting cell end and ratio spacing flags
CPVCS
CPVCS       Rev 1.19   Wed Nov 10 16:05:04 1999   dcg
CPVCS    remove unused ipoints
CPVCS
CPVCS       Rev 1.18   Tue Oct 19 11:55:10 1999   dcg
CPVCS    implicit none for interp routine
CPVCS    more cleanup
CPVCS
CPVCS       Rev 1.17   Tue Oct 19 11:37:34 1999   dcg
CPVCS    implicit none for rzbrick3
CPVCS    check for nwds before setting isym,jsym,ksym
CPVCS
CPVCS       Rev 1.16   Fri Jul 23 09:12:20 1999   dcg
CPVCS    replace rz commands with createpts
CPVCS
CPVCS       Rev 1.15   Wed Mar 11 15:58:58 1998   dcg
CPVCS    accept pset or pstatus
CPVCS
CPVCS       Rev 1.14   Tue Sep 23 16:15:12 1997   dcg
CPVCS    don't set itp in this routine - must use setpts
CPVCS
CPVCS       Rev 1.13   Mon Apr 14 17:00:30 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.12   Thu Mar 06 21:52:52 1997   het
CPVCS    Add the rzinterp routine.
CPVCS
CPVCS       Rev 1.11   Mon Nov 11 20:56:32 1996   het
CPVCS    Consider negative volume hexes and switch the node ordering.
CPVCS
CPVCS       Rev 1.10   Wed Jul 24 17:35:16 1996   dcg
CPVCS    use mesh object 'nef' attribute to pack element and
CPVCS    face number into jtet array
CPVCS
CPVCS       Rev 1.9   Fri May 24 13:55:20 1996   het
CPVCS    Fix a problem is counting points created by this routine.
CPVCS
CPVCS       Rev 1.8   Tue Apr 02 02:23:36 1996   het
CPVCS    Add the connection capability for quads.
CPVCS
CPVCS       Rev 1.7   Mon Mar 04 11:14:02 1996   dcg
CPVCS     remove icn1, int1 unused in this routine
CPVCS
CPVCS       Rev 1.6   Fri Feb 02 14:24:24 1996   dcg
CPVCS    remove references to explicit vector attributes (u,w,v,e,r,pic)
CPVCS
CPVCS       Rev 1.5   Tue Jan 23 09:16:42 1996   het
CPVCS    Add the edges_per_element for hexes elements.
CPVCS
CPVCS       Rev 1.4   Fri Dec 22 14:35:50 1995   het
CPVCS    Correct an error
CPVCS    .
CPVCS
CPVCS       Rev 1.3   11/16/95 15:22:40   dcg
CPVCS    replace character literals in calls
CPVCS
CPVCS       Rev 1.2   11/07/95 17:26:04   dcg
CPVCS    change flag to 2 in mmgetblk calls
CPVCS
CPVCS       Rev 1.1   09/14/95 02:06:50   het
CPVCS    Fix ipcmoprm errors
CPVCS
CPVCS       Rev 1.0   07/17/95 16:23:22   dcg
CPVCS    Initial revision.
C
C#######################################################################
C
      implicit none
      integer nwds,ierr2
      real*8 voltot,xtetvol,xmn,ymn,zmn,xmx,ymx,zmx,xrz,yrz,zrz
      integer ipointi,icscode,ipointj,ierror,npoints,
     *  length,icmotype,ntets,nptsc,nptsv,ifpt1,ics,leni,mpno,
     *  npoints_save,ixz,iyz,izz,ixr,iyr,izr,nsdtopo, mbndry,
     *  icount,ntets_save
      integer jt,jf,node1,it,nnegvol,numtet,nelemavs,nv1,nv2,
     *  nv3,nv4,nv5,nv6,nv7,nv8,nw1,nw2,nw3,nw4,nw5,nw6,nw7,ier,
     *  nw8,ix,iy,iz,isym,jsym,ksym,i,j,k,nx,ny,nz,nxm1,nym1,nzm1,
     *  ixm1,iym1,izm1,ixp1,iyp1,izp1,i1,ifelm,nsd,nen,nef,nee
      integer ivc,icharlnf
      character*70 logmess
C
      include 'chydro.h'
      include 'neibor.h'
      include 'local_element.h'
C
C
      pointer (ipisetwd, isetwd)
      pointer (ipimt1, imt1)
      pointer (ipitp1, itp1)
      pointer (ipicr1, icr1)
      pointer (ipisn1, isn1)
      pointer (ipxic, xic)
      pointer (ipyic, yic)
      pointer (ipzic, zic)
      pointer (ipitet, itet)
      pointer (ipitet, itet1)
      pointer (ipjtet, jtet)
      pointer (ipjtet, jtet1)
      integer isetwd(1000000)
      integer imt1(1000000), itp1(1000000),
     *        icr1(1000000), isn1(1000000),
     *        itet(4,1000000), jtet(4,1000000)
      integer itet1(4*1000000), jtet1(4*1000000)
      real*8   xic(1000000), yic(1000000), zic(1000000)
      pointer (ipitetclr, itetclr)
      pointer (ipitettyp, itettyp)
      pointer (ipitetoff, itetoff)
      pointer (ipjtetoff, jtetoff)
      integer itetclr(1000000), itettyp(1000000),
     *        itetoff(1000000), jtetoff(1000000)
C
C
C#######################################################################
C
C
      integer imsgin(nwds), msgtype(nwds)
      real*8 xmsgin(nwds)
      character*(*) cmsgin(nwds)
C
C#######################################################################
C
      pointer (ipjtet2, jtet2)
      integer jtet2(*)
C
      pointer (ipmpary, mpary)
      integer mpary(*)
C
      pointer (ipidone, idone)
      integer idone(*)
C
      character*32 isubname, cmo, cgeom, ioptrz, imeshopt
C
      real*8 xicvol(100), yicvol(100), zicvol(100)
C
C
C#######################################################################
C
C     DEFINE THE STATEMENT FUNCTIONS FOR THIS ROUTINE.
C
      ivc(i,j,k)=i+(j-1+(k-1)*ny)*nx
C
C#######################################################################
C
      isubname='rzbrick3'

C.......................................................................
C
      call cmo_get_name(cmo,ierror)
C
      call cmo_get_intinfo('ipointi',cmo,ipointi,length,icmotype,
     *   icscode)
         if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info')
      call cmo_get_intinfo('ipointj',cmo,ipointj,length,icmotype,
     *   icscode)
         if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info')
C
C
C.......................................................................
C
      call cmo_get_name(cmo,ierror)
C
      call cmo_get_intinfo('nnodes',cmo,npoints,length,icmotype,ierror)
      call cmo_get_intinfo('nelements',cmo,ntets,length,icmotype,
     *    ierror)
C
      isym=0
      jsym=0
      ksym=0
C
      cgeom=cmsgin(1)
      if(cgeom(1:icharlnf(cgeom)).eq.'interp') then
         call rzinterp(imsgin,xmsgin,cmsgin,msgtype,nwds,ierr2)
         goto 9999
      endif
      nx=imsgin(2)
      ny=imsgin(3)
      nz=imsgin(4)
      nptsc=max((nx-1)*(ny-1)*(nz-1),
     *          (nx-1)*(ny-1),
     *          (nx-1)*(nz-1),
     *          (ny-1)*(nz-1),
     *          nx-1,
     *          ny-1,
     *          nz-1)
      imeshopt=cmsgin(8)
      ioptrz='notset'
      if(imeshopt(1:7).eq.'connect') then
         nptsv=0
         if(msgtype(5).eq.1) then
            if(imsgin(5).eq.0) then
               ifpt1=ipointi
            else
               ifpt1=imsgin(5)
            endif
         elseif(msgtype(5).eq.3) then
            if(cmsgin(5)(1:7).eq.'pstatus'.or.
     *         cmsgin(5)(1:4).eq.'pset') then
               length=npoints
               call mmgetblk('mpary',isubname,ipmpary,length,2,ics)
               call cmo_get_info('isetwd',cmo,
     *                           ipisetwd,leni,icmotype,ierror)
               call cmo_get_info('itp1',cmo,ipitp1,leni,icmotype,ics)
               call pntlimc(cmsgin(5),cmsgin(6),cmsgin(7),
     *                      ipmpary,mpno,npoints,isetwd,itp1)
               ifpt1=mpary(1)
            else
               ifpt1=ipointi
            endif
         endif
         if(nwds.ge.9)isym=imsgin(9)
         if(nwds.ge.10)jsym=imsgin(10)
         if(nwds.ge.11)ksym=imsgin(11)
         npoints_save=ifpt1
      else
         nptsv=nx*ny*nz
         ifpt1=npoints+1
         xmn=xmsgin(5)
         ymn=xmsgin(6)
         zmn=xmsgin(7)
         xmx=xmsgin(8)
         ymx=xmsgin(9)
         zmx=xmsgin(10)
C
         ixz=1
         iyz=1
         izz=1
         ixr=0
         iyr=0
         izr=0
         xrz=1.
         yrz=1.
         zrz=1.
         isym=0
         jsym=0
         ksym=0
         if(nwds.ge.11)ixz=imsgin(11)
         if(nwds.ge.12)iyz=imsgin(12)
         if(nwds.ge.13)izz=imsgin(13)
         if(nwds.ge.14)ixr=imsgin(14)
         if(nwds.ge.15)iyr=imsgin(15)
         if(nwds.ge.16)izr=imsgin(16)
         if(nwds.ge.17)xrz=xmsgin(17)
         if(nwds.ge.18)yrz=xmsgin(18)
         if(nwds.ge.19)zrz=xmsgin(19)
         if(nwds.ge.20)isym=imsgin(20)
         if(nwds.ge.21)jsym=imsgin(21)
         if(nwds.ge.22)ksym=imsgin(22)
C
         npoints_save=npoints
         if(nptsv.gt.0) then
            npoints=npoints+nptsv
            call cmo_set_info('nnodes',cmo,npoints,1,1,ierror)
            call cmo_newlen(cmo,ierror)
         endif
C
         call cmo_get_intinfo('ndimensions_topo',cmo,
     *                     nsdtopo,length,icmotype,ierror)
         call cmo_get_intinfo('nnodes',cmo,npoints,length,icmotype,
     *       ierror)
         call cmo_get_intinfo('nelements',cmo,ntets,length,
     *       icmotype,ierror)
         call cmo_get_intinfo('mbndry',cmo,mbndry,length,
     *       icmotype,ierror)
         call cmo_get_info('isetwd',cmo,
     *                     ipisetwd,leni,icmotype,ierror)
         call cmo_get_info('imt1',cmo,ipimt1,leni,icmotype,ierror)
         call cmo_get_info('itp1',cmo,ipitp1,leni,icmotype,ierror)
         call cmo_get_info('icr1',cmo,ipicr1,leni,icmotype,ierror)
         call cmo_get_info('isn1',cmo,ipisn1,leni,icmotype,ierror)
         call cmo_get_info('xic',cmo,ipxic,leni,icmotype,ierror)
         call cmo_get_info('yic',cmo,ipyic,leni,icmotype,ierror)
         call cmo_get_info('zic',cmo,ipzic,leni,icmotype,ierror)
         call cmo_get_info('itetclr',cmo,
     *                     ipitetclr,leni,icmotype,ier)
         call cmo_get_info('itet',cmo,ipitet,leni,icmotype,ierror)
         call cmo_get_info('jtet',cmo,ipjtet,leni,icmotype,ierror)

C
         icount=ifpt1-1
         if(imeshopt(1:7).ne.'connect') then
            if(ioptrz(1:6).eq.'notset') then
               call rzbrickg(cgeom,icount,
     *              nx , ny , nz,
     *              xmn, ymn, zmn,
     *              xmx, ymx, zmx,
     *              ixz, iyz, izz,
     *              ixr, iyr, izr,
     *              xrz, yrz, zrz ,
     *              ipxic, ipyic, ipzic)
            elseif(ioptrz(1:4).eq.'geom') then
               call rzbrickh(cgeom,icount,
     *              nx , ny , nz,
     *              xmn, ymn, zmn,
     *              xmx, ymx, zmx,
     *              ixz, iyz, izz,
     *              ixr, iyr, izr,
     *              xrz, yrz, zrz,
     *              ipxic, ipyic, ipzic)
            endif
         endif
      endif
C
C
      do 50 i1=1,nptsv
         itp1(i1)=0
         icr1(i1)=0
 50   continue
C
C     ..................................................................
C     CONSTRUCT THE NEIGHBOR CONNECTIVITY MATRIX FOR THE BRICKS.
C
      if(nx.gt.1.and.ny.gt.1.and.nz.gt.1) then
         ifelm=ifelmhex
         nsd=3
      elseif(ny.eq.1.and.nz.eq.1) then
         ifelm=ifelmlin
         nsd=1
      else
         ifelm=ifelmqud
         nsd=2
      endif
      nen=nelmnen(ifelm)
      nef=nelmnef(ifelm)
      nee=nelmnee(ifelm)
      call cmo_set_info('nodes_per_element',cmo,nen,1,1,ierror)
      call cmo_set_info('faces_per_element',cmo,nef,1,1,ierror)
      call cmo_set_info('edges_per_element',cmo,nee,1,1,ierror)
      call cmo_set_info('ndimensions_topo',cmo,nsd,1,1,ierror)
C
      ntets_save=ntets
      ntets=ntets+nptsc
      call cmo_set_info('nelements',cmo,ntets,1,1,ierror)
      call cmo_newlen(cmo,ierror)
C
      call cmo_get_intinfo('nnodes',cmo,npoints,length,
     *  icmotype,ierror)
      call cmo_get_intinfo('nelements',cmo,ntets,length,
     *  icmotype,ierror)
      call cmo_get_intinfo('mbndry',cmo,mbndry,length,
     *  icmotype,ierror)
      call cmo_get_info('isetwd',cmo,
     *                  ipisetwd,leni,icmotype,ierror)
      call cmo_get_info('imt1',cmo,ipimt1,leni,icmotype,ierror)
      call cmo_get_info('itp1',cmo,ipitp1,leni,icmotype,ierror)
      call cmo_get_info('icr1',cmo,ipicr1,leni,icmotype,ierror)
      call cmo_get_info('isn1',cmo,ipisn1,leni,icmotype,ierror)
      call cmo_get_info('xic',cmo,ipxic,leni,icmotype,ierror)
      call cmo_get_info('yic',cmo,ipyic,leni,icmotype,ierror)
      call cmo_get_info('zic',cmo,ipzic,leni,icmotype,ierror)
      call cmo_get_info('itetclr',cmo,
     *                  ipitetclr,leni,icmotype,ier)
      call cmo_get_info('itettyp',cmo,
     *                  ipitettyp,leni,icmotype,ier)
      call cmo_get_info('itetoff',cmo,
     *                  ipitetoff,leni,icmotype,ier)
      call cmo_get_info('jtetoff',cmo,
     *                  ipjtetoff,leni,icmotype,ier)
      call cmo_get_info('itet',cmo,ipitet,leni,icmotype,ierror)
      call cmo_get_info('jtet',cmo,ipjtet,leni,icmotype,ierror)
C
      itetcnt=ntets_save
      do 200 iz=1,max(1,(nz-1))
         do 210 iy=1,max(1,(ny-1))
            do 220 ix=1,max(1,(nx-1))
               nxm1=nx-1
               nym1=ny-1
               nzm1=nz-1
               ixm1=ix-1
               iym1=iy-1
               izm1=iz-1
               ixp1=ix+1
               iyp1=iy+1
               izp1=iz+1
               if(isym.eq.1) then
                  if(ixm1.eq.0 ) ixm1=nx
                  if(ixp1.eq.nx) ixp1=1
               endif
               if(jsym.eq.1) then
                  if(iym1.eq.0 ) iym1=ny
                  if(iyp1.eq.ny) iyp1=1
               endif
               if(ksym.eq.1) then
                  if(izm1.eq.0 ) izm1=nz
                  if(izp1.eq.nz) izp1=1
               endif
               nw1=ivc(ix  ,iy  ,iz  )
               nw2=ivc(ix+1,iy  ,iz  )
               nw3=ivc(ix+1,iy+1,iz  )
               nw4=ivc(ix  ,iy+1,iz  )
               nw5=ivc(ix  ,iy  ,iz+1)
               nw6=ivc(ix+1,iy  ,iz+1)
               nw7=ivc(ix+1,iy+1,iz+1)
               nw8=ivc(ix  ,iy+1,iz+1)
               itetcnt=itetcnt+1
               if(ifelm.eq.ifelmhex) then
                  nv1=ivc(ix  ,iy  ,iz  )
                  nv2=ivc(ixp1,iy  ,iz  )
                  nv3=ivc(ixp1,iyp1,iz  )
                  nv4=ivc(ix  ,iyp1,iz  )
                  nv5=ivc(ix  ,iy  ,izp1)
                  nv6=ivc(ixp1,iy  ,izp1)
                  nv7=ivc(ixp1,iyp1,izp1)
                  nv8=ivc(ix  ,iyp1,izp1)
                  itet1(nen*(itetcnt-1)+1)=nv1+ifpt1-1
                  itet1(nen*(itetcnt-1)+2)=nv2+ifpt1-1
                  itet1(nen*(itetcnt-1)+3)=nv3+ifpt1-1
                  itet1(nen*(itetcnt-1)+4)=nv4+ifpt1-1
                  itet1(nen*(itetcnt-1)+5)=nv5+ifpt1-1
                  itet1(nen*(itetcnt-1)+6)=nv6+ifpt1-1
                  itet1(nen*(itetcnt-1)+7)=nv7+ifpt1-1
                  itet1(nen*(itetcnt-1)+8)=nv8+ifpt1-1
                  itettyp(itetcnt)=ifelm
                  itetoff(itetcnt)=nelmnen(itettyp(itetcnt))*(itetcnt-1)
                  jtetoff(itetcnt)=nelmnef(itettyp(itetcnt))*(itetcnt-1)
                  itetclr(itetcnt)=max(1,
     *                                 imt1(itet1(itetoff(itetcnt)+1)))
                  do i=1,nelmnen(itettyp(itetcnt))
                     i1=itet1(itetoff(itetcnt)+i)
                     itetclr(itetcnt)=max(1,imt1(i1))
                     xicvol(i)=xic(i1)
                     yicvol(i)=yic(i1)
                     zicvol(i)=zic(i1)
                  enddo
                  call volume_element(itettyp(itetcnt),
     *                                xicvol,yicvol,zicvol,
     *                                xtetvol)
                  if(xtetvol.le.0.0d+00) then
                     itet1(nen*(itetcnt-1)+1)=nv1+ifpt1-1
                     itet1(nen*(itetcnt-1)+2)=nv4+ifpt1-1
                     itet1(nen*(itetcnt-1)+3)=nv3+ifpt1-1
                     itet1(nen*(itetcnt-1)+4)=nv2+ifpt1-1
                     itet1(nen*(itetcnt-1)+5)=nv5+ifpt1-1
                     itet1(nen*(itetcnt-1)+6)=nv8+ifpt1-1
                     itet1(nen*(itetcnt-1)+7)=nv7+ifpt1-1
                     itet1(nen*(itetcnt-1)+8)=nv6+ifpt1-1
                  endif
               elseif(ifelm.eq.ifelmqud) then
                  if(nz.eq.1) then
                     nv1=ivc(ix  ,iy  ,iz  )
                     nv2=ivc(ixp1,iy  ,iz  )
                     nv3=ivc(ixp1,iyp1,iz  )
                     nv4=ivc(ix  ,iyp1,iz  )
                     itet1(nen*(itetcnt-1)+1)=nv1+ifpt1-1
                     itet1(nen*(itetcnt-1)+2)=nv2+ifpt1-1
                     itet1(nen*(itetcnt-1)+3)=nv3+ifpt1-1
                     itet1(nen*(itetcnt-1)+4)=nv4+ifpt1-1
                  elseif(nx.eq.1) then
                     nv1=ivc(ix  ,iy  ,iz  )
                     nv2=ivc(ix  ,iyp1,iz  )
                     nv3=ivc(ix  ,iyp1,izp1)
                     nv4=ivc(ix  ,iy  ,izp1)
                     itet1(nen*(itetcnt-1)+1)=nv1+ifpt1-1
                     itet1(nen*(itetcnt-1)+2)=nv2+ifpt1-1
                     itet1(nen*(itetcnt-1)+3)=nv3+ifpt1-1
                     itet1(nen*(itetcnt-1)+4)=nv4+ifpt1-1
                  elseif(ny.eq.1) then
                     nv1=ivc(ix  ,iy  ,iz  )
                     nv2=ivc(ixp1,iy  ,iz  )
                     nv3=ivc(ixp1,iy  ,izp1)
                     nv4=ivc(ix  ,iy  ,izp1)
                     itet1(nen*(itetcnt-1)+1)=nv1+ifpt1-1
                     itet1(nen*(itetcnt-1)+2)=nv2+ifpt1-1
                     itet1(nen*(itetcnt-1)+3)=nv3+ifpt1-1
                     itet1(nen*(itetcnt-1)+4)=nv4+ifpt1-1
                  endif
                  itettyp(itetcnt)=ifelm
                  itetoff(itetcnt)=nelmnen(itettyp(itetcnt))*(itetcnt-1)
                  jtetoff(itetcnt)=nelmnef(itettyp(itetcnt))*(itetcnt-1)
                  do i=1,nelmnen(itettyp(itetcnt))
                     i1=itet1(itetoff(itetcnt)+i)
                     itetclr(itetcnt)=max(1,imt1(i1))
                     xicvol(i)=xic(i1)
                     yicvol(i)=yic(i1)
                     zicvol(i)=zic(i1)
                  enddo
                  call volume_element(itettyp(itetcnt),
     *                                xicvol,yicvol,zicvol,
     *                                xtetvol)
                  if(xtetvol.le.0.0d+00) then
                     itet1(nen*(itetcnt-1)+2)=nv3+ifpt1-1
                     itet1(nen*(itetcnt-1)+3)=nv2+ifpt1-1
                  endif
               elseif(ifelm.eq.ifelmlin) then
                  nv1=ivc(ix  ,iy  ,iz  )
                  nv2=ivc(ixp1,iy  ,iz  )
                  itet1(nen*(itetcnt-1)+1)=nv1+ifpt1-1
                  itet1(nen*(itetcnt-1)+2)=nv2+ifpt1-1
                  itettyp(itetcnt)=ifelm
                  itetoff(itetcnt)=nelmnen(itettyp(itetcnt))*(itetcnt-1)
                  jtetoff(itetcnt)=nelmnef(itettyp(itetcnt))*(itetcnt-1)
                  itetclr(itetcnt)=max(1,
     *                                 imt1(itet1(itetoff(itetcnt)+1)))
                  do i=1,nelmnen(itettyp(itetcnt))
                     i1=itet1(itetoff(itetcnt)+i)
                     itetclr(itetcnt)=max(1,imt1(i1))
                     xicvol(i)=xic(i1)
                     yicvol(i)=yic(i1)
                     zicvol(i)=zic(i1)
                  enddo
                  call volume_element(itettyp(itetcnt),
     *                                xicvol,yicvol,zicvol,
     *                                xtetvol)
                  if(xtetvol.le.0.0d+00) then
                     itet1(nen*(itetcnt-1)+1)=nv2+ifpt1-1
                     itet1(nen*(itetcnt-1)+2)=nv1+ifpt1-1
                  endif
               endif
 220        continue
 210     continue
 200  continue
C
      nelemavs=itetcnt
      length=nef*nelemavs
      call mmgetblk("jtet2",isubname,ipjtet2,length,2,icscode)
      numtet=nelemavs
C
      nnegvol=0
      voltot=0.0
      do it=ntets_save+1,numtet
         do i=1,nelmnen(itettyp(it))
            i1=itet1(itetoff(it)+i)
            xicvol(i)=xic(i1)
            yicvol(i)=yic(i1)
            zicvol(i)=zic(i1)
         enddo
C
         call volume_element(itettyp(it),
     *                       xicvol,yicvol,zicvol,
     *                       xtetvol)
C
         voltot=voltot+xtetvol
         if(xtetvol.lt.0) then
            nnegvol=nnegvol+1
         endif
      enddo
C
      write(logmess,9026) npoints
 9026 format("Number of nodes: ",i11)
      call writloga('default',0,logmess,0,ier)
      write(logmess,9027) ntets
 9027 format("Number of elements: ",i11)
      call writloga('default',0,logmess,0,ier)
      write(logmess,9028) nnegvol
 9028 format("Number of negative volume elements: ",i11)
      call writloga('default',0,logmess,0,ier)
      write(logmess,9029) voltot
 9029 format("Total volume:  ",e21.12)
      call writloga('default',0,logmess,0,ier)
C
      call geniee_cmo(cmo)
C
C     .................................................................
C     SET THE EXTERNAL BOUNDARY NODE TYPE BASED ON BOUNDARY FACES.
C
         length=npoints
         call mmgetblk('idone',isubname,ipidone,length,2,icscode)
C
         do i=1,npoints
            idone(i)=0
            itp1(i)=0
         enddo
C
         do it=1,numtet
            do i=1,nelmnef(itettyp(it))
               if (jtet1(jtetoff(it)+i).ge.mbndry) then
                  do j=1,ielmface0(i,itettyp(it))
                     node1 = itet1(itetoff(it)+
     *                              ielmface1(j,i,itettyp(it)))
Cdcg                     itp1(node1)=ifitprfl
                  enddo
               endif
            enddo
         enddo
C
         do it=1,numtet
            do i=1,nelmnef(itettyp(it))
               if (jtet1(jtetoff(it)+i).gt.0.and.
     *             jtet1(jtetoff(it)+i).lt.mbndry) then
                  jt=1+(jtet1(jtetoff(it)+i)-1)/nef
                  jf=jtet1(jtetoff(it)+i)-nef*(it-1)
                  if(itetclr(it).ne.itetclr(jt)) then
                     do j=1,ielmface0(i,itettyp(it))
                        node1=itet1(itetoff(it)+
     *                               ielmface1(j,i,itettyp(it)))
                        if(idone(node1).eq.0) then
                           idone(node1)=1
                           if(itp1(node1).eq.ifitprfl) then
                              itp1(node1)=ifitpinb
                           else
                              itp1(node1)=ifitpini
                           endif
                        endif
                     enddo
                  endif
               endif
            enddo
         enddo
         call mmrelblk('idone',isubname,ipidone,icscode)
C
      goto 9999
 9999 continue
      call mmrelprt(isubname,ierror)
      return
      end
*dk,rzinterp
      subroutine rzinterp(imsgin,xmsgin,cmsgin,msgtype,nwds,ierr2)
C
C#######################################################################
C
C   This command adds points to a mesh object. It creates points
C   by linear interpolation of coordinates between two point sets
C   For some special cases, it will also produce element connectivity
C   between the point sets.
C
C   The combinations of input and output are:
C
C   Source Element Type | Result Element Type
C   point                 point (no connectivity)
C   line                  quad
C   tri                   prism
C   quad                  hex
C   hybrid (quad,tri)     hybrid (hex, prism)
C   FORMAT:
C   createpts/interp/npoint/i1,i2,i3/j1,j2,j3/cmo_new
C
C
C#######################################################################
      implicit none
C
      include 'local_element.h'
C
      integer nwds
      integer imsgin(nwds), msgtype(nwds)
      real*8 xmsgin(nwds)
      character*(*) cmsgin(nwds)
      integer i1,i2,i3,i4,i5,i6,i7,i8,ipointi,ipointj,i1temp,
     *  it,iflag,itetcnt,itoff,jtoff,l,nef,nen,nsdtopo,
     *  nsdgeom,leni,i,nptsl,icmotp,nef1,nen1,nsdtopo1,
     *  nsdgeom1,ier,icscode,icmotype,nelements2,npoints_new,
     *  nelements_new,mpno2,mpno1,ics,length,itype,ierr,ilen,
     *  nnodes2,ilayers,nelements,nnodes,ierror,ierr2,mbndry
      real*8 xtetvol,dy1,dz1,dsfac,dx1
      character*70 logmess
      character*32 cmesh_type
C
C     __________________________________________________________________
C     Master Mesh Object.
C
      pointer (ipimt1, imt1)
      pointer (ipitp1, itp1)
      integer itp1(1000000), imt1(1000000)
      pointer (ipxic1, xic1)
      pointer (ipyic1, yic1)
      pointer (ipzic1, zic1)
      real*8 xic1(10000000), yic1(10000000), zic1(10000000)
      pointer (ipitetclr1, itetclr1(10000000))
      pointer (ipitettyp1, itettyp1(10000000))
      pointer (ipitetoff1, itetoff1(10000000))
      pointer (ipjtetoff1, jtetoff1(10000000))
      pointer (ipitet1, itet1(10000000))
      pointer (ipjtet1, jtet1(10000000))
      integer itet1,jtet1,itetclr1,itettyp1,itetoff1,jtetoff1
C
C     __________________________________________________________________
C     Slave Mesh Object.
C
      pointer (ipimt2, imt2)
      pointer (ipitp2, itp2)
      integer itp2(1000000), imt2(1000000)
      pointer (ipxic2, xic2)
      pointer (ipyic2, yic2)
      pointer (ipzic2, zic2)
      real*8 xic2(10000000), yic2(10000000), zic2(10000000)
      pointer (ipitetclr2, itetclr2(10000000))
      pointer (ipitettyp2, itettyp2(10000000))
      pointer (ipitetoff2, itetoff2(10000000))
      pointer (ipjtetoff2, jtetoff2(10000000))
      pointer (ipitet2, itet2(10000000))
      pointer (ipjtet2, jtet2(10000000))
      integer itet2,jtet2,itetclr2,itettyp2,itetoff2,jtetoff2
C
      pointer (ipisetwd, isetwd)
      integer isetwd(1000000)
C
      pointer (ipmpary1, mpary1)
      pointer (ipmpary2, mpary2)
      integer mpary1(1000000), mpary2(1000000)
C
      pointer (ipipflag1, ipflag1)
      integer ipflag1(1000000)
      pointer (ipitflag1, itflag1)
      integer itflag1(1000000)
C
      character*32 isubname, cmo, cmonew
      integer ip1,ip2,ip3,ip4,ip5,ip6
C
      real*8 xicvol(100), yicvol(100), zicvol(100)
C
C#######################################################################
C
      isubname='rzinterp'
C
      call cmo_get_name(cmo,ierror)
C
      call cmo_get_intinfo('nnodes',cmo,nnodes,ilen,itype,ierr)
      call cmo_get_intinfo('nelements',cmo,nelements,ilen,itype,ierr)
C
      ilayers=imsgin(2)
      length=nnodes
      call mmgetblk('mpary1',isubname,ipmpary1,length,1,ics)
      call mmgetblk('mpary2',isubname,ipmpary2,length,1,ics)
      if(msgtype(3).eq.1) then
         ip1=imsgin(3)
         ip2=imsgin(4)
         ip3=imsgin(5)
         if((ip1.eq.1).and.(ip2.eq.0).and.(ip3.eq.0))then
           ip1 = 1
           ip2 = nnodes/2
           ip3 = 1
         endif
         mpno1=0
         do i1=ip1,ip2,ip3
            mpno1=mpno1+1
            mpary1(mpno1)=i1
         enddo
      else
         call cmo_get_info('isetwd',cmo,
     *                     ipisetwd,leni,icmotype,ierror)
         call cmo_get_info('itp1',cmo,ipitp1,leni,icmotype,ics)
         call pntlimc(cmsgin(3),cmsgin(4),cmsgin(5),
     *                ipmpary1,mpno1,nnodes,isetwd,itp1)
      endif
      if(msgtype(6).eq.1) then
         ip4=imsgin(6)
         ip5=imsgin(7)
         ip6=imsgin(8)
         if((ip4.eq.1).and.(ip5.eq.0).and.(ip6.eq.0))then
           ip4 = (nnodes/2) + 1
           ip5 =  nnodes
           ip6 =  1
         endif
         mpno2=0
         do i1=ip4,ip5,ip6
            mpno2=mpno2+1
            mpary2(mpno2)=i1
         enddo
      else
         call cmo_get_info('isetwd',cmo,
     *                     ipisetwd,leni,icmotype,ierror)
         call cmo_get_info('itp1',cmo,ipitp1,leni,icmotype,ics)
         call pntlimc(cmsgin(6),cmsgin(7),cmsgin(8),
     *                ipmpary2,mpno2,nnodes,isetwd,itp1)
      endif
C
      if(mpno1 .ne. mpno2) then
         write(logmess,9025)
 9025    format("ERROR:rzinterp")
         call writloga('default',0,logmess,0,ier)
         write(logmess,9026) mpno1, mpno2
 9026    format("Number of nodes in FROM not equal TO: ",i11,i11)
         call writloga('default',0,logmess,0,ier)
         goto 9999
      endif

      cmonew=cmsgin(9)
C
      call cmo_exist(cmonew,icscode)
      if(icscode.eq.0) then
         call cmo_get_intinfo('nnodes',cmonew,nnodes2,ilen,itype,ierr)
         call cmo_get_intinfo('nelements',cmonew,
     *                     nelements2,ilen,itype,ierr)
         call cmo_select(cmonew,icscode)
         npoints_new=nnodes2+(2+ilayers)*mpno1
         nelements_new=nelements2+(2+ilayers-1)*nelements
      else
         nnodes2=0
         nelements2=0
         call cmo_derive(cmonew,cmo,icscode)
         npoints_new=(2+ilayers)*mpno1
         nelements_new=(2+ilayers-1)*nelements
      endif
C
      call cmo_get_intinfo('ndimensions_geom',cmo,nsdgeom1,ilen,
     *  itype,ier)
      call cmo_get_intinfo('ndimensions_topo',cmo,nsdtopo1,ilen,
     *  itype,ier)
      call cmo_get_intinfo('nodes_per_element',cmo,nen1,ilen,
     *  itype,ierr)
      call cmo_get_intinfo('faces_per_element',cmo,nef1,ilen,
     *  itype,ierr)
      if(nsdtopo1.eq.3) then
         write(logmess,9036) nsdtopo1
 9036    format("Grid topology too high: ",i11)
         call writloga('default',0,logmess,0,ier)
         goto 9999
      endif
      if(nen1.eq.nelmnen(ifelmhyb) .and.
     *   nef1.eq.nelmnef(ifelmhyb)) then
         nsdgeom=3
         if(nsdtopo1.eq.1) then
            nsdtopo=2
         else
            nsdtopo=3
         endif
         nen=nelmnen(ifelmhyb)
         nef=nelmnef(ifelmhyb)
         cmesh_type = 'hyb'
      else
         if(nsdtopo1.eq.2) then
            if(nen1.eq.nelmnen(ifelmtri) .and.
     *         nef1.eq.nelmnef(ifelmtri)) then
               nen=nelmnen(ifelmpri)
               nef=nelmnef(ifelmpri)
               nsdgeom = 3
               nsdtopo = 3
               cmesh_type = 'pri'
            elseif(nen1.eq.nelmnen(ifelmqud) .and.
     *             nef1.eq.nelmnef(ifelmqud)) then
               nen=nelmnen(ifelmhex)
               nef=nelmnef(ifelmhex)
               nsdgeom = 3
               nsdtopo = 3
               cmesh_type = 'hex'
            endif
         elseif(nsdtopo1.eq.1) then
            nsdgeom=3
            nsdtopo=2
            if(nen1.eq.nelmnen(ifelmlin) .and.
     *         nef1.eq.nelmnef(ifelmlin)) then
               nen=nelmnen(ifelmqud)
               nef=nelmnef(ifelmqud)
               cmesh_type = 'qud'
            endif
         endif
      endif
C
      call cmo_set_info('nnodes',cmonew,npoints_new,1,1,ierr)
      call cmo_set_info('nelements',cmonew,nelements_new,1,1,ierr)
c
c      call cmo_set_info('ndimensions_geom',cmonew,nsdgeom,1,1,ier)
c      call cmo_set_info('ndimensions_topo',cmonew,nsdtopo,1,1,ier)
c      call cmo_set_info('nodes_per_element',cmonew,nen,1,1,ierr)
c      call cmo_set_info('faces_per_element',cmonew,nef,1,1,ierr)
c
c     The set_info calls above were incomplete. Replace with set_mesh_type
c
      call cmo_set_mesh_type(cmonew, cmesh_type, ierr)
C
      call cmo_newlen(cmonew,ierr)
C
      call cmo_get_intinfo('mbndry',cmonew,mbndry,
     *                  leni,icmotp,ierror)
      call cmo_get_info('imt1',cmonew,ipimt2,leni,icmotp,ierr)
      call cmo_get_info('itp1',cmonew,ipitp2,leni,icmotp,ierr)
      call cmo_get_info('xic',cmonew,ipxic2,leni,icmotp,ierr)
      call cmo_get_info('yic',cmonew,ipyic2,leni,icmotp,ierr)
      call cmo_get_info('zic',cmonew,ipzic2,leni,icmotp,ierr)
      call cmo_get_info('itetclr',cmonew,
     *                  ipitetclr2,leni,icmotp,ier)
      call cmo_get_info('itettyp',cmonew,
     *                  ipitettyp2,leni,icmotp,ier)
      call cmo_get_info('itetoff',cmonew,
     *                  ipitetoff2,leni,icmotp,ier)
      call cmo_get_info('jtetoff',cmonew,
     *                  ipjtetoff2,leni,icmotp,ier)
      call cmo_get_info('itet',cmonew,ipitet2,leni,icmotp,ierr)
      call cmo_get_info('jtet',cmonew,ipjtet2,leni,icmotp,ierr)
C
      call cmo_get_info('imt1',cmo,ipimt1,leni,icmotp,ierr)
      call cmo_get_info('itp1',cmo,ipitp1,leni,icmotp,ierr)
      call cmo_get_info('xic',cmo,ipxic1,leni,icmotp,ierr)
      call cmo_get_info('yic',cmo,ipyic1,leni,icmotp,ierr)
      call cmo_get_info('zic',cmo,ipzic1,leni,icmotp,ierr)
      call cmo_get_info('itetclr',cmo,
     *                  ipitetclr1,leni,icmotp,ier)
      call cmo_get_info('itettyp',cmo,
     *                  ipitettyp1,leni,icmotp,ier)
      call cmo_get_info('itetoff',cmo,
     *                  ipitetoff1,leni,icmotp,ier)
      call cmo_get_info('jtetoff',cmo,
     *                  ipjtetoff1,leni,icmotp,ier)
      call cmo_get_info('itet',cmo,ipitet1,leni,icmotp,ierr)
      call cmo_get_info('jtet',cmo,ipjtet1,leni,icmotp,ierr)
C
      nptsl=mpno1
      do i=1,mpno1
         i1=mpary1(i)
         imt2(nnodes2+i)=imt1(i1)
         itp2(nnodes2+i)=itp1(i1)
         xic2(nnodes2+i)=xic1(i1)
         yic2(nnodes2+i)=yic1(i1)
         zic2(nnodes2+i)=zic1(i1)
      enddo
      do i=1,mpno2
         i1=mpary2(i)
         imt2(nnodes2+nptsl*(2+ilayers-1)+i)=imt1(i1)
         itp2(nnodes2+nptsl*(2+ilayers-1)+i)=itp1(i1)
         xic2(nnodes2+nptsl*(2+ilayers-1)+i)=xic1(i1)
         yic2(nnodes2+nptsl*(2+ilayers-1)+i)=yic1(i1)
         zic2(nnodes2+nptsl*(2+ilayers-1)+i)=zic1(i1)
      enddo
      if(ilayers.gt.0) then
         do l=2,(2+ilayers)-1
            dsfac=real(l-1)/real(ilayers+1)
            do i=1,mpno1
               i1=mpary1(i)
               dx1=xic2(nnodes2+nptsl*(2+ilayers-1)+i1)-xic2(nnodes2+i1)
               dy1=yic2(nnodes2+nptsl*(2+ilayers-1)+i1)-yic2(nnodes2+i1)
               dz1=zic2(nnodes2+nptsl*(2+ilayers-1)+i1)-zic2(nnodes2+i1)
               imt2(nnodes2+nptsl*(l-1)+i1)=imt2(nnodes2+i1)
               itp2(nnodes2+nptsl*(l-1)+i1)=itp2(nnodes2+i1)
               xic2(nnodes2+nptsl*(l-1)+i1)=xic2(nnodes2+i1)+dx1*dsfac
               yic2(nnodes2+nptsl*(l-1)+i1)=yic2(nnodes2+i1)+dy1*dsfac
               zic2(nnodes2+nptsl*(l-1)+i1)=zic2(nnodes2+i1)+dz1*dsfac
            enddo
         enddo
      endif
C
      length=nnodes
      call mmgetblk('ipflag1',isubname,ipipflag1,length,1,icscode)
      do i=1,nnodes
         ipflag1(i)=0
      enddo
      length=nelements
C
C     To avoid asking for 0 length memory
C
      if (nelements .eq. 0)length = 1
C
      call mmgetblk('itflag1',isubname,ipitflag1,length,1,icscode)
      do it=1,nelements
         itflag1(it)=0
      enddo
      do i=1,mpno1
         i1=mpary1(i)
         ipflag1(i1)=i
      enddo
      do it=1,nelements
         iflag=0
         do i=1,nelmnen(itettyp1(it))
            i1=itet1(itetoff1(it)+i)
            if(ipflag1(i1).gt.0) then
               iflag=iflag+1
            endif
         enddo
         if(iflag.eq.nelmnen(itettyp1(it))) then
            itflag1(it)=1
         endif
      enddo
C
      if(nelements2.le.0) then
         itetcnt=0
         itoff=0
         jtoff=0
      else
         itetcnt=nelements2
         itoff=itetoff2(nelements2)+nelmnen(itettyp2(nelements2))
         jtoff=jtetoff2(nelements2)+nelmnef(itettyp2(nelements2))
      endif
      do l=1,2+ilayers-1
         do it=1,nelements
            if(itflag1(it).eq.1) then
               if(itettyp1(it).eq.ifelmlin) then
                  i1=nnodes2+nptsl*(l-1)+itet1(itetoff1(it)+1)
                  i2=nnodes2+nptsl*(l-1)+itet1(itetoff1(it)+2)
                  i4=nptsl+i1
                  i3=nptsl+i2
                  itetcnt=itetcnt+1
                  itetclr2(itetcnt)=itetclr1(it)
                  itettyp2(itetcnt)=ifelmqud
                  itetoff2(itetcnt)=itoff
                  jtetoff2(itetcnt)=jtoff
                  itoff=itoff+nelmnen(itettyp2(itetcnt))
                  jtoff=jtoff+nelmnef(itettyp2(itetcnt))
                  itet2(itetoff2(itetcnt)+1)=i1
                  itet2(itetoff2(itetcnt)+2)=i2
                  itet2(itetoff2(itetcnt)+3)=i3
                  itet2(itetoff2(itetcnt)+4)=i4
                  do i=1,nelmnef(itettyp2(it))
                     jtet2(jtetoff2(itetcnt)+i)=-1
                  enddo
                  do i=1,nelmnen(itettyp2(itetcnt))
                     i1temp=itet2(itetoff2(itetcnt)+i)
                     xicvol(i)=xic2(i1temp)
                     yicvol(i)=yic2(i1temp)
                     zicvol(i)=zic2(i1temp)
                  enddo
                  call volume_element(itettyp2(itetcnt),
     *                                xicvol,yicvol,zicvol,
     *                                xtetvol)
                  if(xtetvol.le.0.0d+00) then
                     itet2(itetoff2(itetcnt)+1)=i1
                     itet2(itetoff2(itetcnt)+2)=i4
                     itet2(itetoff2(itetcnt)+3)=i3
                     itet2(itetoff2(itetcnt)+4)=i2
                  endif
               elseif(itettyp1(it).eq.ifelmtri) then
                  i1=nnodes2+nptsl*(l-1)+itet1(itetoff1(it)+1)
                  i2=nnodes2+nptsl*(l-1)+itet1(itetoff1(it)+2)
                  i3=nnodes2+nptsl*(l-1)+itet1(itetoff1(it)+3)
                  i4=nptsl+i1
                  i5=nptsl+i2
                  i6=nptsl+i3
                  itetcnt=itetcnt+1
                  itetclr2(itetcnt)=itetclr1(it)
                  itettyp2(itetcnt)=ifelmpri
                  itetoff2(itetcnt)=itoff
                  jtetoff2(itetcnt)=jtoff
                  itoff=itoff+nelmnen(itettyp2(itetcnt))
                  jtoff=jtoff+nelmnef(itettyp2(itetcnt))
                  itet2(itetoff2(itetcnt)+1)=i1
                  itet2(itetoff2(itetcnt)+2)=i2
                  itet2(itetoff2(itetcnt)+3)=i3
                  itet2(itetoff2(itetcnt)+4)=i4
                  itet2(itetoff2(itetcnt)+5)=i5
                  itet2(itetoff2(itetcnt)+6)=i6
                  do i=1,nelmnef(itettyp2(it))
                     jtet2(jtetoff2(itetcnt)+i)=-1
                  enddo
                  do i=1,nelmnen(itettyp2(itetcnt))
                     i1temp=itet2(itetoff2(itetcnt)+i)
                     xicvol(i)=xic2(i1temp)
                     yicvol(i)=yic2(i1temp)
                     zicvol(i)=zic2(i1temp)
                  enddo
                  call volume_element(itettyp2(itetcnt),
     *                                xicvol,yicvol,zicvol,
     *                                xtetvol)
                  if(xtetvol.le.0.0d+00) then
C*****                     itet2(itetoff2(itetcnt)+1)=i1
C*****                     itet2(itetoff2(itetcnt)+2)=i3
C*****                     itet2(itetoff2(itetcnt)+3)=i2
C*****                     itet2(itetoff2(itetcnt)+4)=i4
C*****                     itet2(itetoff2(itetcnt)+5)=i6
C*****                     itet2(itetoff2(itetcnt)+6)=i5
                  endif
               elseif(itettyp1(it).eq.ifelmqud) then
                  i1=nnodes2+nptsl*(l-1)+itet1(itetoff1(it)+1)
                  i2=nnodes2+nptsl*(l-1)+itet1(itetoff1(it)+2)
                  i3=nnodes2+nptsl*(l-1)+itet1(itetoff1(it)+3)
                  i4=nnodes2+nptsl*(l-1)+itet1(itetoff1(it)+4)
                  i5=nptsl+i1
                  i6=nptsl+i2
                  i7=nptsl+i3
                  i8=nptsl+i4
                  itetcnt=itetcnt+1
                  itetclr2(itetcnt)=itetclr1(it)
                  itettyp2(itetcnt)=ifelmhex
                  itetoff2(itetcnt)=itoff
                  jtetoff2(itetcnt)=jtoff
                  itoff=itoff+nelmnen(itettyp2(itetcnt))
                  jtoff=jtoff+nelmnef(itettyp2(itetcnt))
                  itet2(itetoff2(itetcnt)+1)=i1
                  itet2(itetoff2(itetcnt)+2)=i2
                  itet2(itetoff2(itetcnt)+3)=i3
                  itet2(itetoff2(itetcnt)+4)=i4
                  itet2(itetoff2(itetcnt)+5)=i5
                  itet2(itetoff2(itetcnt)+6)=i6
                  itet2(itetoff2(itetcnt)+7)=i7
                  itet2(itetoff2(itetcnt)+8)=i8
                  do i=1,nelmnef(itettyp2(it))
                     jtet2(jtetoff2(itetcnt)+i)=-1
                  enddo
                  do i=1,nelmnen(itettyp2(itetcnt))
                     i1temp=itet2(itetoff2(itetcnt)+i)
                     xicvol(i)=xic2(i1temp)
                     yicvol(i)=yic2(i1temp)
                     zicvol(i)=zic2(i1temp)
                  enddo
                  call volume_element(itettyp2(itetcnt),
     *                                xicvol,yicvol,zicvol,
     *                                xtetvol)
                  if(xtetvol.le.0.0d+00) then
                     itet2(itetoff2(itetcnt)+1)=i1
                     itet2(itetoff2(itetcnt)+2)=i4
                     itet2(itetoff2(itetcnt)+3)=i3
                     itet2(itetoff2(itetcnt)+4)=i2
                     itet2(itetoff2(itetcnt)+5)=i5
                     itet2(itetoff2(itetcnt)+6)=i8
                     itet2(itetoff2(itetcnt)+7)=i7
                     itet2(itetoff2(itetcnt)+8)=i6
                     do i=1,nelmnen(itettyp2(itetcnt))
                        i1temp=itet2(itetoff2(itetcnt)+i)
                        xicvol(i)=xic2(i1temp)
                        yicvol(i)=yic2(i1temp)
                        zicvol(i)=zic2(i1temp)
                     enddo
                     call volume_element(itettyp2(itetcnt),
     *                                   xicvol,yicvol,zicvol,
     *                                   xtetvol)
                  endif
               else
                  write(logmess,9046) it
 9046             format("Illegal element to rzinterp: ",i11)
                  call writloga('default',0,logmess,0,ier)
               endif
            endif
         enddo
      enddo
C
      call cmo_set_info('nelements',cmonew,itetcnt,1,1,ierr)
C
      ipointi=nnodes2+1
      ipointj=npoints_new
      call cmo_set_info('ipointi',cmonew,
     *                ipointi,1,1,icscode)
      if (icscode .ne. 0) call x3d_error(isubname,'cmo_set_info')
      call cmo_set_info('ipointj',cmonew,
     *                ipointj,1,1,icscode)
      if (icscode .ne. 0) call x3d_error(isubname,'cmo_set_info')
C
      call geniee_cmo(cmonew)
C
      goto 9999
 9999 continue
C
      call mmrelprt(isubname,icscode)
C
      return
      end