!-------------------------------------- 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 set_sor - initialization of all control parameters for output
*
#include "model_macros_f.h"
*
subroutine set_sor() 1,3
*
implicit none
*
*author
* J. Caveen - rpn - august 1994 - v0_16
*
*revision
* v2_00 - Lee V. - initial MPI version (from setsor v1_03)
* v2_10 - Lee V. - to broadcast Pslab_useit,Slab_xnbits and
* v2_10 print tables of both variables requested
* v2_10 for output
* v2_20 - Lee V. - enable output of entry bus variables
* v2_21 - Desgagne M. - rpn_comm stooge for MPI
* v2_21 - J. P. Toviessi - set diez (#) slab output
* v2_30 - Lee V. - reduced Level_typ to be 1-D,
* v2_30 save staggered eta levels in Level_stag_ip1
* v2_31 - Lee V. - output on Geomg_hyb coordinates, check if
* v2_31 file output.cfg before call to srequet
* v2_31 - Common blocks of p_busp,p_busv... eliminated
* v2_31 - Allocate vectors for chemistry tracer output
* v2_32 - Lee V. - output files set to TIMESTEP units if frequency
* v2_32 of output more than unit requested
* v3_00 - Desgagne & Lee - Lam configuration
* v3_01 - Lee V. - new ip1 encoding (kind=5 -- unnormalized)
* v3_20 - Lee V. - request of physics output via long/short name
* v3_20 - A. Kallaur - request chemical var. output (05/2005)
* v3_33 - Lee V. - output files set to frequency requested
*
*object
* See above id
*
*arguments
* none
*
*implicits
#include "glb_ld.cdk"
#include "lun.cdk"
#include "ptopo.cdk"
#include "out3.cdk"
#include "level.cdk"
#include "modconst.cdk"
#include "timestep.cdk"
#include "schm.cdk"
#include "step.cdk"
#include "lctl.cdk"
#include "outd.cdk"
#include "outp.cdk"
#include "outc.cdk"
#include "hgc.cdk"
#include "grid.cdk"
#include "itf_phy_buses.cdk"
#include "itf_chm_bus.cdk"
#include "geomg.cdk"
#include "cstv.cdk"
#include "rhsc.cdk"
#include "vt0.cdk"
#include "vth.cdk"
#include "vt1.cdk"
#include "vt2.cdk"
#include "vta.cdk"
#include "vtx.cdk"
#include "orh.cdk"
#include "p_geof.cdk"
*
integer srequet,fnom,longueur
external srequet,fnom,longueur
*
character*5 blank_S
character*8 unit_S
character*256 fn
logical iela
integer pnerror,i,idx,k,j,levset,kk
integer ixg(4), sorvmm
*
if (Lun_out.gt.0) write(Lun_out,5200)
* Fill in the positional records for scalar grid
ixg(1) = Hgc_ig1ro
ixg(2) = Hgc_ig2ro
ixg(3) = Hgc_ig3ro
ixg(4) = Hgc_ig4ro
pnerror = 0
if (Ptopo_myproc.eq.0) then
fn = Lun_sortie_S(1:longueur(Lun_sortie_S))
inquire (FILE=fn,EXIST=iela)
if (iela) then
pnerror = pnerror + srequet()
else
pnerror = pnerror + 1
endif
if (pnerror .gt. 0) then
write(Lun_out,5000) pnerror
endif
if (Out3_unit_s .eq. ' '.or. Out3_unit_s .eq. 'H') then
unit_S = 'HOURS'
endif
if (Out3_unit_s .eq. 'D') then
unit_S = 'DAYS'
endif
if (Out3_unit_s .eq. 'M') then
unit_S = 'MINUTES'
endif
if (Out3_unit_s .eq. 'S') then
unit_S = 'SECONDS'
Out3_ndigits = 6
endif
if (Out3_unit_s .eq. 'P') then
unit_S = 'TIMESTEPS'
Out3_ndigits = 6
endif
write(6,3000)unit_S
* Transfer filter and xnbit info to requested variables
do k=1, Outd_sets
do j=1,Outd_var_max(k)
do i=1,Out3_filtpass_max
if (Outd_var_S(j,k) .eq. Out3_filt_S(i)) then
Outd_filtpass(j,k) = Out3_filtpass(i)
Outd_filtcoef(j,k) = Out3_filtcoef(i)
endif
enddo
do i=1,Out3_xnbits_max
if (Outd_var_S(j,k) .eq. Out3_xnbits_S(i)) then
Outd_nbit(j,k) = Out3_xnbits(i)
endif
enddo
enddo
enddo
do k=1, Outp_sets
do j=1,Outp_var_max(k)
do i=1,Out3_filtpass_max
if (Outp_varnm_S(j,k) .eq. Out3_filt_S(i)) then
Outp_filtpass(j,k) = Out3_filtpass(i)
Outp_filtcoef(j,k) = Out3_filtcoef(i)
endif
enddo
do i=1,Out3_xnbits_max
if (Outp_varnm_S(j,k) .eq. Out3_xnbits_S(i)) then
Outp_nbit(j,k) = Out3_xnbits(i)
endif
enddo
enddo
enddo
do k=1, Outc_sets
do j=1,Outc_var_max(k)
do i=1,Out3_filtpass_max
if (Outc_varnm_S(j,k) .eq. Out3_filt_S(i)) then
Outc_filtpass(j,k) = Out3_filtpass(i)
Outc_filtcoef(j,k) = Out3_filtcoef(i)
endif
enddo
do i=1,Out3_xnbits_max
if (Outc_varnm_S(j,k) .eq. Out3_xnbits_S(i)) then
Outc_nbit(j,k) = Out3_xnbits(i)
endif
enddo
enddo
enddo
* Check number of VMM variables requested for output
sorvmm=0
do 100 k=1, Outd_sets
do 50 j=1,Outd_var_max(k)
if (vt0_first(1).ge.0.and.sorvmm.lt.1) then
do i=1,COMMON_SIZE(vt0)
if (Outd_var_S(j,k) .eq. vt0_n_first(i)) then
sorvmm = sorvmm+1
cycle
endif
enddo
endif
if (vth_first(1).ge.0.and.sorvmm.lt.1) then
do i=1,COMMON_SIZE(vth)
if (Outd_var_S(j,k) .eq. vth_n_first(i)) then
sorvmm = sorvmm+1
cycle
endif
enddo
endif
if (vt1_first(1).ge.0.and.sorvmm.lt.1) then
do i=1,COMMON_SIZE(vt1)
if (Outd_var_S(j,k) .eq. vt1_n_first(i)) then
sorvmm = sorvmm+1
cycle
endif
enddo
endif
if (vtx_first(1).ge.0.and.sorvmm.lt.1) then
do i=1,COMMON_SIZE(vtx)
if (Outd_var_S(j,k) .eq. vtx_n_first(i)) then
sorvmm = sorvmm+1
cycle
endif
enddo
endif
if (vta_first(1).ge.0.and.sorvmm.lt.1) then
do i=1,COMMON_SIZE(vta)
if (Outd_var_S(j,k) .eq. vta_n_first(i)) then
sorvmm = sorvmm+1
cycle
endif
enddo
endif
if (rhsc_first(1).ge.0.and.sorvmm.lt.1) then
do i=1,COMMON_SIZE(rhsc)
if (Outd_var_S(j,k) .eq. rhsc_n_first(i)) then
sorvmm = sorvmm+1
cycle
endif
enddo
endif
if (orh_first(1).ge.0.and.sorvmm.lt.1) then
do i=1,COMMON_SIZE(orh)
if (Outd_var_S(j,k) .eq. orh_n_first(i)) then
sorvmm = sorvmm+1
cycle
endif
enddo
endif
if (geof_first(1).ge.0.and.sorvmm.lt.1) then
do i=1,COMMON_SIZE(geof)
if (Outd_var_S(j,k) .eq. geof_n_first(i)) then
sorvmm = sorvmm+1
cycle
endif
enddo
endif
50 continue
100 continue
if (sorvmm.gt.0) Outd_vmm_L = .true.
endif
COMMON_BROADCAST(Timestep_i)
COMMON_BROADCAST(Timestep_l)
COMMON_BROADCAST(Grid_i)
COMMON_BROADCAST(Grid_c)
COMMON_BROADCAST(Level_r)
COMMON_BROADCAST(Level_i)
COMMON_BROADCAST(Level_c)
COMMON_BROADCAST(Outd)
COMMON_BROADCAST(Outp)
COMMON_BROADCAST(Outc)
COMMON_BROADCAST(Outd_c)
COMMON_BROADCAST(Outd_r)
COMMON_BROADCAST(Outd_l)
COMMON_BROADCAST(Outp_c)
COMMON_BROADCAST(Outp_r)
COMMON_BROADCAST(Outc_c)
COMMON_BROADCAST(Outc_r)
COMMON_BROADCAST(Out3_c)
COMMON_BROADCAST(Out3_i)
COMMON_BROADCAST(Out3_l)
* Print table of dynamic variables demanded for output
if (Lun_out.gt.0) then
write(Lun_out,900)
write(Lun_out,1006)
write(Lun_out,901)
do j=1,Outd_sets
do i=1,Outd_var_max(j)
write(Lun_out,1008) Outd_var_S(i,j),Outd_var_S(i,j),Outd_nbit(i,j),
$ Outd_filtpass(i,j),Outd_filtcoef(i,j),Level_typ(Outd_lev(j))
enddo
enddo
write(Lun_out,1006)
write(Lun_out,2001)
endif
*
* PHYSICS PACKAGE VARIABLES
* =========================
* Save only the short name of the requested physics variables
* and print table of variables demanded for output
* p_bent_out=total number of output variables found in busent
* p_bper_out=total number of output variables found in busper
* p_bdyn_out=total number of output variables found in busdyn
* p_bvol_out=total number of output variables found in busvol
* print *,'P_bent_top=',P_bent_top
* print *,'P_bper_top=',P_bper_top
* print *,'P_bdyn_top=',P_bdyn_top
* print *,'P_bvol_top=',P_bvol_top
*
kk = 0
if (Lun_out.gt.0) then
write(Lun_out,1000)
write(Lun_out,1006)
write(Lun_out,1005)
write(Lun_out,1006)
write(Lun_out,902)
endif
do i = 1, P_bent_top
do k=1, Outp_sets
do j=1,Outp_var_max(k)
if (Outp_varnm_S(j,k).eq.entnm(i)(1:16) .or.
$ Outp_varnm_S(j,k).eq.enton(i)(1:4)) then
Outp_var_S(j,k)= enton(i)(1:4)
if (Lun_out.gt.0) write(Lun_out,1007)
$ enton(i)(1:4),entnm(i)(1:16),Outp_nbit(j,k),
$ Outp_filtpass(j,k),Outp_filtcoef(j,k),'M'
kk=kk+1
p_bent_idx(kk)=i
endif
enddo
enddo
enddo
p_bent_out = kk
kk = 0
if (Lun_out.gt.0) then
write(Lun_out,1006)
write(Lun_out,1002)
write(Lun_out,1006)
write(Lun_out,902)
endif
do i = 1, P_bper_top
do k=1, Outp_sets
do j=1,Outp_var_max(k)
if (Outp_varnm_S(j,k).eq.pernm(i)(1:16) .or.
$ Outp_varnm_S(j,k).eq.peron(i)(1:4)) then
Outp_var_S(j,k)= peron(i)(1:4)
if (Lun_out.gt.0) write(Lun_out,1007)
$ peron(i)(1:4),pernm(i)(1:16),Outp_nbit(j,k),
$ Outp_filtpass(j,k),Outp_filtcoef(j,k),'M'
kk=kk+1
p_bper_idx(kk)=i
endif
enddo
enddo
enddo
p_bper_out = kk
kk = 0
if (Lun_out.gt.0) then
write(Lun_out,1006)
write(Lun_out,1003)
write(Lun_out,1006)
write(Lun_out,902)
endif
do i = 1, P_bdyn_top
do k=1, Outp_sets
do j=1,Outp_var_max(k)
if (Outp_varnm_S(j,k).eq.dynnm(i)(1:16) .or.
$ Outp_varnm_S(j,k).eq.dynon(i)(1:4)) then
Outp_var_S(j,k)= dynon(i)(1:4)
if (Lun_out.gt.0) write(Lun_out,1007)
$ dynon(i)(1:4),dynnm(i)(1:16),Outp_nbit(j,k),
$ Outp_filtpass(j,k),Outp_filtcoef(j,k),'M'
kk=kk+1
p_bdyn_idx(kk)=i
endif
enddo
enddo
enddo
p_bdyn_out = kk
kk=0
if (Lun_out.gt.0) then
write(Lun_out,1006)
write(Lun_out,1004)
write(Lun_out,1006)
write(Lun_out,902)
endif
do i = 1, P_bvol_top
do k=1, Outp_sets
do j=1,Outp_var_max(k)
if (Outp_varnm_S(j,k).eq.volnm(i)(1:16) .or.
$ Outp_varnm_S(j,k).eq.volon(i)(1:4)) then
Outp_var_S(j,k)= volon(i)(1:4)
if (Lun_out.gt.0) write(Lun_out,1007)
$ volon(i)(1:4),volnm(i)(1:16),Outp_nbit(j,k),
$ Outp_filtpass(j,k),Outp_filtcoef(j,k),'M'
kk=kk+1
p_bvol_idx(kk)=i
endif
enddo
enddo
enddo
p_bvol_out = kk
* No need to proceed, if Chemistry switch is "off".
if (.not. Schm_chems_L) goto 9988
*
* FOR CHEMICAL SCHEMES:
* =====================
* Save only the short name of the requested chemical variables
* and print table of variables demanded for output.
* chm_bent_out=total number of output variables found in chemical busent
* chm_bper_out=total number of output variables found in chemical busper
* chm_bdyn_out=total number of output variables found in chemical busdyn
* chm_bvol_out=total number of output variables found in chemical busvol
* print *,'chm_bent_top=',chm_bent_top
* print *,'chm_bper_top=',chm_bper_top
* print *,'chm_bdyn_top=',chm_bdyn_top
* print *,'chm_bvol_top=',chm_bvol_top
*
kk = 0
if (Lun_out.gt.0) then
write(Lun_out,1001)
write(Lun_out,1006)
write(Lun_out,1005)
write(Lun_out,1006)
write(Lun_out,903)
endif
do i = 1, chm_bent_top
do k=1, Outc_sets
do j=1,Outc_var_max(k)
if (Outc_varnm_S(j,k).eq.chmentnm(i)(1:16) .or.
$ Outc_varnm_S(j,k).eq.chmenton(i)(1:4)) then
Outc_var_S(j,k)= chmenton(i)(1:4)
if (Lun_out.gt.0) write(Lun_out,1007)
$ chmenton(i)(1:4),chmentnm(i)(1:16),Outc_nbit(j,k),
$ Outc_filtpass(j,k),Outc_filtcoef(j,k),'M'
kk=kk+1
chm_bent_idx(kk)=i
endif
enddo
enddo
enddo
chm_bent_out = kk
kk = 0
if (Lun_out.gt.0) then
write(Lun_out,1006)
write(Lun_out,1002)
write(Lun_out,1006)
write(Lun_out,903)
endif
do i = 1, chm_bper_top
do k=1, Outc_sets
do j=1,Outc_var_max(k)
if (Outc_varnm_S(j,k).eq.chmpernm(i)(1:16) .or.
$ Outc_varnm_S(j,k).eq.chmperon(i)(1:4)) then
Outc_var_S(j,k)= chmperon(i)(1:4)
if (Lun_out.gt.0) write(Lun_out,1007)
$ chmperon(i)(1:4),chmpernm(i)(1:16),Outc_nbit(j,k),
$ Outc_filtpass(j,k),Outc_filtcoef(j,k),'M'
kk=kk+1
chm_bper_idx(kk)=i
endif
enddo
enddo
enddo
chm_bper_out = kk
kk = 0
if (Lun_out.gt.0) then
write(Lun_out,1006)
write(Lun_out,1003)
write(Lun_out,1006)
write(Lun_out,903)
endif
do i = 1, chm_bdyn_top
do k=1, Outc_sets
do j=1,Outc_var_max(k)
if (Outc_varnm_S(j,k).eq.chmdynnm(i)(1:16) .or.
$ Outc_varnm_S(j,k).eq.chmdynon(i)(1:4)) then
Outc_var_S(j,k)= chmdynon(i)(1:4)
if (Lun_out.gt.0) write(Lun_out,1007)
$ chmdynon(i)(1:4),chmdynnm(i)(1:16),Outc_nbit(j,k),
$ Outc_filtpass(j,k),Outc_filtcoef(j,k),'M'
kk=kk+1
chm_bdyn_idx(kk)=i
endif
enddo
enddo
enddo
chm_bdyn_out = kk
kk=0
if (Lun_out.gt.0) then
write(Lun_out,1006)
write(Lun_out,1004)
write(Lun_out,1006)
write(Lun_out,903)
endif
do i = 1, chm_bvol_top
do k=1, Outc_sets
do j=1,Outc_var_max(k)
if (Outc_varnm_S(j,k).eq.chmvolnm(i)(1:16) .or.
$ Outc_varnm_S(j,k).eq.chmvolon(i)(1:4)) then
Outc_var_S(j,k)= chmvolon(i)(1:4)
if (Lun_out.gt.0) write(Lun_out,1007)
$ chmvolon(i)(1:4),chmvolnm(i)(1:16),Outc_nbit(j,k),
$ Outc_filtpass(j,k),Outc_filtcoef(j,k),'M'
kk=kk+1
chm_bvol_idx(kk)=i
endif
enddo
enddo
enddo
chm_bvol_out = kk
*
9988 if (Lun_out.gt.0) write(Lun_out,1006)
*
call out_sblock(Ptopo_numpe_perb,Ptopo_nblocx,Ptopo_nblocy,
$ Ptopo_myblocx,Ptopo_myblocy, Ptopo_mycol, Ptopo_myrow,
$ 0,0,l_ni,l_nj,Ptopo_blocme, Ptopo_mybloc,
$ Ptopo_gindx,Ptopo_numproc,Ptopo_myproc,ixg,Hgc_gxtyp_s,Out3_unit_S,
$ int(Cstv_dt_8),Out3_date,Out3_etik_S, Out3_ndigits,
$ Mod_runstrt_S,
$ min(Step_total, Lctl_step+Step_rsti),Out3_flipit_L,Out3_debug_L)
call ac_posi (G_xg_8(1),G_yg_8(1),G_ni,G_nj,Lun_out.gt.0)
*
return
*
900 format(/'+',35('-'),'+',17('-'),'+',5('-'),'+'/'| DYNAMIC VARIABLES REQUESTED FOR OUTPUT |',5x,'|')
901 format('|',1x,'OUTPUT',1x,'|',2x,' OUTCFG ',2x,'|',2x,' BITS |','FILTPASS|FILTCOEF| LEV |')
902 format('|',1x,'OUTPUT',1x,'|',2x,'PHYSIC NAME ',2x,'|',2x,' BITS |','FILTPASS|FILTCOEF| LEV |')
903 format('|',1x,'OUTPUT',1x,'|',2x,'CHEMCL NAME ',2x,'|',2x,' BITS |','FILTPASS|FILTCOEF| LEV |')
1000 format(/'+',35('-'),'+',17('-'),'+',5('-'),'+'/'| PHYSICS VARIABLES REQUESTED FOR OUTPUT |',5x,'|')
1001 format(/'+',35('-'),'+',17('-'),'+',5('-'),'+'/'|CHEMICAL VARIABLES REQUESTED FOR OUTPUT |',5x,'|')
1002 format('|',5X,'Permanent Bus ',40x, '|')
1003 format('|',5X,'Dynamic Bus ',40x, '|')
1004 format('|',5X,'Volatile Bus ',40x, '|')
1005 format('|',5X,'Entry Bus ',40x, '|')
1006 format('+',8('-'),'+',16('-'),'+',9('-'),'+',8('-'),'+',8('-'),'+',5('-'))
1007 format('|',2x,a4,2x,'|',a16,'|',i5,' |',i8,'|',f8.3,'|',a4,' |')
1008 format('|',2x,a4,2x,'|',a4,12x,'|',i5,' |',i8,'|',f8.3,'|',a4,' |')
2001 format('* Note: NO filter is applied to 3D fields on M levels')
3000 format(/,'SET_SOR - OUTPUT FILES will be in ',A8)
5000 format(
$ ' TOTAL NUMBER OF WARNINGS ENCOUNTERED IN',
$ ' DIRECTIVE SETS: ', I5)
5200 format(/,'INITIALIZATION OF OUTPUT PRODUCTS (S/R SET_SOR)',
% /,'===============================================')
end