!-------------------------------------- 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 --------------------------------------
copyright (C) 2001 MSC-RPN COMM %%%MC2%%%
***s/r write_3df
#include "model_macros_f.h"
*
subroutine write_3df ( fa,lminx,lmaxx,lminy,lmaxy,nis,njs,nks, 29,2
$ nomvar,gid, gif, gjd, gjf,con,ind_o,unf )
implicit none
*
character* (*) nomvar
integer lminx,lmaxx,lminy,lmaxy,nis,njs,nks,
$ gid, gif, gjd, gjf, ind_o(*), unf
real fa(*),con
*
*author
* Michel Desgagne - Spring 2006
*
*revision
* v3_30 - Lee V. - initial version
*
**
#include "grdc.cdk"
#include "ptopo.cdk"
#include "lctl.cdk"
#include "lun.cdk"
*
integer i,j,k,n,nbits,nb
real tr1(nis,njs,nks),add
real, dimension (:), allocatable :: wkc
logical prout_L
*
*----------------------------------------------------------------------
*
* Writing field 'nomvar' if fa to binary fortran file unit=unf
*
prout_L=.false.
if (Lun_debug_L.and.Ptopo_numproc.eq.1) prout_L=.true.
add = 0.
call blkcol ( tr1,nis,njs,gid,gif,gjd,gjf,con,add,
$ fa,lminx,lmaxx,lminy,lmaxy,nks,ind_o,nks )
if (prout_L) call statfld(tr1,nomvar(1:4),Lctl_step,
$ "writ3",1,nis,1,njs,nks,1,1,1,nis,njs,nks)
*
nb = 0
nbits = Grdc_nbits
*
if (Ptopo_blocme.eq.0) then
write (unf) nomvar(1:4),nis,njs,nks,nbits
if (nbits.ge.32) then
write (unf) tr1
else
n = (nis*njs*nbits+120+32-1)/32
allocate (wkc(n))
do k=1,nks
call xxpak (tr1(1,1,k), wkc, nis, njs, -nbits, nb, 1)
write (unf) wkc
end do
deallocate (wkc)
endif
endif
*
*----------------------------------------------------------------------
return
end
*
***s/r write_bcs
subroutine write_bcs (fa,lminx,lmaxx,lminy,lmaxy,is,nis,js,jn,njs, 20,4
$ iw,ie,niw,jw,njw,nks,nomvar,con,ind_o,unf)
implicit none
*
character* (*) nomvar
integer lminx,lmaxx,lminy,lmaxy,nks,ind_o(*),unf
integer is,nis,js,jn,njs,iw,ie,niw,jw,njw
real fa(*),con
*
**
#include "grdc.cdk"
#include "ptopo.cdk"
#include "lun.cdk"
*
integer i,j,k,ns,nw,nbits,nb
real wks(nis*njs*nks,2), wkw(niw*njw*nks,2)
real fs (nis,njs*2,nks), fw (niw*2,njw,nks)
real, dimension (:), allocatable :: wkc,wkd
logical prout_L
*
*----------------------------------------------------------------------
*
if (Lun_debug_L.and.Ptopo_numproc.eq.1) prout_L=.true.
call glbcolc2 ( wks,is,is+nis-1,js,js+njs-1,fa,
$ lminx,lmaxx,lminy,lmaxy,nks,ind_o,nks )
call glbcolc2 ( wks(1,2),is,is+nis-1,jn,jn+njs-1,fa,
$ lminx,lmaxx,lminy,lmaxy,nks,ind_o,nks )
*
call glbcolc2 ( wkw,iw,iw+niw-1,jw,jw+njw-1,fa,
$ lminx,lmaxx,lminy,lmaxy,nks,ind_o,nks )
call glbcolc2 ( wkw(1,2),ie,ie+niw-1,jw,jw+njw-1,fa,
$ lminx,lmaxx,lminy,lmaxy,nks,ind_o,nks )
*
do k=1,nks
do j=1,njs
do i=1,nis
fs(i,j,k) = wks((k-1)*nis*njs+(j-1)*nis+i,1)
fs(i,njs+j,k) = wks((k-1)*nis*njs+(j-1)*nis+i,2)
end do
end do
do j=1,njw
do i=1,niw
fw(i,j,k) = wkw((k-1)*niw*njw+(j-1)*niw+i,1)
fw(niw+i,j,k) = wkw((k-1)*niw*njw+(j-1)*niw+i,2)
end do
end do
end do
*
nb = 0
nbits = Grdc_nbits
*
if (Ptopo_myproc.eq.0) then
if (prout_L)
$ write(Lun_out,1000) nomvar(1:4),
$ nis,njs,niw,njw,nks,fs(1,1,1),fw(1,1,1)
write (unf) nomvar(1:4),nis,njs,niw,njw,nks,nbits
if (nbits.ge.32) then
write (unf) fs,fw
else
ns = (nis*njs*2*nbits+120+32-1)/32
allocate (wkc(ns))
nw = (niw*njw*2*nbits+120+32-1)/32
allocate (wkd(nw))
do k=1,nks
call xxpak (fs(1,1,k), wkc, nis,njs*2,-nbits,nb,1)
call xxpak (fw(1,1,k), wkd, niw*2,njw,-nbits,nb,1)
write (unf) wkc,wkd
end do
deallocate (wkc,wkd)
endif
endif
1000 format("write_bcs:",a4," nis,njs,niw,njw=",i4,i4,i4,i4,"nks=",i4,
$ "fs(1,1,1)=",f14.5,"w(1,1,1)=",f14.5)
*
*----------------------------------------------------------------------
return
end