copyright (C) 2001  MSC-RPN COMM  %%%MC2%%%
***s/r ecris_fst2

      subroutine ecris_fst2 ( fa,lminx,lmaxx,lminy,lmaxy,rf,nomvar,con, 53,2
     $                              ip2,stepno,kind,nkfa,ind_o,nko,unf )
      implicit none
*
      character* (*) nomvar
      integer lminx,lmaxx,lminy,lmaxy,ip2,stepno,kind,nkfa,ind_o(*),
     $        nko,unf
      real fa(lminx:lmaxx,lminy:lmaxy,*),rf(*),con
*
**
#include "lcldim.cdk"
#include "sor.cdk"
#include "grd.cdk"
#include "partopo.cdk"
#include "yomdyn1.cdk"
*
      integer  fstecr,fstopc
      external fstecr,fstopc
*
      character*1 grdtyp
      character*8 dumc
      integer i,j,k,n,ier,pnip1,pnip2,pnip3,cnt,nis,njs,nrd,
     $        ii,jj,im,jm,g3,g4,oi,oj
      logical reduc_L
      real*8 sum_8
      real, dimension (:,:  ), allocatable :: wk1,wk2
      real, dimension (:,:,:), allocatable :: tr1
      real tr2
      pointer (patr2, tr2(out_nisl,out_njsl,*))
*
*----------------------------------------------------------------------
*
      if (g_reduc .gt. 1) then
         call reducnw ( fa,lminx,lmaxx,lminy,lmaxy,rf,nomvar,con,
     $                        ip2,stepno,kind,nkfa,ind_o,nko,unf )
         return
      endif
*
*     Writing field 'nomvar' to a FST file
*
      if (mybloc.ne.0) ier = fstopc('MSGLVL','SYSTEM',.false.)
*
      if ((out_nisl.le.0).or.(out_njsl.le.0)) goto 999
*
c      call statf_dm (fa, nomvar, ip2, 'ecris', .false.,
c     $       lminx,lmaxx,lminy,lmaxy,nkfa,g_id,g_jd,1,g_if,g_jf,nkfa)
*
      if (blocme.eq.0) then
*
         grdtyp = 'Z'
         if (Grd_proj_S.eq.'X') grdtyp = 'X'
         g3 = 0
         g4 = 0
         if (nblocx*nblocy.gt.1) then
            grdtyp = '#'
            g3     =  Grd_ig3
            g4     =  Grd_ig4
         endif
         pnip1 = 0
         pnip2 = ip2
         pnip3 = 0
         if (gnip3.lt.0) pnip3 = stepno
         reduc_L = g_reduc .gt. 1
         nis = out_ifg - out_idg + 1
         njs = out_jfg - out_jdg + 1
         allocate (tr1(nis,njs,nko))
         patr2 = loc(tr1(1,1,1))
         if (reduc_L) then
            call hpalloc (patr2,out_nisl*out_njsl*nko,ier,1)
            if (nblocx*nblocy.gt.1) then
               g3 = (out_rdi-g_id)/g_reduc+1
               g4 = (out_rdj-g_jd)/g_reduc+1
            endif
         endif 
*
      endif
*
      call blkcol ( tr1,nis,njs,g_id,g_if,g_jd,g_jf,con,
     $              fa,lminx,lmaxx,lminy,lmaxy,nkfa,ind_o,nko )
*
      if (blocme.eq.0) then
*
      if (reduc_L) then
c         nrd = g_reduc-1
         nrd = g_reduc/2
         oi  = out_rdi-max(glb_pos(1)-hx*b_west ,g_id)+1
         oj  = out_rdj-max(glb_pos(3)-hy*b_south,g_jd)+1
         do k=1,nko
         do j=1,out_njsl
         do i=1,out_nisl
            cnt=0
            sum_8=0.0d0
            im = (i-1)*g_reduc + oi
            jm = (j-1)*g_reduc + oj
            do jj=max(1,jm-nrd),min(jm+nrd,njs)
            do ii=max(1,im-nrd),min(im+nrd,nis)
               cnt=cnt+1
               sum_8 = sum_8 + tr1(ii,jj,k)
            end do
            end do
            tr2(i,j,k) = sum_8 / dble(cnt)
         end do
         end do
         end do
      endif
*
      if (flipit) then
*
         allocate (wk2(out_nisl,nko))
         do j=1,out_njsl
            do k=1,nko
            do i=1,out_nisl
               wk2(i,k) = tr2(i,j,k)
            end do
            end do
            ier= fstecr (wk2,wk2,-nbit,unf,out_dat0,int(grdt),stepno,
     $                   out_nisl,nko,1,0,pnip2,pnip3,gttpvar,nomvar,
     $                   gtetikt,'X',0,0,0,0,datyp,.false.)
         end do
         deallocate (wk2)
*
      else
*
         do k=1,nko
            n = ind_o(k)
            if (kind.ge.0) call convip(pnip1,rf(n),kind,+2,dumc,.false.)
            ier = fstecr (tr2(1,1,k),tr1,-nbit,unf,out_dat0,int(grdt),
     $                    stepno,out_nisl,out_njsl,1,pnip1,pnip2,pnip3,
     $                    gttpvar,nomvar,gtetikt,grdtyp,
     $                    Grd_ig1,Grd_ig2,g3,g4,datyp,.false.)
         end do
*     
      endif
*
      deallocate (tr1)
      if (reduc_L) call hpdeallc (patr2 , ier, 1)
*
      endif
*
 999  if (mybloc.ne.0) ier = fstopc('MSGLVL','INFORM',.false.)
*
*----------------------------------------------------------------------
      return
      end