!-------------------------------------- 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_dyn_3df - output in the form of 3DF files
*
#include "model_macros_f.h"
*

      subroutine out_dyn_3df ( datev, mode, gid, gif, gjd, gjf ) 1,7
      implicit none
*
      character* (*) datev
      integer mode, gid, gif, gjd, gjf
*
*author M.Desgagne ( MC2 2001)
*
*revision
* v3_30 - V.Lee - initial version for GEM LAM (new I/O)
*
#include "glb_ld.cdk"
#include "geomg.cdk"
#include "out.cdk"
#include "vt1.cdk"
#include "vth.cdk"
#include "schm.cdk"
#include "grdc.cdk"
#include "tr3d.cdk"
#include "lctl.cdk"
*
      integer  vmmlod,vmmget,vmmuld
      external vmmlod,vmmget,vmmuld
*
      integer*8 pnt_trp(Grdc_ntr)
      integer i,j,k,nis,njs,ind_o(G_nk+1),cnt,unf,key(21),
     $        nvar,err,keyp_,keyp(Grdc_ntr)
      real trp
      pointer (patrp, trp(LDIST_SHAPE,*))
*
*------------------------------------------------------------------
*
      if ((out_nisl.le.0).or.(out_njsl.le.0)) return
*
      nis = out_ifg - out_idg + 1
      njs = out_jfg - out_jdg + 1
      do k=1,G_nk+1
         ind_o(k) = k
      end do
      
*
      key (1)=VMM_KEY(ut1)
      key (2)=VMM_KEY(vt1)
      key (3)=VMM_KEY(tt1)
      key (4)=VMM_KEY(pipt1)
      key (5)=VMM_KEY(fit1)
      nvar = 5
*
      err = vmmlod (key,nvar)

      err = VMM_GET_VAR(ut1)
      err = VMM_GET_VAR(vt1)
      err = VMM_GET_VAR(tt1)
      err = VMM_GET_VAR(fit1)
      err = VMM_GET_VAR(pipt1)
*
      keyp_ = VMM_KEY (trt1)
      do k=1,Grdc_ntr
         do i=1,Tr3d_ntr
            if (Grdc_trnm_S(k).eq.Tr3d_name_S(i)) keyp(k) = keyp_ + i
         end do
      end do
      err = vmmlod(keyp,Grdc_ntr)
      do k=1,Grdc_ntr
         err = vmmget(keyp(k),patrp,trp)
         pnt_trp(k) = patrp
      end do
*
      if (Out_blocme.eq.0) 
     $     call out_sfile_3df (datev,unf,'DYNAMICS',gid, gif, gjd, gjf,
     $                                              nvar,Grdc_ntr,mode)
*
      call write_3df (  tt1,l_minx,l_maxx,l_miny,l_maxy,nis,njs,G_nk ,
     $                       'TT  ',gid, gif, gjd, gjf,1.0,ind_o,unf )
      call write_3df ( fit1(l_minx,l_miny,G_nk),
     $                         l_minx,l_maxx,l_miny,l_maxy,nis,njs,1 ,
     $                       'PHI ',gid, gif, gjd, gjf,1.0,ind_o,unf )
      call write_3df (pipt1(l_minx,l_miny,G_nk),
     $                         l_minx,l_maxx,l_miny,l_maxy,nis,njs,1 ,
     $                       'PIPT',gid, gif, gjd, gjf,1.0,ind_o,unf )
*
      do k=1,Grdc_ntr
         patrp = pnt_trp(k)
         call write_3df (trp,l_minx,l_maxx,l_miny,l_maxy,nis,njs,G_nk ,
     $                Grdc_trnm_S(k),gid, gif, gjd, gjf,1.0,ind_o,unf )
      end do

      call write_3df (  ut1,l_minx,l_maxx,l_miny,l_maxy,nis,njs,G_nk ,
     $                       'UU  ',gid, gif, gjd, gjf,1.0,ind_o,unf )
      call write_3df (  vt1,l_minx,l_maxx,l_miny,l_maxy,nis,njs,G_nk ,
     $                       'VV  ',gid, gif, gjd, gjf,1.0,ind_o,unf )
*
      if (Out_blocme.eq.0) then
         close (unf)
      endif
*
*------------------------------------------------------------------
      return
      end
*