!-------------------------------------- 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 --------------------------------------
!
subroutine getdjdx 1,35
c||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
c----------------------------------------------------------------------
c Author: JF Caron, ARMA / MRD, Decembre 2006
c----------------------------------------------------------------------
c
c Purpose: Get sensitivity gradients (in RPN Standard file format)
c from adjoint model for OSV
c----------------------------------------------------------------------
c Revisions
c Simon Pellerin, mars 2009
c .Lecture des sommes de djdx: retrait de l'argument
c .Changement du nom du fichier a djdx.fst
c .Unite logique de fichier standard dynamique (fnom)
c
*
use modstag
, only: r1qm2_s, lstagwinds
implicit none
*
#include "comlun.cdk"
#include "comdim.cdk"
#include "comgd0.cdk"
#include "pardim.cdk"
#include "comgem.cdk"
#include "comleg.cdk"
#include "comcst.cdk"
*
character(len=1) :: CDTLMADJ
*
* Local variables
*
integer nivmax
parameter (nivmax=500)
integer niv(nivmax)
integer :: jlev,jlat, jlon, jgl, imax, jstag
integer :: ig1gem,ig2gem,ig3gem,ig4gem,iun01
integer :: ig1gauss,ig2gauss,ig3gauss,ig4gauss
integer :: nigem,njgem,nkgem,nigauss,njgauss,njgauss_vv,i,j,k
integer :: dateo,deet,npas,nbits,datyp
integer :: ip1,ip2,ip3,swa,lng,dltf,ubc,ip3grad
integer :: extra1,extra2,extra3
integer :: fnom, fstouv, fclos, fstopc, fstfrm
integer :: dimgrid,fstinf,fstprm,key
integer :: ier, fstlir3d_eta,fstlir,irec,icount
integer :: nrecs
character (len=4) :: nomvar
character (len=1) :: typvar, grtypgem
character (len=12) :: etiket
character (len=128) :: infile
character*8 nul
data nul /" "/
real,allocatable,dimension(:,:,:) :: buf3di, buf3do, buf3do_vv
real,allocatable,dimension(:,:) :: wki, buf2do
c----------------------------------------------------------------------
c Opening RPN STD File
c----------------------------------------------------------------------
write(nulout,*)
write(nulout,*)
write(nulout,*) '////////////////////////////////////////////////'
infile = 'djdx.fst'
write(nulout,*)'GETDJDX: Reading sensitivity vector'
call vflush(nulout)
iun01 = 0
ier = fnom(iun01, infile, 'RND', 0)
nrecs = fstouv(iun01, 'RND')
c----------------------------------------------------------------------
c Set ip3 value of input gradient
c----------------------------------------------------------------------
ip3grad = 19
c----------------------------------------------------------------------
c Get grid size and level of input data
c----------------------------------------------------------------------
dimgrid = fstinf(iun01,nigem,njgem,k,-1,' ',-1, -1,ip3grad,
$ ' ','TPT1')
if (dimgrid.lt.0) then
call abort3d(nulout
$ ,'GETDJDX: field TPT1 not found')
endif
call get_niv_eta(niv, nkgem, dimgrid, iun01)
if (nkgem.ne.nflev) then
call abort3d(nulout
$ ,'GETDJDX: the number of level for in the input file is not
$ equal to NFLEV')
endif
c----------------------------------------------------------------------
c Destination grid parameters (3DVar Gaussian Grid)
c----------------------------------------------------------------------
nigauss = ni
njgauss = nj
ig1gauss = 0
ig2gauss = 0
ig3gauss = 0
ig4gauss = 0
allocate(buf3do(nigauss,njgauss,nflev))
allocate(buf2do(nigauss,njgauss))
c----------------------------------------------------------------------
c Reading of sensitivity gradients
c----------------------------------------------------------------------
* -----------------------
c < Gradients of U-Wind >
* -----------------------
key = fstinf(iun01,nigem,njgem,k,-1,' ',-1, -1,ip3grad,
$ ' ','UT1')
if (key.lt.0) then
call abort3d(nulout
$ ,'GETDJDX: field UT1 not found')
endif
allocate(buf3di(nigem,njgem,nflev))
allocate(wki(nigem,njgem))
ier = fstprm(key,dateo,deet,npas,nigem,njgem,k,nbits,datyp,
$ ip1,ip2,ip3,typvar,nomvar,etiket,grtypgem,ig1gem,ig2gem,
$ ig3gem,ig4gem,swa,lng,dltf,ubc,extra1,extra2,extra3)
irec=fstlir3d_eta(buf3di,wki,iun01,nigem,njgem,nkgem,
$ -1,' ',niv,ip2,ip3grad,nul,'UT1 ')
if (lstagwinds.eqv.(.false.)) then
c 3DVar u-wind grid not staggered
if( (nigem.eq.nigauss).and.(njgem.eq.njgauss).and.
$ (grtypgem.eq.'G').and.(ig1gem.eq.ig1gauss).and.
$ (ig2gem.eq.ig2gauss).and.(ig3gem.eq.ig3gauss).and.
$ (ig4gem.eq.ig4gauss) ) then
write(nulout,*)'--> UT1 is already on 3DVar gauss grid'
write(nulout,*)
call vflush(nulout)
buf3do(:,:,:) = buf3di(:,:,:)
else
write(nulout,*)'--> UT1 is interpolated on 3DVar gauss grid'
write(nulout,*)
call vflush(nulout)
call gem2gauss3d(buf3do,buf3di,nigem,njgem,ig1gem,ig2gem,
$ ig3gem,ig4gem,grtypgem,iun01,nigauss,njgauss,ig1gauss,
$ ig2gauss,ig3gauss,ig4gauss,nflev)
endif
*
else
c 3DVar u-wind grid staggered
if( (nigem-1.eq.nigauss).and.(njgem.eq.njgauss).and.
$ (grtypgem.eq.'Z') ) then
write(nulout,*)'--> UT1 is already on 3DVar stag gauss grid'
write(nulout,*)
call vflush(nulout)
call chop3d(buf3do,buf3di,nigem,njgem,nigauss,njgauss,nflev)
else
call abort3d(nulout
$ ,'GETDJDX: Grid type not supported for UT1')
endif
endif
do jlev = 1, nflev
do jlat = 1, njgauss
do jlon = 1, nigauss
ut0(jlon,jlev,jlat) = buf3do(jlon,njgauss -jlat+1,jlev)
$ * conphy(jlat)
end do
end do
end do
deallocate(buf3di)
deallocate(wki)
* -----------------------
c < Gradients of V-Wind >
* -----------------------
key = fstinf(iun01,nigem,njgem,k,-1,' ',-1, -1,ip3grad,
$ ' ','VT1')
if (key.lt.0) then
call abort3d(nulout
$ ,'GETDJDX: field VT1 not found')
endif
allocate(buf3di(nigem,njgem,nflev))
allocate(wki(nigem,njgem))
ier = fstprm(key,dateo,deet,npas,nigem,njgem,k,nbits,datyp,
$ ip1,ip2,ip3,typvar,nomvar,etiket,grtypgem,ig1gem,ig2gem,
$ ig3gem,ig4gem,swa,lng,dltf,ubc,extra1,extra2,extra3)
irec=fstlir3d_eta(buf3di,wki,iun01,nigem,njgem,nkgem,
$ -1,' ',niv,ip2,ip3grad,nul,'VT1 ')
if (lstagwinds.eqv.(.false.)) then
c 3DVar v-wind grid not staggered
njgauss_vv = njgauss
if( (nigem.eq.nigauss).and.(njgem.eq.njgauss).and.
$ (grtypgem.eq.'G').and.(ig1gem.eq.ig1gauss).and.
$ (ig2gem.eq.ig2gauss).and.(ig3gem.eq.ig3gauss).and.
$ (ig4gem.eq.ig4gauss) ) then
write(nulout,*)'--> VT1 is already on 3DVar gauss grid'
write(nulout,*)
call vflush(nulout)
buf3do(:,:,:) = buf3di(:,:,:)
else
write(nulout,*)'--> VT1 is interpolated on 3DVar gauss grid'
write(nulout,*)
call vflush(nulout)
call gem2gauss3d(buf3do,buf3di,nigem,njgem,ig1gem,ig2gem,
$ ig3gem,ig4gem,grtypgem,iun01,nigauss,njgauss,ig1gauss,
$ ig2gauss,ig3gauss,ig4gauss,nflev)
endif
*
else
c 3DVar v-wind grid staggered
njgauss_vv = njgauss-1
allocate(buf3do_vv(nigauss,njgauss_vv,nflev))
if( (nigem-1.eq.nigauss).and.(njgem.eq.njgauss_vv).and.
$ (grtypgem.eq.'Z') ) then
write(nulout,*)'--> VT1 is already on 3DVar stag gauss grid'
write(nulout,*)
call vflush(nulout)
call chop3d(buf3do_vv,buf3di,nigem,njgem,nigauss,njgauss_vv
& ,nflev)
else
call abort3d(nulout
$ ,'GETDJDX: Grid not supported for VT1')
endif
endif
do jlev = 1, nflev
do jlat = 1, njgauss_vv
do jlon = 1, nigauss
if (lstagwinds.eqv.(.false.)) then
vt0(jlon,jlev,jlat) = buf3do(jlon,njgauss_vv -jlat+1,jlev)
$ * conphy(jlat)
else
vt0(jlon,jlev,jlat) = buf3do_vv(jlon,njgauss_vv -jlat+1
& ,jlev)* ra*r1qm2_s(jlat)
endif
end do
end do
end do
if (allocated(buf3do_vv)) deallocate(buf3do_vv)
deallocate(buf3di)
deallocate(wki)
* ----------------------------
c < Gradients of Temperature >
* ----------------------------
key = fstinf(iun01,nigem,njgem,k,-1,' ',-1, -1,ip3grad,
$ ' ','TPT1')
if (key.lt.0) then
call abort3d(nulout
$ ,'GETDJDX: field TPT1 not found')
endif
allocate(buf3di(nigem,njgem,nflev))
allocate(wki(nigem,njgem))
ier = fstprm(key,dateo,deet,npas,nigem,njgem,k,nbits,datyp,
$ ip1,ip2,ip3,typvar,nomvar,etiket,grtypgem,ig1gem,ig2gem,
$ ig3gem,ig4gem,swa,lng,dltf,ubc,extra1,extra2,extra3)
irec=fstlir3d_eta(buf3di,wki,iun01,nigem,njgem,nkgem,
$ -1,' ',niv,ip2,ip3grad,nul,'TPT1 ')
if( (nigem.eq.nigauss).and.(njgem.eq.njgauss).and.
$ (grtypgem.eq.'G').and.(ig1gem.eq.ig1gauss).and.
$ (ig2gem.eq.ig2gauss).and.(ig3gem.eq.ig3gauss).and.
$ (ig4gem.eq.ig4gauss) ) then
write(nulout,*)'--> TPT1 is already on 3DVar gauss grid'
write(nulout,*)
call vflush(nulout)
buf3do(:,:,:) = buf3di(:,:,:)
else
write(nulout,*)'--> TPT1 is interpolated on 3DVar gauss grid'
write(nulout,*)
call vflush(nulout)
call gem2gauss3d(buf3do,buf3di,nigem,njgem,ig1gem,ig2gem,
$ ig3gem,ig4gem,grtypgem,iun01,nigauss,njgauss,ig1gauss,
$ ig2gauss,ig3gauss,ig4gauss,nflev)
endif
do jlev = 1, nflev
do jlat = 1, njgauss
do jlon = 1, nigauss
tt0(jlon,jlev,jlat) = buf3do(jlon,njgauss -jlat+1,jlev)
end do
end do
end do
deallocate(buf3di)
deallocate(wki)
* ----------------------------------
c < Gradients of Specific Humidity >
* ----------------------------------
key = fstinf(iun01,nigem,njgem,k,-1,' ',-1, -1,ip3grad,
$ ' ','HUT1')
if (key.lt.0) then
call abort3d(nulout
$ ,'GETDJDX: field HUT1 not found')
endif
allocate(buf3di(nigem,njgem,nflev))
allocate(wki(nigem,njgem))
ier = fstprm(key,dateo,deet,npas,nigem,njgem,k,nbits,datyp,
$ ip1,ip2,ip3,typvar,nomvar,etiket,grtypgem,ig1gem,ig2gem,
$ ig3gem,ig4gem,swa,lng,dltf,ubc,extra1,extra2,extra3)
irec=fstlir3d_eta(buf3di,wki,iun01,nigem,njgem,nkgem,
$ -1,' ',niv,ip2,ip3grad,nul,'HUT1 ')
if( (nigem.eq.nigauss).and.(njgem.eq.njgauss).and.
$ (grtypgem.eq.'G').and.(ig1gem.eq.ig1gauss).and.
$ (ig2gem.eq.ig2gauss).and.(ig3gem.eq.ig3gauss).and.
$ (ig4gem.eq.ig4gauss) ) then
write(nulout,*)'--> HUT1 is already on 3DVar gauss grid'
write(nulout,*)
call vflush(nulout)
buf3do(:,:,:) = buf3di(:,:,:)
else
write(nulout,*)'--> HUT1 is interpolated on 3DVar gauss grid'
write(nulout,*)
call vflush(nulout)
call gem2gauss3d(buf3do,buf3di,nigem,njgem,ig1gem,ig2gem,
$ ig3gem,ig4gem,grtypgem,iun01,nigauss,njgauss,ig1gauss,
$ ig2gauss,ig3gauss,ig4gauss,nflev)
endif
do jlev = 1, nflev
do jlat = 1, njgauss
do jlon = 1, nigauss
q0(jlon,jlev,jlat) = buf3do(jlon,njgauss -jlat+1,jlev)
end do
end do
end do
deallocate(buf3di)
deallocate(wki)
deallocate(buf3do)
* ----------------------------------
c < Gradients of Surface pressure >
* ----------------------------------
key = fstinf(iun01,nigem,njgem,k,-1,' ',-1, -1,ip3grad,
$ ' ','ST1')
if (key.lt.0) then
call abort3d(nulout
$ ,'GETDJDX: field ST1 not found')
endif
allocate(wki(nigem,njgem))
ier = fstprm(key,dateo,deet,npas,nigem,njgem,k,nbits,datyp,
$ ip1,ip2,ip3,typvar,nomvar,etiket,grtypgem,ig1gem,ig2gem,
$ ig3gem,ig4gem,swa,lng,dltf,ubc,extra1,extra2,extra3)
irec=fstlir(wki,iun01,i,j,k,-1,' ',0,ip2,ip3grad,nul,'ST1 ')
if( (nigem.eq.nigauss).and.(njgem.eq.njgauss).and.
$ (grtypgem.eq.'G').and.(ig1gem.eq.ig1gauss).and.
$ (ig2gem.eq.ig2gauss).and.(ig3gem.eq.ig3gauss).and.
$ (ig4gem.eq.ig4gauss) ) then
write(nulout,*)'--> ST1 is already on 3DVar gauss grid'
write(nulout,*)
call vflush(nulout)
buf2do(:,:) = wki(:,:)
else
write(nulout,*)'--> ST1 is interpolated on 3DVar gauss grid'
write(nulout,*)
call vflush(nulout)
call gem2gauss2d(buf2do,wki,nigem,njgem,ig1gem,ig2gem,
$ ig3gem,ig4gem,grtypgem,iun01,nigauss,njgauss,ig1gauss,
$ ig2gauss,ig3gauss,ig4gauss)
endif
do jlat = 1, njgauss
do jlon = 1, nigauss
gps0(jlon,1,jlat) = buf2do(jlon,njgauss -jlat+1)
end do
end do
deallocate(wki)
deallocate(buf2do)
c----------------------------------------------------------------------
c Add adjustment for change of norm as in BILINAD
c----------------------------------------------------------------------
c
do jgl = 1, nj
imax = nilon(jgl)
do jlev = 1, nkgdim
do jlon = 1, imax
gd(jlon,jlev,jgl) = gd(jlon,jlev,jgl) *
$ nilon(jgl) / rwt(jgl)
enddo
enddo
enddo
c----------------------------------------------------------------------
c Closing RPN STD File
c----------------------------------------------------------------------
ier=fstopc('MSGLVL','INFORM',.false.)
ier = fstfrm(iun01)
ier = fclos(iun01)
c call abort3d(nulout,'Modifs OK')
*
end subroutine getdjdx
c######################################################################
c#################### #######################
c#################### Sous-routines locales #######################
c#################### #######################
c######################################################################
*----------------------------------------------------------------------
c GET_NIV_ETA
*----------------------------------------------------------------------
subroutine get_niv_eta(NIV, NK, key, iun) 1,1
implicit none
c ----------------------------------------------------------
c Ecrite par Christian Page -
c version eta par JF Caron -
c Janvier 2004 -
c Departement des Sciences de la Terre et de l'Atmosphere -
c UQAM -
c ----------------------------------------------------------
c ----------------------------------------------------------
c ---------- Definition des vecteurs utilises -----------
c
c niv ---> champ(nk) des niveaux eta encodes (ip1) -
c
c ----------------------------------------------------------
integer nivmax
parameter (nivmax=500)
integer nk, key, iun
integer niv(nivmax)
integer ier
integer dateo,deet,npas,ni,nj,nnk,nbits,datyp
integer ip1,ip2,dumip3,swa,lng,dltf,ubc
integer ig1,ig2,ig3,ig4,extra1,extra2,extra3
integer liste(nivmax),infon
character*4 nomvar
character*1 typvar, grtyp
character*12 etiket
c integer work(1)
c integer ibwork
real,allocatable,dimension(:) :: work
integer fstprm, fstinl
integer i, k, ip1_vco,ipmode,jlev
character(len=1) :: clstring
*
c On recupere l'information des parametres RPN
*
ier = fstprm(key,dateo,deet,npas,ni,nj,nnk,nbits,
$ datyp,ip1,ip2,dumip3,typvar,nomvar,etiket,grtyp,ig1,ig2,
$ ig3,ig4,swa,lng,dltf,ubc,extra1,extra2,extra3)
*
c On definit notre vecteur des niveaux pour le fichier d'entree
*
ier =fstinl(iun, ni, nj, nnk, -1, etiket, -1, ip2, dumip3, typvar,
$ nomvar, liste, infon, NIVMAX)
k = 1
do i=1,infon
ier = fstprm(liste(i),dateo,deet,npas,ni,nj,nnk,nbits,
$ datyp,ip1,ip2,dumip3,typvar,nomvar,etiket,grtyp,ig1,ig2,
$ ig3,ig4,swa,lng,dltf,ubc,extra1,extra2,extra3)
c if(ip1.ge.2000.and.ip1.le.12000.) then
call ins_unique_vect(niv, ip1, k, NIVMAX)
c endif
enddo
nk = k - 1
if (nk.gt.0) then
c-------- Decode, sort levels from top to bottom
ipmode = -1
allocate(work(nk))
do jlev = 1,nk
call CONVIP(niv(jlev),WORK(jlev),IP1_VCO
& ,ipmode,clstring, .false. )
enddo
c
call sort(work,nk)
c
c---------Encode iip1s_trl to match the sorted zlev
if(niv(1) .le. 32767) then
ipmode = 3
else
ipmode = 2
endif
do jlev = 1,nk
call CONVIP(niv(jlev),work(jlev),ip1_vco
& ,ipmode,clstring, .false. )
enddo
deallocate(work)
else
print*
print*,'Nombre de niveaux egal a zero.'
print*,'Impossible de continuer.'
print*
stop
endif
return
end
*----------------------------------------------------------------------
c GEM2GAUSS3D
*----------------------------------------------------------------------
subroutine gem2gauss3d(bufgauss,bufgem,nigem,njgem,ig1gem,ig2gem, 4,2
$ ig3gem,ig4gem,grtypgem,iun01,nigauss,njgauss,ig1gauss,
$ ig2gauss,ig3gauss,ig4gauss,nk)
implicit none
c ----------------------------------------------------------
c Ecrite par JF Caron -
c Decembre 2006 -
c ARMA / MRD -
c ----------------------------------------------------------
c ----------------------------------------------------------
c ---------- Definition des vecteurs utilises -----------
c
c bufgem ---> champ(ni,nj,nk) d'entree sur grille GEM -
c bufgauss --> champ(ni,nj,nk) de sortie sur grille GAUSS -
c
c ----------------------------------------------------------
integer nigem,njgem,nk,k,nigauss,njgauss
real bufgauss(nigauss,njgauss,nk),bufgem(nigem,njgem,nk)
integer ig1gem,ig2gem,ig3gem,ig4gem,iun01
integer ig1gauss,ig2gauss,ig3gauss,ig4gauss
integer gdgem,gdgauss,iset,ier
integer ezqkdef,ezdefset,ezsint
character*1 grtypgem
real,allocatable,dimension(:,:) :: zgem, zgauss
allocate(zgem(nigem,njgem))
allocate(zgauss(nigauss,njgauss))
gdgem = ezqkdef(nigem,njgem,grtypgem,ig1gem,ig2gem,ig3gem,
$ ig4gem,iun01)
gdgauss = ezqkdef(nigauss,njgauss,'G',ig1gauss,ig2gauss,ig3gauss,
$ ig4gauss,-1)
iset = ezdefset(gdgauss, gdgem)
do k = 1,nk
call vec3d2d(zgem,bufgem,k,nigem,njgem,nk)
ier = ezsint(zgauss, zgem)
call vec2d3d(bufgauss,zgauss,k,nigauss,njgauss,nk)
enddo
deallocate(zgem)
deallocate(zgauss)
return
end
*----------------------------------------------------------------------
c GEM2GAUSS2D
*----------------------------------------------------------------------
subroutine gem2gauss2d(bufgauss,bufgem,nigem,njgem,ig1gem,ig2gem, 1
$ ig3gem,ig4gem,grtypgem,iun01,nigauss,njgauss,ig1gauss,
$ ig2gauss,ig3gauss,ig4gauss)
implicit none
c ----------------------------------------------------------
c Ecrite par JF Caron -
c Decembre 2006 -
c ARMA / MRD -
c ----------------------------------------------------------
c ----------------------------------------------------------
c ---------- Definition des vecteurs utilises -----------
c
c bufgem ---> champ(ni,nj) d'entree sur grille GEM -
c bufgauss --> champ(ni,nj) de sortie sur grille GAUSS -
c
c ----------------------------------------------------------
integer nigem,njgem,nigauss,njgauss
real bufgauss(nigauss,njgauss),bufgem(nigem,njgem)
integer ig1gem,ig2gem,ig3gem,ig4gem,iun01
integer ig1gauss,ig2gauss,ig3gauss,ig4gauss
integer gdgem,gdgauss,iset,ier
integer ezqkdef,ezdefset,ezsint
character*1 grtypgem
gdgem = ezqkdef(nigem,njgem,grtypgem,ig1gem,ig2gem,ig3gem,
$ ig4gem,iun01)
gdgauss = ezqkdef(nigauss,njgauss,'G',ig1gauss,ig2gauss,ig3gauss,
$ ig4gauss,-1)
iset = ezdefset(gdgauss, gdgem)
ier = ezsint(bufgauss, bufgem)
return
end
*----------------------------------------------------------------------
c CHOP3D
*----------------------------------------------------------------------
subroutine chop3d(bufgauss,bufgem,nigem,njgem,nigauss,njgauss, 2
$ nflev)
implicit none
c ----------------------------------------------------------
c Ecrite par JF Caron -
c Decembre 2006 -
c ARMA / MRD -
c ----------------------------------------------------------
c ----------------------------------------------------------
c ---------- Definition des vecteurs utilises -----------
c
c bufgem ---> champ(ni,nj,nk) d'entree sur grille -
c GAUSS de GEM -
c bufgauss --> champ(ni-1,nj,nk) de sortie sur grille -
c GAUSS du 3D-Var -
c
c ----------------------------------------------------------
integer nigem,njgem,nigauss,njgauss,i,j,k,nflev
real bufgauss(nigauss,njgauss,nflev)
real bufgem(nigem,njgem,nflev)
do k=1,nflev
do j=1,njgauss
do i=1,nigauss
bufgauss(i,j,k) = bufgem(i,j,k)
enddo
enddo
enddo
return
end
*----------------------------------------------------------------------
c FSTLIR3D_ETA
*----------------------------------------------------------------------
integer function fstlir3d_eta(D,WORK,iun,ni,nj,nk,datev,etiket, 4
$ niv,ip2,ip3,typvar,nomvar)
implicit none
c *****************************
c Auteur : Christian Page
c Departement de physique UQAM
c Juillet 1993
c *****************************
c Sous-routine pour lire un champ en 3 dimensions d'un fichier
c standard
c
c D Vecteur destination 3 dimensions ni x nj x nk
c WORK Vecteur 2 dimensions de travail ni x nj
c iun Unite fortran
c ni, nj, nk 3 dimensions du vecteur destination D
c datev Date de validite du champ. (MMDDYYHHR) DATE TIME
c STAMP CMC sans le premier chiffre
c etiket Etiquette du champ
c niv Vecteurs des niveaux de pression
c ip2 Heure de la prevision (0 a 32767)
c ip3 Descripteur (generalement 1) (0 a 4095)
c typvar Type de champ (1 caractere)
c nomvar Nom du champ (2 caracteres)
integer ni,nj,nk,i,j,k,niv(nk)
integer ip2,ip3,datev,iun,n1,n2,n3
integer irec,fstlir
integer ip1rpn
character*4 nomvar
character*1 typvar
character*(*) etiket
real d(ni,nj,nk),work(ni,nj)
do k=1,nk
irec=fstlir(work,iun,n1,n2,n3,datev,etiket,
$ niv(k), ip2, ip3, typvar,nomvar)
if (irec.lt.0) then
write(*,600) iun, datev, etiket, nomvar, typvar,
$ niv(k), niv(k), ip2, ip3, irec
endif
fstlir3d_eta=irec
do j=1,nj
do i=1,ni
d(i,j,k)=work(i,j)
enddo
enddo
enddo
600 format(' FSTLIR-IUN=',I3,' , PAS TROUVE CHAMP --> DATE=',I10,
$ ' ETIQUETTE=',A8,' NOM=',A2,' TYPE= ',A1,' IP1RPN=',I5,
$ ' IP1=',I5, ' IP2=',I5,
$ ' IP3=',I4,' IREC=',I4)
return
end
*???????????????????????????????????????????????????????????????????????
subroutine vec2d3d (D,s,k,ni,nj,nk) 1
implicit none
c *****************************
c Auteur : Michel Desgagne
c *****************************
*
c Transcrit un vecteur 2d au niveau k d'un vecteur 3d.
*
c D vecteur de destination de dimension ni x nj x nk
c s vecteur source de dimension ni x nj
c k niveau (indice)
*
integer ni,nj,nk,i,j,k
real d(ni,nj,nk),s(ni,nj)
*
do j=1,nj
do i=1,ni
d(i,j,k) = s(i,j)
enddo
enddo
*
return
end
*
*???????????????????????????????????????????????????????????????????????
subroutine vec3d2d (D,s,k,ni,nj,nk) 1
implicit none
c *****************************
c Auteur : Michel Desgagne
c *****************************
*
c Transcrit le niveau k d'un vecteur 3d dans un vecteur 2d.
*
c D vecteur de destination de dimension ni x nj
c s vecteur source de dimension ni x nj x nk
c k niveau (indice)
*
integer ni,nj,nk,i,j,k
real d(ni,nj),s(ni,nj,nk)
*
do j=1,nj
do i=1,ni
d(i,j) = s(i,j,k)
enddo
enddo
*
return
end
*
*??????????????????????????????????????????????????????????????????????
subroutine c_sort(D,work,ni)
implicit none
*
c Tri un vecteur en ordre croissant
*
c D vecteur de source et de destination de dimension ni
c work vecteur de travail de dimension ni
c ni dimension des vecteurs
*
integer i,j,k,l,m,ni
integer D(ni),work(ni),s,t
i = 1
10 k = i
20 j = i
i = i + 1
if ( j .eq. ni ) goto 30
if ( D(i) .ge. D(j) ) goto 20
work(k) = i
goto 10
30 if ( k .eq. 1 ) return
work(k) = ni + 1
40 m = 1
l = 1
50 i = l
if ( i .gt. ni ) goto 120
s = D(i)
j = work(i)
k = j
if ( j .gt. ni ) goto 100
t = D(j)
l = work(j)
D(i) = l
60 if ( s .gt. t ) goto 70
work(m) = s
m = m + 1
i = i + 1
if ( i .eq. k ) goto 80
s = D(i)
goto 60
70 work(m)= t
m = m + 1
j = j + 1
if ( j .eq. l ) goto 110
t = D(j)
goto 60
80 work(m) = t
k = m + l - j
i = j - m
90 m = m + 1
if ( m .eq. k ) goto 50
work(m) = D(m+i)
goto 90
100 D(i) = j
l = j
110 work(m) = s
k = m + k - i
i = i - m
goto 90
120 i = 1
130 k = i
j = D(i)
140 D(i) = work(i)
i = i + 1
if ( i .lt. j ) goto 140
work(k) = i
if ( i .le. ni ) goto 130
if ( k .eq. 1 ) return
goto 40
end
*
*??????????????????????????????????????????????????????????????????????
subroutine ins_unique_vect(S,val,elem,nk) 1
implicit none
c Sous-routine qui insere un element dans un vecteur 1D si cette
c valeur n'existe pas deja : val + vecteur => integer
c s Vecteur source de dimension nk
c val Valeur a inserer si necessaire
c elem Element a remplir
c nk Dimension
*
c *****************************************
c Auteur : Christian Page
c Departement des sciences de la Terre UQAM
c Mars 1996
c *****************************************
*
integer nk,k,elem,trouve
integer s(nk), val
trouve = 0
do k=1,(elem-1)
if (val.eq.s(k)) then
trouve = 1
endif
enddo
if (trouve.eq.0) then
s(elem) = val
elem = elem + 1
endif
return
end
*