C    @(#)kmptrl.f	20.3 2/13/96
        function kmptrl (m,n)
C

      include 'ipfinc/parametr.inc'

      include 'ipfinc/bus.inc'
      include 'ipfinc/prt.inc'
      include 'ipfinc/transf.inc'

        character idm * 1, idn * 1
C
        if (m .eq. n) then
           kmptrl = 0
        else
           m1 = kldata(1,m)
           m2 = kldata(2,m)
           n1 = kldata(1,n)
           n2 = kldata(2,n)
           kmptrl = min0 (m1,m2) - min0 (n1,n2)

           if (kmptrl .eq. 0) then
              kmptrl = max0 (m1,m2) - max0 (n1,n2)

              if (kmptrl .eq. 0) then
                 idm = char(kldata(3,m))
                 idn = char(kldata(3,n))
                 kmptrl = kompr (idm,idn,junk)

                 if (kmptrl .eq. 0) then
                    kmptrl = kldata(4,m) - kldata(4,n)

                    if (kmptrl .eq. 0) then

                        write (errbuf(1),100) bus(m1), base(m1),
     1                     bus(m2), base(m2), idm, kldata(4,m)
  100                   format ('0 Duplicate >OUTAGE branches ',
     1                          a8,f6.1,1x,a8,f6.1,1x,a1,i2)
                        call prterx ('W',1)
                        error = 1
                    endif
                 endif
              endif
           endif
        endif
        return
        end


C
C	$Id: ps.bkg_white.f,v 1.4 2008-07-27 00:59:05 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
      PROGRAM BKGWHT
C
C  This Fortran code is a filter (reads from standard input, writes
C  to standard output) for PostScript files produced from the NCAR
C  Graphics package.  It reverses the intensity color values in a
C  PostScript file (the reversal applies only to gray scale values,
C  i.e. color values with R=G=B).  This filter is written as an ad
C  hoc solution to an incompatibility with PostScript files created
C  with NCAR CGM generators prior to Release 3.01.
C
      INTEGER      CTFLG,CRFLG
      CHARACTER*80 LIN,LOUT
C
      DATA EPS /0.00001/
   10 CONTINUE
C
C  Read an input line
C
      LIN = ' '
      READ(5,100,END=80) LIN
  100 FORMAT(A80)
C
C  Determine if this is a color table setting.
C
      CTFLG = 0
      DO 20 I=1,80
      IF (LIN(I:I) .EQ. ' ') THEN
        GO TO 20
      ELSE
        IF (LIN(I:I).EQ.'c' .AND. LIN(I+1:I+1).EQ.'t') THEN
          CTFLG = I
          GO TO 30
        ENDIF
      ENDIF
   20 CONTINUE
   30 CONTINUE
      IF (CTFLG .GT. 0) THEN
C
C  Determine if the color values represent a gray value.
C
        CALL CKGRY(LIN,EPS,CTFLG,CRFLG,IDX,R,G,B)
C
C  Encode the complemented color values in LOUT.
C
        IF (CRFLG.NE.0) THEN
          LOUT = ' '
          WRITE(LOUT,500) IDX, R,G,B
  500     FORMAT(' ct ',I3,' [',F5.3,' ',F5.3,' ',F5.3,'] put')
        ELSE
          LOUT = LIN
        ENDIF
      ELSE
          LOUT = LIN
      ENDIF
C
C  Trim blanks and write to output.
C
      KPOS = 1
      DO 110 I=80,1,-1
        IF (LOUT(I:I) .NE. ' ') THEN
          KPOS = I
          GO TO 120
        ENDIF
  110 CONTINUE
  120 CONTINUE
      WRITE(6,130) (LOUT(LL:LL),LL=1,KPOS)
  130 FORMAT(80A1)
C
      GO TO 10
C
   80 CONTINUE
      STOP
      END
      SUBROUTINE CKGRY(LIN,EPS,JFLG,IFLG,IDX,R,G,B)
C
C  Check if the input line in LIN contains a gray intensity value
C  (within the limits of EPS).  IFLG is 1 if a gray value is found;
C  IFLG is 0 otherwise.  If IFLG is 1, then IDX is the color index,
C  and R, G, and B are the complemented color vlaues.
C
      CHARACTER*80 LIN,CTMP
      REAL         EPS,COLORS(3)
C
      IFLG = 0
C
C  Determine the location of the left bracket.
C
      ICOL = 0
      DO 10 I=1,80
        IF (LIN(I:I) .EQ. '[') THEN
          ICOL = I
          GO TO 20
        ELSE
          IF (I .EQ. 80) GO TO 40
          GO TO 10
        ENDIF
   10 CONTINUE
   20 CONTINUE
C
C  Get the color index.
C
      READ(LIN(JFLG+2:ICOL-2),520) IDX
  520 FORMAT(I4)
C
C  Get the three color values.
C
      JSTRT = ICOL+1
      DO 50 I=1,3
        CTMP = ' '
        K = 0
        DO 60 J=JSTRT,80
          K = K+1
          IF (LIN(J:J).EQ.' ' .OR. LIN(J:J).EQ.']') THEN
            IF (K .GT. 1) THEN
              CTMP(1:K-1) = LIN(JSTRT:J-1)
            ELSE
              GO TO 40
            ENDIF
            GO TO 70
          ELSE
            GO TO 60
          ENDIF
   60   CONTINUE
   70   CONTINUE
        READ(CTMP(1:K-1),500) COLORS(I)
  500   FORMAT(F10.3)
        JSTRT = J+1
   50 CONTINUE
C
C  Determine if we have a gray value.
C
      IFLG = 0
      IF (ABS(COLORS(1)-COLORS(2)).LE.EPS .AND.
     -    ABS(COLORS(2)-COLORS(3)).LE.EPS) IFLG = 1
C
C  Complement the color values.
C
      IF (IFLG .EQ. 1) THEN
        DO 90 I =1,3
          IF (COLORS(I) .GT. .79) THEN
            COLORS(I) = 0.
          ELSE
            COLORS(I) = 1.-COLORS(I)
          ENDIF
   90   CONTINUE
        R = COLORS(1)
        G = COLORS(2)
        B = COLORS(3)
      ELSE
        GO TO 40
      ENDIF
C
   40 CONTINUE
      RETURN
      END


module type_mesh_motion
#include <messenger.h>
    use mod_constants
    use mod_kinds,                              only: rk, ik
    use type_chidg_worker,                      only: chidg_worker_t
    use type_domain,                            only: domain_t
    use type_mesh,                              only: mesh_t
    implicit none

    !>  Mesh motion class. Abstract interface to enable treatment of prescribed mesh motion.
    !!
    !!  Data flow:
    !!  gridfile :-- readmeshmotion_hdf --> mm_group, mm_domain_data ...
    !!  :-- init_mm_group, init_mm_domain --> mesh_motion(:), mesh
    !!
    !!  @author Eric Wolf
    !!  @date   3/16/2017
    !!
    !---------------------------------------------------------------------------------------------------------------

    type, public, abstract     :: mesh_motion_t

        ! mesh motions are stored as a vector of mesh_motion_t's
        ! chidg%data%mesh%mesh_motion(1:nmm)

        !mm_ID is the unique ID for this pmm, so that it can be accessed via
        ! chidg%data%mesh%mesh_motion(mm_ID)

        integer(ik)                                                 :: mm_ID

        !mm_name is a name assigned to this mm
        ! This is used to identify the polymorphic type of the MM.
        character(:), allocatable                                   :: mm_name
        character(:), allocatable                                   :: family_name

        real(rk)                                                    :: time = 0.0_rk

    contains

        ! Deferred procedures
        procedure(init_mm_name_interface),   deferred    :: init_name
        procedure(init_mm_interface),   deferred    :: init
        procedure(update_mm_interface), deferred    :: update
        procedure(apply_mm_interface),  deferred    :: apply

        ! Standard set/get procedures for pmm_name
        procedure   :: set_name
        procedure   :: get_name

        procedure   :: set_family_name
        procedure   :: get_family_name
        !These procedures read in the intermediate mm  data structures
        !created when reading in the grid file, which are
        ! mm_group, which contains a mm instance that is used as an
        ! allocation source for the present mm, and
        ! mm_domain_data, which contains a domain name and a mm_ID,
        ! which is used to store the mm_ID of the mesh in the appropriate domain
        procedure   :: init_mm_group
        procedure   :: init_mm_domain

    end type mesh_motion_t

     abstract interface
         subroutine init_mm_name_interface(self)
            import mesh_motion_t

            class(mesh_motion_t),  intent(inout)   :: self
         end subroutine init_mm_name_interface

         subroutine init_mm_interface(self, mesh)
            use mod_kinds,  only: rk
            import mesh_motion_t
            import mesh_t

            class(mesh_motion_t),  intent(inout)   :: self
            type(mesh_t),         intent(inout)   :: mesh
        end subroutine init_mm_interface

        subroutine update_mm_interface(self, mesh, time)
            use mod_kinds,  only: rk
            import mesh_motion_t
            import mesh_t

            class(mesh_motion_t),  intent(inout)   :: self
            type(mesh_t),         intent(inout)   :: mesh
            real(rk),               intent(in)      :: time
        end subroutine update_mm_interface

        subroutine apply_mm_interface(self, mesh, time)
            use mod_kinds,  only: rk
            import mesh_motion_t
            import mesh_t

            class(mesh_motion_t),  intent(inout)   :: self
            type(mesh_t),         intent(inout)   :: mesh
            real(rk),               intent(in)      :: time
        end subroutine apply_mm_interface

    end interface

contains

    !>
    !!  @author Eric Wolf
    !!  @date 4/7/2017
    !--------------------------------------------------------------------------------
    subroutine set_name(self,mm_name)
        class(mesh_motion_t),            intent(inout)       :: self
        character(*),                               intent(in)          :: mm_name

        self%mm_name = mm_name

    end subroutine set_name
    !********************************************************************************

    !>
    !!  @author Eric Wolf
    !!  @date 4/7/2017
    !--------------------------------------------------------------------------------
    function get_name(self) result(mm_name)
        class(mesh_motion_t),            intent(inout)       :: self

        character(len=:), allocatable                                   :: mm_name

        mm_name =  self%mm_name

    end function get_name
    !********************************************************************************

    !>
    !!  @author Eric Wolf
    !!  @date 4/7/2017
    !--------------------------------------------------------------------------------
    subroutine set_family_name(self,mm_name)
        class(mesh_motion_t),            intent(inout)       :: self
        character(*),                               intent(in)          :: mm_name

        self%family_name = mm_name

    end subroutine set_family_name
    !********************************************************************************

    !>
    !!  @author Eric Wolf
    !!  @date 4/7/2017
    !--------------------------------------------------------------------------------
    function get_family_name(self) result(mm_name)
        class(mesh_motion_t),            intent(inout)       :: self

        character(len=:), allocatable                                   :: mm_name

        mm_name =  self%family_name

    end function get_family_name
    !********************************************************************************

    !>
    !!  This subroutine takes a an input mm (from a mm_group, which is generated by reading in the
    !!  grid file and initializing a mm instance according to a MM group),
    !!  and uses this mm instance as an allocation source for the present mm.
    !!
    !!  @author Eric Wolf
    !!  @date 4/7/2017
    !--------------------------------------------------------------------------------
    subroutine init_mm_group(self,mm_in)
        class(mesh_motion_t),               intent(inout)       :: self
        class(mesh_motion_t),               intent(inout)       :: mm_in

        integer(ik)     :: ierr

        call self%set_name(mm_in%get_name())

    end subroutine init_mm_group
    !********************************************************************************

    !>
    !!  This subroutine takes in a mesh (domain) that was selected from a
    !!  mm_domain_data_t, whch is generated by reading in the grid file,
    !!  and sets the mm_ID for all elements and faces in the mesh (domain)
    !!  to be equal to the present mm_ID.
    !!
    !!  Called from chidg%data%add_mm_domain(..)
    !!
    !!  @author Eric Wolf
    !!  @date 4/7/2017
    !--------------------------------------------------------------------------------
    subroutine init_mm_domain(self,domain)
        class(mesh_motion_t),               intent(inout)       :: self
        type(domain_t),                                       intent(inout)           ::domain

        integer(ik)     :: ielem, nelem, iface

        ! Loop through the elements and faces in the mesh and assign the mm_ID

        domain%mm_ID = self%mm_ID
        nelem = domain%nelem
        do ielem = 1, nelem
            !Check if a MM has already been assigned
            !if (mesh%elems(ielem)%mm_ID /= NO_MM_ASSIGNED)  then
            !   bad bad bad
            !else
            domain%elems(ielem)%mm_ID = self%mm_ID
            do iface = 1, NFACES
                domain%faces(ielem, iface)%mm_ID = self%mm_ID
            end do
            !end if
        end do

    end subroutine init_mm_domain
    !********************************************************************************

end module type_mesh_motion


    program demo_atomic_fetch_and
    use iso_fortran_env
    implicit none
    integer(atomic_int_kind) :: atom[*], old
       call atomic_fetch_and (atom[1], int(b'10100011101'), old)
    end program demo_atomic_fetch_and


fl

1 wconstant build_hdserial

{
forth routines 25kbps max (80 Mhz clock), 14.5kpbs max for open collector
assembler routines 3.636Mbs max (80Mhz clock - max is clkfreq / 22)

because of rounding the actual bitrate will be:

clkfreq clkfreq desiredbaud u/ u/

usage:

\ allocate a serial structure, the txpin and the rxpin can be the same pin
d_9600 d_9600 d_16 d_16 hdserialStruct ser

\ to send data
data ser hdserialTx
\ or for Open Collector drive
data ser hdserialTxOC

\ to receive data - this will wait for a byte
ser hdserialRx

to run tests:

uncomment hdserial_test definition
load this file

test -	starts test uses cog 0 & 1 , use pin 16 as the serial pin
	pin 17 is the default for test_syncPin, test_syncPin will
	be low while a character is transmitting. This is useful
	for debugging and syncing with LogicAnalyzer.
	Specifying an invalid output pin for test_syncPin will
	disable this.

testOC - same as test, but uses open collector

test_stat - dumps current test stat

test_test_error - causes an error by putting "noise on the pin"

}

\
\ uncomment this to use the forth routines instead of assembler
\
\ 1 wconstant hdserial_forth

\
\ uncomment this to include test routines
\
 1 wconstant hdserial_test

{
half duplex serial structure
00 - 04 -- rx bitticks
04 - 08 -- tx bitticks
08 - 0C -- rx pin mask
0C - 10 -- tx pin mask
}
\ hdserialStruct ( rxbaud txbaud rxpin txpin -- )
: hdserialStruct
	lockdict variable hC allot lastnfa nfa>pfa 2+ alignl freedict
	tuck swap >m swap hC + L!
	tuck swap >m swap h8 + L!
	tuck swap clkfreq swap u/ swap h4 + L!
	swap clkfreq swap u/ swap L!
;

{
fl
build_BootOpt :rasm
\ treg6 - serpin mask
\ treg5 - bitticks
\ treg4 - cnt nextbit
\ treg1 - serialStruct
\ stTOS - data
	spopt

	add	$C_treg1 , # h4
	rdlong	$C_treg5 , $C_treg1
	add	$C_treg1 , # h8
	rdlong	$C_treg6 , $C_treg1
\
\ serpin high
\
	or	outa , $C_treg6
	or	dira , $C_treg6
\
\ data + 2 stop bits + start bit
\
	or	$C_stTOS , __h300
	shl	$C_stTOS , # 1
\
\ first loop tick count count
\
	mov	$C_treg4 , $C_treg5
	add	$C_treg4 , cnt
	mov	$C_treg3 , # d_11
__txloop
	waitcnt	$C_treg4 , $C_treg5
	test	$C_stTOS , # 1 wz
	muxnz	outa , $C_treg6
	shr	$C_stTOS , # 1
	djnz	$C_treg3 , # __txloop
	spop
\
\ serpin in
\
	andn	dira , $C_treg6
\
	jexit
__h300
	h300
;asm hdserialTx

build_BootOpt :rasm
\ treg6 - serpin mask
\ treg5 - bitticks
\ treg4 - cnt nextbit
\ treg1 - serialStruct
\ stTOS - data
	spopt

	add	$C_treg1 , # h4
	rdlong	$C_treg5 , $C_treg1
	add	$C_treg1 , # h8
	rdlong	$C_treg6 , $C_treg1
\
\ serpin high
\
	andn	dira , $C_treg6
	andn	outa , $C_treg6
\
\ data + 2 stop bits + start bit
\
	or	$C_stTOS , __h300
	shl	$C_stTOS , # 1
\
\ first loop tick count count
\
	mov	$C_treg4 , $C_treg5
	add	$C_treg4 , cnt
	mov	$C_treg3 , # d_11
__txloop
	waitcnt	$C_treg4 , $C_treg5
	test	$C_stTOS , # 1 wz
	muxz	dira , $C_treg6
	shr	$C_stTOS , # 1
	djnz	$C_treg3 , # __txloop
	spop
\
\ serpin in
\
	andn	dira , $C_treg6
\
	jexit
__h300
	h300
;asm hdserialTxOC

build_BootOpt :rasm
\ treg6 - serpin mask
\ treg5 - bitticks
\ treg4 - cnt nextbit
\ treg1 - serialStruct
\ stTOS - data

	rdlong	$C_treg5 , $C_stTOS
	add	$C_stTOS , # h8
\
\ receive bit counter
\
	mov	$C_treg3 , # d_8
\
	rdlong	$C_treg6 , $C_stTOS
\
\ serpin as input
\
	andn	dira , $C_treg6
\
\ data byte
\
	mov	$C_stTOS , # 0
\
\ first loop tick count, 1.25 bit times  so we sample closer to the middle
\ necessary in the assembler routine, in the forth routine, the delays of the loop setup
\ make this unecessary so we only use 1 bit time
\
	mov	$C_treg4 , $C_treg5
	shr	$C_treg4 , # 2
	add	$C_treg4 , $C_treg5

\
\ wait for a hi to lo transition
\
	waitpeq	$C_treg6 , $C_treg6
	waitpne	$C_treg6 , $C_treg6
\
\ first loop tick count
\
	add	$C_treg4 , cnt
__rxloop
	waitcnt	$C_treg4 , $C_treg5
	test	$C_treg6 , ina	wz
\
	shr	$C_stTOS , # 1
	muxnz	$C_stTOS , # h_80
\
	djnz	$C_treg3 , # __rxloop
\
	jexit
;asm hdserialRx
}

[ifndef hdserial_forth

lockdict create hdserialTx forthentry
$C_a_lxasm w, h128  h113  1- tuck - h9 lshift or here W@ alignl h10 lshift or l,
z1SyLIZ l, z20yPW4 l, z8iQ3C l, z20yPW8 l, z8iQBC l, z1bixZH l, z1bixmH l, z1biPSa l,
zfyPO1 l, z2WiPuG l, z20iPyk l, z2WyPjB l, z3riPuG l, z1YVPO1 l, z1vixZH l, zbyPO1 l,
z3[yPnV l, z1SyLI[ l, z1[ixmH l, z1SV01X l, zC0 l,
freedict

lockdict create hdserialTxOC forthentry
$C_a_lxasm w, h128  h113  1- tuck - h9 lshift or here W@ alignl h10 lshift or l,
z1SyLIZ l, z20yPW4 l, z8iQ3C l, z20yPW8 l, z8iQBC l, z1[ixmH l, z1[ixZH l, z1biPSa l,
zfyPO1 l, z2WiPuG l, z20iPyk l, z2WyPjB l, z3riPuG l, z1YVPO1 l, z1rixmH l, zbyPO1 l,
z3[yPnV l, z1SyLI[ l, z1[ixmH l, z1SV01X l, zC0 l,
freedict

lockdict create hdserialRx forthentry
$C_a_lxasm w, h125  h113  1- tuck - h9 lshift or here W@ alignl h10 lshift or l,
z8iQ3B l, z20yPO8 l, z2WyPj8 l, z8iQBB l, z1[ixmH l, z2WyPO0 l, z2WiPuG l, zbyPr2 l,
z20iPuG l, z3jFQBH l, z3nFQBH l, z20iPyk l, z3riPuG l, z1YFQFl l, zbyPO1 l, z1vyPQ0 l,
z3[yPnV l, z1SV01X l,
freedict

]

[ifdef hdserial_forth

\ _maskPinin ( mask -- )
: _maskPinin
	dira COG@ swap andn dira COG!
;

\ _maskPinout ( mask -- )
: _maskPinout
	dira COG@ swap or dira COG!
;

\ hdserialRx ( serialStruct -- data)
: hdserialRx
	dup h8 + L@ dup _maskPinin
\
\ serialStruct serpinmask --
\
	swap L@
\
\ serpinmask  bitticks--
\
\
\ wait for a start bit
\
	over dup dup dup
	waitpeq waitpne
	0 swap
\
\ serpinmask data bitticks --
\
\ sample first bit in 1 bit times
\
	dup cnt COG@ +
\
\ serpinmask data bitticks cnt_nextbit --
\
\ receive the bits, lsb first
\
	d8 0
	do
\
\ serpinmask data bitticks cnt_nextbit --
\
		over waitcnt
		3 ST@ _maskin
\
\ serpinmask data bitticks cnt_nextbit flag --
\
		if
			h80
		else
			0
		then
		3 ST@ 1 rshift or 2 ST!
	loop
\
\ clean up
\
	2drop nip
;

\ hdserialTX ( data serialStruct -- )
: hdserialTx
\
\ serpin hi
\
	dup hC + L@ dup _maskouthi dup _maskPinout swap
\
\ data serpinmask serialStruct
\
	4 + L@
\
\ data serpinmask bitticks --
\
\
\ data + 2 stop bits + start bit
\
	rot h300 or 1 lshift swap
\
\ serpinmask bits bitticks --
\
	dup cnt COG@ +
\
\ serpinmask bits bitticks cnt_nextbit --
\
\ send the bits, lsb first, send 1 stop bit at the beginning and one at the end
\
	d11 0
	do
\
\ serpinmask bits bitticks cnt_nextbit --
\
		over waitcnt
		2 ST@
\
\ serpinmask bits bitticks cnt_nextbit bits --
\
		dup 1 and
		if
			4 ST@ _maskouthi
		else
			4 ST@ _maskoutlo
		then
		1 rshift 2 ST!
	loop
\
\ clean up
\
	3drop
\
\ serpinmask --
	_maskPinin
;

\ hdserialTxOC ( data serialStruct -- )
: hdserialTxOC
\
\ serpin hi
\
	dup hC + L@ dup _maskoutlo dup _maskPinin swap
\
\ data serpinmask serialStruct
\
	4 + L@
\
\ data serpinmask bitticks --
\
\
\ data + 2 stop bits + start bit
\
	rot h300 or 1 lshift swap
\
\ serpinmask bits bitticks --
\
	dup cnt COG@ +
\
\ serpinmask bits bitticks cnt_nextbit --
\
\ send the bits, lsb first, send 1 stop bit at the beginning and one at the end
\
	d11 0
	do
\
\ serpinmask bits bitticks cnt_nextbit --
\
		over waitcnt
		2 ST@
\
\ serpinmask bits bitticks cnt_nextbit bits --
\
		dup 1 and
		if
			4 ST@ _maskPinin
		else
			4 ST@ _maskPinout
		then
		1 rshift 2 ST!
	loop
\
\ clean up
\
	3drop
\
\ serpinmask --
	_maskPinin
;
]

[ifdef hdserial_test

d_9600 d_9600 d_16 d_16 hdserialStruct ser

d_17 wconstant test_syncPin

\ _maskPinin ( mask -- )
: _maskPinin
	dira COG@ swap andn dira COG!
;

\ _maskPinout ( mask -- )
: _maskPinout
	dira COG@ swap or dira COG!
;

variable numtestchars
variable numtesterrors

: test_transmit
	c" TEST_TX" cds W!
	4 state andnC!
	test_syncPin 0 d_31 between
	if
		test_syncPin >m dup _maskPinout
	else
		0
	then
	begin
		key over _maskoutlo ser hdserialTx dup _maskouthi
	0 until
;

: test_transmitOC
	c" TEST_TX" cds W!
	4 state andnC!
	test_syncPin 0 d_31 between
	if
		test_syncPin >m dup _maskPinout
	else
		0
	then
	begin
		key over _maskoutlo ser hdserialTxOC dup _maskouthi
	0 until
;

: test_loop
	0 numtestchars L!
	0 numtesterrors L!
	c" TEST_RX" cds W!
	4 state andnC!
	0 cogreset 100 delms c" test_transmit" 0 cogx
	cogid 0 ioconn
	0 begin
		dup numtestchars L!
		dup hFF and dup emit
		ser hdserialRx
		2dup <>
		if
			numtesterrors L@ 1+ numtesterrors L!
			hex c" actual: " .concstr .conbyte c"  expected: " .concstr .conbyte .concr
		else
			2drop
		then
		1+
	0 until
;

: test_loopOC
	0 numtestchars L!
	0 numtesterrors L!
	c" TEST_RX" cds W!
	4 state andnC!
	0 cogreset 100 delms c" test_transmitOC" 0 cogx
	cogid 0 ioconn
	0 begin
		dup numtestchars L!
		dup hFF and dup emit
		ser hdserialRx
		2dup <>
		if
			numtesterrors L@ 1+ numtesterrors L!
			hex c" actual: " .concstr .conbyte c"  expected: " .concstr .conbyte .concr
		else
			2drop
		then
		1+
	0 until
;

: test
	1 iodis
	1 cogreset 100 delms c" test_loop" 1 cogx
;

: testOC
	1 iodis
	1 cogreset 100 delms c" test_loopOC" 1 cogx
;

: test_stat
	." num chars: " numtestchars L@ . ." num errors: " numtesterrors L@ . cr
;

: test_test_error
	ser hC + L@
	dup _maskouthi dup _maskPinout
	d_10 delms
	dup _maskoutlo _maskPinin
;

\ test_set_baud ( baud -- )
: test_set_baud
	clkfreq swap u/ ser 2dup L! 4+ L!
;
]


      subroutine tfgetv(word,lfno,next,exist)
      use tfstk
      use ffs
      use ffs_pointer
      use tffitcode
      use tfcsi,only:ipoint
      use tflinepcom
      use ffs_seg
      implicit none
      type (sad_comp), pointer :: cmpd
      type (sad_descriptor) kx
      type (sad_rlist),pointer:: kl
      integer*8 kav
      integer*4 ,intent(in):: lfno
      integer*4 ,intent(out):: next
      integer*4 ii,i,id,iv,ivi,kv,next1,lw1,j,lv,
     $     nl,irtc,lw,iii,lenw,isp0,itfuplevel,itfdownlevel,
     $     ivj
      real*8 v,getva,va,vx
      character*(*) ,intent(in):: word
      character*128 word1
      logical*4 ,intent(out):: exist
      logical*4 get,rel,maxf,minf,
     $     abbrev,var,exist1,diff,vcomp, cont,vs,nvs

c     Initialize to avoid compiler warning
      lv=itfuplevel()
      if(iflinep .eq. 0)then
        call tfinitlinep(irtc)
      endif
      vs=.false.
      nvs=.false.
      v=0
      kv=-1
      iv=-1
      id=0
      isp0=isp
c
      vcomp=index(word,'.') .gt. 0
      cont=.false.
 1    exist=.false.
      get=.true.
      rel=.false.
      maxf=.false.
      minf=.false.
      diff=.true.
      id=0
      lw=len_trim(word)
      call tfgetlineps(word,lw,nl,kav,1,irtc)
      if(irtc .ne. 0 .or. nl .le. 0)then
        go to 9000
      endif
      exist=.true.
      LOOP_II: do iii=1,nl
        i=int(rlist(kav+iii))
        ii=nelvx(i)%klp
        if(get)then
          id=idtypec(ii)
          get=.false.
          iv=nelvx(i)%ival
          kv=0
          var=.true.
          call peekwd(word1,next1)
          lw1=lenw(word1)
          if(lw1 .gt. MAXPNAME)then
            go to 912
          endif
          call capita1(word1(1:lw1))
          if(abbrev(word1,'R_ELATIVE','_'))then
            rel=.true.
          elseif(word1 .eq. 'MAX')then
            maxf=.true.
          elseif(word1 .eq. 'MIN')then
            minf=.true.
          elseif(word1 .eq. 'MAXABS' .or. word1 .eq. 'ABSMAX' .or.
     1           word1 .eq. 'MAXMIN' .or. word1 .eq. 'MINMAX')then
            maxf=.true.
            minf=.true.
          elseif(word1 .eq. ' ' .or. word1 .eq. '-')then
            next=next1
            ipoint=next
            exist=.true.
            if(cont)then
              go to 9000
            else
              call termes(lfno,'?Missing value for ',word)
              exist=.false.
              exit
            endif
          else
            kv=itftypekey(id,word1,lw1,kx)
            if(kv .eq. 0)then
              go to 912
            else
              iv=merge(-1,kv,tfreallistq(kx,kl))
            endif
          endif
          next=next1
          ipoint=next
          exist=.true.
 912      if(iv .eq. 0)then
            call termes(lfno,'?No default keyword for ',word)
            exist=.false.
            exit
          endif
          v=getva(exist1)
          if(.not. exist1)then
            if(cont)then
            else
              call termes(lfno,'?Missing value for ',word)
            endif
            exist=.false.
            exit
          endif
        endif
        if(idtypec(ii) .ne. id)then
          id=idtypec(ii)
          kv=itftypekey(id,word1,lw1,kx)
          if(kv .gt. 0)then
            ivi=kv
          else
            ivi=merge(-1,nelvx(i)%ival,tfreallistq(kx,kl))
          endif
          if(ivi .eq. 0)then
            cycle LOOP_II
          endif
          if(diff)then
            call termes(lfno,
     1           'Info-Different types of elements match ',
     $           word(1:lw)//" "//word1(1:lw1))
            diff=.false.
          endif
        else
          ivi=iv
        endif
        if(minf .or. maxf)then
          ivi=nelvx(i)%ival
        endif
        if(ivi .eq. 0)then
          call termes(lfno,'?No default keyword for ',word)
          exist=.false.
          exit
        endif
        var=ivi .eq. nelvx(i)%ival
        if(rel)then
          call loc_comp(idvalc(ii),cmpd)
          va=cmpd%value(ivi)*(1.d0+v)
        else
          va=v
        endif
        call compelc(ii,cmpd)
        cmpd%update=cmpd%nparam .le. 0
        if(var)then
          vx=cmpd%value(ivi)/errk(1,ii)
          if(minf)then
            if(maxf)then
              nelvx(i)%vlim(1)=-abs(va)
              nelvx(i)%vlim(2)=abs(va)
              vx=min(abs(va),max(-abs(va),vx))
            else
              nelvx(i)%vlim(1)=va
              vx=max(va,vx)
            endif
          elseif(maxf)then
            nelvx(i)%vlim(2)=va
            vx=min(va,vx)
          else
            vx=va
          endif
c          call tfsetcmp(vx*errk(1,ii),cmpd,ivi)
          cmpd%value(ivi)=vx*errk(1,ii)
c          rlist(latt(ii)+ivi)=vx*errk(1,ii)
        else
          vx=va
          if(ivi .gt. 0)then
            if(ktfnonrealq(cmpd%dvalue(ivi)))then
              call tfree(ktfaddr(cmpd%dvalue(ivi)))
            endif
            cmpd%value(ivi)=vx
            if(.not. vcomp)then
              call tftouch(i,ivi)
              isp=isp+1
              itastk(1,isp)=i
              itastk(2,isp)=ivi
            endif
          else
            do j=1,kl%nl
              ivj=int(kl%rbody(j))
              if(ktfnonrealq(cmpd%dvalue(ivj)))then
                call tfree(ktfaddr(cmpd%dvalue(ivj)))
              endif
              cmpd%value(ivj)=vx
              if(.not. vcomp)then
c                call tftouch(i,ivi)
                isp=isp+1
                itastk(1,isp)=i
                itastk(2,isp)=ivj
              endif
            enddo
          endif
        endif
        if(.not. vcomp)then
          isp=isp+1
          itastk(1,isp)=i
          itastk(2,isp)=ivi
          vs=vs .or. var
          nvs=nvs .or. .not. var
        endif
      enddo LOOP_II
      if(exist)then
        cont=.true.
        go to 1
      endif
 9000 if(isp .gt. isp0)then
        call tffsadjust1(isp0,vs,nvs)
      endif
      isp=isp0
      lv=itfdownlevel()
      return
      end


      program isubaregion
      use mod_za  ! HYCOM I/O interface
      use mod_zb  ! HYCOM I/O interface for subregion
      implicit none
c
c     create a diferent-grid subregion from a full region archive file.
c
c     subregion grid is arbitrary, except that any part of this grid
c     that is outside the input grid must be land.
c
c     same resolution grid is allowed.  this is usually handled by
c     subregion.f, but use this program (or isubregion.f) when the
c     bathymetries are not identical over the subregion.
c
c     subregion same as region is allowed.  this provides a way to
c     restart a run with a different coastline and/or bathymetry,
c     i.e. original archive -> modified archive -> modified restart.
c
c     if the output grid is an integer multiple of the original, with
c     co-located p-grid points, then isubregion.f will be faster and
c     it will also produce more accurate velocity fields.
c
c     first run isuba_gmap to generate the sub-region grid map.
c
c     Alan J. Wallcraft,  NRL,  July 2002 and January 2009.
c
      character*80         :: cline,cline_u,cline_out
      character*256        :: flnm_in, flnm_tin,
     &                        flnm_out,flnm_top,flnm_reg,flnm_map
      integer              :: idm_out,jdm_out
      integer              :: i,ii,ios,ip,itmp,j,jj,jp,jq,l,
     &                        ni,nir,no,nor
      integer              :: k,l0,l1, ibadl,ibads
      integer              :: if_sm,il_sm,jf_sm,jl_sm
      logical              :: lrot(2),lcheck,lnotsd
      logical              :: layave,laythk,smooth,icegln
      real                 :: hmina,hminb,hmaxa,hmaxb,
     &                        rtmp,up,vp
      integer, allocatable ::    m_sm(:,:),    iv_sm(:,:)
      integer, allocatable ::    m_in(:,:),    m_out(:,:),
     &                                         m_osm(:,:)
      real,    allocatable ::    a_in(:,:),    a_out(:,:)
      real,    allocatable ::    u_in(:,:),    u_out(:,:)
      real,    allocatable ::    v_in(:,:),    v_out(:,:)
      real,    allocatable ::    t_in(:,:),    t_out(:,:,:)
      real,    allocatable ::    h_in(:,:)
      real,    allocatable ::    p_in(:,:,:),  p_out(:,:,:)
      real,    allocatable :: pang_in( :,:),pang_out(:,:)
c
      integer, allocatable :: i_out(:,:),j_out(:,:)
      real,    allocatable :: x_out(:,:),y_out(:,:)
c
      real,    parameter   :: hspval=0.5*2.0**100  ! half spval
      real,    parameter   :: onem=9806.0          ! g/thref
      real,    parameter   :: tenm=10.0*onem
c
      call xcspmd
      call zaiost
      call blkdat(idm_out,jdm_out,
     &            layave,smooth,icegln,
     &            flnm_reg,flnm_map,flnm_in,flnm_tin,
     &            flnm_out,flnm_top,cline_out)
      call zbiost(idm_out,jdm_out)
c
      allocate(   iv_sm(jdm,2) )
c
      allocate(    m_sm(idm,jdm),     m_osm(idm_out,jdm_out) )
      allocate(    m_in(idm,jdm),     m_out(idm_out,jdm_out) )
      allocate(    a_in(idm,jdm),     a_out(idm_out,jdm_out) )
      allocate(    u_in(idm,jdm),     u_out(idm_out,jdm_out) )
      allocate(    v_in(idm,jdm),     v_out(idm_out,jdm_out) )
      allocate(    t_in(idm,jdm),     t_out(idm_out,jdm_out,3) )
      allocate(    p_in(idm,jdm,0:1), p_out(idm_out,jdm_out,0:1) )
      allocate( pang_in(idm,jdm),  pang_out(idm_out,jdm_out) )
c
      if     (layave) then
        allocate(  h_in(idm,jdm) )
      endif
c
      allocate( i_out(idm_out,jdm_out), j_out(idm_out,jdm_out) )
      allocate( x_out(idm_out,jdm_out), y_out(idm_out,jdm_out) )
c
c     get the output p-grid mask from the bathymetry.
c
      l  = len_trim(flnm_top)
      open (unit=13,file=flnm_top(1:l-2)//'.b',form='formatted',
     .      status='old',action='read')
      write(lp,'(/a)') 'OUTPUT BATHYMETRY:'
      do i= 1,6
        read( 13,'(a)') cline
        write(lp,'(a)') cline(1:len_trim(cline))
      enddo
      l = index(cline,'=')
      read (cline(l+1:),*)  hminb,hmaxb
      close(unit=13)
c
      l  = len_trim(flnm_top)
      call zbiopf(flnm_top(1:l-2)//'.a','old', 13)
      call zbiord(t_out(1,1,1),m_out,.false., hmina,hmaxa, 13)
      call zbiocl(13)
      if     (abs(hmina-hminb).gt.abs(hminb)*1.e-4 .or.
     &        abs(hmaxa-hmaxb).gt.abs(hmaxb)*1.e-4     ) then
        write(lp,'(/ a / a,1p3e14.6 / a,1p3e14.6 /)')
     &    'error - output bathymetry .a and .b files not consistent:',
     &    '.a,.b min = ',hmina,hminb,hmina-hminb,
     &    '.a,.b max = ',hmaxa,hmaxb,hmaxa-hmaxb
        stop
      endif
c
      do j= 1,jdm_out
        do i= 1,idm_out
          if     (t_out(i,j,1).gt.hspval .or.
     &            t_out(i,j,1).le.0.0        ) then
            t_out(i,j,1) = 0.0
            m_out(i,j)   = 0
          else
            t_out(i,j,1) = t_out(i,j,1)*onem
            m_out(i,j)   = 1
          endif
        enddo
      enddo
c
c     get the input p-grid mask from the bathymetry.
c
      l  = len_trim(flnm_tin)
      open (unit=13,file=flnm_tin(1:l-2)//'.b',form='formatted',
     .      status='old',action='read')
      write(lp,'(/a)') ' INPUT BATHYMETRY:'
      do i= 1,6
        read( 13,'(a)') cline
        write(lp,'(a)') cline(1:len_trim(cline))
      enddo
      l = index(cline,'=')
      read (cline(l+1:),*)  hminb,hmaxb
      close(unit=13)
c
      l  = len_trim(flnm_tin)
      call zaiopf(flnm_tin(1:l-2)//'.a','old', 13)
      call zaiord(t_in,m_in,.false., hmina,hmaxa, 13)
      call zaiocl(13)
      if     (abs(hmina-hminb).gt.abs(hminb)*1.e-4 .or.
     &        abs(hmaxa-hmaxb).gt.abs(hmaxb)*1.e-4     ) then
        write(lp,'(/ a / a,1p3e14.6 / a,1p3e14.6 /)')
     &    'error - bathymetry .a and .b files not consistent:',
     &    '.a,.b min = ',hmina,hminb,hmina-hminb,
     &    '.a,.b max = ',hmaxa,hmaxb,hmaxa-hmaxb
        stop
      endif
c
      do j= 1,jdm
        do i= 1,idm
          if     (t_in(i,j).gt.hspval .or.
     &            t_in(i,j).le.0.0        ) then
            t_in(i,j) = 0.0
            m_in(i,j) = 0
            m_sm(i,j) = 0
          else
            t_in(i,j) = t_in(i,j)*onem
            m_in(i,j) = 1
            m_sm(i,j) = 1
          endif
        enddo
      enddo
c
c     read the input and output grid locations (no error checking).
c
      nir = 24
      call zaiopf('regional.grid.a','old', nir)
      call zaiosk(nir) !plon
      call zaiosk(nir) !plat
      call zaiosk(nir) !qlon
      call zaiosk(nir) !qlat
      call zaiosk(nir) !ulon
      call zaiosk(nir) !ulat
      call zaiosk(nir) !vlon
      call zaiosk(nir) !vlat
      call zaiord(pang_in,m_in,.false., hmina,hmaxa, nir)
      call zaiocl(nir)
c
      nor = 25
      call zbiopf(trim(flnm_reg),'old', nor)
      call zbiosk(nor) !plon
      call zbiosk(nor) !plat
      call zbiosk(nor) !qlon
      call zbiosk(nor) !qlat
      call zbiosk(nor) !ulon
      call zbiosk(nor) !ulat
      call zbiosk(nor) !vlon
      call zbiosk(nor) !vlat
      call zbiord(pang_out,m_out,.false., hmina,hmaxa, nor)
      call zbiocl(nor)
c
      nor = 26
      call zbiopf(trim(flnm_map),'old', nor)
      call zbiord(x_out,m_out,.false., hmina,hmaxa, nor)
      call zbiord(y_out,m_out,.false., hmina,hmaxa, nor)
      call zbiocl(nor)
c
      do jj= 1,jdm_out
        do ii= 1,idm_out
          if     (x_out(ii,jj).lt.hspval) then
            i_out(ii,jj) = int(x_out(ii,jj))
            x_out(ii,jj) =     x_out(ii,jj) - i_out(ii,jj)
            j_out(ii,jj) = int(y_out(ii,jj))
            y_out(ii,jj) =     y_out(ii,jj) - j_out(ii,jj)
          else  !update output mask
            m_out(ii,jj) = 0
          endif
        enddo !ii
      enddo !jj
c
      lrot(1) = minval(pang_in(:,:)).ne.0.0 .or.
     &          maxval(pang_in(:,:)).ne.0.0
      if     (.not.lrot(1)) then
        write(6,'(a)') ' input domain is     aligned E-W,N-S'
      else
        write(6,'(a)') ' input domain is not aligned E-W,N-S'
      endif
c
      lrot(2) = minval(pang_out(:,:)).ne.0.0 .or.
     &          maxval(pang_out(:,:)).ne.0.0
      if     (.not.lrot(2)) then
        write(6,'(a)') 'output domain is     aligned E-W,N-S'
      else
        write(6,'(a)') 'output domain is not aligned E-W,N-S'
      endif
c
c --- form the p-grid smoother mask,
c --- set to 2 if a land point is needed for interpolation.
c --- we are assuming that "2" is never needed outside the
c --- target subregion, which will be the case unless the
c --- subregion rectangle is poorly chosen.
c
      do jj= 1,jdm_out
        do ii= 1,idm_out
          if     (m_out(ii,jj).eq.1) then
            j  = j_out(ii,jj)
            i  = i_out(ii,jj)
            jp = min(j+1,jdm)
            if     (i.ne.idm) then
              ip = i+1
            else  !lperiod
              ip =   1
            endif
            if     (m_sm(i, j ).eq.0) then
              m_sm(i, j ) = 2
            endif
            if     (m_sm(i, jp).eq.0) then
              m_sm(i, jp) = 2
            endif
            if     (m_sm(ip,j ).eq.0) then
              m_sm(ip,j ) = 2
            endif
            if     (m_sm(ip,jp).eq.0) then
              m_sm(ip,jp) = 2
            endif
          endif
        enddo
      enddo
c
      do j= 1,jdm
        iv_sm(j,1) = idm
        do i= 1,idm
          if     (m_sm(i,j).eq.2) then
            iv_sm(j,1) = i
            exit
          endif
        enddo
        iv_sm(j,2) = 1
        do i= idm,iv_sm(j,1),-1
          if     (m_sm(i,j).eq.2) then
            iv_sm(j,2) = i
            exit
          endif
        enddo
      enddo
      jf_sm = jdm
      do j= 1,jdm
        if     (iv_sm(j,1).le.iv_sm(j,2)) then
          jf_sm = j
          exit
        endif
      enddo
      jl_sm = 1
      do j= jdm,jf_sm,-1
        if     (iv_sm(j,1).le.iv_sm(j,2)) then
          jl_sm = j
          exit
        endif
      enddo
      if_sm = minval(iv_sm(:,1))
      il_sm = maxval(iv_sm(:,2))
c
c     interpolate the input bathymetry to the output grid.
c
      call landfill(  t_in,m_sm,   idm,    jdm,
     &                iv_sm,if_sm,il_sm,jf_sm,jl_sm)
      call bilinear_p(t_in,        idm,    jdm,
     &                t_out(1,1,2),idm_out,jdm_out,
     &                m_out,i_out,j_out,x_out,y_out)
c
c     allow for a bottom boundary layer
c
      do j= 1,jdm_out
        do i= 1,idm_out
          if     (m_out(i,j).eq.1) then
            t_out(i,j,3) = t_out(i,j,2) -
     &                     max( onem,
     &                          min( tenm,
     &                               t_out(i,j,2)*0.03 ) )
          endif
        enddo
      enddo
c
c     open input and output files.
c
      ni = 14
      l  = len_trim(flnm_in)
      open (unit=ni,file=flnm_in(1:l-2)//'.b',form='formatted',
     .      status='old',action='read')
      call zaiopf(flnm_in(1:l-2)//'.a','old', ni)
c
      no = 15
      l  = len_trim(flnm_out)
      open (unit=no,file=flnm_out(1:l-2)//'.b',form='formatted',
     .      status='new',action='write')
      call zbiopf(flnm_out(1:l-2)//'.a','new', no)
c
c     process the archive header
c
      write(lp,'(/a)') 'ARCHIVE HEADER:'
c
      read( ni,'(a)') cline  ! ctitle(1)
      write(no,'(a)') cline
      write(lp,'(a)') cline(1:len_trim(cline))
c
      read( ni,'(a)') cline  ! ctitle(2)
      write(no,'(a)') cline
      write(lp,'(a)') cline(1:len_trim(cline))
c
      read( ni,'(a)') cline  ! ctitle(3)
      write(no,'(a)') cline
      write(lp,'(a)') cline(1:len_trim(cline))
c
      read( ni,'(a)') cline  ! ctitle(4), replace with cline_out
      write(no,'(a)') cline_out
      write(lp,'(a)') cline_out(1:len_trim(cline))
c
      read( ni,'(a)') cline  ! iversn
      write(no,'(a)') cline
      write(lp,'(a)') cline(1:len_trim(cline))
c
      read( ni,'(a)') cline  ! iexpt
      write(no,'(a)') cline
      write(lp,'(a)') cline(1:len_trim(cline))
c
      read( ni,'(a)') cline  ! yrflag
      write(no,'(a)') cline
      write(lp,'(a)') cline(1:len_trim(cline))
c
      read( ni,'(a)') cline  ! idm, replace with idm_out
      write(no,'(i5,4x,a)') idm_out,"'idm   ' = longitudinal array size"
      write(lp,'(i5,4x,a)') idm_out,"'idm   ' = longitudinal array size"
c
      read( ni,'(a)') cline  ! jdm, replace with jdm_out
      write(no,'(i5,4x,a)') jdm_out,"'jdm   ' = latitudinal  array size"
      write(lp,'(i5,4x,a)') jdm_out,"'jdm   ' = latitudinal  array size"
c
      read( ni,'(a)') cline  ! field ...
      write(no,'(a)') cline
      write(lp,'(a)') cline(1:len_trim(cline))
c
      call flush(no)
      call flush(lp)
c
c     loop through all 2-d fields in archive file.
c     treat layer thickness as layer interface depth (p).
c
      k = 0
      lcheck = .true.
      p_in( :,:,:) = 0.0
      p_out(:,:,:) = 0.0
c
      lnotsd = .true.  !default is mean or snapshot archive
      laythk = .false. !.false. until layer thickness is in h_in
c
      do  ! loop until file ends
        read( ni,'(a)',iostat=ios) cline
        if     (ios.ne.0) then
          exit
        endif
c
        l = index(cline,'=')
        read (cline(l+1:),*)  itmp,rtmp,itmp,rtmp,hminb,hmaxb
        call zaiord(a_in,m_in,.false., hmina,hmaxa, ni)
        if     (abs(hmina-hminb).gt.abs(hminb)*1.e-4 .or.
     &          abs(hmaxa-hmaxb).gt.abs(hmaxb)*1.e-4     ) then
          write(lp,'(/ a / a,1p3e14.6 / a,1p3e14.6 /)')
     &      'error - .a and .b files not consistent:',
     &      '.a,.b min = ',hmina,hminb,hmina-hminb,
     &      '.a,.b max = ',hmaxa,hmaxb,hmaxa-hmaxb
          stop
        endif
c
        if     (.not. icegln .and.
     &          (cline(1:8).eq.'covice  ' .or.
     &           cline(1:8).eq.'thkice  ' .or.
     &           cline(1:8).eq.'temice  '     )) then
          cycle  ! no ice output
        endif
c
        if     (cline(1:1).eq.'u') then
c
c ---     u-grid, save the field (on the p-grid) for later processing.
c
          do j= 1,jdm
            do i= 1,idm
              if     (a_in(i,j).gt.hspval) then
                a_in(i,j) = 0.0
              endif
            enddo
            do i= 1,idm-1
              u_in(i,j) = 0.5*(a_in(i,j)+a_in(i+1,j))
            enddo
            u_in(idm,j) = 0.5*(a_in(idm,j)+a_in(1,j))
          enddo
          cline_u = cline
c
        elseif (cline(1:1).eq.'v' .and.
     &          cline(1:8).ne.'viscty  ') then
c
c ---     v-grid.  process both u and v fields.
c
          j=jdm
            do i= 1,idm
              if     (a_in(i,j).gt.hspval) then
                a_in(i,j) = 0.0
              endif
              v_in(i,j) = 0.0
            enddo
          do j= jdm-1,1,-1
            do i= 1,idm
              if     (a_in(i,j).gt.hspval) then
                a_in(i,j) = 0.0
              endif
              v_in(i,j) = 0.5*(a_in(i,j)+a_in(i,j+1))
            enddo
          enddo
c
c         u_out (eastwards) and v_out (northwards) on p-grid.
c
          if     (.not.lrot(1)) then
            call bilinear_p(u_in,     idm,    jdm,
     &                      u_out,    idm_out,jdm_out,
     &                      m_out,i_out,j_out,x_out,y_out)
            call bilinear_p(v_in,     idm,    jdm,
     &                      v_out,    idm_out,jdm_out,
     &                      m_out,i_out,j_out,x_out,y_out)
          else  !lrot(1)
            do j= 1,jdm
              do i= 1,idm
                a_in(i,j) = cos(pang_in(i,j))*u_in(i,j) -
     &                      sin(pang_in(i,j))*v_in(i,j)
              enddo
            enddo
            call bilinear_p(a_in,     idm,    jdm,
     &                      u_out,    idm_out,jdm_out,
     &                      m_out,i_out,j_out,x_out,y_out)
c
            do j= 1,jdm
              do i= 1,idm
                a_in(i,j) = cos(pang_in(i,j))*v_in(i,j) +
     &                      sin(pang_in(i,j))*u_in(i,j)
              enddo
            enddo
            call bilinear_p(a_in,     idm,    jdm,
     &                      v_out,    idm_out,jdm_out,
     &                      m_out,i_out,j_out,x_out,y_out)
          endif !.not.lrot(1):else
c
c         re-rotate on output p-grid, if necessary.
c
          if     (lrot(2)) then
            do jj= 1,jdm_out
              do ii= 1,idm_out
                up = u_out(ii,jj)
                vp = v_out(ii,jj)
                u_out(ii,jj) = cos(pang_out(ii,jj))*up +
     &                         sin(pang_out(ii,jj))*vp
                v_out(ii,jj) = cos(pang_out(ii,jj))*vp -
     &                         sin(pang_out(ii,jj))*up
              enddo
            enddo
          endif
c
c         write u-velocity on output u-grid.
c
          do jj= 1,jdm_out
              a_out( 1,jj) = 0.5*(u_out( 1,jj)+u_out(idm_out,jj))
            do ii= 2,idm_out
              a_out(ii,jj) = 0.5*(u_out(ii,jj)+u_out(   ii-1,jj))
            enddo
          enddo
          call zbiowr(a_out,m_out,.false., hmina,hmaxa, no, .false.)
          write(no,'(a,1p2e16.7)') cline_u(1:41),hmina,hmaxa
          call flush(no)
          write(lp,'(a,1p2e16.7)') cline_u(1:41),hmina,hmaxa
          call flush(lp)
c
c         write v-velocity on output v-grid.
c
          jj=1
            do ii= 1,idm_out
              a_out(ii,jj) =      v_out(ii,jj)
            enddo
          do jj= 2,jdm_out
            do ii= 1,idm_out
              a_out(ii,jj) = 0.5*(v_out(ii,jj)+v_out(ii,jj-1))
            enddo
          enddo
          call zbiowr(a_out,m_out,.false., hmina,hmaxa, no, .false.)
          write(no,'(a,1p2e16.7)') cline(1:41),hmina,hmaxa
          call flush(no)
          write(lp,'(a,1p2e16.7)') cline(1:41),hmina,hmaxa
          call flush(lp)
c
        elseif ( cline(1:8).eq.'mnthknss' .or.                !sd archive
     &          (cline(1:8).eq.'thknss  ' .and. lnotsd)) then !mn or snapshot
c
c ---     (mean) layer thickness (on p-grid),
c ---     do interpolation etcetera on interface depth.
c
          lnotsd = cline(1:8).ne.'mnthknss'
c
          k  = k + 1
          l0 = mod(k+1, 2)
          l1 = mod(k,   2)
          if     (layave) then
            laythk = .true.  !h_in is defined
            do j= 1,jdm
              do i= 1,idm
                if     (a_in(i,j).gt.hspval) then
                  h_in(i,j) = 0.0
                else
                  h_in(i,j) = a_in(i,j)
                endif
              enddo
            enddo
          endif
          p_in(:,:,l0) = p_in(:,:,l1) + a_in(:,:)
          call landfill(  p_in( 1,1,l0),m_sm,idm,    jdm,
     &                    iv_sm,if_sm,il_sm,jf_sm,jl_sm)
          call bilinear_p(p_in( 1,1,l0),     idm,    jdm,
     &                    p_out(1,1,l0),     idm_out,jdm_out,
     &                    m_out,i_out,j_out,x_out,y_out)
          do j= 1,jdm_out
            do i= 1,idm_out
              if     (m_out(i,j).eq.1) then
                p_out(i,j,l0) = max( p_out(i,j,l1),
     &                               min( t_out(i,j,1),
     &                                    p_out(i,j,l0) ) )
                if     (t_out(i,j,1) .gt.t_out(i,j,2) .and.
     &                  p_out(i,j,l0).gt.t_out(i,j,3)      ) then
c
c                 if within old bottom boundary layer,
c                 extend layer to the new (deeper) bottom.
c
*                 if     (p_out(i,j,l0).ne.t_out(i,j,1)) then
*                   write(lp,'(a,2i5,i3,3f9.2)')
*    &                'deep: ',i,j,k,
*    &                (t_out(i,j,3)-p_out(i,j,l0))/onem,
*    &                p_out(i,j,l0)/onem,t_out(i,j,1)/onem
*                 endif
                  p_out(i,j,l0) = t_out(i,j,1)
                endif
              endif
            enddo
          enddo
          if     (smooth) then
            do j= 1,jdm_out
              do i= 1,idm_out
                if     (m_out(i,j).eq.1 .and.
     &                  p_out(i,j,l0).lt.t_out(i,j,1)) then
                  m_osm(i,j) = 1
                else
                  m_osm(i,j) = 0
                endif
              enddo
            enddo
            call psmooth( p_out(1,1,l0),m_osm,
     &                    p_out(1,1,l1),t_out(1,1,1),idm_out,jdm_out)
          endif
c
          do j= 1,jdm_out
            do i= 1,idm_out
              if     (m_out(i,j).eq.1) then
                a_out(i,j) = p_out(i,j,l0) - p_out(i,j,l1)
              endif
            enddo
          enddo
          call zbiowr(a_out,m_out,.true.,  hmina,hmaxa, no, .false.)
          write(no,'(a,1p2e16.7)') cline(1:41),hmina,hmaxa
          call flush(no)
          write(lp,'(a,1p2e16.7)') cline(1:41),hmina,hmaxa
          call flush(lp)
c
        else
c
c ---     p-grid.
c
          if     (lcheck) then  !1st p-grid field
            lcheck = .false.
c
            ibadl = 0
            ibads = 0
            do j= 1,jdm
              do i= 1,idm
                if     (m_in(i,j).eq.1) then !topo sea
                  if     (a_in(i,j).gt.2.0**99) then !archive land
                    ibads = ibads + 1   ! topo sea, archive land
*                   if     (mod(ibads,100).eq.1) then
*                   if     (mod(ibads, 10).eq.1) then
*                     write(lp,*) 'topo sea, archive land at i,j = ',i,j
*                   endif
                  endif
                else !topo land
                  if     (a_in(i,j).lt.2.0**99) then !archive sea
                    ibadl = ibadl + 1   ! topo land, archive sea
*                   if     (mod(ibadl,100).eq.1) then
*                   if     (mod(ibadl, 10).eq.1) then
*                     write(lp,*) 'topo land, archive sea at i,j = ',i,j
*    &                            ,a_in(i,j)
*                   endif
                  endif
                endif !ip-sea:ip-land
              enddo !i
            enddo !j
            if     (ibads.ne.0) then
              write(lp,*)
              write(lp,*) 'error - wrong bathymetry for this archive'
              write(lp,*) 'number of topo sea  mismatches = ',ibads
              write(lp,*) 'number of topo land mismatches = ',ibadl
              write(lp,*)
              call flush(lp)
              stop
            endif
            if     (ibadl.ne.0) then
              write(lp,*)
*             write(lp,*) 'warning - wrong bathymetry for this archive'
              write(lp,*) 'error - wrong bathymetry for this archive'
              write(lp,*) 'number of topo sea  mismatches = ',ibads
              write(lp,*) 'number of topo land mismatches = ',ibadl
              write(lp,*)
              call flush(lp)
              stop
            endif
          endif !lcheck
c
c ---     p-grid (continued).
c
          call landfill(  a_in,m_sm,idm,    jdm,
     &                    iv_sm,if_sm,il_sm,jf_sm,jl_sm)
          if     (laythk) then !implies layave
            call bilinear_ph(a_in,h_in,idm,    jdm,
     &                       a_out,    idm_out,jdm_out,
     &                       m_out,i_out,j_out,x_out,y_out)
          else
            call bilinear_p(a_in,     idm,    jdm,
     &                      a_out,    idm_out,jdm_out,
     &                      m_out,i_out,j_out,x_out,y_out)
          endif
          call zbiowr(a_out,m_out,.true.,  hmina,hmaxa, no, .false.)
          write(no,'(a,1p2e16.7)') cline(1:41),hmina,hmaxa
          call flush(no)
          write(lp,'(a,1p2e16.7)') cline(1:41),hmina,hmaxa
          call flush(lp)
        endif
      enddo  !loop until file ends
c
      call zbiocl(no)
      close( unit=no)
c
      end program isubaregion

      subroutine bilinear_p(a_in, idm_in, jdm_in,
     &                      a_out,idm_out,jdm_out,
     &                      m_out,i_out,j_out,x_out,y_out)
      implicit none
c
      integer idm_in, jdm_in,
     &        idm_out,jdm_out
      integer m_out(idm_out,jdm_out),
     &        i_out(idm_out,jdm_out),
     &        j_out(idm_out,jdm_out)
      real    a_in( idm_in, jdm_in ),
     &        a_out(idm_out,jdm_out),
     &        x_out(idm_out,jdm_out),
     &        y_out(idm_out,jdm_out)
c
c --- interpolate from a_in to a_out.
c
      integer i,ii,ip,j,jj,jp
      real    sx,sy
c
      do jj= 1,jdm_out
        do ii= 1,idm_out
          if     (m_out(ii,jj).eq.1) then
            sx = x_out(ii,jj)
            sy = y_out(ii,jj)
            i  = i_out(ii,jj)
            if     (i.ne.idm_in) then
              ip = i+1
            else
              ip =   1
            endif
            j  = j_out(ii,jj)
            jp = j+1
c
            a_out(ii,jj) = (1.0-sx)*(1.0-sy)*a_in(i, j ) +
     &                     (1.0-sx)*     sy *a_in(i, jp) +
     &                          sx *(1.0-sy)*a_in(ip,j ) +
     &                          sx *     sy *a_in(ip,jp)
*           if     (a_out(ii,jj).lt.0.0) then
*             write(6,'(a,6i5,2f7.3,5f9.2)')
*    &        'ii,jj,i,ip,j,jp,sx,sy,a_out,a_in',
*    &         ii,jj,i,ip,j,jp,
*    &         sx,sy,a_out(ii,jj),
*    &         a_in(i, j ),
*    &         a_in(i, jp),
*    &         a_in(ip,j ),
*    &         a_in(ip,jp)
*           endif
          endif
        enddo
      enddo
      return
      end subroutine bilinear_p

      subroutine bilinear_ph(a_in,h_in, idm_in, jdm_in,
     &                       a_out,     idm_out,jdm_out,
     &                       m_out,i_out,j_out,x_out,y_out)
      implicit none
c
      integer idm_in, jdm_in,
     &        idm_out,jdm_out
      integer m_out(idm_out,jdm_out),
     &        i_out(idm_out,jdm_out),
     &        j_out(idm_out,jdm_out)
      real    a_in( idm_in, jdm_in ),
     &        h_in( idm_in, jdm_in ),
     &        a_out(idm_out,jdm_out),
     &        x_out(idm_out,jdm_out),
     &        y_out(idm_out,jdm_out)
c
c --- interpolate from a_in to a_out.
c --- version that weights the interpolation by layer thickness
c
      real, parameter  :: onemm=9.806  !h_in is in pressure units
c
      integer i,ii,ip,j,jj,jp
      real    sx,sy,w00,w01,w10,w11
c
      do jj= 1,jdm_out
        do ii= 1,idm_out
          if     (m_out(ii,jj).eq.1) then
            sx = x_out(ii,jj)
            sy = y_out(ii,jj)
            i  = i_out(ii,jj)
            if     (i.ne.idm_in) then
              ip = i+1
            else
              ip =   1
            endif
            j  = j_out(ii,jj)
            jp = j+1
c
            w00 = (1.0-sx)*(1.0-sy)*max(onemm,h_in(i, j ))
            w01 = (1.0-sx)*     sy *max(onemm,h_in(i, jp))
            w10 =      sx *(1.0-sy)*max(onemm,h_in(ip,j ))
            w11 =      sx *     sy *max(onemm,h_in(ip,jp))
            a_out(ii,jj) = (w00*a_in(i, j ) +
     &                      w01*a_in(i, jp) +
     &                      w10*a_in(ip,j ) +
     &                      w11*a_in(ip,jp)  ) / (w00+w01+w10+w11)
*           if     (a_out(ii,jj).lt.0.0) then
*             write(6,'(a,6i5,2f7.3,5f9.2)')
*    &        'ii,jj,i,ip,j,jp,sx,sy,w_sum,h_in',
*    &         ii,jj,i,ip,j,jp,
*    &         sx,sy,(w00+w01+w10+w11),
*    &         h_in(i, j ),
*    &         h_in(i, jp),
*    &         h_in(ip,j ),
*    &         h_in(ip,jp)
*             write(6,'(a,6i5,2f7.3,5f9.2)')
*    &        'ii,jj,i,ip,j,jp,sx,sy,a_out,a_in',
*    &         ii,jj,i,ip,j,jp,
*    &         sx,sy,a_out(ii,jj),
*    &         a_in(i, j ),
*    &         a_in(i, jp),
*    &         a_in(ip,j ),
*    &         a_in(ip,jp)
*           endif
          endif
        enddo
      enddo
      return
      end subroutine bilinear_ph

      subroutine landfill(a,mask,m,n, iv,if,il,jf,jl)
      implicit none
c
      integer m,n,mask(m,n), iv(n,2),if,il,jf,jl
      real    a(m,n)
c
c --- extrapolate a 1-grid cell into the land mask,
c ---   mask == 0 for land.
c ---   mask == 1 for ocean.
c ---   mask == 2 for land to be extrapolated to ocean.
c
      integer, allocatable :: mm(:,:,:)
c
      logical doland
      integer i,ii,ip0,ip1,ipass,j,jj,ki,kj,nleft,nup
      integer ifj,ilj
      real    sa,ss
c
      logical lfirst
      real    s(-1:1,-1:1)
      save    lfirst,s
c
      data lfirst / .true. /
      data      s / 1.0, 2.0, 1.0,
     &              2.0, 4.0, 2.0,
     &              1.0, 2.0, 1.0 /
c
c     adding a halo to mm simplifies ocean selection logic.
c
      allocate( mm(0:m+1,0:n+1,0:1) )
c
      mm( : , : ,0) = 0
      mm(1:m,1:n,0) = mask
      mm( : , : ,1) = mm(:,:,0)
c
c --- repeated passes of 9-point "smoother" to
c ---  convert all mask==2 points to mask==1.
c --- double-buffering mm allows in-place use of a.
c
      if     (lfirst) then
        write(6,'(/a,6i5/)')
     &    'landfill - m,n,if,il,jf,jl =',m,n,if,il,jf,jl
      endif
      doland = .false.  !only extrapolate where mm==2
      do ipass= 1,n+m
        ip0   = mod(ipass+1,2)
        ip1   = mod(ipass,  2)
        nup   = 0
        nleft = 0
        do j= jf,jl
          if     (doland) then
            ifj = max(if-1,1)
            ilj = min(il+1,m)
          else
            ifj = iv(j,1)
            ilj = iv(j,2)
          endif
          do i= ifj,ilj
            if     (mm(i,j,ip0).eq.2) then
              sa = 0.0
              ss = 0.0
              do kj= -1,1
                jj = j+kj
                do ki= -1,1
                  ii = i+ki
                  if     (mm(ii,jj,ip0).eq.1) then
                    sa = sa + s(ki,kj)*a(ii,jj)
                    ss = ss + s(ki,kj)
                  endif
                enddo
              enddo
              if     (ss.ne.0.0) then
c
c               at least one ocean point within stencil.
c
                a( i,j)     = sa/ss
                mm(i,j,ip1) = 1
                nup         = nup + 1
*               if     (mask(i,j).eq.1) then
*                 write(6,*) 'error - i,j,ip0,ip1,mask,mm = ',
*    &              i,j,ip0,ip1,mask(i,j),mm(i,j,ip0)
*                 stop
*               endif
*               if     (mod(nup,1000).eq.1) then
*                 write(6,'(a,2i5,f5.1,f10.3)')
*    &              '   i,j,ss,a = ',i,j,ss,a(i,j)
*               endif
              else
                nleft = nleft + 1
              endif
            elseif (doland .and. mm(i,j,ip0).eq.0) then
              sa = 0.0
              ss = 0.0
              do kj= -1,1
                jj = j+kj
                do ki= -1,1
                  ii = i+ki
                  if     (mm(ii,jj,ip0).eq.1) then
                    sa = sa + s(ki,kj)*a(ii,jj)
                    ss = ss + s(ki,kj)
                  endif
                enddo
              enddo
              if     (ss.ne.0.0) then
c
c               at least one ocean point within stencil.
c
                a( i,j)     = sa/ss
                mm(i,j,ip1) = 1
              endif
            endif  !mm=2:doland&mm=0
          enddo
        enddo
        if     (lfirst) then
          write(6,'(a,i5,a,i6,a,i6,a)')
     &      'landfill: pass',ipass,
     &      ' filled in',nup,
     &      ' points, with',nleft,' still to fill'
          call flush(6)
        endif
        if     (nup.eq.0 .and. nleft.eq.0) then
          exit
        elseif (nup.eq.0 .and. .not.doland) then  !nleft>0
          doland = .true.  !extrapolate where mm==2 or mm==0
          if     (lfirst) then
            write(6,'(a)')
     &        ' switching to extrapolation of all land points'
            call flush(6)
          endif
        endif  !nup
        mm(if:il,jf:jl,ip0) = mm(if:il,jf:jl,ip1)
      enddo  ! ipass=1,...
      if     (lfirst) then
        write(6,*)
        lfirst = .false.
      endif
      if     (nleft.ne.0) then
        write(6,'(/a,i6,a/a/)')
     &    'error in landfill - ',
     &    nleft,' "mask==2" values are not fillable',
     &    'probably a mismatch between coarse and fine land masks'
        call flush(6)
        do j= jf,jl
          do i= iv(j,1),iv(j,2)
            if     (mm(i,j,ip1).eq.2) then
              write(6,'(a,2i5)') 'mask==2 at (coarse) i,j = ',i,j
            endif
          enddo
        enddo
        write(6,*)
        call flush(6)
        stop
      endif
c
      deallocate( mm )
c
      return
      end subroutine landfill

      subroutine psmooth(a,mask,amn,amx,m,n)
      implicit none
c
      integer m,n,mask(m,n)
      real    a(m,n),amn(m,n),amx(m,n)
c
c --- smooth under mask and within amn,amx range.
c
      integer, allocatable :: mm(:,:)
      real,    allocatable :: aa(:,:)
c
      integer i,ii,j,jj,ki,kj
      real    rss,sa
c
      real    s(-1:1,-1:1)
      save    s
      data    s / 1.0, 2.0, 1.0,
     &            2.0, 4.0, 2.0,
     &            1.0, 2.0, 1.0 /
c
      rss = 1.0/sum(s(:,:))
c
c     local copy of a.
c
      allocate( aa(m,n) )
      aa = a
c
c     adding a halo to mm simplifies ocean selection logic.
c
      allocate( mm(0:m+1,0:n+1) )
      mm(  0, : ) = 0
      mm(m+1, : ) = 0
      mm( : ,  0) = 0
      mm( : ,n+1) = 0
      mm(1:m,1:n) = mask
c
      do j= 1,n
        do i= 1,m
          if     (mm(i,j).eq.1) then
            sa = 0.0
            do kj= -1,1
              jj = j+kj
              do ki= -1,1
                ii = i+ki
                if     (mm(ii,jj).eq.1) then
                  sa = sa + s(ki,kj)*aa(ii,jj)  ! must use local copy of a
                else
                  sa = sa + s(ki,kj)*aa(i ,j )
                endif
              enddo
            enddo
            a(i,j) = max( amn(i,j),
     &                    min( amx(i,j), sa*rss ) )
          endif
        enddo
      enddo
c
      deallocate( aa, mm )
c
      return
      end subroutine psmooth

      subroutine blkdat(idm_out,jdm_out,
     &                  layave,smooth,icegln,
     &                  flnm_reg,flnm_map,flnm_in,flnm_tin,
     &                  flnm_out,flnm_top,
     &                  cline_out)
      use mod_xc  ! HYCOM communication interface
      implicit none
      integer       :: idm_out,jdm_out
      logical       :: layave,smooth,icegln
      character*256 :: flnm_reg,flnm_map,flnm_in,flnm_tin,
     &                 flnm_out,flnm_top
      character*80  :: cline_out
c
c --- read blkdat.input for interpolated subregion.
c
      character*6   :: cvarin
      logical       :: lblkdat
      integer       :: iceflg,n,idm_reg,jdm_reg
c
c --- 'flnm_reg'  = target sub-region grid       filename
c --- 'flnm_map'  = target sub-region grid map   filename
c --- 'flnm_top'  = target bathymetry filename, or 'NONE'
c --- 'flnm_tin'  = input  bathymetry filename, or 'NONE'
c --- 'flnm_in'   = input  archive    filename
c --- 'flnm_out'  = output archive    filename
c --- 'cline_out' = output title line (replaces preambl(5))
c
      read( *,'(a)')      flnm_reg
      write(6,'(a)') trim(flnm_reg)
      read( *,'(a)')      flnm_map
      write(6,'(a)') trim(flnm_map)
      read( *,'(a)')      flnm_top
      write(6,'(a)') trim(flnm_top)
      read( *,'(a)')      flnm_tin
      write(6,'(a)') trim(flnm_tin)
      read( *,'(a)')      flnm_in
      write(6,'(a)') trim(flnm_in)
      read( *,'(a)')      flnm_out
      write(6,'(a)') trim(flnm_out)
      read( *,'(a)')      cline_out
      write(6,'(a)') trim(cline_out)
      write(6,*)
      call flush(6)
c
c --- 'idm   ' = longitudinal array size
c --- 'jdm   ' = latitudinal  array size
c
      call blkini(idm_out,   'idm   ')
      call blkini(jdm_out,   'jdm   ')
c
c --- check idm_out,jdm_out
c
      n = len_trim(flnm_reg)
      open(unit=11,file=flnm_reg(1:n-2)//'.b',form='formatted',
     &     status='old',action='read')
      read( 11,*) idm_reg
      read( 11,*) jdm_reg
      close(11)
      if     (idm_out.ne.idm_reg .or.
     &        jdm_out.ne.jdm_reg     ) then
        write(lp,'(/ a,a / a,2i6 /)')
     &    'error - target idm,jdm not consistent with ',
     &    flnm_reg(1:n-2)//'.b',
     &    ' which has idh,jdm =',idm_reg,jdm_reg
        stop
      endif
c
c --- 'iceflg' = ice in output archive flag (0=none,1=energy loan model)
      call blkini(iceflg, 'iceflg')
      icegln = iceflg.eq.1
c
      write(6,*)
      call flush(6)
c
c --- 'layave' = allow for layer thickness in scalar interp. (0=F,1=T)
c ---             optional, default .false.
c --- 'smooth' = smooth interface depths (0=F,1=T)
      call blkinl2(lblkdat,n,'layave','smooth')
      if     (n.eq.1) then
        layave = lblkdat
        call blkinl(smooth,'smooth')
      else
        layave = .false.
        smooth = lblkdat
      endif
c
      write(6,*)
      call flush(6)
c
      return
 6000 format('blkdat: ',a6,' =',i6)
      end subroutine blkdat

      subroutine blkini(ivar,cvar)
      implicit none
c
      integer     ivar
      character*6 cvar
c
c     read in one integer value
c
      character*6 cvarin
c
      read( *,*) ivar,cvarin
      write(6,6000) cvarin,ivar
      call flush(6)
c
      if     (cvar.ne.cvarin) then
        write(6,*)
        write(6,*) 'error in blkini - input ',cvarin,
     +                      ' but should be ',cvar
        write(6,*)
        call flush(6)
        stop
      endif
      return
 6000 format(a6,' =',i6)
      end subroutine blkini

      subroutine blkinl(lvar,cvar)
      implicit none
c
      logical     lvar
      character*6 cvar
c
c     read in one logical value
c     due to a SGI bug for logical I/O: read in an integer 0=F,1=T
c
      character*6 cvarin
      integer     ivar
c
      read( *,*) ivar,cvarin
      lvar = ivar .ne. 0
      write(6,6000) cvarin,lvar
      call flush(6)
c
      if     (cvar.ne.cvarin) then
        write(6,*)
        write(6,*) 'error in blkinr - input ',cvarin,
     +                      ' but should be ',cvar
        write(6,*)
        call flush(6)
        stop
      endif
      return
 6000 format(a6,' =',l6)
      end subroutine blkinl

      subroutine blkinl2(lvar,nvar,cvar1,cvar2)
      implicit none
c
      logical     lvar
      integer     nvar
      character*6 cvar1,cvar2
c
c     read in one logical value
c     identified as either cvar1 (return nvar=1) or cvar2 (return nvar=2)
c     due to a SGI bug for logical I/O: read in an integer 0=F,1=T
c
      character*6 cvarin
      integer     ivar
c
      read(*,*) ivar,cvarin
      lvar = ivar .ne. 0
      write(6,6000) cvarin,lvar
      call flush(6)
c
      if     (cvarin.eq.cvar1) then
        nvar = 1
      elseif (cvarin.eq.cvar2) then
        nvar = 2
      else
        write(6,*)
        write(6,*) 'error in blkinl2 - input ',cvarin,
     +             ' but should be ',cvar1,' or ',cvar2
        write(6,*)
        call flush(6)
        stop
      endif
      return
 6000 format(a6,' =',l6)
      end subroutine blkinl2


SUBROUTINE unsparse(print,save)
  IMPLICIT NONE

  logical, intent(in) :: print,save

  character*32, parameter :: fmt='"<",i3,"|H|",i3,"> ="'
  character*32, parameter :: fmt0='"<",i3,"|H|",i3,"> = 0"'
  ! block properties
  integer ncn,ncfg
  ! global iterators
  integer nz,ncoef,nb
  ! in-block iterators
  integer ja,jb, nijcurr,mei
  integer i,n
  ! integral caracteristics
  integer ipack,icase,iptr,k,l1,l2,r1,r2,ni
  !tmp
  integer j
  character*3 str
  character*50 str2

  type(Hang) cur

!  if(.not.save.and..not.print)then
!    write(0,*) "Nothing to do in unparse"
!    return
!  endif

  if(save) allocate(tot_hang(nblock))

  ncoef = 0
  nz=0
  do nb=1,nblock

    ncfg=ncfg_bl(nb)

    if(save) allocate(tot_hang(nb)%h(ncfg,ncfg))

    ncn=ncn_bl(nb)
    ja = 1
    jb = 1
    nijcurr = nz+1

    ! prepare the first matrix element

    mei=0
    ni=ico(nijcurr)
    if(save)then
      cur%ni=ni
      allocate(cur%int(ni))
      allocate(tot_hang(nb)%h(1,1)%int(ni))
    endif
    if(print)then
      write(*,*)
      write(*,'('//fmt//')') 1,1
    endif

    do i = 1, ncn;

      n = ncoef+i

      !determines the next non-zero element
      !and do what is correspondingly necessary

      if (i.gt.ico(nijcurr))then

        nijcurr = nijcurr + 1

        if(save) tot_hang(nb)%h(ja,jb)=cur

        ! determines row and column of the current matrix elements

        if(ja.lt.jan(nijcurr)) then
          do j=ja+1,jan(nijcurr)-1
            if(save)tot_hang(nb)%h(j,jb)%ni=0
            if(print)then
              write(*,*)
              write(*,'('//fmt0//')') jb,j
            endif
          enddo
        else
          do j=ja+1,ncfg
            if(save) tot_hang(nb)%h(j,jb)%ni=0
            if(print)then
              write(*,*)
              write(*,'('//fmt0//')') jb,j
            endif
          enddo

          jb=jb+1

          do j=jb,jan(nijcurr)-1
            if(save) tot_hang(nb)%h(j,jb)%ni=0
            if(print)then
              write(*,*)
              write(*,'('//fmt0//')') jb,j
            endif
          enddo

        endif
        ja= jan(nijcurr)

        ! prepare the matrix element
        mei=0
        ni=ico(nijcurr)-ico(nijcurr-1)
        if(save)then
          deallocate(cur%int)
          cur%ni=ni
          allocate(cur%int(ni))
          allocate(tot_hang(nb)%h(ja,jb)%int(ni))
        endif
        if(print)then
          write(*,*)
          write(*,'('//fmt//')') jb,ja
        endif
      endif

      !determines integral caracteristics

      mei=mei+1
      iptr  = inptr(n)
      ipack = ipackn(iptr)

        !icase

      if(iptr.le.intptr(1))then
        icase=1
      else if(iptr.le.intptr(2))then
        icase=2
      else if(iptr.le.intptr(3))then
        icase=3
      else
        icase=4
      endif

        !involved electron

      if (icase.eq.3) then
        r2 = mod(ipack,64)
        ipack = ipack/64
        r1 = mod(ipack,64)
        ipack = ipack/64
        l2 = mod(ipack,64)
        ipack = ipack/64
        l1 = mod(ipack,64)
        k = ipack/64
      else
        l2 = mod(ipack,64)
        ipack = ipack/64
        l1 = mod(ipack,64)
        k = ipack/64
      end if

      if(save)then
        cur%int(mei)%c  = cn(n)
        cur%int(mei)%inptr = iptr
        cur%int(mei)%icase = icase
        cur%int(mei)%l1 = k
        cur%int(mei)%l1 = l1
        cur%int(mei)%l2 = l2
        cur%int(mei)%r1 = r1
        cur%int(mei)%r2 = r2
      endif
      if(print)then

        str='no'
        if(mod(mei,3)==0.or.mei==ni) str='yes'

        if (icase==3) then
          write(str2,'('//intfmt(3)//')') &
                   k,el(l1),el(l2),el(r1),el(r2)
        else if (icase==4) then
          write(str2,'('//intfmt(4)//')') el(l1),el(l2)
        else
          write(str2,'('//intfmt(icase)//')') k,el(l1),el(l2)
        endif

        write(*,'(" + ",f14.10,"  ")',advance='no') cn(n)
        write(*,'(a20)',advance=str) str2
      endif

    end do

    ncoef = ncoef + ncn
    nz=nz+nze_bl(nblock)
  enddo
END SUBROUTINE unsparse


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2018 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine distributingcouplings(inpc,textpart,ipompc,nodempc,
     &  coefmpc,nmpc,nmpc_,mpcfree,nk,ikmpc,ilmpc,
     &  labmpc,istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc,lakon,
     &  kon,ipkon,set,nset,istartset,iendset,ialset,co,ier)
!
!     reading the input deck: *DISTRIBUTING COUPLING
!
      implicit none
!
      character*1 inpc(*)
      character*8 lakon(*)
      character*20 labmpc(*)
      character*81 set(*),elset,noset
      character*132 textpart(16)
!
      integer ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree,istep,istat,
     &  n,i,j,key,nk,node,ier,
     &  mpcfreeold,ikmpc(*),ilmpc(*),id,idof,iline,ipol,inl,
     &  ipoinp(2,*),inp(3,*),ipoinpc(0:*),irefnode,
     &  k,ipos,kon(*),ipkon(*),nset,idir,newmpc,
     &  istartset(*),iendset(*),ialset(*),indexm,ielem
!
      real*8 coefmpc(*),co(3,*),weight,totweight
!
      elset(1:1)=' '
      do i=2,n
         if(textpart(i)(1:6).eq.'ELSET=') then
            elset=textpart(i)(7:86)
            elset(81:81)=' '
            ipos=index(elset,' ')
            elset(ipos:ipos)='E'
         else
            write(*,*) '*WARNING reading *DISTRIBUTING COUPLING:'
            write(*,*) '         parameter not recognized:'
            write(*,*) '         ',
     &           textpart(i)(1:index(textpart(i),' ')-1)
            call inputwarning(inpc,ipoinpc,iline,
     &"*DISTRIBUTING COUPLING%")
         endif
      enddo
!
      if(elset(1:1).eq.' ') then
         write(*,*) '*ERROR reading *DISTRIBUTING COUPLING:'
         write(*,*) '       no element set given'
         call inputerror(inpc,ipoinpc,iline,
     &        "*DISTRIBUTING COUPLING%",ier)
         return
      endif
!
!     check whether the element set exists
!
      do i=1,nset
         if(set(i).eq.elset) exit
      enddo
      if(i.gt.nset) then
         write(*,*) '*ERROR reading *DISTRIBUTING COUPLING:'
         write(*,*) '       element set ',elset(1:ipos-1),
     &         ' is not defined'
         ier=1
         return
      endif
!
!     check whether only one element belongs
!     to the set
!
      if(istartset(i).ne.iendset(i)) then
         write(*,*) '*ERROR reading *DISTRIBUTING COUPLING:'
         write(*,*) '       element set ',elset(1:ipos-1),
     &        ' contains more than one element'
         ier=1
         return
      endif
!
!     check whether the element is a DCOUP3D element
!
      ielem=ialset(istartset(i))
      if(lakon(ielem)(1:7).ne.'DCOUP3D') then
         write(*,*) '*ERROR reading *DISTRIBUTING COUPLING:'
         write(*,*) '       element ',ielem,' is not a'
         write(*,*) '       DCOUP3D element'
         ier=1
         return
      endif
!
!     the reference node belongs to the DCOUP3D element
!
      irefnode=kon(ipkon(ielem)+1)
      newmpc=0
      totweight=0.d0
!
!     generate a MPC for dof 1
!
      do
         call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl,
     &        ipoinp,inp,ipoinpc)
         if((istat.lt.0).or.(key.eq.1)) exit
!
         read(textpart(1)(1:10),'(i10)',iostat=istat) node
         if(istat.eq.0) then
            if(node.gt.nk) then
               write(*,*) '*ERROR reading *DISTRIBUTING COUPLING:'
               write(*,*) '       node ',node,' is not defined'
               ier=1
               return
            endif
!
!           if first node : new MPC
!
            if(newmpc.eq.0) then
               idof=8*(node-1)+1
               call nident(ikmpc,idof,nmpc,id)
               if(id.gt.0) then
                  if(ikmpc(id).eq.idof) then
                     write(*,*) '*ERROR reading *DISTRIBUTING COUPLING:'
                     write(*,*) '       dof 1 of node ',node,
     &                    ' is already used'
                     ier=1
                     return
                  endif
               endif
!
               nmpc=nmpc+1
               if(nmpc.gt.nmpc_) then
                  write(*,*) '*ERROR reading *DISTRIBUTING COUPLING:'
                  write(*,*) '       increase nmpc_'
                  ier=1
                  return
               endif
               ipompc(nmpc)=mpcfree
               labmpc(nmpc)='                    '
               ipompc(nmpc)=mpcfree
!
!              updating ikmpc and ilmpc
!
               do j=nmpc,id+2,-1
                  ikmpc(j)=ikmpc(j-1)
                  ilmpc(j)=ilmpc(j-1)
               enddo
               ikmpc(id+1)=idof
               ilmpc(id+1)=nmpc
!
               newmpc=1
            endif
!
!           reading the weight
!
            read(textpart(2)(1:20),'(f20.0)',iostat=istat) weight
            if(istat.gt.0) then
               call inputerror(inpc,ipoinpc,iline,
     &              "*DISTRIBUTING COUPLING%",ier)
               return
            endif
            totweight=totweight+weight
!
!           new term in MPC
!
            nodempc(1,mpcfree)=node
            nodempc(2,mpcfree)=1
            coefmpc(mpcfree)=weight
            mpcfree=nodempc(3,mpcfree)
!
         else
!
!           node set
!
            read(textpart(1)(1:80),'(a80)',iostat=istat) noset
            read(textpart(2)(1:20),'(f20.0)',iostat=istat) weight
            if(istat.gt.0) then
               call inputerror(inpc,ipoinpc,iline,
     &              "*DISTRIBUTING COUPLING%",ier)
               return
            endif
            noset(81:81)=' '
            ipos=index(noset,' ')
            noset(ipos:ipos)='N'
            do i=1,nset
               if(set(i).eq.noset) exit
            enddo
            if(i.gt.nset) then
               noset(ipos:ipos)=' '
               write(*,*) '*ERROR reading *DISTRIBUTING COUPLING:'
               write(*,*) '       node set ',noset
               write(*,*) '       has not yet been defined. '
               call inputerror(inpc,ipoinpc,iline,
     &              "*DISTRIBUTING COUPLING%",ier)
               return
            endif
            do j=istartset(i),iendset(i)
               if(ialset(j).gt.0) then
                  node=ialset(j)
                  totweight=totweight+weight
!
                  if(newmpc.eq.0) then
                     idof=8*(node-1)+1
                     call nident(ikmpc,idof,nmpc,id)
                     if(id.gt.0) then
                        if(ikmpc(id).eq.idof) then
                           write(*,*)
     &                       '*ERROR reading *DISTRIBUTING COUPLING:'
                           write(*,*) '       dof 1 of node ',node,
     &                          ' is already used'
                           ier=1
                           return
                        endif
                     endif
!
                     nmpc=nmpc+1
                     if(nmpc.gt.nmpc_) then
                        write(*,*)
     &                    '*ERROR reading *DISTRIBUTING COUPLING:'
                        write(*,*) '       increase nmpc_'
                        ier=1
                        return
                     endif
                     ipompc(nmpc)=mpcfree
                     labmpc(nmpc)='                    '
                     ipompc(nmpc)=mpcfree
!
!              updating ikmpc and ilmpc
!
                     do k=nmpc,id+2,-1
                        ikmpc(k)=ikmpc(k-1)
                        ilmpc(k)=ilmpc(k-1)
                     enddo
                     ikmpc(id+1)=idof
                     ilmpc(id+1)=nmpc
!
                     newmpc=1
                  endif
!
!           new term in MPC
!
                  nodempc(1,mpcfree)=node
                  nodempc(2,mpcfree)=1
                  coefmpc(mpcfree)=weight
                  mpcfree=nodempc(3,mpcfree)
!
               else
                  node=ialset(j-2)
                  do
                     node=node-ialset(j)
                     if(node.ge.ialset(j-1)) exit
                     totweight=totweight+weight
!
!                    new term in MPC
!
                     nodempc(1,mpcfree)=node
                     nodempc(2,mpcfree)=1
                     coefmpc(mpcfree)=weight
                     mpcfree=nodempc(3,mpcfree)
                  enddo
               endif
            enddo
         endif
      enddo
!
!     reference node
!
      nodempc(1,mpcfree)=irefnode
      nodempc(2,mpcfree)=1
      coefmpc(mpcfree)=-totweight
      mpcfreeold=mpcfree
      mpcfree=nodempc(3,mpcfree)
      nodempc(3,mpcfreeold)=0
!
!     dofs 2 and 3
!
      do idir=2,3
!
         indexm=ipompc(nmpc)
         node=nodempc(1,indexm)
!
         idof=8*(node-1)+idir
         call nident(ikmpc,idof,nmpc,id)
         if(id.gt.0) then
            if(ikmpc(id).eq.idof) then
               write(*,*) '*ERROR reading *DISTRIBUTING COUPLING:'
               write(*,*) '       dof',idir,' of node ',node,
     &              ' is already used'
               ier=1
               return
            endif
         endif
!
         nmpc=nmpc+1
         if(nmpc.gt.nmpc_) then
            write(*,*) '*ERROR reading *DISTRIBUTING COUPLING:'
            write(*,*) '       increase nmpc_'
            ier=1
            return
         endif
         ipompc(nmpc)=mpcfree
         labmpc(nmpc)='                    '
         ipompc(nmpc)=mpcfree
!
!     updating ikmpc and ilmpc
!
         do j=nmpc,id+2,-1
            ikmpc(j)=ikmpc(j-1)
            ilmpc(j)=ilmpc(j-1)
         enddo
         ikmpc(id+1)=idof
         ilmpc(id+1)=nmpc
!
         do
            nodempc(1,mpcfree)=nodempc(1,indexm)
            nodempc(2,mpcfree)=idir
            coefmpc(mpcfree)=coefmpc(indexm)
            if(nodempc(3,indexm).eq.0) then
               mpcfreeold=mpcfree
               mpcfree=nodempc(3,mpcfree)
               nodempc(3,mpcfreeold)=0
               exit
            else
               mpcfree=nodempc(3,mpcfree)
               indexm=nodempc(3,indexm)
            endif
         enddo
      enddo
!
      return
      end


      subroutine ptgra(nowcrp)
c
c     + + + PURPOSE + + +
c     This is the plant growth subroutine for annual crops.
c     This subroutine predicts canopy cover, canopy height, and
c     root mass at different soil zones, root depth, leaf area
c     index and plant basal area.
c
c     Called from WATBAL
c     Author(s): Alberts, Ghiddey, Arnold
c     Reference in User Guide:
c
c     Changes:
c           1) Parameter MXGRAZ not used, so PMAXGRZ.INC
c              was dereferenced.
c           2) Common blocks RINPT1, CLIYR, CLIM, RIDGE, & WATER were
c              not used, so they were dereferenced.
c           3) Imbedded RETURN's were converted to IF's.
c           4) ISENES changed to ISENES(MXPLAN). -- CRM -- 5/29/92
c           5) Since ISENES is now stored in common block SENES,
c              DATA statement which set it to zero was removed.
c              This is statement is now included in BLKDATA.
c              CRM -- 6/9/92.
c           6) Variables IDECOM[p], ISTART, TMPVAR, IFLAG, X5, and
c              X6 are not needed for the call to GROW, since in
c              PTGRA they are always zero.  ISTART & IFLAG were
c              the only ones that were even initialized.  All these
c              variables were deleted.  6/09/92 -- CRM
c           7) VDMT set to zero at planting.  6/26/92 -- CRM.
c           8) In order to conform to the WEPP Coding Convention, the
c              5th - 8th arguments to GROW moved after the 2nd one,
c              and the last argument moved after the 3rd one.  Cor-
c              responding changes made in the call to GROW from this
c              routine.
c           9) Deleted dummy parameters TMPFLG, ISTART, & TRTMAS from
c              GROW, and its calls from PTGRA, PTGRP, and RANGE
c          10) Adding setting back of TLIVE to 0.0 whenever VDMT was
c              set back to zero.  TLIVE is used by new interception
c              code from Savabi.  Also  XXX  Arnold needs to review
c              the meaning, computation, and use of variables VDMT,
c              TLIVE, RMOGT, RMAGT, CANCOV, CANHGT - as there appear
c              to be inconsistencies between CROPLAND and RANGELAND
c              usage - and RANGELAND usage seems to match variable
c              descriptions better.   dcf   7/30/93
c
c
c     Version: This module recoded from WEPP version 91.40.
c     Date recoded: 10/02/91.
c     Note: This module is current with WEPP release version 91.50.
c     Date checked: 12/5/91.
c     Note: This module is current with WEPP release version 92.25.
c     Date checked: 5/29/92 - 6/09/92.
c     Recoded by: Charles R. Meyer.
c     Note: This module is current with WEPP version 93.05  dcf 5/19/93
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
      include 'pntype.inc'
      include 'pmxnsl.inc'
      include 'ptilty.inc'
      include 'pmxpln.inc'
      include 'pmxres.inc'
      include 'pmxcrp.inc'
      include 'pmxcut.inc'
      include 'pmxtls.inc'
      include 'pmxtil.inc'
      include 'pmxhil.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
      integer nowcrp
c
c     + + + ARGUMENT DEFINITIONS + + +
c     nowcrp - index of current crop
c
c     + + + COMMON BLOCKS + + +
      include 'ccrpvr1.inc'
c     modify: rmagt(mxplan),rtm(mxres,iplane)
c
      include 'ccrpvr2.inc'
c     modify: vdmt(mxplan)
c
      include 'ccrpvr3.inc'
c       read: fgs,dlai,gssen
c      write: sumgdd(mxplan)
c
      include 'ccrpvr5.inc'
c       read: ncount(mxplan)
c
      include 'ccover.inc'
c      write: canhgt(mxplan), cancov(mxplan), gcover(mxplan)
c
      include 'ccrpout.inc'
c      write: rtd(mxplan), rtmass(mxplan), lai(mxplan)
c
      include 'ccrpprm.inc'
c       read: jdharv(mxcrop,mxplan), jdplt(mxcrop,mxplan)
c
      include 'ccrpgro.inc'
c      write: hia(mxplan)
      include 'cdecvar1.inc'
c       read: cuthgt(ntype)
c
      include 'cflags.inc'
c       read: yldflg
      include 'cgcovr.inc'
c     modify: gcvplt(mxplan)
c
      include 'cperen.inc'
c       read: jdherb(mxcrop, mxplan),jdburn(mxcrop, mxplan),
c             jdslge(mxcrop, mxplan)
c
      include 'crout.inc'
c     modify: tlive(mxplan)
c
      include 'cstruc.inc'
c       read: iplane, ivers
c
      include 'cupdate.inc'
c       read: sdate
c
      include 'csenes.inc'
c     modify: isenes(mxplan)
c
c
c     + + + LOCAL VARIABLES + + +
      integer intcrp, idecom, nowres
      real silamt
c
c     + + + LOCAL DEFINITIONS + + +
c     intcrp - flag set at harvest, planting, burning, silage or
c              herbicide date. Vegetative dry matter, canopy cover,
c              canopy height, root mass, and root depth are set to
c              zero while the canopy cover decays.
c     idecom - dummy variable required by GROW. IDECOM is a flag used
c              to indicate whether residue updating needs to be done
c              at the first freezing of a perennial crop (call to RESUP)
c              setting of IDECOM is done in PTGRP
c     isenes - flag used in resup to indicate type of update for residue
c               1 - harvest after senescence
c               0 - harvest before senescence
c              -1 - stop/kill date of perennial
c              -2 - senescence (annual) or 1st freeze of perennial
c     silamt - silage harvest amount kg/m^2
c
c
c     + + + SUBROUTINES CALLED + + +
c     initpl
c     resup
c     grow
c
c     + + + END SPECIFICATIONS + + +
c
      intcrp = 0
c
c     Planting Date
c
      if (sdate.eq.jdplt(nowcrp,iplane)) then
        if (ivers.ne.3) write (6,*) 'PLANTING CROP #',nowcrp,
     1      ' on OFE #',iplane,' on DAY',sdate
        if (ivers.eq.3) write (6,*) 'PLANTING CROP #',nowcrp,
     1      ' on CHANNEL #',iplane,' on DAY',sdate
        isenes(iplane) = 0
        intcrp = 1
c
        vdmt(iplane) = 0.0
c
c       XXX - Variable TLIVE is never reset to 0.0 - this probably should
c       be done here when plant date is reached and other variables
c       set back to zero.   dcf   7/30/93
c
        tlive(iplane) = 0.0
c
        hia(iplane) = 0.0
c
c       Need to save the ground cover on the day of planting value -
c       this value will then be passed to subroutine INFPAR to compute
c       the macroporosity adjustment factor.  dcf  1/6/93
c
        gcvplt(iplane) = gcover(iplane)
      end if
c
c
c     TRAPS: If simulation date is greater than date of silage,
c     burning or herbicide application, then RETURN.
c
c     *** L0 IF ***
      if ((sdate.gt.jdslge(nowcrp,iplane)).and.(jdslge(nowcrp,iplane)
     1    .ne.0)) then
        continue
c
c     *** L0 ELSE-IF ***
      else if ((sdate.gt.jdburn(nowcrp,iplane)).and.(
     1    jdburn(nowcrp,iplane).ne.0).and.(jdburn(nowcrp,iplane).gt.
     1    jdplt(nowcrp,iplane))) then
        continue
c
c     *** L0 ELSE-IF ***
      else if ((sdate.gt.jdherb(nowcrp,iplane)).and.(
     1    jdherb(nowcrp,iplane).ne.0)) then
        continue
c
c     *** L0 ELSE ***
      else
c
c       *** L1 IF ***
c
c       silage modifications 3/24/98
c
        if (sdate.eq.jdslge(nowcrp,iplane)) then
c         set residue mass above ground to ratio of
c         vegetative dry matter-
c         (harvest cut height/canopy height)*vegetative dry matter
          intcrp = 1
          if(canhgt(iplane).le.0.0.or.vdmt(iplane).le.0.0)then
            write(6,1400)
          else
            if(canhgt(iplane).le.cuthgt(nowcrp))then
              silamt=((canhgt(iplane)-(canhgt(iplane)*0.05))/
     1           canhgt(iplane))*vdmt(iplane)
              write(6,1300)canhgt(iplane)*0.05
            else
            silamt=((canhgt(iplane)-cuthgt(nowcrp))/
     1         canhgt(iplane))*vdmt(iplane)
            end if
            rmagt(iplane)=rmagt(iplane)+vdmt(iplane)-silamt
c           Kill annual crop
            vdmt(iplane)=0.0
            if (ivers.ne.3) write (6,1000) sdate, iplane, silamt
            if (ivers.eq.3) write (6,1200) sdate, iplane, silamt
c
            if (yldflg.eq.1)
     1         write (46,1100)itype(nowcrp,iplane),sdate,iplane,silamt

            nowres = 1
            rtm(3,iplane) = rtm(2,iplane)
            rtm(2,iplane) = rtm(nowres,iplane)
            rtm(nowres,iplane) = rtm15(iplane)
          end if

c
c       Herbicide Application Date
c
c       *** L1 ELSE-IF ***
        else if (sdate.eq.jdherb(nowcrp,iplane).and.
     1      jdherb(nowcrp,iplane).ne.0) then
          rmagt(iplane) = rmagt(iplane) + vdmt(iplane)
          nowres = 1
          rtm(3,iplane) = rtm(2,iplane)
          rtm(2,iplane) = rtm(nowres,iplane)
          rtm(nowres,iplane) = rtm15(iplane)
          intcrp = 1
c
c       Harvest Date
c
c       *** L1 ELSE-IF ***
        else if (sdate.eq.jdharv(nowcrp,iplane)) then
c
          call resup(nowcrp,isenes(iplane))
          intcrp = 1
c
c       Burning Date
c
c       *** L1 ELSE-IF ***
        else if (sdate.eq.jdburn(nowcrp,iplane).and.
     1      jdburn(nowcrp,iplane).ne.0) then
          rmagt(iplane) = (rmagt(iplane)+vdmt(iplane))
          nowres = 1
          rtm(3,iplane) = rtm(2,iplane)
          rtm(2,iplane) = rtm(nowres,iplane)
          rtm(nowres,iplane) = rtm15(iplane)
          intcrp = 1
c
        end if
c
c       Vegetative dry matter, canopy cover, canopy height, root mass,
c       and root depth values are set to zero when any of the following
c       times: at harvest, before planting, or at burning, silage, and
c       herbicide dates.
c
        if (intcrp.eq.1) then
c
          rtd(iplane) = 0.0
          rtmass(iplane) = 0.0
          rtm15(iplane) = 0.0
          rtm30(iplane) = 0.0
          rtm60(iplane) = 0.0
          sumgdd(iplane) = 0.0
          cancov(iplane) = 0.0
          canhgt(iplane) = 0.0
          if(jdslge(nowcrp,iplane).ne.sdate)vdmt(iplane) = 0.0
          lai(iplane) = 0.0
c
c         XXX  - Variable TLIVE is never reset to 0.0 - this probably should
c         be done here when stop date is reached and other variables
c         set back to zero.   dcf   7/30/93
c
          tlive(iplane) = 0.0
        else if (intcrp.eq.0) then
c
c         Check whether simulation date is within the growing season.
c         -------- summer crop or winter crop
          if (((jdplt(nowcrp,iplane).lt.jdharv(nowcrp,iplane)).and.((
     1        sdate.ge.jdplt(nowcrp,iplane)).and.(sdate.le.
     1        jdharv(nowcrp,iplane)))).or.((jdplt(nowcrp,iplane).ge.
     1        jdharv(nowcrp,iplane)).and.((sdate.ge.
     1        jdplt(nowcrp,iplane)).or.(sdate.le.jdharv(nowcrp,iplane)))
     1        )) then
c
            call grow(nowcrp,iplane,0.0,0.0,ncount(iplane),idecom)
          end if
        end if
c
c     *** L0 ENDIF ***
      end if
c
      return
 1000 format(' SILAGE HARVEST DATE ',i3,' -- plane ',i2,
     1    ' yield ',f6.3,'(kg/m**2) '/)
 1100 format(' Crop Type # ',i2,' Date = ',i3,' OFE # ',i2,
     1    ' SILAGE= ',f8.3,'(kg/m**2)  ')
 1200 format(' SILAGE HARVEST DATE ',i3,' -- channel ',i2,
     1    ' yield ',f6.3,'(kg/m**2) '/)
 1300 format(//,' *** WARNING ***',/,' Cutting height greater than or',
     1    ' equal to canopy height!',/,' Cutting height set to 5% of',
     1    ' canopy height, cutting height for silage =',f5.2,' m',
     1    /,' *** WARNING ***',//)
 1400 format(//,' *** WARNING ***',/,' Canopy height or Vegetative dry',
     1    ' matter less than or equal to 0.0,',/,' No silage operation',
     1    ' performed!',/,' *** WARNING ***',//)
      end


* namal must be a factor of grid *
      integer namal
      parameter (namal = 10)
      integer i,j,k,l,ii,jj
      integer count
      real ans(360,720,12),lat,lon,ans1(12)

      open(11,file='global/era40/30min/raindays.dat',status='old')
      open(21,file='global/era40/5deg/raindays.dat')

      do i=1,360
        do j=1,720
          read(11,'(12f6.2)') (ans(i,j,k),k=1,12)
        enddo
      enddo
      close(11)

      do i=1,360/namal
        do j=1,720/namal
          count = 0
          do m=1,12
            ans1(m) = 0.0
          enddo
          do k=1,namal
            do l=1,namal
              ii = (i-1)*namal+k
              jj = (j-1)*namal+l
              if (ans(ii,jj,1).GT.-1.0e-6) then
                count = count + 1
                do m=1,12
                  ans1(m) = ans1(m) + ans(ii,jj,m)
                enddo
              endif
            enddo
          enddo
          if (count.GT.0) then
            write(21,'(12f6.2)') ans1/real(count)
          else
            write(21,'(12f6.2)') -1.0,-1.0,
     &-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0
          endif
        enddo
      enddo
      close(21)

      open(11,file='global/era40/30min/stdtmp.dat',status='old')
      open(21,file='global/era40/5deg/stdtmp.dat')

      do i=1,360
        do j=1,720
          read(11,'(12f6.2)') (ans(i,j,k),k=1,12)
        enddo
      enddo
      close(11)

      do i=1,360/namal
        do j=1,720/namal
          count = 0
          do m=1,12
            ans1(m) = 0.0
          enddo
          do k=1,namal
            do l=1,namal
              ii = (i-1)*namal+k
              jj = (j-1)*namal+l
              if (ans(ii,jj,1).GT.-1.0e-6) then
                count = count + 1
                do m=1,12
                  ans1(m) = ans1(m) + ans(ii,jj,m)
                enddo
              endif
            enddo
          enddo
          if (count.GT.0) then
            write(21,'(12f6.2)') ans1/real(count)
          else
            write(21,'(12f6.2)') -1.0,-1.0,
     &-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0
          endif
        enddo
      enddo
      close(21)

      open(11,file='global/era40/30min/stdhum.dat',status='old')
      open(21,file='global/era40/5deg/stdhum.dat')

      do i=1,360
        do j=1,720
          read(11,'(12f6.2)') (ans(i,j,k),k=1,12)
        enddo
      enddo
      close(11)

      do i=1,360/namal
        do j=1,720/namal
          count = 0
          do m=1,12
            ans1(m) = 0.0
          enddo
          do k=1,namal
            do l=1,namal
              ii = (i-1)*namal+k
              jj = (j-1)*namal+l
              if (ans(ii,jj,1).GT.-1.0e-6) then
                count = count + 1
                do m=1,12
                  ans1(m) = ans1(m) + ans(ii,jj,m)
                enddo
              endif
            enddo
          enddo
          if (count.GT.0) then
            write(21,'(12f6.2)') ans1/real(count)
          else
            write(21,'(12f6.2)') -1.0,-1.0,
     &-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0
          endif
        enddo
      enddo
      close(21)

      stop
      end