!-------------------------------------- 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 sugrdpar2 1,7
#if defined (DOC)
!
!**** sugrdpar2 - Defines Analysis grid fields and rotation matrix, parameters, etc.
!
! Modifications.
! --------------
*Author : L. Fillion ARMA/EC - 28 Apr 2009.
*Revision:
* L. Fillion ARMA/EC - May 2010 - Slight improvement in printout.
!
#endif
!
IMPLICIT NONE
#include "taglam4d.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comgrd2.cdk"
#include "comgdpar.cdk"
#include "comgrd_param.cdk"
!
integer ierr,ji,jj,j1,j2
integer ii0,ij0,Idum,Imargin
!
real zxlon1_4,zxlat1_4,zxlon2_4,zxlat2_4
!
real*8 a_8,b_8,c_8,d_8,xyz1_8(3),xyz2_8(3)
real*8 zrot_t(3,3),zunit(3,3)
!
!!
WRITE(nulout,FMT='(/,'' sugrdpar2- LAM: Analysis Grid Fields and parameters'')')
!
!
! Compute grd_x0,grd_y0,grd_xl,grd_yl as in e_gemnml
! --------------------------------------------------
!
if (nila2*njla2.eq.0.) then
call abort3d(nulout,'sugrdpar2: VERIFY nila2,njla2 IN NAMELIST NAMGRD')
endif
grd_ni2 = nila2
grd_nj2 = njla2
grd_nila2 = nila2
grd_njla2 = njla2
grd_x02 = grd_lonr2 - (grd_iref2-1) * grd_dx2
grd_y02 = grd_latr2 - (grd_jref2-1) * grd_dy2
grd_xl2 = grd_x02 + (nila2 -1) * grd_dx2
grd_yl2 = grd_y02 + (njla2 -1) * grd_dy2
if (grd_x02.lt.0.) grd_x02=grd_x02+360.
if (grd_xl2.lt.0.) grd_xl2=grd_xl2+360.
if ( (grd_x02.lt. 0.).or.(grd_y02.lt.-90.).or.
& (grd_xl2.gt.360.).or.(grd_yl2.gt. 90.) ) then
call abort3d(nulout,'sugrdpar2: Problem with grd_x02 etc')
endif
!
! Compute the rotation matrix (r_8) that allows transformation
! from the non-rotated to the rotated spherical coordinate system.
! ---------------------------------------------------------------
!
! Compute transform matrices xyz1_8 and xyz2_8
!
zxlon1_4=grd_xlon12
zxlat1_4=grd_xlat12
zxlon2_4=grd_xlon22
zxlat2_4=grd_xlat22
!
call vllacar ( xyz1_8, zxlon1_4, zxlat1_4, 1, 1 )
call vllacar ( xyz2_8, zxlon2_4, zxlat2_4, 1, 1 )
!
! Compute a = cos(alpha) & b = sin(alpha)
!
a_8 = (xyz1_8(1)*xyz2_8(1)) + (xyz1_8(2)*xyz2_8(2))
& + (xyz1_8(3)*xyz2_8(3))
b_8 = sqrt (((xyz1_8(2)*xyz2_8(3)) - (xyz2_8(2)*xyz1_8(3)))**2
& + ((xyz2_8(1)*xyz1_8(3)) - (xyz1_8(1)*xyz2_8(3)))**2
& + ((xyz1_8(1)*xyz2_8(2)) - (xyz2_8(1)*xyz1_8(2)))**2)
!
! Compute c = norm(-r1) & d = norm(r4)
!
c_8 = sqrt ( xyz1_8(1)**2 + xyz1_8(2)**2 + xyz1_8(3)**2 )
d_8 = sqrt ( ( ( (a_8*xyz1_8(1)) - xyz2_8(1) ) / b_8 )**2 +
& ( ( (a_8*xyz1_8(2)) - xyz2_8(2) ) / b_8 )**2 +
& ( ( (a_8*xyz1_8(3)) - xyz2_8(3) ) / b_8 )**2 )
!
grd_rot_82(1,1)= -xyz1_8(1)/c_8
grd_rot_82(1,2)= -xyz1_8(2)/c_8
grd_rot_82(1,3)= -xyz1_8(3)/c_8
grd_rot_82(2,1)= ( ((a_8*xyz1_8(1)) - xyz2_8(1)) / b_8)/d_8
grd_rot_82(2,2)= ( ((a_8*xyz1_8(2)) - xyz2_8(2)) / b_8)/d_8
grd_rot_82(2,3)= ( ((a_8*xyz1_8(3)) - xyz2_8(3)) / b_8)/d_8
grd_rot_82(3,1)=
& ( (xyz1_8(2)*xyz2_8(3)) - (xyz2_8(2)*xyz1_8(3)))/b_8
grd_rot_82(3,2)=
& ( (xyz2_8(1)*xyz1_8(3)) - (xyz1_8(1)*xyz2_8(3)))/b_8
grd_rot_82(3,3)=
& ( (xyz1_8(1)*xyz2_8(2)) - (xyz2_8(1)*xyz1_8(2)))/b_8
!
! do jj=1,3
! do ji=1,3
! grd_rot_82(ji,jj) = 0.0
! enddo
! enddo
! grd_rot_82(1,1) = 1.
! grd_rot_82(2,2) = 1.
! grd_rot_82(3,3) = 1.
!
do j1=1,3
do j2=1,3
write(nulout,*) 'sugrdpar2: j1,j2,grd_rot_82(j1,j2)=',j1,j2,grd_rot_82(j1,j2)
enddo
enddo
!
! Verify Transpose is the inverse
!
call zero(3*3,zunit)
call zero(3*3,zrot_t)
do j1=1,3
do j2=1,3
zrot_t(j1,j2)=grd_rot_82(j2,j1)
enddo
enddo
call mxma8x(zunit,zrot_t,grd_rot_82,3,3,3)
do j1=1,3
do j2=1,3
write(nulout,*) 'sugrdpar2: j1,j2,zunit=',j1,j2,zunit(j1,j2)
enddo
enddo
!
!----------------------------------------------------------------------
!
return
end