!--------------------------------------- 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 VEZUVINT(duuout, dvvout, duuin, dvvin, nio, nii)
*
#if defined (DOC)
*
***s/r VEZUVINT -real*8 interface for real*4 subroutine EZUVINT.
*
*Author : JM Belanger *CMDA/SMC Aug 2000
*Revision:
* Simon Pellerin *ARMA/SMC June 2001
* . elimination of 2nd and 3rd dimensions
*
*Arguments
* Output:
* duuout
* dvvout
*
* Input:
* duuin
* dvvin
* nii
* nio
#endif
IMPLICIT NONE
*implicits
real*8 duuout(nio), dvvout(nio),
$ duuin(nii) , dvvin(nii)
integer iun, nio, nii
*
integer ikey, ierr, ileni, ileno, jk1
real, allocatable :: bufuuout4(:), bufvvout4(:), bufuuin4(:), bufvvin4(:)
*
integer ezuvint
external ezuvint
*-----7----------------------------------------------------------------
allocate(bufuuin4(nii))
allocate(bufvvin4(nii))
allocate(bufuuout4(nio))
allocate(bufvvout4(nio))
do jk1 = 1,nii
bufuuin4(jk1) = duuin(jk1)
bufvvin4(jk1) = dvvin(jk1)
enddo
ierr = ezuvint(bufuuout4, bufvvout4, bufuuin4, bufvvin4)
do jk1 = 1,nio
duuout(jk1) = bufuuout4(jk1)
dvvout(jk1) = bufvvout4(jk1)
enddo
deallocate(bufuuin4)
deallocate(bufvvin4)
deallocate(bufuuout4)
deallocate(bufvvout4)
return
end
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
SUBROUTINE VEZUVINT2(duuout, dvvout, duuin, dvvin, nio, nii)
*
#if defined (DOC)
*
***s/r VEZUVINT -real*8 interface for real*4 subroutine EZUVINT.
*
*Author : JM Belanger *CMDA/SMC Aug 2000
*Revision:
* Simon Pellerin *ARMA/SMC June 2001
* . elimination of 2nd and 3rd dimensions
*
*Arguments
* Output:
* duuout
* dvvout
*
* Input:
* duuin
* dvvin
* nii
* nio
#endif
IMPLICIT NONE
*implicits
real*8 duuout(nio), dvvout(nio)
real*4 duuin(nii) , dvvin(nii)
integer iun, nio, nii
*
integer ikey, ierr, ileni, ileno, jk1
real, allocatable :: bufuuout4(:), bufvvout4(:)
*
integer ezuvint
external ezuvint
*-----7----------------------------------------------------------------
allocate(bufuuout4(nio))
allocate(bufvvout4(nio))
ierr = ezuvint(bufuuout4, bufvvout4, duuin, dvvin)
do jk1 = 1,nio
duuout(jk1) = bufuuout4(jk1)
dvvout(jk1) = bufvvout4(jk1)
enddo
deallocate(bufuuout4)
deallocate(bufvvout4)
return
end
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
FUNCTION VEZGDEF(ni, nj, grtyp, grtypref, ig1, ig2, ig3, ig4, 2
& ax, ay)
*
#if defined (DOC)
*
***s/r VEZGDEF -real*8 interface for real*4 function EZGDEF.
*
*Author : JM Belanger *CMDA/SMC Aug 2000
*Revision:
*
*Arguments: See EZGDEF code for documentation.
* Input:
* ni
* nj
* grtyp
* grtypref
* ig1
* ig2
* ig3
* ig4
* ax
* ay
*
* Output:
* none
*
#endif
IMPLICIT NONE
integer vezgdef
integer ni, nj, ig1, ig2, ig3, ig4
real*8 ax(*), ay(*)
character(len=*) :: grtyp, grtypref
*
integer ier1,ier2,jk,ilenx,ileny
real, allocatable :: bufax4(:), bufay4(:)
*
integer ezgdef
external ezgdef
*-----7----------------------------------------------------------------
if (grtyp .eq. 'Y') then
ilenx=max(1,ni*nj)
ileny=ilenx
else if (grtyp .eq. 'Z') then
ilenx=max(1,ni)
ileny=max(1,nj)
else
write(*,'()') 'STOP in VEZGDEF: Grid type not supported'
STOP
endif
allocate(bufax4(ilenx))
allocate(bufay4(ileny))
do jk = 1,ilenx
bufax4(jk) = ax(jk)
enddo
do jk = 1,ileny
bufay4(jk) = ay(jk)
enddo
ier2 = ezgdef(ni, nj, grtyp, grtypref, ig1, ig2, ig3, ig4,
& bufax4, bufay4)
deallocate(bufax4)
deallocate(bufay4)
vezgdef=ier2
return
end
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
SUBROUTINE VCXGAIG(grtyp, ig1, ig2, ig3, ig4, xlat0, xlon0, 2
$ dlat, dlon)
*
#if defined (DOC)
*
***s/r vcxgaig -real*8 interface for real*4 subroutine CXGAIG.
*
*Author : JM Belanger *CMDA/SMC Aug 2000
*Revision:
*
*Arguments: See CXGAIG code for documentation
*
* Input:
* grtyp
* xlat0
* xlon0
* dlat
* dlon
*
* Output:
* ig1
* ig2
* ig3
* ig4
#endif
IMPLICIT NONE
*implicits
integer ig1, ig2, ig3, ig4
real*8 xlat0, xlon0, dlat, dlon
character(len=*) :: grtyp
*
real xlat04, xlon04, dlat4, dlon4
*
external cxgaig
*-----7----------------------------------------------------------------
xlat04=xlat0
xlon04=xlon0
dlat4=dlat
dlon4=dlon
call cxgaig(grtyp, ig1, ig2, ig3, ig4, xlat04, xlon04,
$ dlat4, dlon4)
return
end
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
FUNCTION VFSTLIR(fld8, iun, ni, nj, nk, datev, etiket, 53
$ ip1, ip2, ip3, typvar, nomvar)
*
#if defined (DOC)
*
***s/r VFSTLIR -real*8 interface for real*4 function FSTLIR.
*
*Author : JM Belanger *CMDA/SMC Aug 2000
*Revision:
* S. Pellerin *ARMA/SMC Nov. 2001
* . Additionnal return key check
*
*Arguments: See FSTLIR code for documentation
* Input:
* iun
* datev
* etiket
* ip1
* ip2
* ip3
* typvar
* nomvar
*
* Output:
* fld8
* ni
* nj
* nk
*
#endif
IMPLICIT NONE
*implicits
integer vfstlir
real*8 fld8(*)
integer iun, ni, nj, nk, datev, ip1, ip2, ip3
character(len=*) :: etiket
character(len=*) :: nomvar
character(len=*) :: typvar
*
integer key1,key2, ierr, ilen, jk1, jk2, jk3, la
real, allocatable :: buffer4(:)
*
integer fstluk, fstinf
external fstluk, fstinf
*-----7----------------------------------------------------------------
* Get field dimensions and allow memory for REAL copy of fld8.
key1 = fstinf(iun, ni, nj, nk, datev, etiket,
$ ip1, ip2, ip3, typvar, nomvar)
if(key1 >= 0) then
ilen = ni*nj*nk
allocate(buffer4(ilen))
* Read field
key2 = fstluk(buffer4, key1, ni, nj, nk)
if(key2 >= 0) then
do jk3 = 1,nk
do jk2 = 1,nj
do jk1 = 1,ni
la=jk1+(jk2-1)*ni+(jk3-1)*ni*nj
fld8(la) = buffer4(la)
enddo
enddo
enddo
endif
deallocate(buffer4)
endif
vfstlir=key1
return
end
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
FUNCTION VFSTECR(fld8, work, npak, iun, dateo, deet, 31
$ npas, ni, nj, nk, ip1, ip2, ip3, typvar,
$ nomvar, etiket, grtyp, ig1, ig2, ig3, ig4,
$ datyp, rewrit)
*
#if defined (DOC)
*
***s/r VFSTECR -real*8 interface for real*4 function FSTECR.
*
*Author : JM Belanger *CMDA/SMC Aug 2000
*Revision:
*
*Arguments: See FSTECR code for documentation
* Input:
* all
*
* Output:
* none
*
#endif
IMPLICIT NONE
*implicits
integer vfstecr
real work(*)
real*8 fld8(ni,nj,nk)
integer iun, ni, nj, nk, datev, ip1, ip2, ip3, ig1, ig2, ig3, ig4
integer npak, dateo, deet, npas, datyp, rewrit
character(len=*) :: etiket
character(len=*) :: typvar
character(len=*) :: grtyp
character(len=*) :: nomvar
*
integer ikey, ierr, jk1, jk2, jk3
real, allocatable :: buffer4(:,:,:)
*
integer fstecr
external fstecr
*-----7----------------------------------------------------------------
allocate(buffer4(ni,nj,nk))
do jk3 = 1,nk
do jk2 = 1,nj
do jk1 = 1,ni
buffer4(jk1,jk2,jk3) = fld8(jk1,jk2,jk3)
enddo
enddo
enddo
ikey = fstecr(buffer4, work, npak, iun, dateo, deet,
$ npas, ni, nj, nk, ip1, ip2, ip3, typvar, nomvar,
$ etiket, grtyp, ig1, ig2, ig3, ig4, datyp, rewrit)
deallocate(buffer4)
vfstecr=ikey
return
end
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
FUNCTION VFSTLUK(fld8, key, ni, nj, nk) 2
*
#if defined (DOC)
*
***s/r VFSTLUK -real*8 interface for real*4 function FSTLUK.
*
*Author : JM Belanger *CMDA/SMC Aug 2000
*Revision:
*
*Arguments: See FSTLUK code for documentation
* Input:
* key
*
* Output:
* fld8
* ni
* nj
* nk
*
#endif
IMPLICIT NONE
*implicits
integer vfstluk
real*8 fld8(ni,nj,nk)
integer key, ni, nj, nk
*
integer ikey, ierr, jk1, jk2, jk3
real, allocatable :: buffer4(:,:,:)
*
integer fstluk
external fstluk
*-----7----------------------------------------------------------------
allocate(buffer4(ni,nj,nk))
ikey = fstluk(buffer4, key, ni, nj, nk)
do jk3 = 1,nk
do jk2 = 1,nj
do jk1 = 1,ni
fld8(jk1,jk2,jk3) = buffer4(jk1,jk2,jk3)
enddo
enddo
enddo
deallocate(buffer4)
vfstluk=ikey
return
end
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
SUBROUTINE VCONVIP(ip, p8, kind, mode, string, flag) 2
*
#if defined (DOC)
*
***s/r VCONVIP -real*8 interface for rmnlib real*4 subroutine CONVIP.
*
*Author : JM Belanger *CMDA/SMC Sept 2000
*Revision:
*
*Arguments: See CONVIP code for documentation.
*
* Input:
* kind
* mode
* string
*
* Output:
* flag
*
* Input/Output:
* ip (mode < 0 / mode > 0)
* p8 (mode > 0 / mode < 0)
*
#endif
IMPLICIT NONE
*implicits
integer ip, kind, mode
real*8 p8
character(len=*) :: string
logical flag
*
real p4
*
external convip
*-----7----------------------------------------------------------------
* conversion p --> ip
if (mode .gt. 0) then
p4=p8
call convip(ip, p4, kind, mode, string, flag)
endif
* conversion ip --> p
if (mode .lt. 0) then
call convip(ip, p4, kind, mode, string, flag)
p8=p4
endif
return
end
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
SUBROUTINE VSORT(array8,n) 1
*
#if defined (DOC)
*
***s/r VSORT -real*8 interface for RMNLIB real*4 subroutine SORT.
*
*Author : JM Belanger *CMDA/SMC Sept 2000
*Revision:
*
*Arguments: See SORT code for documentation
* Input:
* array8
* n
* Output:
* array8
*
#endif
IMPLICIT NONE
*implicits
integer n
real*8 array8(n)
*
integer ierr,jk
real, allocatable :: buffer4(:)
*
external sort
*-----7----------------------------------------------------------------
allocate(buffer4(n))
do jk = 1,n
buffer4(jk) = array8(jk)
enddo
call sort(buffer4,n)
do jk = 1,n
array8(jk) = buffer4(jk)
enddo
deallocate(buffer4)
return
end
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
FUNCTION VMRFOPR(optnom,opvalr8)
*
#if defined (DOC)
*
***s/r VMRFOPR -real*8 interface for real*4 function MRFOPR.
*
*Author : JM Belanger *CMDA/SMC Sept 2000
*Revision:
*
*Arguments: See MRFOPR code for documentation
* Input:
* optnom
* opvalr8
* Output:
* none
#endif
IMPLICIT NONE
*implicits
integer VMRFOPR
real*8 opvalr8
character(len=*) :: optnom
*
integer ier
real opvalr4
*
integer MRFOPR
external MRFOPR
*-----7----------------------------------------------------------------
opvalr4=opvalr8
ier = MRFOPR(optnom,opvalr4)
vmrfopr=ier
return
end
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
FUNCTION VMRBCVT(liste,tblval,rval8,nele,nval,nt,mode)
*
#if defined (DOC)
*
***s/r VMRBCVT -real*8 interface for real*8 function MRBCVT.
*
*Author : JM Belanger *CMDA/SMC Sept 2000
*Revision:
*
*Arguments: See MRBCVT code for documentation
* Input:
* liste
* nele
* nval
* nt
* mode
* Output:
*
* Input/Output
* rval8 (mode=1/mode=0)
* tblval (mode=0/mode=1)
*
#endif
IMPLICIT NONE
*implicits
integer VMRBCVT
integer nele,nval,nt,mode
integer liste(nele),tblval(nele,nval,nt)
real*8 rval8(nele,nval,nt)
*
integer ier1,ier2,j1,j2,j3,ilen
real, allocatable :: rval4(:,:,:)
*
integer mrbcvt
external mrbcvt
*-----7----------------------------------------------------------------
ilen=nele*nval*nt
allocate(rval4(nele,nval,nt))
* rval8 ---> tblval
if (mode .eq. 1) then
rval4(:,:,:) = rval8(:,:,:)
ier2 = mrbcvt(liste,tblval,rval4,nele,nval,nt,mode)
endif
* tblval ---> rval8
if (mode .eq. 0) then
rval4(:,:,:)=tblval(:,:,:)
ier2 = mrbcvt(liste,tblval,rval4,nele,nval,nt,mode)
rval8(:,:,:) = rval4(:,:,:)
endif
deallocate(rval4)
vmrbcvt=ier2
return
end
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
SUBROUTINE VEZSINT(zout8, zin8, nio, njo, nko, nii, nji, nki) 2
*
#if defined (DOC)
*
***s/r VEZSINT -real*8 interface for real*4 subroutine EZSINT.
*
*Author : JM Belanger *CMDA/SMC Aug 2000
*Revision:
*
*Arguments: See EZSINT code for documentation
* Input:
* zin8
* nii
* nji
* nki
* nio
* njo
* nko
*
* Output:
* zout8
#endif
IMPLICIT NONE
*implicits
integer nii, nji, nki, nio, njo, nko
real*8 zout8(nio,njo,nko),zin8(nii,nji,nki)
*
integer ierr, jk1, jk2, jk3
real, allocatable :: bufferi4(:,:,:), buffero4(:,:,:)
*
integer ezsint
external ezsint
*-----7----------------------------------------------------------------
allocate(bufferi4(nii,nji,nki))
allocate(buffero4(nio,njo,nko))
do jk3 = 1,nki
do jk2 = 1,nji
do jk1 = 1,nii
bufferi4(jk1,jk2,jk3) = zin8(jk1,jk2,jk3)
enddo
enddo
enddo
ierr = ezsint(buffero4,bufferi4)
do jk3 = 1,nko
do jk2 = 1,njo
do jk1 = 1,nio
zout8(jk1,jk2,jk3) = buffero4(jk1,jk2,jk3)
enddo
enddo
enddo
deallocate(bufferi4)
deallocate(buffero4)
return
end
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
SUBROUTINE VEZSINT2(zout8, zin4, nio, njo, nko, nii, nji, nki)
*
#if defined (DOC)
*
***s/r VEZSINT -real*8 interface for real*4 subroutine EZSINT.
*
*Author : JM Belanger *CMDA/SMC Aug 2000
*Revision:
*
*Arguments: See EZSINT code for documentation
* Input:
* zin4
* nii
* nji
* nki
* nio
* njo
* nko
*
* Output:
* zout8
#endif
IMPLICIT NONE
*implicits
integer nii, nji, nki, nio, njo, nko
real*8 zout8(nio,njo,nko)
real*4 zin4(nii,nji,nki)
*
integer ierr, jk1, jk2, jk3
real, allocatable :: buffero4(:,:,:)
*
integer ezsint
external ezsint
*-----7----------------------------------------------------------------
allocate(buffero4(nio,njo,nko))
ierr = ezsint(buffero4,zin4)
do jk3 = 1,nko
do jk2 = 1,njo
do jk1 = 1,nio
zout8(jk1,jk2,jk3) = buffero4(jk1,jk2,jk3)
enddo
enddo
enddo
deallocate(buffero4)
return
end