c
c------------------------------------------------------------------
c Begin file /home/sting/foster/timegcm/mksrc/wrhist.f
c------------------------------------------------------------------
c
      subroutine wrhist(j)
c
c Write out a latitude slice:
c
      include 'mksrc.h'
      data idb/0/
c
c Write out samples before 'packing' if debug is on:
      if (idb.gt.0) then
        if (j.le.2.or.mod(j,6).eq.0) then
          write(6,"(' Samples (before packing) from f array follow:')")
          do 45 ip=1,nfldsd
            write(6,"(' ')")
c           do 46 i=1,imx,18
            do 46 k=1,kmx,5
 46           write(6,"('f samples: j=',i3,' ip=',i3,' k=',i3,
     +          ' f(1-imx by 18,k,ip)=',/(5e12.4))") j,ip,k,
     +          (f(i,k,ip),i=1,imx,18)
 45       continue
        endif
      endif
c
c Do basic contours at current latitude if iplt > 0:
c
c     if (j.eq.1.or.mod(j,6).eq.0.or.j.eq.jmx) call pltlat(j)
c
c The following is taken from tgcm5, subroutine output:
c ("change data structure from internal to external format")
c
      f(1,1,1) = -j
      iix = 1
      do 100 n=1,kmx*nfldst
        do 200 i=3,imxp3
          iix = iix+1
          f(iix,1,1) = f(i,n,1)
 200    continue
 100  continue
c
c Write out samples after 'packing' if debug is on:
      if (idb.gt.0) then
        if (j.eq.1.or.mod(j,6).eq.0) then
          write(6,"(' Samples from f (after packing) array follow:')")
          do 55 ip=1,nfldsd
            write(6,"(' ')")
            do 56 k=1,kmx,5
 56           write(6,"('proclat samples: j=',i3,' ip=',i3,' k=',i3,
     +          ' f(1-imx by 18,k,ip)=',/(5e12.4))") j,ip,k,
     +          (f(i,k,ip),i=1,imx,18)
 55       continue
        endif
      endif
c
      lbtap = imxp1 * kmx * nfldsw + 1            ! lbtap = 42551
c
c Buffer out the latitude slice:
c
      buffer out(lutime,1) (f,f(lbtap))
      if (unit(lutime)) 220,225,225
 220  write(6,"('Wrhist: wrote latitude slice at j=',i3)") j
      return
 225  write(6,"('Wrhist: error writing latitude slice at j=',i3)") j
      stop 'wrhist'
 221  continue
      return
      end