!-------------------------------------- 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/p set_var - initialize list of variables to output
*
#include "model_macros_f.h"
*
integer function set_var (F_argc,F_argv_S,F_cmdtyp_S,F_v1,F_v2)
*
implicit none
*
integer F_argc,F_v1,F_v2
character *(*) F_argv_S(0:F_argc),F_cmdtyp_S
*
*author Vivian Lee - rpn - April 1999
*
*revision
* v2_00 - Lee V. - initial MPI version
* v2_10 - Lee V. - replaced CNMXPHY with Slab_pntop
* v2_21 - J. P. Toviessi - set diez (#) slab output
* v2_31 - Lee V. - add chemistry output list
* v2_32 - Lee V. - gridset,levset,stepset are now IDs defined by the
* v2_32 user so, they are matched to the SORTIE command
* v3_30 - Lee/Bilodeau - bug fix to allow lower and upper case var names
*
*object
* initialization of the common blocks OUTD,OUTP. This function is
* called when the keyword "sortie" is found in the first word
* of the directives in the input file given in the statement
* "process_f_callback". This feature is enabled by the
* ARMNLIB "rpn_fortran_callback" routine (called in "srequet")
* which allows a different way of passing user directives than
* the conventional FORTRAN namelist. This function will process
* the following example command read from the named input file.
*
* ie: sortie([UU,VV,TT],levels,2,grid,3,steps,1)
* sortie([PR,PC,RR],grid,3,steps,2,levels,1)
*
* The "rpn_fortran_callback" routine will process the above
* statement and return 5 arguments to this function. For more
* information to how this is processed, see "SREQUET".
*
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* F_argc I - number of elements in F_argv_S
* F_argv_S I - array of elements received
* if F_argv_S(ii) contains "[", the value in this
* argument indicates number of elements following it
* F_cmdtyp_S I - character command type - not used
* F_v1 I - integer parameter 1 - not used
* F_v2 I - integer parameter 2 - not used
*----------------------------------------------------------------
*
*Notes:
* ie: sortie([UU,VV,TT],levels,2,grid,3,steps,1)
* sortie([PR,PC,RR],grid,3,steps,2,levels,1)
*
* sortie([vr1,vr2,vr3,...],levels,[levelset],grid,[gridset],steps,[stepset])
*
* vr1,vr2,vr3... - set of variable names to output (max of 60)
* levelset - levelset number to use for this set of variables
* gridset - gridset number to use for this set of variables
* stepset - stepset number (timestep set) to use for this set of variables
*
* For each "sortie" command, the levelset, gridset and stepset must be
* specified or an error will occur.
*
*implicits
#include "glb_ld.cdk"
#include "lun.cdk"
#include "out3.cdk"
#include "setsor.cdk"
#include "itf_phy_buses.cdk"
#include "outd.cdk"
#include "outp.cdk"
#include "outc.cdk"
#include "grid.cdk"
#include "level.cdk"
#include "timestep.cdk"
*
**
*
character*5 stuff_S
character*8 varname_S
character string4*4, string16*16
integer levset,stepset,gridset,varmax
integer i, j, k, m, pndx, ii, jj, kk
*
*----------------------------------------------------------------
*
if (Lun_out.gt.0) then
write(Lun_out,*)
write(Lun_out,*) F_argv_S
endif
set_var=0
if (index(F_argv_S(1),'[').gt.0) then
stuff_S=F_argv_S(1)
read(stuff_S(2:4),*) varmax
else
if (Lun_out.gt.0) write(Lun_out,*)
$ 'SET_VAR WARNING: syntax incorrect'
set_var=1
return
endif
*
* Check if chosen levels,grid and timestep sets are valid
*
levset=-1
gridset=-1
stepset=-1
do i=varmax+2, F_argc
if (F_argv_S(i).eq.'levels') then
read(F_argv_S(i+1),*) levset
else if (F_argv_S(i).eq.'grid') then
read(F_argv_S(i+1),*) gridset
else if (F_argv_S(i).eq.'steps') then
read(F_argv_S(i+1),*) stepset
endif
enddo
if (gridset.lt.0) then
if (Lun_out.gt.0) write(Lun_out,*)
$ 'SET_VAR WARNING: no Grid chosen'
set_var=1
return
else
do i=1,Grid_sets
if (gridset .eq. Grid_id(i)) then
gridset=i
exit
endif
enddo
if (i.gt.Grid_sets) then
if (Lun_out.gt.0) write(Lun_out,*)
$ 'SET_VAR WARNING: invalid Grid set ID#'
set_var=1
return
endif
endif
if (levset.lt.0) then
if (Lun_out.gt.0) write(Lun_out,*)
$ 'SET_VAR WARNING: no Levels chosen'
set_var=1
return
else
do i=1,Level_sets
if (levset .eq. Level_id(i)) then
levset=i
exit
endif
enddo
if (i.gt. Level_sets) then
if (Lun_out.gt.0) write(Lun_out,*)
$ 'SET_VAR WARNING: invalid Level set ID#'
set_var=1
return
endif
endif
if (stepset.lt.0) then
if (Lun_out.gt.0) write(Lun_out,*)
$ 'SET_VAR WARNING: no Timesteps chosen'
set_var=1
return
else
do i=1,Timestep_sets
if (stepset .eq. Timestep_id(i)) then
stepset=i
exit
endif
enddo
if (i .gt. Timestep_sets) then
if (Lun_out.gt.0) write(Lun_out,*)
$ 'SET_VAR WARNING: invalid Timestep set ID#'
set_var=1
return
endif
endif
*
* Store variables in variable sets
*
if (F_argv_S(0).eq.'sortie') then
j = Outd_sets + 1
if (j.gt.MAXSET) then
if (Lun_out.gt.0) write(Lun_out,*)
$ 'SET_VAR WARNING: too many OUTD sets'
set_var=1
return
endif
*
jj=0
do ii=1,varmax
jj = jj + 1
call low2up (F_argv_S(ii+1),string4)
Outd_var_S(jj,j) =string4
Outd_nbit(jj,j) = Out3_nbitg
enddo
if (jj.gt.0) then
Outd_sets = j
Outd_var_max(j) = jj
Outd_grid(j) = gridset
Outd_lev(j) = levset
Outd_step(j) = stepset
else
if (Lun_out.gt.0) write(Lun_out,1400)
endif
else if (F_argv_S(0).eq.'sortie_p') then
j = Outp_sets + 1
if (j.gt.MAXSET) then
if (Lun_out.gt.0) write(Lun_out,*)
$ 'SET_VAR WARNING: too many OUTP sets'
set_var=1
return
endif
*
jj=0
do ii=1,varmax
jj = jj + 1
call low2up (F_argv_S(ii+1),string16)
Outp_varnm_S(jj,j)=string16
Outp_nbit(jj,j) = Out3_nbitg
enddo
if (jj.gt.0) then
Outp_sets = j
Outp_var_max(j) = jj
Outp_grid(j) = gridset
Outp_lev(j) = levset
Outp_step(j) = stepset
if (Lun_out.gt.0) then
write(Lun_out,*) '***PHY***Outp_sets=',Outp_sets
write(Lun_out,*) 'Outp_var_max=',Outp_var_max(j)
write(Lun_out,*) 'Outp_varnm_S=',
$ (Outp_varnm_S(jj,j),jj=1,Outp_var_max(j))
write(Lun_out,*) 'Outp_grid=',Outp_grid(j)
write(Lun_out,*) 'Outp_lev=',Outp_lev(j)
write(Lun_out,*) 'Outp_step=',Outp_step(j)
endif
else
if (Lun_out.gt.0) write(Lun_out,1400)
endif
else if (F_argv_S(0).eq.'sortie_c') then
j = Outc_sets + 1
if (j.gt.MAXSET) then
if (Lun_out.gt.0) write(Lun_out,*)
$ 'SET_VAR WARNING: too many OUTC sets'
set_var=1
return
endif
*
jj=0
do ii=1,varmax
jj = jj + 1
Outc_varnm_S(jj,j)= F_argv_S(ii+1)
Outc_nbit(jj,j) = Out3_nbitg
enddo
if (jj.gt.0) then
Outc_sets = j
Outc_var_max(j) = jj
Outc_grid(j) = gridset
Outc_lev(j) = levset
Outc_step(j) = stepset
if (Lun_out.gt.0) then
write(Lun_out,*) '***CHM***Outc_sets=',Outc_sets
write(Lun_out,*) 'Outc_var_max=',Outc_var_max(j)
write(Lun_out,*) 'Outc_varnm_S=',
$ (Outc_varnm_S(jj,j),jj=1,Outc_var_max(j))
write(Lun_out,*) 'Outc_grid=',Outc_grid(j)
write(Lun_out,*) 'Outc_lev=',Outc_lev(j)
write(Lun_out,*) 'Outc_step=',Outc_step(j)
endif
else
if (Lun_out.gt.0) write(Lun_out,1400)
endif
endif
*
*----------------------------------------------------------------
*
1400 format('SET_VAR - WARNING: NO VARIABLES DEFINED FOR THIS SET')
return
end