copyright (C) 2001 MSC-RPN COMM %%%MC2%%%
***s/r out_sfile
*
subroutine out_sfile (nsor,stepno) 2,2
implicit none
*
integer nsor,stepno
*
*AUTHOR Michel Desgagne September 2003
*
*REVISION
*
*ARGUMENTS
* NAMES I/O TYPE DESCRIPTION
*
#include "lcldim.cdk"
#include "yomdyn1.cdk"
#include "partopo.cdk"
#include "path.cdk"
#include "sor.cdk"
#include "rec.cdk"
#include "grd.cdk"
#include "cdate.cdk"
*
integer prog_filename,fnom,fstouv,fstinl,fstecr,fstopc,longueur
external prog_filename,fnom,fstouv,fstinl,fstecr,fstopc,longueur
*
character*3 ros
character*30 redg
character*15 datev,startindx
integer nlis,prognum,err,nrec,n1,n2,n3,lislon,i,
$ indx,glb1,glb2,glb3,glb4
parameter (nlis = 1024)
integer liste (nlis)
real xpos(out_nisg), ypos(out_njsg)
real*8 grdt_8,ONE, OV_day, OV_hour, OV_min, dayfrac, sec_in_day
parameter ( ONE = 1.0d0, OV_day = ONE/86400.0d0,
$ OV_hour = ONE/3600.0d0, OV_min = ONE/60.0d0,
$ sec_in_day=86400.0d0 )
data ros /'RND'/
**
*----------------------------------------------------------------------
*
out_unf = 0
if (mybloc.ne.0) err = fstopc('MSGLVL','SYSTEM',.false.)
*
if ((blocme.eq.0).and.(out_nisl.gt.0).and.(out_njsl.gt.0)) then
*
if (nsor.le.0) then
out_clostep = stepno
else
if (mod(stepno,nsor).eq.0) then
out_clostep = stepno
if (stepno.eq.0) out_clostep = nsor
else
out_clostep = (stepno/nsor + 1) * nsor
endif
endif
cES specific if ((out_lt.eq.'dm').and.(g_reduc.le.1)) out_clostep=stepno
out_clostep = min(out_clostep,endstepno)
prognum = out_clostep
grdt_8 = dble(out_clostep)*dble(grdt)
if (out_unit_S.eq.'D') prognum = nint(grdt_8 * OV_day )
if (out_unit_S.eq.'H') prognum = nint(grdt_8 * OV_hour)
if (out_unit_S.eq.'M') prognum = nint(grdt_8 * OV_min )
if (out_unit_S.eq.'S') prognum = nint(grdt_8)
if (out_lt.eq.'cm') then
dayfrac = dble(stepno) * dble(grdt) / sec_in_day
call incdatsd (datev,gcrunstrt,dayfrac)
write (startindx,'((i7.7),a1,(i7.7))') out_idg,'-',out_jdg
progfilen='ic'//datev//'_'//startindx
progfilen_fp = '../../output/casc/'//
$ progfilen(1:longueur(progfilen))
else
err = prog_filename (progfilen,out_lt,out_dat2,out_h0,-1,-1,
$ myblocx,myblocy,prognum,6,out_unit_S)
progfilen_fp = '../../output/'//
$ progfilen(1:longueur(progfilen))
endif
c if (g_reduc.gt.1) then
c write (redg,'(a,i3.3,a)') '.',g_reduc,'dx'
c progfilen_fp = progfilen_fp(1:longueur(progfilen_fp))//redg
c endif
if ((g_reduc.gt.1).or.(g_id.gt.1).or.(g_jd.gt.1).or.(g_if.lt.gni).or.(g_jf.lt.gnj)) then
write (redg, 67) g_id,g_jd,g_if,g_jf,g_reduc
progfilen_fp = progfilen_fp(1:longueur(progfilen_fp))//redg
endif
67 format ('.',4(i5.5,'_'),i3.3,'dx')
err = fnom (out_unf ,progfilen_fp,'STD+'//ros,0)
err = fstouv(out_unf ,ros)
if (mybloc.eq.0)
$ write (6,101) out_unf,progfilen(1:longueur(progfilen))
nrec= fstinl (out_unf,n1,n2,n3,' ',' ',Grd_ig1,Grd_ig2,0,
$ ' ','>>',liste,lislon,nlis)
if ((lislon.lt.1).and.(.not.flipit)) then
glb1 = glb_pos(1)-hx*b_west
glb2 = glb_pos(2)+hx*b_east
glb3 = glb_pos(3)-hy*b_south
glb4 = glb_pos(4)+hy*b_north
if ( g_reduc .le. 1 ) then
out_rdi = max(glb1,g_id)
out_rdj = max(glb3,g_jd)
do i=1,out_nisg
xpos(i) = xpx(g_id+hx+i-1)
end do
err=fstecr(xpos,xpos,-32,out_unf,0,0,0,out_nisg,1,
$ 1,Grd_ig1,Grd_ig2,0,'X', '>>','POS_X',gtgrtyp,
$ igs(1), igs(2), igs(3), igs(4), 5, .true.)
do i=1,out_njsg
ypos(i) = ypx(g_jd+hy+i-1)
end do
err=fstecr(ypos,ypos,-32,out_unf,0,0,0,1,out_njsg,
$ 1,Grd_ig1,Grd_ig2,0,'X', '^^','POS_Y',gtgrtyp,
$ igs(1), igs(2), igs(3), igs(4), 5, .true.)
else
out_rdi=glb2
do i=1,out_nisg
indx = g_id+(i-1)*g_reduc
xpos(i) = xpx(indx+hx)
if (indx.ge.glb1) out_rdi= min(out_rdi,max(glb1,indx))
end do
out_rdj=glb4
do i=1,out_njsg
indx = g_jd+(i-1)*g_reduc
ypos(i) = ypx(indx+hy)
if (indx.ge.glb3) out_rdj= min(out_rdj,max(glb3,indx))
end do
err= fstecr (xpos,xpq,-32,out_unf,0,0,0,out_nisg,1,1,
$ Grd_ig1,Grd_ig2,0,'X', '>>','POS_X',gtgrtyp,
$ igs(1), igs(2), igs(3), igs(4), 5, .true.)
err= fstecr (ypos,ypq,-32,out_unf,0,0,0,1,out_njsg,1,
$ Grd_ig1,Grd_ig2,0,'X', '^^','POS_Y',gtgrtyp,
$ igs(1), igs(2), igs(3), igs(4), 5, .true.)
endif
out_nisl = (min(g_if,glb2)-out_rdi) / g_reduc + 1
out_njsl = (min(g_jf,glb4)-out_rdj) / g_reduc + 1
endif
if (levtyp.eq.'G') call wrvref ( out_unf )
*
endif
*
if (mybloc.ne.0) err = fstopc('MSGLVL','INFORM',.false.)
*
101 format (' FST FILE UNIT=',i3,' FILE = ',a,' IS OPENED')
*----------------------------------------------------------------------
return
end
*
subroutine out_cfile 2
implicit none
*
#include "partopo.cdk"
#include "sor.cdk"
*
integer fstfrm,longueur
external fstfrm,longueur
*
integer err
*----------------------------------------------------------------------
*
if ((blocme.eq.0).and.(out_unf.gt.0)) then
err = fstfrm(out_unf)
call fclos(out_unf)
if (mybloc.eq.0)
$ write (6,102) out_unf,progfilen(1:longueur(progfilen))
out_unf = 0
endif
*
102 format (' FST FILE UNIT=',i3,' FILE = ',a,' IS CLOSED')
*----------------------------------------------------------------------
return
end
*