!-------------------------------------- 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_phy
#include "model_macros_f.h"
*
subroutine out_phy ( bus_o,F_ni,F_nj,stepno ) 4,11
use v4d_prof, only: Pr_nsim4d
implicit none
*
integer F_ni,F_nj,ni,nj,stepno
real bus_o(F_ni*F_nj,*)
*
*AUTHOR Michel Desgagne July 2004 (MC2)
*
*REVISION
* v3_20 - Lee V. - initial GEMDM version
* v3_21 - Lee V. - bugfix for LAM output
* 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 - Lee and Bilodeau - in offline mode, extend physics output
* grid to whole domain
* v3_31 - Lee V. - kind is set to 2 (press) for 2D fields, not -1
*
*OBJECT
* Gather the index of physics variables to write on disk
* for the current timestep.
*
*ARGUMENTS
* NAMES I/O TYPE A/S DESCRIPTION
*
* fni I I S folded dimension along X
* fnj I I S folded dimension along Y
* l_ni I I S computational hor. dimension along X
* l_nj I I S computational hor. dimension along Y
* ni I I S regular dimension along X
* nj I I S regular dimension along Y
* stepno I I S step number
*
*IMPLICIT
#include "glb_ld.cdk"
#include "glb_pil.cdk"
#include "dcst.cdk"
#include "out3.cdk"
#include "geomg.cdk"
#include "geomn.cdk"
#include "init.cdk"
#include "rstr.cdk"
#include "grid.cdk"
#include "out.cdk"
#include "itf_phy_buses.cdk"
#include "obus.cdk"
#include "grd.cdk"
#include "level.cdk"
#include "outp.cdk"
#include "ptopo.cdk"
#include "v4dg.cdk"
#include "schm.cdk"
*
**
character*4 ext_S
character*6 etikadd_S
integer i,j,k,mult,nk_o,levset,ii,jj,kk,ip3,ig1
integer, dimension (:), allocatable :: ind_o
integer irff(100)
integer grille_x0,grille_x1,grille_y0,grille_y1
logical periodx_L
real rff(100)
*----------------------------------------------------------------------
*
if (Obus_top.le.0) return
* setup of ip3 and modifs to label
*
call tmg_start0(67, 'OUT_PHY ')
ip3=0
etikadd_S = ' '
ext_S=""
if (Out3_ip3.eq.-1) ip3 = stepno
if (Out3_ip3.gt.0 ) ip3 = Out3_ip3
if (V4dg_conf.ne.0) 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.
$ ((stepno.gt.(Init_dfnp-1)/2)) )
$ ext_S = '_dgf'
*########## REGULAR OUTPUT #######################################
*
* ON sortie_p sets
*
do 100 kk=1,Outp_sets
if ( Outp_dostep_L(kk) )then
periodx_L=.false.
if (.not.G_lam .and. (Grid_x1(Outp_grid(kk))-Grid_x0(Outp_grid(kk))+1).eq. G_ni ) periodx_L= .true.
ig1 = Grid_ig1(outp_grid(kk))
grille_x0 = max( 1+Lam_pil_w - p_nmp, Grid_x0(outp_grid(kk)) )
grille_x1 = min( Grid_x1(outp_grid(kk)), G_ni - Lam_pil_e + p_nmp )
grille_y0 = max( 1+Lam_pil_s - p_nmp,Grid_y0(outp_grid(kk)) )
grille_y1 = min( Grid_y1(outp_grid(kk)), G_nj - Lam_pil_n + p_nmp )
if (G_lam .and.
$ ( grille_x0.ne.Grid_x0(outp_grid(kk)).or.
$ grille_x1.ne.Grid_x1(outp_grid(kk)).or.
$ grille_y0.ne.Grid_y0(outp_grid(kk)).or.
$ grille_y1.ne.Grid_y1(outp_grid(kk)) ) )
$ ig1=Grid_ig1(outp_grid(kk))+100
if (Schm_offline_L) then
grille_x0 = max(1 ,Grid_x0(outp_grid(kk)))
grille_x1 = min(G_ni,Grid_x1(outp_grid(kk)))
grille_y0 = max(1 ,Grid_y0(outp_grid(kk)))
grille_y1 = min(G_nj,Grid_y1(outp_grid(kk)))
endif
call out_sgrid(grille_x0,grille_x1,grille_y0,grille_y1,
$ periodx_L,
$ ig1,Grid_ig2(outp_grid(kk)),
$ Grid_stride(outp_grid(kk)),
$ Grid_etikext_s(outp_grid(kk)),etikadd_S,
$ Geomn_longs, Geomn_latgs )
levset= Outp_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,'p')
call out_sfile(Out3_closestep,stepno,ip3,ext_S)
if (Level_typ(levset).eq.'M') then
do ii=1, Outp_var_max(kk)
do j=1,Obus_top
if ( Outp_var_S(ii,kk).eq. Obus_var_S(j) ) then
*
if (obus_shp(j).gt.1) then
* 3D field
if (obus_stag(j).eq.0) then
call ecris_fst2(bus_o(1,obus_offset(j)),
$ 1,l_ni,1,l_nj,Geomg_hyb,obus_var_s(j),
$ Obus_mul(j),Obus_add(j),Out_kind,G_nk,ind_o,nk_o,
$ Outp_nbit(ii,kk) )
else
* 3D field staggerred
do i=1,G_nk-2
rff(i)= (Geomg_hyb(i+1)+Geomg_hyb(i))/2.
enddo
do i=G_nk-1,G_nk
rff(i)=Geomg_hyb(i)
enddo
call ecris_fst2(bus_o(1,obus_offset(j)),
$ 1,l_ni,1,l_nj,rff,obus_var_s(j),
$ Obus_mul(j),Obus_add(j),Out_kind,G_nk,ind_o,nk_o,
$ Outp_nbit(ii,kk) )
endif
else
* 2D field-multiple
if ( obus_mult(j).gt.1) then
do mult=1,obus_mult(j)
rff(mult)= mult
irff(mult)=mult
enddo
call ecris_fst2(bus_o(1,obus_offset(j)),
$ 1,l_ni,1,l_nj,rff,obus_var_s(j),
$ Obus_mul(j),Obus_add(j),3,obus_mult(j),
$ irff,obus_mult(j), Outp_nbit(ii,kk) )
else
* 2d field
call ecris_fst2(bus_o(1,obus_offset(j)),
$ 1,l_ni,1,l_nj,0.0,obus_var_s(j),
$ Obus_mul(j),Obus_add(j), 2,1,1,1,
$ Outp_nbit(ii,kk) )
endif
endif
endif
enddo
enddo
endif
*
deallocate (ind_o)
*
call out_cfile
endif
*
100 continue
call tmg_stop0(67)
*
*----------------------------------------------------------------------
return
end