!-------------------------------------- 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 vspng_abc -- Prepares matrices aix,bix,cix,dix,aiy,biy,ciy
*
#include "model_macros_f.h"
*
subroutine vspng_abc(F_aix_8, F_bix_8, F_cix_8, F_dix_8 , 23,2
$ F_aiy_8, F_biy_8, F_ciy_8, F_coef_8,
$ F_cy2_8, F_xp0_8, F_xp2_8, F_yp0_8 ,
$ F_yp2_8, Gni, Gnj,F_gnjv)
*
implicit none
*
integer Gni,Gnj,F_gnjv
real*8 F_aix_8(*), F_bix_8(*), F_cix_8(*), F_dix_8(*),
$ F_aiy_8(*), F_biy_8(*), F_ciy_8(*), F_coef_8,
$ F_cy2_8(*), F_xp0_8(Gni,3), F_xp2_8(Gni,3),
$ F_yp0_8(Gnj,3), F_yp2_8(Gnj,3)
*
*author
* Michel Desgagne October 2000
*
*revision
* v2_11 - Desgagne M. - initial version
* v3_03 - Desgagne M. - adjust horizontal scope (in,jn)
* v3_10 - Corbeil & Desgagne & Lee - AIXport+Opti+OpenMP
* v3_20 - Lee V. - correction to insure index in,jn >=0
*
*object
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* F_aix_8
*----------------------------------------------------------------
*
*implicit
#include "glb_ld.cdk"
#include "vspng.cdk"
#include "trp.cdk"
#include "ptopo.cdk"
*
integer i, j, k, ii, jj, j2, in, jn
real*8 ax_8(Vspng_nk,trp_12emax,G_ni),
$ bx_8(Vspng_nk,trp_12emax,G_ni),
$ cx_8(Vspng_nk,trp_12emax,G_ni),
$ ay_8(Vspng_nk,trp_22emax,G_nj),
$ by_8(Vspng_nk,trp_22emax,G_nj),
$ cy_8(Vspng_nk,trp_22emax,G_nj),diy_8,mdifc(Gnj)
real*8 ZERO_8,ONE_8,HALF_8
parameter ( ZERO_8 = 0.0 , ONE_8 = 1.0 , HALF_8 = 0.5 )
**
* ---------------------------------------------------------------
*
C call tmg_start(86,'vspng_abc')
if (Vspng_njpole .lt. 1) then
do j = 1, Gnj
mdifc(j) = ONE_8
end do
else
do j = 1, Vspng_njpole
mdifc(j) = dble(j-1)/dble(Vspng_njpole)
end do
do j = Vspng_njpole+1, F_gnjv-Vspng_njpole
mdifc(j) = ONE_8
end do
do j = F_gnjv-Vspng_njpole+1, Gnj
mdifc(j) = max(ZERO_8,dble(F_gnjv-j)/dble(Vspng_njpole))
end do
endif
*
* Calcul le long de X
* calculate the ending point JN of where to fill the data
* as the tile is ldnh_maxy size (l_maxy size)
c jn = trp_12en
c88 j2 = Ptopo_gindx(3,Ptopo_myproc+1) + Trp_12en0 + jn - 2
c if (j2.gt.Gnj) then
c jn = jn - 1
c goto 88
c endif
jn = trp_12en
j2 = Ptopo_gindx(3,Ptopo_myproc+1) + Trp_12en0 + jn - 2
if (j2.gt.Gnj) jn = jn - (j2-Gnj)
* Insure that any filling on the end of the tile is within the tile
* in case JN is negative
jn = max(0,jn)
!$omp parallel private(jj,j2)
!$omp do
do i = 1, G_ni
! do k = 1, Vspng_nk
do j = 1, jn
jj = Trp_12en0 + j - 1
j2 = Ptopo_gindx(3,Ptopo_myproc+1) + jj - 1
! do i = 1, G_ni
do k = 1, Vspng_nk
ax_8(k,j,i) = F_xp0_8(i,1) - F_xp2_8(i,1) * mdifc(j2)
$ *F_coef_8*Vspng_mf(k) / cos(F_cy2_8(jj))**2
bx_8(k,j,i) = F_xp0_8(i,2) - F_xp2_8(i,2) * mdifc(j2)
$ *F_coef_8*Vspng_mf(k) / cos(F_cy2_8(jj))**2
cx_8(k,j,i) = F_xp0_8(i,3) - F_xp2_8(i,3) * mdifc(j2)
$ *F_coef_8*Vspng_mf(k) / cos(F_cy2_8(jj))**2
enddo
enddo
*
do j = jn+1,trp_12emax
do k = 1, Vspng_nk
bx_8(k,j,i)= ONE_8
cx_8(k,j,i)= ZERO_8
ax_8(k,j,i)= ZERO_8
enddo
enddo
enddo
!$omp enddo
!$omp end parallel
*
call set_trig21 (F_aix_8,F_bix_8,F_cix_8,F_dix_8, ax_8,bx_8,cx_8,
$ Vspng_nk*trp_12emax, 1, G_ni,
$ Vspng_nk*trp_12en, .true.)
*
* Calcul le long de Y
*
* calculate the ending point IN of where to fill the data
* as the tile is ldnh_maxx size (l_maxx size)
c in = trp_22en
c99 j2 = Ptopo_gindx(1,Ptopo_myproc+1) + trp_22en0 + in - 2
c if (j2.gt.G_ni) then
c in = in - 1
c goto 99
c endif
in = trp_22en
j2 = Ptopo_gindx(1,Ptopo_myproc+1) + trp_22en0 + in - 2
if (j2.gt.G_ni) in = in - (j2-G_ni)
* Insure that any filling on the end of the tile is within the tile
* in case IN is negative
in = max(0,in)
!$omp parallel
!$omp do
do j= 1, F_gnjv
do i= 1, in
do k= 1, Vspng_nk
ay_8(k,i,j) = F_yp0_8(j,1) - F_yp2_8(j,1)
$ * F_coef_8 * Vspng_mf(k) * mdifc(j)
by_8(k,i,j) = F_yp0_8(j,2) - F_yp2_8(j,2)
$ * F_coef_8 * Vspng_mf(k) * mdifc(j)
cy_8(k,i,j) = F_yp0_8(j,3) - F_yp2_8(j,3)
$ * F_coef_8 * Vspng_mf(k) * mdifc(j)
enddo
enddo
enddo
!$omp enddo
!$omp do
do i= 1, in
do k= 1, Vspng_nk
ay_8(k,i,1) = ZERO_8
enddo
enddo
!$omp enddo
*
!$omp do
do j = 1, F_gnjv
do i = in+1,trp_22emax
do k = 1, Vspng_nk
by_8(k,i,j)= ONE_8
cy_8(k,i,j)= ZERO_8
ay_8(k,i,j)= ZERO_8
enddo
enddo
enddo
!$omp enddo
!$omp end parallel
*
call set_trig21 (F_aiy_8,F_biy_8,F_ciy_8,diy_8, ay_8,by_8,cy_8,
$ Vspng_nk*trp_22emax, 1, F_gnjv,
$ Vspng_nk*trp_22en, .false.)
*
* ---------------------------------------------------------------
*
C call tmg_stop(86)
return
end