!-------------------------------------- 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 --------------------------------------
***s/r out_dyn - perform dynamic output
*
#include "model_macros_f.h"
*
subroutine out_dyn (reg_out,casc_out) 15,27
use v4d_prof, only: Pr_nsim4d
implicit none
*
logical reg_out
integer casc_out
*
*author
* V. Lee - rpn - July 2004 (from dynout2 v3_12)
*
*revision
* v3_20 - Lee V. - Initial MPI version (from dynout2 v3_11)
* v3_30 - Milbrandt J. - Added extra hydrometeor variables (snow and hail)
* for Milbrandt-Yau scheme for water-loading
* v3_30 - McTaggart-Cowan R. - Allow for user-defined domain tag extensions
* v3_31 - Lee V. - modification of Out_etik_S in out_sgrid only
* v3_31 - Milbrandt J./ - Changed dyn. variable output names for QR to QL (rain),
* v3_31 - Milbrandt J./ - Changed dyn. variable output names for QR to QL (rain),
* Desgagne M. QG to QJ (graupel), and QC to QB (cloud; Kong-Yau and
* Milbrandt-Yau only) to avoid conflicts with existing variables
*
*object
* Subroutine to control the production of
* the output of the dynamic variables
*
*arguments
* NONE
*
*implicits
#include "glb_ld.cdk"
#include "dcst.cdk"
#include "out3.cdk"
#include "lun.cdk"
#include "geomg.cdk"
#include "geomn.cdk"
#include "schm.cdk"
#include "pres.cdk"
#include "init.cdk"
#include "rstr.cdk"
#include "vt0.cdk"
#include "vt1.cdk"
#include "level.cdk"
#include "outd.cdk"
#include "ptopo.cdk"
#include "tr3d.cdk"
#include "grd.cdk"
#include "grdc.cdk"
#include "grid.cdk"
#include "v4dg.cdk"
#include "lctl.cdk"
#include "vt1m.cdk"
#include "cstv.cdk"
#include "out.cdk"
#include "acid.cdk"
*
**
integer doout, longueur,
$ vmmlod, vmmuld, vmmget, vmmuln
external doout, longueur,
$ vmmlod, vmmuld, vmmget, vmmuln
*
integer err,nrec,dostep(MAXSET), dostep_max, step, key0, key1,
$ pnlkey(15),i,j,k,trkey0(Tr3d_ntr),trkey1(Tr3d_ntr),keytotal
character*4 ext_S
character*6 etikadd_S
character*15 datev,pdate
integer i0,in,j0,jn,ii,jj,kk,levset,n,ip3,pnerr,nk_o
integer is,nis,js,njs,iw,ie,niw,jw,njw
integer, dimension(:), allocatable :: ind_o
real deg2rad
real ptop(LDIST_SHAPE), wlao(LDIST_SHAPE)
real qx(LDIST_SHAPE,G_nk),qc(LDIST_SHAPE,G_nk),
$ hu(LDIST_SHAPE,G_nk), hum(LDIST_SHAPE,G_nk),
$ wlnph(LDIST_SHAPE,G_nk),
$ vtm(LDIST_SHAPE,G_nk)
integer keym(Tr3d_ntr),key0m
logical periodx_L,v4dgconf_L,doneonce,ontimec
real hut1,qct1,hum1,qjt1
pointer (pahum, hum1(LDIST_SHAPE,*))
pointer (pahu, hut1(LDIST_SHAPE,*)),(paqj, qjt1(LDIST_SHAPE,*)),
$ (paqc, qct1(LDIST_SHAPE,*))
real*8 dayfrac,sec_in_day
parameter ( sec_in_day=86400.0d0 )
data doneonce/.false./
save doneonce
**
*
* check if output is required and initialize control tables
* ---------------------------------------------------------------
*
if (Rstri_rstn_L.and..not.doneonce) goto 998
*
*
*########## REGULAR OUTPUT #######################################
*
if (reg_out) then
*
i0 = 1
in = l_ni
j0 = 1
jn = l_nj
v4dgconf_L = V4dg_conf .ne. 0
dostep_max = doout(dostep,1)
deg2rad = acos( -1.0)/180.
*
if (dostep_max.gt.0 .and. V4dg_output_L) then
if (Lun_out.gt.0) write(Lun_out,7001) Lctl_step
else
*
if (Lun_out.gt.0) write(Lun_out,7002) Lctl_step
return
*
endif
call tmg_start( 66, 'OUT_DYN')
*
* PREPARATION for OUT_THM
* ---------------------------
*
key0 = VMM_KEY(pipt1)
err = vmmlod (key0,1)
err = VMM_GET_VAR(pipt1)
*
do j=1,l_nj
do i=1,l_ni
ptop (i,j) = geomg_z_8(1) + pipt1(i,j,1)
wlao (i,j) = Geomn_latrx(i,j) * deg2rad
end do
end do
*
pnlkey(1) = VMM_KEY(fit1)
pnlkey(2) = VMM_KEY(tt1)
pnlkey(3) = VMM_KEY(st1)
pnlkey(4) = VMM_KEY(ut1)
pnlkey(5) = VMM_KEY(vt1)
pnlkey(6) = VMM_KEY(psdt1)
pnlkey(7) = VMM_KEY(tdt1)
pnlkey(8) = VMM_KEY(zz1)
keytotal = 8
*
*
if(.not.v4dgconf_L.or.(v4dgconf_L.and.V4dg_di_L)) then
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
wlnph (i,j,k) = log ( geomg_z_8(k) + pipt1(i,j,k) )
enddo
enddo
enddo
err = vmmlod (pnlkey,8)
else
* <<<<<<<<<<<<<<<<<< CAUTION >>>>>>>>>>>>>>>>>>>>>>>>>>
* Temporary patch for pressure levels when TLM,ADJ.
* Correct evaluation should use TRAJECTORY when TLM,ADJ
* on pressure levels will be activated.
* <<<<<<<<<<<<<<<<<< CAUTION >>>>>>>>>>>>>>>>>>>>>>>>>>
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
wlnph(i,j,k) = log ( geomg_z_8(k) )
enddo
enddo
enddo
*
pnlkey(9) = VMM_KEY(tpt1)
pnlkey(10) = VMM_KEY(tpt1m)
pnlkey(11) = VMM_KEY(st1m)
*
keytotal =11
pnerr = vmmlod(pnlkey,11)
pnerr = VMM_GET_VAR(tpt1)
pnerr = VMM_GET_VAR(tpt1m)
pnerr = VMM_GET_VAR(st1m)
*
endif
err = vmmuld(key0,1)
err = VMM_GET_VAR(fit1)
err = VMM_GET_VAR(tt1)
err = VMM_GET_VAR(st1)
err = VMM_GET_VAR(ut1)
err = VMM_GET_VAR(vt1)
err = VMM_GET_VAR(psdt1)
err = VMM_GET_VAR(tdt1)
err = VMM_GET_VAR(zz1)
* Allocate work space and initialize
hu = 0.; hum = 0.;
qc = 0.; qx = 0.;
pahu = loc(hu)
pahum= loc(hum)
paqc = loc(qc)
key0 = VMM_KEY (trt0)
key1 = VMM_KEY (trt1)
do k=1,Tr3d_ntr
trkey0(k) = key0 + k
trkey1(k) = key1 + k
end do
pnerr = vmmlod(trkey0,Tr3d_ntr)
pnerr = vmmlod(trkey1,Tr3d_ntr)
do n=1,Tr3d_ntr
if (Tr3d_name_S(n).eq.'HU') then
pnerr = vmmget(trkey1(n),pahu,hut1)
endif
if (Schm_phyms_L) then
if (Tr3d_name_S(n).eq.'QC'.or.Tr3d_name_S(n).eq.'QB') then
pnerr = vmmget(trkey1(n),paqc,qct1)
endif
if(Schm_wload_L)then
if (Tr3d_name_S(n).eq.'QC'.or.
$ Tr3d_name_S(n).eq.'QB'.or.
$ Tr3d_name_S(n).eq.'QL'.or.
$ Tr3d_name_S(n).eq.'QI'.or.
$ Tr3d_name_S(n).eq.'QN'.or.
$ Tr3d_name_S(n).eq.'QJ'.or.
$ Tr3d_name_S(n).eq.'QH' ) then
pnerr = vmmget(trkey1(n),paqj,qjt1)
do k=1,l_nk
do j=j0,jn
do i=i0,in
qx (i,j,k) = qx (i,j,k) + max(0.0,qjt1(i,j,k))
enddo
enddo
enddo
endif
endif
endif
enddo
*
if(v4dgconf_L.and.(V4dg_tl_L.or.V4dg_ad_L)) then
do k=1,l_nk
do j=j0,jn
do i=i0,in
vtm (i,j,k) = tpt1m(i,j,k) + Cstv_tstr_8
enddo
enddo
enddo
key0m = VMM_KEY (trt1m)
do k=1,Tr3d_ntr
keym(k) = key0m + k
end do
pnerr = vmmlod(keym,Tr3d_ntr)
do n=1,Tr3d_ntr
if (Tr3d_name_S(n).eq.'HU') then
pnerr = vmmget(keym(n),pahum,hum1)
endif
enddo
endif
*
* setup of ip3 and modifs to label
*
ip3 = 0
etikadd_S = ' '
ext_S=""
if (Out3_ip3.eq.-1) ip3 = Lctl_step
if (Out3_ip3.gt.0 ) ip3 = Out3_ip3
if (v4dgconf_L) then
if (.not.V4dg_4dvar_L) then
ip3 = V4dg_status
if (V4dg_conf/100.eq.1.and.V4dg_ad_L)
% ip3 = 20 + V4dg_status
else
ip3 = V4dg_status
if(V4dg_tl_L) ip3 = Pr_nsim4d
if(V4dg_ad_L) ip3 = Pr_nsim4d
endif
ext_S = '_nl'
if (V4dg_tl_L) ext_S = '_tl'
if (V4dg_ad_L) ext_S = '_ad'
write(etikadd_S,'(a3,i3.3)')ext_S,ip3
endif
*
* setup of filename extension if needed
if ( ((Init_balgm_L).and.(.not.Rstri_idon_L)).and.
$ ((Lctl_step.ge.(Init_dfnp-1)/2)) )
$ ext_S = '_dgf'
* output loop on the number of "sortie" sets
do 100 jj=1,dostep_max
do 50 kk=1, Outd_sets
if ( Outd_step(kk).eq.dostep(jj) ) then
* (if the timestep set of this sortie set is to output now)
periodx_L=.false.
if (.not.G_lam .and. (Grid_x1(Outd_grid(kk))
$ -Grid_x0(Outd_grid(kk))+1).eq. G_ni ) periodx_L=.true.
call out_sgrid(Grid_x0(outd_grid(kk)),Grid_x1(outd_grid(kk)),
$ Grid_y0(outd_grid(kk)),Grid_y1(outd_grid(kk)),
$ periodx_L,
$ Grid_ig1(outd_grid(kk)),Grid_ig2(outd_grid(kk)),
$ Grid_stride(outd_grid(kk)),
$ Grid_etikext_s(outd_grid(kk)),etikadd_S,
$ Geomn_longs,Geomn_latgs)
levset = Outd_lev(kk)
nk_o = Level_max(levset)
allocate (ind_o(nk_o+1))
call out_slev(Level_typ(levset),Level(1,levset),
$ ind_o,nk_o,G_nk,Level_kind_ip1,'d')
call out_sfile(Out3_closestep,Lctl_step,ip3,ext_S)
*
* output of 3-D tracers
*
call out_tracer (wlnph,trkey0,trkey1,
$ l_minx,l_maxx,l_miny,l_maxy,G_nk,
$ Level_typ(levset),Level(1,levset),ind_o,nk_o,kk)
*
* output of temperature, humidity and mass fields,omega
*
call out_thm(fit1,tt1,st1,qct1,qx,hut1,tpt1,psdt1,tdt1,zz1,
$ vtm,hum1,st1m,
$ wlnph,ptop,wlao,
$ (l_maxx-l_minx+1)*(l_maxy-l_miny+1),G_nk,
$ Level_typ(levset),Level(1,levset),ind_o,nk_o,kk)
*
* output of winds
*
call out_uv (ut1,vt1,wlnph,l_minx,l_maxx,l_miny,l_maxy,G_nk,
$ Level_typ(levset),Level(1,levset),ind_o,nk_o,kk)
*
* output of divergence and vorticity
*
call out_dq (ut1,vt1,wlnph,wlao,l_minx,l_maxx,l_miny,l_maxy,G_nk,
$ Level_typ(levset),Level(1,levset),ind_o,nk_o,kk)
*
*
deallocate (ind_o)
endif
call out_cfile
50 continue
100 continue
pnerr = vmmuln(pnlkey,keytotal)
pnerr = vmmuln(trkey0,Tr3d_ntr)
pnerr = vmmuln(trkey1,Tr3d_ntr)
if(v4dgconf_L.and.(V4dg_tl_L.or.V4dg_ad_L)) pnerr = vmmuln(keym,Tr3d_ntr)
if (Outd_vmm_L) then
* Output VMM model variables
do 200 jj=1,dostep_max
do 150 kk=1, Outd_sets
if ( Outd_step(kk).eq.dostep(jj) ) then
* (if the timestep set of this sortie set is to output now)
periodx_L=.false.
if (.not.G_lam .and.
$ (Grid_x1(Outd_grid(kk))-Grid_x0(Outd_grid(kk))+1).eq.
$ G_ni ) periodx_L=.true.
call out_sgrid(Grid_x0(outd_grid(kk)),Grid_x1(outd_grid(kk)),
$ Grid_y0(outd_grid(kk)),Grid_y1(outd_grid(kk)),
$ periodx_L,
$ Grid_ig1(outd_grid(kk)),Grid_ig2(outd_grid(kk)),
$ Grid_stride(outd_grid(kk)),
$ Grid_etikext_s(outd_grid(kk)),etikadd_S,
$ Geomn_longs,Geomn_latgs)
levset = Outd_lev(kk)
nk_o = Level_max(levset)
allocate (ind_o(nk_o+1))
call out_slev(Level_typ(levset),Level(1,levset),
$ ind_o,nk_o,G_nk,Level_kind_ip1,'d')
call out_sfile(Out3_closestep,Lctl_step,ip3,ext_S)
call out_vmm (wlnph,ip3,etikadd_S,ext_S,
$ l_minx,l_maxx,l_miny,l_maxy,
$ G_nk, Level_typ(levset),Level(1,levset),ind_o,nk_o,kk)
deallocate (ind_o)
endif
call out_cfile
150 continue
200 continue
endif
*
* Delay closure of files, de-allocation, wlog write out if...
if ( .not. (Lctl_step .eq. 0 .and. Schm_phyms_L).or.v4dgconf_L) then
*
*
if((Init_balgm_L) .and. (.not. Rstri_idon_L) ) then
call wlog('IOUT')
else
call wlog('FOUT')
endif
endif
call tmg_stop(66, 'OUT_DYN')
* end of regular output
endif
*
*#################################################################
*
*########## SPECIAL OUTPUT FOR CASCADE ###########################
*
if ((casc_out.gt.0).and.(Grdc_proj_S.ne.'@').and.(Grdc_ndt.ge.0))
$then
*
ontimec = .false.
if ( Lctl_step.ge.Grdc_start.and.Lctl_step.le.Grdc_end) then
if ( Grdc_ndt.eq.0 ) then
ontimec = Lctl_step.eq.0
else
ontimec = (mod(Lctl_step+Grdc_start,Grdc_ndt).eq.0)
endif
endif
*
if ( ((Init_balgm_L).and.(.not.Rstri_idon_L)).and.
$ ((Lctl_step.gt.(Init_dfnp-1)/2)) ) ontimec = .false.
if ( ontimec ) then
*
if ((Lctl_step.eq.Grdc_start).or.(.not.Grdc_bcs_hollow_L)) then
*
call out_sgrid (Grdc_gid,Grdc_gif,Grdc_gjd,Grdc_gjf,
$ .false.,-1,-1,1,'','',Geomn_longs,Geomn_latgs)
call datf2p (pdate,Out3_date)
dayfrac = dble(Lctl_step) * Cstv_dt_8 / sec_in_day
call incdatsd (datev,pdate,dayfrac)
if (Acid_test_L) then
call acid_outdyn_3df (datev,casc_out,Grdc_gid,Grdc_gif,
$ Grdc_gjd,Grdc_gjf)
else
call out_dyn_3df (datev,casc_out,Grdc_gid,Grdc_gif,
$ Grdc_gjd,Grdc_gjf)
endif
*
else
*
call bcs_hollow(Grdc_gid,Grdc_gif,Grdc_gjd,Grdc_gjf,
$ Grdc_gjdi,Grdc_hbsn,Grdc_hbwe,is,nis,js,njs,jn,iw,niw,ie,jw,njw)
call datf2p (pdate,Out3_date)
dayfrac = dble(Lctl_step) * Cstv_dt_8 / sec_in_day
call incdatsd (datev,pdate,dayfrac)
if (Acid_test_L) then
call acid_outdyn_bcs (datev,is,nis,js,jn,njs,iw,ie,
$ niw,jw,njw,casc_out)
else
call out_dyn_bcs (datev,is,nis,js,jn,njs,iw,ie,
$ niw,jw,njw,casc_out)
endif
endif
*
endif
*
ontimec = .false.
*
endif
*
998 doneonce = .true.
*
7001 format(/,' OUT_DYN- WRITING DYNAMIC OUTPUT FOR STEP (',I8,')')
7002 format(/,' OUT_DYN- NO DYNAMIC OUTPUT FOR STEP (',I8,')')
*
return
end