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

      subroutine out_phyr ( bus_o,gthid,ngth,fni,fnj,doni,donj,ni,nj, 2,4
     $                                   stepno,ind_o,nk_o,nsor,mode )
      implicit none
*
      character*1 mode
      integer gthid(*),ngth,fni,fnj,doni,donj,ni,nj,stepno,ind_o(*),
     $        nk_o,nsor
      real bus_o(*)
*
*AUTHOR     Michel Desgagne                Dec   2002
*
*REVISION
*
*OBJECT
*    Gather the index of physics variables to write on disk 
*    for the current timestep.
*
*FILES
*
*ARGUMENTS
*    NAMES     I/O  TYPE  A/S        DESCRIPTION
*
*   bus_o       I    R    A    physics output bus (complete)
*   fni         I    I    S    folded dimension along X
*   fnj         I    I    S    folded dimension along Y
*   doni        I    I    S    computational hor. dimension along X
*   donj        I    I    S    computational hor. dimension along Y
*   ni          I    I    S    regular dimension along X
*   nj          I    I    S    regular dimension along Y
*   stepno      I    I    S    step number
*
**
#include "lesbus.cdk"
#include "partopo.cdk"
*
      character*8 wrponm(phyotop)
      integer i,j,k,id,im,npar,nnk,offw1,offbo,wrpospc
      parameter (npar = 3)
      integer wrpopar(npar,phyotop)
      real, dimension (:), allocatable :: wrk1
*----------------------------------------------------------------------
*
      wrpospc = 0
      do id=1,ngth
         wrponm (id)   = bus_oname(gthid(id),2)
         wrpopar(1,id) = wrpospc + 1
         wrpopar(2,id) = bus_opar(gthid(id),3)
         wrpopar(3,id) = bus_opar(gthid(id),4)
         wrpospc       = wrpopar(1,id) +
     $           ni*nj*bus_opar(gthid(id),3)*bus_opar(gthid(id),4) - 1
      end do
*
      allocate (wrk1(wrpospc))
      wrk1 (:) = 0.
*
      do id=1,ngth
         nnk = bus_opar(gthid(id),3)
         do im=1,bus_opar(gthid(id),4)
            offw1=wrpopar(1,id)       + (im-1)*ni  * nj  * nnk
            offbo=bus_opar(gthid(id),1)+ (im-1)*fni * fnj * nnk
            do k =1,nnk
            do j =1,donj
            do i =1,doni
               wrk1   ( offw1 + (nnk-k)*ni *nj  + (j-1)*ni   +i-1 ) =
     $         bus_o  ( offbo +   (k-1)*fni*fnj + (j-1)*doni +i-1 )
            end do
            end do
            end do
         end do
      end do
*
      if (mode.eq.'N') then
      call out_wrphyo ( wrk1, wrpospc, wrponm, wrpopar, ngth, stepno, 
     $                                               ind_o,nk_o,nsor )
      elseif (mode.eq.'C') then
      call out_wrphyoc ( wrk1, wrponm, wrpopar, ngth, stepno, ind_o )
      elseif (mode.eq.'A') then
      call out_wrphyo ( wrk1, wrpospc, wrponm, wrpopar, ngth, stepno, 
     $                                               ind_o,nk_o,nsor )
      call out_wrphyoc ( wrk1, wrponm, wrpopar, ngth, stepno, ind_o )
      endif
      deallocate (wrk1)
*
*----------------------------------------------------------------------
      return
      end