!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer, 
!                     version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms 
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer 
!version 3 or (at your option) any later version that should be found at: 
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html 
!
!This software 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 above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software; 
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec), 
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
copyright (C) 2001  MSC-RPN COMM  %%%MC2%%%
***s/r out_perbus_3df- output permanent bus fields into 3DF files
#include "model_macros_f.h"
*

      subroutine out_perbus_3df ( bus_o,F_ni,F_nj,datev, 1,2
     %                         gid,gif,gjd,gjf )

      implicit none
*
      character* (*) datev
      integer F_ni,F_nj,gid,gif,gjd,gjf
      real bus_o(F_ni,F_nj,*)
*
*AUTHOR     Vivian Lee                     Oct. 2005 (GEM)
*
*revision
* v3_30 - Lee V. - initial version
*
*
*OBJECT
*    Gather the index of physics variables to write on disk 
*    for the current timestep.
*
*ARGUMENTS
*    NAMES     I/O  TYPE  A/S        DESCRIPTION
*
*   fni         I    I    S    folded dimension along X
*   fnj         I    I    S    folded dimension along Y
*
*IMPLICIT
#include "glb_ld.cdk"
#include "glb_pil.cdk"
#include "dcst.cdk"
#include "out3.cdk"
#include "geomg.cdk"
#include "geomn.cdk"
#include "init.cdk"
#include "rstr.cdk"
#include "grid.cdk"
#include "out.cdk"
#include "itf_phy_buses.cdk"
#include "grd.cdk"
#include "level.cdk"
#include "outp.cdk"
#include "ptopo.cdk"
#include "v4dg.cdk"
#include "lun.cdk"
*
**
      integer i,j,k,nis,njs,ind_o(100),cnt
      integer bigk,idx,unf,mult,shp,mode
      integer nks(P_bper_top),nkphy
*----------------------------------------------------------------------
*
*
      if ((out_nisl.le.0).or.(out_njsl.le.0)) return
      if (Lun_debug_L) write(Lun_out,1000)
*
      nis = out_ifg - out_idg + 1
      njs = out_jfg - out_jdg + 1

*########## PHYSICS SNAPSHOT #####################################
*
*
       mode=2
       nkphy=0
       do idx = 1, P_bper_top
          mult=perpar(idx,6)
          if (perpar(idx,5).gt.p_ni) then
              shp=l_nk
          else
              shp=1
          endif
          nks(idx)=shp*mult
          nkphy=nkphy+nks(idx)
       enddo
       if (Out_blocme.eq.0) then
           call out_sfile_3df (datev,unf,'PERBUSSS',gid, gif, gjd, gjf,
     $                                    P_bper_top,0,mode)
           write (unf) (peron(idx)(1:4),nks(idx),idx=1,P_bper_top)
       endif
       bigk = 1
       do idx = 1, P_bper_top
          do k=1,nks(idx)
              ind_o(k) = k
          end do
          call write_3df ( bus_o(1,1,bigk),1,F_ni,1,F_nj,
     $                     nis,njs,nks(idx),
     $                     peron(idx)(1:4),gid, gif, gjd, gjf,1.0,ind_o,unf )
          bigk = bigk + nks(idx)
       enddo
       If (Out_blocme.eq.0) then
           close (unf)
       endif
*
*----------------------------------------------------------------------
 1000 format(3X,'OUTPUT THE PERMANENT PHYSICS BUS: (S/R OUT_PERBUS_3DF)')
      return
      end