!-------------------------------------- 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 sugrdpar 1,7
#if defined (DOC)
!
!**** sugrdpar - Defines Analysis grid fields and rotation matrix, parameters, etc.
! First letter is G or L "GU" for Global or Lam
! Second letter is U or V for Uniform or Variable mesh
!
! Initialization of part of comgrd (also partly filled by sugeom).
!
! Modifications.
! --------------
*Author : L. Fillion ARMA/MSC Dec 2004 Limited area analysis.
*Revision:
* L. Fillion ARMA/MSC May 2006: Mesovar upgrade to v10_0_0.
* L. Fillion ARMA/EC 8 Oct 2008: Introduce embedded lam option.
* L. Fillion ARMA/EC 8 Oct 2009 (Yes really 8 Oct !): Set rotation matrix in Global option too.
!
#endif
!
IMPLICIT NONE
#include "taglam4d.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
#include "comgdpar.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='(/,'' sugrdpar: Analysis Grid Fields and parameters'')')
!
!
! Compute grd_x0,grd_y0,grd_xl,grd_yl as in e_gemnml
! --------------------------------------------------
!
if (ni*nj.eq.0.) then
call abort3d(nulout,'sugrdpar: VERIFY NI,NJ IN NAMELIST NAMDIM')
endif
grd_ni = nila
grd_nj = njla
grd_nila = nila
grd_njla = njla
grd_x0 = grd_lonr - (grd_iref-1) * grd_dx
grd_y0 = grd_latr - (grd_jref-1) * grd_dy
grd_xl = grd_x0 + (nila -1) * grd_dx
grd_yl = grd_y0 + (njla -1) * grd_dy
if (grd_x0.lt.0.) grd_x0=grd_x0+360.
if (grd_xl.lt.0.) grd_xl=grd_xl+360.
if ( (grd_x0.lt. 0.).or.(grd_y0.lt.-90.).or.
& (grd_xl.gt.360.).or.(grd_yl.gt. 90.) ) then
call abort3d(nulout,'SUGRDPAR: Problem with grd_x0 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_xlon1
zxlat1_4=grd_xlat1
zxlon2_4=grd_xlon2
zxlat2_4=grd_xlat2
!
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_8(1,1)= -xyz1_8(1)/c_8
grd_rot_8(1,2)= -xyz1_8(2)/c_8
grd_rot_8(1,3)= -xyz1_8(3)/c_8
grd_rot_8(2,1)= ( ((a_8*xyz1_8(1)) - xyz2_8(1)) / b_8)/d_8
grd_rot_8(2,2)= ( ((a_8*xyz1_8(2)) - xyz2_8(2)) / b_8)/d_8
grd_rot_8(2,3)= ( ((a_8*xyz1_8(3)) - xyz2_8(3)) / b_8)/d_8
grd_rot_8(3,1)=
& ( (xyz1_8(2)*xyz2_8(3)) - (xyz2_8(2)*xyz1_8(3)))/b_8
grd_rot_8(3,2)=
& ( (xyz2_8(1)*xyz1_8(3)) - (xyz1_8(1)*xyz2_8(3)))/b_8
grd_rot_8(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_8(ji,jj) = 0.0
! enddo
! enddo
! grd_rot_8(1,1) = 1.
! grd_rot_8(2,2) = 1.
! grd_rot_8(3,3) = 1.
!
do j1=1,3
do j2=1,3
write(nulout,*) 'sugrdpar: j1,j2,grd_rot_8(j1,j2)=',j1,j2,grd_rot_8(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_8(j2,j1)
enddo
enddo
call mxma8x(zunit,zrot_t,grd_rot_8,3,3,3)
do j1=1,3
do j2=1,3
write(nulout,*) 'sugrdpar: j1,j2,zunit=',j1,j2,zunit(j1,j2)
enddo
enddo
!
!----------------------------------------------------------------------
!
return
end