!-------------------------------------- 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 TRANSFER (CDCTL) 134
#if defined (DOC)
*
***s/r TRANSFER - Transfer of model or observation states in memory
* . and initialisation to zero
*
*Author : P. Gauthier *ARMA/AES June 9, 1992
*Revision:
* L.Fillion*RPN/AESFeb 93 - Observation state option added
* P. Gauthier ARMA/MSC March 2003- Code cleanup for migration to IBM-p690
* M. Buehner ARMA May 2008- Added initialization of TB and SPLAT
* L. Fillion: ARMA/EC - 29 May 2008 - Introduce further transfer option: GDG1 and GD1G. Also: Add GZ.
* L. Fillion: ARMA/EC - 13 Jan 2009 - Upgrade lam4d to v_10_1_2 of 3dvar.
*
* -------------------
** Purpose: takes a global model state (spectral or grid-point)
* . from one comdeck to another.
* . This subroutine can also be used to set to zero
* . the model states
*Arguments
* i : CDCTL : = 'ZGD0' initialisation to zero of COMGD0
* i : = 'ZGD1' initialisation to zero of COMGD1
* i : = 'ZSP0' initialisation to zero of COMSP
* i : = 'ZSP1' initialisation to zero of COMSP1
* i : = 'ZSPG' initialisation to zero of COMSPG
* i : = 'ZOB0' initialisation to zero of COMMVO
* i : = 'ZOB1' initialisation to zero of COMMVO1
* i : = 'ZOBG' initialisation to zero of COMMVOG
* i : = 'GD10' transfer of COMGD1 to COMGD0
* i : = 'GD01' transfer of COMGD0 to COMGD1
* i : = 'GDG1' transfer of COMPDG to COMGD1
* i : = 'GD1G' transfer of COMGD1 to COMPDG
* i : = 'SP10' transfer of COMSP1 to COMSP
* i : = 'SP01' transfer of COMSP to COMSP1
* i : = 'SP0G' transfer of COMSP to COMSPG
* i : = 'SPG0' transfer of COMSPG to COMSP
* i : = 'OB10' transfer of COMMVO1 to COMMVO
* i : = 'OB01' transfer of COMMVO to COMMVO1
* i : = 'OB0G' transfer of COMMVO to COMMVOG
* i : = 'OBG0' transfer of COMMVOG to COMMVO
* i : = 'HR2D' transfer of 2D var of commvo to commvohr
*
#endif
IMPLICIT NONE
*implicits
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comlun.cdk"
#include "compdg.cdk"
#include "comgd0.cdk"
#include "comgd1.cdk"
#include "comsp.cdk"
#include "comsp1.cdk"
#include "comspg.cdk"
#include "commvo.cdk"
#include "commvo1.cdk"
#include "commvog.cdk"
#include "commvohr.cdk"
#include "comstate.cdk"
*
C
CHARACTER*4 CDCTL
INTEGER JV, JOBS,jvhr,jva,ji,jj,jk
!
! Case selection
!
select case (cdctl)
C
C 1. Set to zero
C . -----------
C
C
C . 1.1 Set COMGD0 to zero
C . ------------------
case ('ZGD0')
gd(:,:,:) = 0.d0
tb0(:,:,:) = 0.d0
C
C . 1.1.2 Set COMGD1 to zero
C . ------------------
C
case('ZGD1')
GD1(:,:,:) = 0.d0
tb1(:,:,:) = 0.d0
C
C . 1.2 Set COMSP to zero
C . -----------------
CASE('ZSP0')
SP(:,:,:) = 0.d0
C . 1.2 Set SPLAT to zero
C . -----------------
CASE('ZSPL')
SPLAT(:,:,:,:) = 0.d0
C
C . 1.2.1 Set COMSP1 to zero
C . ------------------
CASE('ZSP1')
SP1(:,:,:) = 0.d0
C
C . 1.2.2 Set COMSPG to zero
C . ------------------
CASE('ZSPG')
SPG(:,:,:) = 0.d0
C
C . 1.3 Set COMMVO to zero
C . ------------------
C
CASE('ZOB0')
GOMOBS(:,:) = 0.d0
C
C . 1.3.1 Set COMMVO1 to zero
C . -------------------
C
CASE('ZOB1')
GOMOBS1(:,:) = 0.d0
C
C . 1.3.1 Set COMMVOG to zero
C . -------------------
C
CASE('ZOBG')
GOMOBSG(:,:) = 0.d0
C
C 2. Transfer between spectral model states
C . ----------------------------------------
C
C 2.1 COMSP ---> COMSP1
C . --------------------
C
CASE('SP01')
SP1(:,:,:) = SP(:,:,:)
C
C 2.2 COMSP ---> COMSPG
C . --------------------
C
CASE('SP0G')
SPG(:,:,:) = SP(:,:,:)
C
C 2.3 COMSP1 ---> COMSP
C . --------------------
C
CASE('SP10')
SP(:,:,:) = SP1(:,:,:)
C
C 2.4 COMSPG ---> COMSP
C . --------------------
C
CASE('SPG0')
SP(:,:,:) = SPG(:,:,:)
C
C 3. Transfer between grid-point model states
C . ----------------------------------------
C . 3.1 COMGD ---> COMGD1
C . -----------------
CASE('GD01')
GD1(:,:,:) = GD(:,:,:)
TB1(:,:,:) = TB0(:,:,:)
C
C . 3.2 COMGD1 ---> COMGD
C . -----------------
C
CASE('GD10')
GD(:,:,:) = GD1(:,:,:)
TB0(:,:,:) = TB1(:,:,:)
C
C . 3.3 COMPDG ---> COMGD1
C . ------------------
CASE('GDG1')
do ji=1,ni
do jj=1,nj
do jk=1,nflev
ut1(ji,jk,jj) = utg(ji,jk,jj)
vt1(ji,jk,jj) = vtg(ji,jk,jj)
tt1(ji,jk,jj) = ttg(ji,jk,jj)
q1(ji,jk,jj) = qg(ji,jk,jj)
enddo
if(NGEXIST(ngps).eq.1) then
gps1(ji,1,jj) = gpsg(ji,1,jj)
endif
enddo
enddo
C
C . 3.4 COMGD1 ---> COMPDG
C . ------------------
C
CASE('GD1G')
do ji=1,ni
do jj=1,nj
do jk=1,nflev
utg(ji,jk,jj) = ut1(ji,jk,jj)
vtg(ji,jk,jj) = vt1(ji,jk,jj)
ttg(ji,jk,jj) = tt1(ji,jk,jj)
qg(ji,jk,jj) = q1(ji,jk,jj)
enddo
if(NGEXIST(ngps).eq.1) then
gpsg(ji,1,jj) = gps1(ji,1,jj)
endif
enddo
enddo
C
C 4. Transfer of model states at obs. points
C
C . 4.1 COMMVO ---> COMMVO1
C . -------------------
CASE('OB01')
GOMOBS1(:,:) = GOMOBS(:,:)
C
C . 4.2 COMMVO1 ---> COMMVO
C . -------------------
CASE('OB10')
GOMOBS(:,:) = GOMOBS1(:,:)
C
C . 4.3 COMMVO ---> COMMVOG
C . -------------------
CASE('OB0G')
GOMOBSG(:,:) = GOMOBS(:,:)
C
C . 4.4 COMMVOG ---> COMMVO
C . -------------------
CASE('OBG0')
GOMOBS(:,:) = GOMOBSG(:,:)
C
C . 4.5 Transfer of 2D var fields commvo --> commvohr
C
CASE('HR2D')
DO JOBS = 1, NOBTOT
DO JV = 1,nvo2d
jvhr = jv + nvo3d*nlevtrl
jva = jv + nvo3d*nflev
GOMOBSHR(JVhr,JOBS) = GOMOBSG(JVa,JOBS)
enddo
enddo
! Default Case
CASE DEFAULT
WRITE(NULOUT,FMT='(/,4X,10('' *''),''In TRANSFER:'',
S '' Configuration not supported'',A4)')CDCTL
END SELECT
C
RETURN
END