SUBROUTINE CH_RSTDDEV_ADD(PSTD,KNI,KSDIM,KNSTATLEV,K2D, 1,1
1 KSPEC,KJN,CDSPEC)
*
IMPLICIT NONE
*
* Arguments
*
integer kspec,ksdim,kni,knstatlev,k2d,kjn
real*8 pstd(ksdim)
character*(*) cdspec(kspec)
*
#if defined (DOC)
*
***s/r CH_RSTDDEV_ADD - Read RSTDDEV for species and add to PSTD
*
*
*Author : Y.J. Rochon, AQRX/MSC June 2005
*
*Revisions:
*
* -------------------
*
* Purpose: Read RSTDDEV for species and add to PSTD
*
* Arguments
*
* Input:
*
* PSTD: Initial RSTDDEV array
* KNI: Dimension of initial RSTDDEV
* KSDIM: Expected final dimension of PSTD
* KNSTATLEV: Number of vertical levels
* K2D: Number of 2D fields
* KSPEC: Number of additional analysis fields
* CDSPEC: Names of additional analysis fields
* KJN: Spectral wavenumber index
*
* Output:
*
* PSTD: Final RSTDDEV array
*
#endif
*
* Global variables
*
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comstate.cdk"
#include "comchem.cdk"
#include "rpnstd.cdk"
*
real*8, allocatable, dimension(:) :: zwork,zfld
*
integer J,JN,JC,ikey,INUM
c
allocate(zwork(ksdim))
allocate(zfld(knstatlev))
c
c Store input array in augmented array, leaving spaces where
c appropriate
c
INUM=KNI-K2D
c
zwork(:)=0.0
if (K2D.gt.0) then
zwork(KSDIM-K2D+1:KSDIM)=pstd(INUM+1:INUM+K2D)
end if
c
zwork(1:INUM)=pstd(1:INUM)
c
c Read extra RSTDDEV and add to ZWORK
c
DO J=1,KSPEC
c
JN=KJN
c DO JN=0,ntrunc
c
c Looking for FST record parameters..
c
idateo = -1
cletiket = 'RSTDDEV'
ip1 = -1
ip2 = JN
ip3 = -1
cltypvar = 'X'
clnomvar = cdspec(J)
c
ikey = vfstlir
(ZFLD,nulbgstr,INI,INJ,INK,idateo,cletiket,
& ip1,ip2,ip3,cltypvar,clnomvar)
c
if (ikey.lt.0) then
write(nulout,*) 'Field: ',clnomvar,JN
call abort3d(nulout
& ,'CH_RDSTDDEV_ADD: Missing field')
endif
c
if (ini .ne. knstatlev) then
write(nulout,*) 'Field: ',clnomvar,JN
call abort3d(nulout
& ,'CH_RDSTDDEV_ADD: BG stat levels inconsistencies')
endif
c
jc=INUM+(j-1)*KNSTATLEV
zwork(jc+1:jc+knstatlev)=zfld(:)
c
c END DO
c
END DO
c
pstd(1:ksdim)=zwork(1:ksdim)
c
deallocate(zwork)
deallocate(zfld)
c
return
end