!-------------------------------------- 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 adw_vder_ad - ADJ of adw_vder
*
#include "model_macros_f.h"
*
subroutine adw_vder_ad (F_inzz, F_in, F_nit, F_njt, F_nk) 1,2
*
#include "impnone.cdk"
*
integer F_nit, F_njt, F_nk
*
real F_inzz (F_nit, F_njt, F_nk), F_in (F_nit, F_njt, F_nk)
*
*author
* monique tanguay
*
*revision
* v2_31 - Tanguay M. - initial MPI version
* v3_00 - Tanguay M. - adapt to restructured adw_main
* v3_01 - Lee V. - calls to opinv7,optriss7 instead of
* v3_01 opinv6,optriss6 to correct bug
*
*language
* fortran 77
*
*object
* see id section
*
*ADJ of
*arguments
*______________________________________________________________________
* | | |
* NAME | DESCRIPTION | I/O |
*--------------|-------------------------------------------------|-----|
* | | |
* F_inzz | second derivative along z of F_in | o |
* F_in | field to be differenciated | i |
* | | |
* F_nit | \ total number of points in x,y direction in | i |
* F_njt | / advection grid (including halos) | i |
* | | |
* F_nk | number of levels | i |
*______________|_________________________________________________|_____|
*
*implicits
#include "glb_ld.cdk"
#include "adw.cdk"
#include "geomg.cdk"
#include "schm.cdk"
************************************************************************
*
integer i, j, k, i_deb, j_deb, i_fin, j_fin
*
real prd, pr1, pr2, pr1p, pr2p
*
real F_in_w(F_nit, F_njt, l_nk)
*
real*8 ZERO_8
parameter (ZERO_8=0.0)
*
************************************************************************
* ------------------
* TRAJECTORY (START)
* ------------------
i_deb = 1
if ( l_west .and. G_lam) i_deb = Adw_halox-1 +2
j_deb = 1
if ( l_south ) j_deb = Adw_haloy-1
if ( l_south.and. G_lam) j_deb = Adw_haloy-1 +2
*
i_fin = Adw_nit
if ( l_east .and. G_lam) i_fin = Adw_halox + Adw_nic -2
j_fin = Adw_njt
if ( l_north ) j_fin = Adw_haloy + Adw_njc + 2
if ( l_north .and.G_lam) j_fin = Adw_haloy + Adw_njc - 2
*
* ----------------
* TRAJECTORY (END)
* ----------------
*
if ( Adw_nkbz_L ) then
*
* ------------------
* TRAJECTORY (START)
* ------------------
if ( l_nk.eq.3 ) then
pr1 = 0.0
pr2 = 0.0
else
pr1= (Geomg_z_8(2)-Geomg_z_8(1))/(Geomg_z_8(3)-Geomg_z_8(2))
pr2= (Geomg_z_8(l_nk )-Geomg_z_8(l_nk-1)) /
$ (Geomg_z_8(l_nk-1)-Geomg_z_8(l_nk-2))
endif
pr1p = pr1 + 1.0
pr2p = pr2 + 1.0
pr1 = - pr1
pr2 = - pr2
*
* ----------------
* TRAJECTORY (END)
* ----------------
*
do j=j_deb,j_fin
do i=i_deb,i_fin
F_inzz(i,j,l_nk-1) = pr2p * F_inzz(i,j,l_nk) + F_inzz(i,j,l_nk-1)
F_inzz(i,j,l_nk-2) = pr2 * F_inzz(i,j,l_nk) + F_inzz(i,j,l_nk-2)
F_inzz(i,j,l_nk) = 0.
F_inzz(i,j,2) = pr1p * F_inzz(i,j,1) + F_inzz(i,j,2)
F_inzz(i,j,3) = pr1 * F_inzz(i,j,1) + F_inzz(i,j,3)
F_inzz(i,j,1) = 0.
enddo
enddo
endif
*
call opinv7_ad ( F_inzz, i_deb, j_deb,i_fin, j_fin,l_nk, 'Z', prd, prd,
$ prd, Adw_qzi_8, Adw_qzi_8(G_nk+1),
$ Adw_qzi_8(2*G_nk+1), Adw_qzi_8(3*G_nk+1), .false.,
$ 'D', Adw_nit, Adw_njt, l_nk, 1 )
*
* --------------------------------
* Store INPUT to OPTRISS_AD
* since OPTRISS_AD will destroy it
* --------------------------------
do k=1,l_nk
do j=1,F_njt
do i=1,F_nit
F_in_w(i,j,k) = F_in(i,j,k)
enddo
enddo
enddo
*
call optriss7_ad( F_inzz, F_in, i_deb, j_deb, i_fin, j_fin, l_nk,
$ 'Z', Adw_qzz_8, Adw_qzz_8(G_nk+1),
$ Adw_qzz_8(2*G_nk+1), .false.,
$ Adw_nit, Adw_njt, l_nk, 1 )
*
* ADD OLD and NEW contributions
* -----------------------------
do k=1,l_nk
do j=1,F_njt
do i=1,F_nit
F_in (i,j,k) = F_in(i,j,k) + F_in_w(i,j,k)
F_inzz(i,j,k) = ZERO_8
F_in_w(i,j,k) = ZERO_8
enddo
enddo
enddo
*
return
end