!-------------------------------------- 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/r itf_cpl_fillatm
*
#include "model_macros_f.h"
*
subroutine itf_cpl_fillatm 2,9
implicit none
*
*authors Michel Desgagne - Spring 2008
*
*revision
* v3_31 - Desgagne M. - initial MPI version
**
*implicits
#include "glb_ld.cdk"
#include "itf_cpl.cdk"
#include "dcst.cdk"
#include "geomg.cdk"
#include "geomn.cdk"
#include "cstv.cdk"
#include "lctl.cdk"
#include "ptopo.cdk"
#include "modconst.cdk"
#include "vt1.cdk"
#include "out3.cdk"
#include "rstr.cdk"
#include "schm.cdk"
*
**
integer vmmlod,vmmget
external vmmlod,vmmget
*
character*4 nomvar
character*16 datev,datem
logical flag,first
integer key(3),err,i,j,send,recv
real u(LDIST_SHAPE),v(LDIST_SHAPE),uug(l_ni,l_nj),vvg(l_ni,l_nj),
$ tt(l_ni,l_nj), es(l_ni,l_nj),sbuf(G_ni,G_nj),mask(G_ni,G_nj)
$
real*8 dayfrac,one,sid,rsid
parameter(one=1.0d0, sid=86400.0d0, rsid=one/sid)
data first/.true./
save first
* ________________________________________________________________
*
if (.not.C_coupling_L) return
if (first) then
if (Rstri_rstn_L.and.oce_hotstart) goto 1001
endif
atm_busin = 0.
if (.not. ( (Lctl_step.ge.cpl_debut) .and.
$ (Lctl_step.le.cpl_fin ) ) ) return
*
key( 1) = VMM_KEY(ut1)
key( 2) = VMM_KEY(vt1)
*
err = vmmlod(key,2)
err = VMM_GET_VAR(ut1)
err = VMM_GET_VAR(vt1)
*
if (.not.Schm_offline_L) then
u(:,:) = ut1 (:,:,G_nk)
v(:,:) = vt1 (:,:,G_nk)
call itf_phy_uvgridscal (u,v,LDIST_DIM, 1, .true.)
do j= 1, l_nj
do i= 1, l_ni
uug(i,j) = u(i,j)* Dcst_rayt_8 / cos(geomg_y_8(j))
vvg(i,j) = v(i,j)* Dcst_rayt_8 / cos(geomg_y_8(j))
end do
end do
else
uug(:,:) = ut1 (1:l_ni,1:l_nj,G_nk)
vvg(:,:) = vt1 (1:l_ni,1:l_nj,G_nk)
endif
*
call wind_rot2ll (uug,vvg,Geomn_lonrx,Geomn_latrx,l_ni*l_nj)
*
call diag_ttes (tt,es,l_ni,l_nj,G_nk)
*
atm_local_busou(:,:,1) = tt
atm_local_busou(:,:,2) = uug
atm_local_busou(:,:,3) = vvg
atm_local_busou(:,:,4) = es
*
call glbcolc (atm_busou, G_ni, G_nj, atm_Local_busou,
$ 1, l_ni, 1, l_nj, n_fldou)
*
if (Ptopo_myproc.eq.0) then
*
dayfrac = dble(Lctl_step)*Cstv_dt_8*rsid
call incdatsd (datev,Mod_runstrt_S,dayfrac)
dayfrac = dble( max(Lctl_step-1,0) )*Cstv_dt_8*rsid
call incdatsd (datem,Mod_runstrt_S,dayfrac)
*
atm_busou(:,:,2) = 1.
call cpl_exchg (datev, atm_busou, datem, atm_busin,
$ G_ni, G_nj, 2, send, recv)
if ((send.lt.0).or.(recv.lt.0)) C_coupling_L = .false.
if (.not.C_coupling_L) goto 999
*
flag = (mod(Lctl_step,1).eq.0)
flag = .false.
if (flag) then
do i=1,n_fldou
nomvar = nv_writ(i)(5:7)
if (nomvar.eq.'UDA') nomvar='UU'
if (nomvar.eq.'VDA') nomvar='VV'
call r_rawfstw(atm_busou(1,(i-1)*G_nj+1,1),G_ni,G_nj,nomvar,
$ Lctl_step,int(Cstv_dt_8),Out3_date,'..//gem_cpl_out.fst')
end do
do i=1,n_fldin
nomvar = nv_read(i)(5:7)
if (nomvar.eq.'UDA') nomvar='UU'
if (nomvar.eq.'VDA') nomvar='VV'
call r_rawfstw(atm_busin(1,(i-1)*G_nj+1) ,G_ni,G_nj,nomvar,
$ Lctl_step,int(Cstv_dt_8),Out3_date,'..//gem_cpl_in.fst' )
end do
endif
c if (cpl_name.eq.'MECatmg15_240x290GSL <==> GOMoceg05_150x236GSL')
c $ atm_busin(1:94,1:G_nj)= 0. ; atm_busin(176:G_ni,1:G_nj)= 0.
endif
*
999 call RPN_COMM_bcast (C_coupling_L, 1, "MPI_LOGICAL", 0,"grid",err)
if (.not.C_coupling_L) return
call glbdist (atm_busin, G_ni, G_nj, atm_local_busin,
$ 1, l_ni, 1, l_nj, n_fldin, 0, 0)
*
atm_local_busin (1:l_ni,1:l_nj,2)=
$ max(atm_local_busin (1:l_ni,1:l_nj,2),250.)
*
if (recv.eq.9001) then
atm_local_busin (1:l_ni,1:l_nj,1)=0.
atm_local_busin (1:l_ni,1:l_nj,2)=273.
atm_local_busin (1:l_ni,1:l_nj,3)=273.
atm_local_busin (1:l_ni,1:l_nj,4)=0.
atm_local_busin (1:l_ni,1:l_nj,5)=0.
endif
1001 first = .false.
*
* ________________________________________________________________
*
return
end