!-------------------------------------- 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 grid_nml
*
#include "model_macros_f.h"
*
integer function grid_nml (F_namelistf_S) 5,2
implicit none
*
character* (*) F_namelistf_S
*
*author
* M. Desgagne - Summer 2006
*
*revision
* v3_30 - Desgagne M. - initial version
* v3_31 - Lee V. - added extra CHECK for LAM grid
*
*object
* Default configuration and reading namelist grid
*
#include "grd.cdk"
#include "hgc.cdk"
#include "lun.cdk"
#include "schm.cdk"
*
integer fnom
external fnom
*
character*120 dumc
integer unf,nrec
real*8 epsilon,a_8,b_8,c_8,d_8,xyz1_8(3),xyz2_8(3)
parameter (epsilon = 1.0d-5)
*
*-------------------------------------------------------------------
*
grid_nml = -1
*
if ((F_namelistf_S.eq.'print').or.(F_namelistf_S.eq.'PRINT')) then
grid_nml = 0
if (Lun_out.gt.0) then
write (Lun_out ,nml=grid)
write (Lun_out, 5000) Grd_rot_8
endif
return
endif
*
* Defaults values for ptopo namelist variables
*
Grd_typ_S = 'GU'
Grd_ni = 0
Grd_nj = 0
Grd_nila = 0
Grd_njla = 0
Grd_dx = 0.
Grd_dy = 0.
Grd_dxmax = 360.
Grd_dymax = 180.
Grd_iref = 1
Grd_jref = 1
Grd_latr = 0.
Grd_lonr = 0.
Grd_xlon1 = 180.
Grd_xlat1 = 0.
Grd_xlon2 = 270.
Grd_xlat2 = 0.
Grd_gauss_L = .false.
Grd_filename_S ='/dev/null'
*
if (F_namelistf_S .ne. '') then
*
unf = 0
if (fnom (unf,F_namelistf_S, 'SEQ+OLD', nrec) .ne. 0) goto 9110
rewind(unf)
read (unf, nml=grid, end = 9120, err=9120)
*
call fclos (unf)
*
endif
*
call low2up (Grd_typ_S,dumc)
Grd_typ_S = dumc
*
if (Grd_ni*Grd_nj.eq.0) then
if (Lun_out.gt.0) write(Lun_out,*)
$ 'VERIFY Grd_NI & Grd_NJ IN NAMELIST grid'
goto 9988
endif
if (Grd_typ_S(1:1).eq.'G') then
if (Grd_typ_S(2:2).eq.'U') then
Grd_nila = Grd_ni
Grd_njla = Grd_nj
else
if (Grd_nila*Grd_njla*Grd_dx*Grd_dy.eq.0) then
if (Lun_out.gt.0) write(Lun_out,*)
$ 'VERIFY Grd_NILA, Grd_NJLA, Grd_DX & ',
$ 'Grd_DY IN NAMELIST grid'
goto 9988
endif
endif
Grd_x0= 0.0
Grd_xl=360.0
Grd_y0=-90.0
Grd_yl= 90.0
else
if (Grd_dx*Grd_dy.eq.0) then
if (Lun_out.gt.0) write(Lun_out,*)
$ 'VERIFY Grd_DX & Grd_DY IN NAMELIST grid'
goto 9988
endif
Grd_nila = Grd_ni
Grd_njla = Grd_nj
if (Grd_iref.lt.1.or.Grd_iref.gt.Grd_ni.or.
$ Grd_jref.lt.1.or.Grd_jref.gt.Grd_nj) then
if (Lun_out.gt.0) write(Lun_out,1002)
$ Grd_ni,Grd_nj,Grd_iref,Grd_jref
goto 9988
endif
Grd_x0 = Grd_lonr - (Grd_iref-1) * Grd_dx
Grd_y0 = Grd_latr - (Grd_jref-1) * Grd_dy
Grd_xl = Grd_x0 + (Grd_ni -1) * Grd_dx
Grd_yl = Grd_y0 + (Grd_nj -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
if (Lun_out.gt.0) write (Lun_out,1001)
$ Grd_x0,Grd_y0,Grd_xl,Grd_yl
if (.not.Schm_offline_L) goto 9988
endif
endif
*
if (nint( 360./Grd_dxmax ) .gt. Grd_ni+1 .or.
+ nint( 180./Grd_dymax ) .gt. Grd_nj+1 ) then
if (Lun_out.gt.0) write(Lun_out,*)
$ ' INCONSISTENT Grd_NI, Grd_NJ, ',
$ ' Grd_DXMAX & Grd_DYMAX values in namelist grid'
goto 9988
endif
*
* compute RPN/FST grid descriptors
*
Hgc_gxtyp_s = 'E'
call cxgaig ( Hgc_gxtyp_S,Hgc_ig1ro,Hgc_ig2ro,Hgc_ig3ro,Hgc_ig4ro,
$ Grd_xlat1,Grd_xlon1,Grd_xlat2,Grd_xlon2 )
call cigaxg ( Hgc_gxtyp_S,Grd_xlat1,Grd_xlon1,Grd_xlat2,Grd_xlon2,
$ Hgc_ig1ro,Hgc_ig2ro,Hgc_ig3ro,Hgc_ig4ro )
*
Grd_roule = .not. ( (abs(Grd_xlon1-180.d0).lt.epsilon) .and.
$ ( abs(Grd_xlon2-270.d0).lt.epsilon) .and.
$ ( abs(Grd_xlat1 ).lt.epsilon) .and.
$ ( abs(Grd_xlat2 ).lt.epsilon) )
*
Grd_rot_8 = 0.
Grd_rot_8(1,1) = 1.
Grd_rot_8(2,2) = 1.
Grd_rot_8(3,3) = 1.
*
if (Grd_roule) then
*
* Compute the rotation matrix that allows transformation
* from the none-rotated to the rotated spherical coordinate system.
*
* Compute transform matrices xyz1_8 and xyz2_8
*
call llacar ( xyz1_8, Grd_xlon1, Grd_xlat1, 1, 1 )
call llacar ( xyz2_8, Grd_xlon2, Grd_xlat2, 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
*
endif
*
grid_nml = 1
goto 9999
*
9110 if (Lun_out.ge.0) write (Lun_out, 9050) trim( F_namelistf_S )
goto 9988
*
9120 call fclos (unf)
if (Lun_out.ge.0) write (Lun_out, 9150) trim( F_namelistf_S )
goto 9988
*
5000 format(' HORIZONTAL GRID ROTATION MATRIX:'/3(3d20.12/))
1001 format(/,' WRONG LAM GRID CONFIGURATION --- ABORT ---'/,
$ ' Grd_x0,Grd_y0,Grd_xl,Grd_yl:'/4f10.3/)
1002 format(/,' WRONG LAM GRID CONFIGURATION --- ABORT ---'/,
$ ' Grd_ni,Grd_nj,Grd_iref,Grd_jref:'/4I8/)
8000 format (/,'========= ABORT IN S/R grid_nml.f ============='/)
9050 format (/,' FILE: ',A,' NOT AVAILABLE'/)
9150 format (/,' NAMELIST grid INVALID IN FILE: ',A/)
*
*-------------------------------------------------------------------
*
9988 if (Lun_out.gt.0) write (Lun_out, 8000)
9999 return
end