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

      subroutine out_wrphyo (outbus,wrpospc,wrponm,wrpopar,ngth,stepno, 2,11
     $                                                 ind_o,nk_o,nsor)
      implicit none
*
      character*8 wrponm(*)
      integer wrpopar(3,*),wrpospc,ngth,stepno,ind_o(*),nk_o,nsor
      real outbus(*)
*
*AUTHOR     Michel Desgagne                Dec   2002
*
*REVISION
*
*ARGUMENTS
*    NAMES     I/O  TYPE  A/S        DESCRIPTION
*
*    n          I    I    S    number of output variables on outbus
*    npar       I    I    A    number of attributes per variable
*    stepno     I    I    S    step number
*    iun        I    I    S    fortran unit (input  file)
*    oun        I    I    S    fortran unit (output file)
*
*IMPLICIT
*
#include "dynmem.cdk"
#include "partopo.cdk"
#include "physnml.cdk"
#include "path.cdk"
#include "grd.cdk"
#include "topo.cdk"
#include "sor.cdk"
#include "vinterpo.cdk"
#include "yomdyn1.cdk"
#include "levels.cdk"
*
**
      character*8 varname,pcpnm(4),dianm(4),mixnm(3)
      integer ng,pnprog,nfld3d,id,nkk,err,i,j,k,im,offset,kind,ip3,cnt
      integer, dimension (:), allocatable :: ktop,kbot
      real, dimension (:,:), allocatable :: tr1,t1
      real prt(ldni*ldnj,gnk), lprt(ldni*ldnj,gnk), ht_o(ldni*ldnj,gnk),
     $     intlev(nkout), lv, ztp(gnk), ztmp, con
*
      data pcpnm /'PR','SN','RT','SR'/
      data dianm /'UU','VV','TT','HU'/
      data mixnm /'IF','QI','QW'/
*----------------------------------------------------------------------
*
      ng  = ldni*ldnj
*
      call out_sfile (nsor,stepno)
*
      pnprog = int (dble(stepno) * grdt / 3600. + 1.e-12)
*    
      if (out_lt.ne.'cm')
     $   call ecris_fst2 (hh0,minx,maxx,miny,maxy,0.,'ME  ',1.0,pnprog,
     $                                         stepno,-1,1,1,1,out_unf)
* 
      nfld3d=0
      do id=1,ngth
         if (wrpopar(2,id).gt.1) nfld3d = nfld3d +1
      end do
*
      if (nfld3d.gt.0) then
*
         if (levtyp.ne.'G') then
            call fullprw ( prt, ht_o, ng, gnk, levtyp )
            call out_lev (intlev,nkk,pres_o,prt,height_o,ng,gnk,nkout)
            call hpalloc (papositp, dim2d*     nkk*6  , err,1)
            call hpalloc (pahwwp  , dim2d* (gnk+3)*2  , err,1)
            allocate (t1(ng,nkk),ktop(ng*nkk),kbot(ng*nkk))
            if (levtyp.eq.'P') then
               do k=1,nkk
               do i=1,ng
                  t1(i,k) = alog(intlev(k)*100.)
               end do
               end do
               do k=1,gnk
               do i=1,ng
                  lprt(i,k) = alog(prt(i,k))
               end do
               end do
               call inv_posiz ( posit_op,hww_op,lprt,t1,ktop,kbot,
     $                                                 ng,nkk,gnk )
               do k=1,nkk/2
                  ztmp = intlev(k)
                  intlev(k) = intlev(nkk-k+1)
                  intlev(nkk-k+1) = ztmp
               end do
            elseif (levtyp.eq.'H') then
               do k=1,nkk
               do i=1,ng
                  t1(i,k) = intlev(k)
               end do
               end do
               call posiz3(posit_op,hww_op,ht_o,t1,ktop,kbot,ng,nkk,gnk)
            endif
            deallocate (ktop,kbot)
         else
            nkk = gnk
            do k = 2, gnk
               ztp(k) = ztr(k-1)
            end do
            ztp(1) = zt(1)
         endif
*
      endif
*
      do id=1,ngth
      do im=1,wrpopar(3,id)
         offset  = wrpopar(1,id) + (im-1)*ng*wrpopar(2,id)
         varname = wrponm(id)
         con = 1.
* for phy41
         if ((wrponm(id)(1:2).eq.'7A').or.(wrponm(id)(1:2).eq.'SD')) con=100.
         lv   =  0.
         kind = -1
         if ((wrpopar(3,id).gt.1) .and. 
     $     (.not.((wrponm(id)(1:4).eq.'PCPN').or.(wrponm(id)(1:6).eq.'SFCDIA'))))
     $   then
            lv   = real(im)
            kind = 3
         endif
         if (wrpopar(2,id).lt.2) then  ! 2D fields
            if (wrponm(id)(1:4).eq.'PCPN'  ) varname = pcpnm(im)
            if (wrponm(id)(1:6).eq.'SFCDIA') varname = dianm(im)
            call ecris_fst2 ( outbus(offset),1,ldni,1,ldnj,lv,varname,
     $                           con,pnprog,stepno,kind,1,1,1,out_unf )
         else
            ip3 = 0
            if (wrpopar(3,id).gt.1) ip3 = im
            if (wrponm(id)(1:6).eq.'ICEDIA') then
               varname = mixnm(im)
               ip3 = 0
            endif
            if (levtyp.ne.'G') then
               call inv_vertint (t1,outbus(offset),posit_op,hww_op,
     $                                                  ng,nkk,gnk)
               call ecris_fst2 ( t1,1,ldni,1,ldnj,intlev,varname,1.0,
     $                 pnprog,stepno,out_kind,nkk,ind_o,nk_o,out_unf)
            else
               call ecris_fst2(outbus(offset),1,ldni,1,ldnj,ztp,varname,
     $                1.0,pnprog,stepno,out_kind,nkk,ind_o,nk_o,out_unf)
            endif
         endif
      end do
      end do
*
      if ((nfld3d.gt.0).and.(levtyp.ne.'G')) then
         deallocate (t1)
         call hpdeallc (papositp,err,1)
         call hpdeallc (pahwwp  ,err,1)
         papositp = 0
         pahwwp   = 0
      endif
*
      call out_cfile
*
*----------------------------------------------------------------------
      return
      end