copyright (C) 2001 MSC-RPN COMM %%%MC2%%%
*
subroutine out_dyn (trname,rstrt) 1,10
implicit none
*
character*8 trname(*)
logical rstrt
*
#include "dynmem.cdk"
#include "partopo.cdk"
#include "rec.cdk"
#include "grd.cdk"
#include "sor.cdk"
#include "yomdyn.cdk"
#include "yomdyn1.cdk"
#include "topo.cdk"
*
logical out_step,doneonce,oldstyle
external out_step
integer i,j,k,kk,step_id,level_id,grid_id,nk_o,
$ is,nis,js,jn,njs,iw,ie,niw,jw,njw
integer, dimension (:), allocatable :: ind_o
data doneonce,oldstyle /.false.,.false./
save doneonce
*
*------------------------------------------------------------------
*
call rpn_comm_xch_halo (ppp,minx,maxx,miny,maxy,ldni,ldnj,
$ ndynvar*gnk+1,hx,hy,period_x,period_y,ldni,0)
*
if (rstrt.and..not.doneonce) goto 998
*
*########## REGULAR OUTPUT #######################################
*
do 100 i=1,nkout
*
if (varout_nvar(i).gt.0) then
level_id= varout_p(1,i)
grid_id= varout_p(2,i)
step_id= varout_p(3,i)
nvardyn = 0
if ( (stepout_typ( step_id).ne.'@') .and.
$ (levout_typ (level_id).ne.'@') .and.
$ (gridout_typ( grid_id).ne.'@') ) then
*
if (out_step (gnstepno,stepout(1,step_id),
$ stepout_typ(step_id),stepout_ns(step_id))) then
if (myproc.eq.0) then
write (6,900) i,level_id,grid_id,step_id
print*, (varout_S(j,i) ,j=1,varout_nvar(i))
endif
*
*** Variables
udolist = "#$%^&"
do k=1,varout_nvar(i)
udolist(k) = varout_S(k,i)
end do
nvardyn = varout_nvar(i)
*
*** Levels
nk_o = levout_nlvl(level_id)
allocate (ind_o(nk_o+1))
call out_slev (level_id,nk_o,ind_o,'d')
*
*** Grid
g_id = gridout(1,grid_id)
g_if = gridout(2,grid_id)
g_jd = gridout(3,grid_id)
g_jf = gridout(4,grid_id)
g_reduc = gridout(5,grid_id)
if (g_reduc .gt. 1) then
g_id = min(gni,max(1,g_id))
g_if = min(gni,max(1,g_if))
g_jd = min(gnj,max(1,g_jd))
g_jf = min(gnj,max(1,g_jf))
endif
call out_sgrid
*
* producing the output
call out_dynr (trname,ind_o,nk_o,nstepsor_d)
deallocate (ind_o)
endif
*
endif
endif
*
100 continue
*
*
*#################################################################
*
*########## SPECIAL OUTPUT FOR CASCADE ###########################
*
if (oldstyle) then
if ( (Grdc_proj_S.ne.'@').and.(Grdc_ndt.ge.0) ) then
*
out_ontimec = .false.
if ( gnstepno.ge.Grdc_start ) then
if ( Grdc_ndt.eq.0 ) then
if (gnstepno.eq.0) out_ontimec = .true.
else
out_ontimec = (mod(gnstepno,Grdc_ndt).eq.0)
endif
endif
*
if ( out_ontimec ) then
*
*** Variables
udolist(1) = 'BUOY'
udolist(2) = 'HU '
udolist(3) = 'UU '
udolist(4) = 'VV '
udolist(5) = 'WZ '
udolist(6) = 'PREG'
nvardyn = 6
if (Grdc_trnm_S(1).eq.'@#$%') then
do k=1,ntr
nvardyn = nvardyn + 1
udolist(nvardyn) = trname(k)
end do
else
do kk=1,max_trnm
if (Grdc_trnm_S(kk).eq.'@#$%') goto 87
do k=1,ntr
if (Grdc_trnm_S(kk).eq.trname(k)) then
nvardyn = nvardyn + 1
udolist(nvardyn) = trname(k)
endif
end do
end do
endif
*
*** Levels
87 nk_o = gnk
allocate (ind_o(nk_o+1))
levtyp = 'G'
do k=1,nk_o+1
ind_o(k) = k
end do
out_kind = 4
out_lt = 'cm'
*
*** Grid
g_id = Grdc_gid
g_if = Grdc_gif
g_jd = Grdc_gjd
g_jf = Grdc_gjf
g_reduc = 1
call out_sgrid
*
* producing the output
call out_dynr (trname,ind_o,nk_o,Grdc_nsor)
*
deallocate (ind_o)
*
endif
*
out_ontimec = .false.
*
endif
endif
*
*########## SPECIAL OUTPUT FOR CASCADE ###########################
*
if ( (Grdc_proj_S.ne.'@').and.(Grdc_ndt.ge.0) ) then
*
out_ontimec = .false.
if ( gnstepno.ge.Grdc_start ) then
if ( Grdc_ndt.eq.0 ) then
if (gnstepno.eq.0) out_ontimec = .true.
else
out_ontimec = (mod(gnstepno,Grdc_ndt).eq.0)
endif
endif
*
if ( out_ontimec ) then
*
nvardyn = 0
if (Grdc_trnm_S(1).eq.'@#$%') then
do k=1,ntr
nvardyn = nvardyn + 1
udolist(nvardyn) = trname(k)
end do
else
do kk=1,max_trnm
if (Grdc_trnm_S(kk).eq.'@#$%') goto 89
do k=1,ntr
if (Grdc_trnm_S(kk).eq.trname(k)) then
nvardyn = nvardyn + 1
udolist(nvardyn) = trname(k)
endif
end do
end do
endif
89 continue
*
if ((.not.Grdc_init3d_L).or.(.not.Grdc_bcs_L)) then
*
g_id = Grdc_gid
g_if = Grdc_gif
g_jd = Grdc_gjd
g_jf = Grdc_gjf
g_reduc = 1
call out_sgrid
c if (myproc.eq.0) print*, 'BCS_DYN: ',gnstepno,
c $ g_id,g_if,g_jd,g_jf,g_if-g_id+1,g_jf-g_jd+1,
c $ (g_if-g_id+1)*(g_jf-g_jd+1),
c $ xpx(g_id+hx),xpx(g_id+hx+out_nisg-1),
c $ ypx(g_jd+hy),ypx(g_jd+hy+out_njsg-1)
*
call out_dync (trname)
Grdc_init3d_L = .true.
*
else
*
is = Grdc_gid
nis = Grdc_gif-Grdc_gid+1
js = Grdc_gjd
jn = Grdc_gjf-Grdc_hbsn-1
njs = Grdc_hbsn+2
*
iw = Grdc_gid
ie = Grdc_gif-Grdc_hbwe-1
niw = Grdc_hbwe+2
*
jw = js+njs-5
njw = jn-jw +6
*
c if (myproc.eq.0) print*, 'BCSH_DYN: ',gnstepno,
c $ is,is+nis-1,js,js+njs-1,jn,jn+njs-1,nis,njs,nis*njs,
c $ xpx(is+hx),xpx(is+hx+nis-1),
c $ ypx(js+hy),ypx(js+hy+njs-1),
c $ ypx(jn+hy),ypx(jn+hy+njs-1),
c $ iw,iw+niw-1,ie,ie+niw-1,jw,jw+njw-1,niw,njw,niw*njw
call out_sfileb (gnstepno,is,nis,js,jn,njs,iw,ie,niw,jw,njw)
call out_dynb (trname ,is,nis,js,jn,njs,iw,ie,niw,jw,njw)
*
endif
*
endif
out_ontimec = .false.
endif
*
998 doneonce = .true.
*
*#################################################################
900 format (/' ### ===> DYN OUTPUT SET #',i4,', Levels=',i4,
$ ', Grid=',i4,', Step=',i4)
*------------------------------------------------------------------
return
end