!-------------------------------------- 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 SULEG(KULOUT) 2,2
#if defined (DOC)
*
***s/r SULEG - Initialisation of Gaussian latitudes, weights and related
* . quantities
*
*Author : P. Gauthier *ARMA/AES June 9, 1992
*Revision:
* . L. Fillion *RPN/AES Feb 93 - Include overdimensioning
* . P. Gauthier *ARMA/MSC May 2002. Definitions of staggered grid latitude parameters
* . and weights for a quadrature adapted to it
*Arguments
* i KULOUT: unit used for optional printing
*
#endif
use modstag
, only: rmu_s, rlati_s, rwt_s, r1mu2_s, lstagwinds
S , rsqm2_s, r1qm2_s, r1mui_s, r1mua_s, nj_s, njlath_s
IMPLICIT NONE
*implicits
#include "comdim.cdk"
#include "comcst.cdk"
#include "comleg.cdk"
#include "comlun.cdk"
*
INTEGER KULOUT, JLAT, JM
REAL*8 ZPISU2
EXTERNAL GAUSS
C
WRITE(NULOUT,FMT='(//,6(" ***********"))')
WRITE(NULOUT,*)' SULEG: initialisation of Gaussian',
S ' latitudes, weights, etc...'
WRITE(NULOUT,FMT='(6(" ***********"))')
C
C 1. GAUSSIAN LATITUDES AND WEIGHTS OVER AN HEMISPHERE
C -------------------------------------------------
100 CONTINUE
CALL GAUSS8(NJLATH,RMU(1),RWT(1),RSQM2(1),RCOLAT(1),RWOCS(1)
S ,R1QM2(1),R1MUI(1),R1MU2(1))
C
DO 101 JLAT = 1, NJLATH
RLATI(JLAT) = ASIN(RMU(JLAT))
R1MUA(JLAT) = R1SA*R1MUI(JLAT)
101 CONTINUE
C
C 2. COMPLETION FOR THE SOUTHERN HEMISPHERE
C --------------------------------------
200 CONTINUE
DO 201 JLAT = NJLATH +1, NJ
RMU(JLAT) = -RMU(2*NJLATH +1 - JLAT)
RWOCS(JLAT) = RWOCS(2*NJLATH +1 - JLAT)
R1MU2(JLAT) = R1MU2(2*NJLATH +1 - JLAT)
RSQM2(JLAT) = RSQM2(2*NJLATH +1 - JLAT)
R1QM2(JLAT) = R1QM2(2*NJLATH +1 - JLAT)
R1MUI(JLAT) = R1MUI(2*NJLATH +1 - JLAT)
R1MUA(JLAT) = R1MUA(2*NJLATH +1 - JLAT)
RWT(JLAT) = RWT(2*NJLATH +1 - JLAT)
RLATI(JLAT) = - RLATI (2*NJLATH +1 - JLAT)
201 CONTINUE
C
ZPISU2 = RPI/2.
DO 202 JLAT = 1, NJ
RCOLAT(JLAT) = ZPISU2 - RLATI(JLAT)
202 CONTINUE
C
C* 3. Overdimensioning for interpolation
C
300 CONTINUE
C
IF(NJSUR.GE.2) THEN
RMU (-1) = RMU (1)
R1MU2(-1) = R1MU2(1)
RSQM2(-1) = RSQM2(1)
R1QM2(-1) = R1QM2(1)
R1MUI(-1) = R1MUI(1)
R1MUA(-1) = R1MUA(1)
RLATI(-1) = RPI-RLATI(1)
C
RMU (0) = 1.
R1MU2(0) = 0.
RSQM2(0) = 0.
R1QM2(0) = RINFINI
R1MUI(0) = RINFINI
R1MUA(0) = RINFINI
RLATI(0) = RPI*.5
C
RMU (NJ+1) = -1.
R1MU2(NJ+1) = 0.
RSQM2(NJ+1) = 0.
R1QM2(NJ+1) = RINFINI
R1MUI(NJ+1) = RINFINI
R1MUA(NJ+1) = RINFINI
RLATI(NJ+1) = -RPI*.5
C
RMU (NJ+2) = RMU (NJ)
R1MU2(NJ+2) = R1MU2(NJ)
RSQM2(NJ+2) = RSQM2(NJ)
R1QM2(NJ+2) = R1QM2(NJ)
R1MUI(NJ+2) = R1MUI(NJ)
R1MUA(NJ+2) = R1MUA(NJ)
RLATI(NJ+2) = -RPI-RLATI(NJ)
END IF
C
C* 4. Print the content of GAUS
C
400 CONTINUE
WRITE(NULOUT,FMT='(" JLAT:",4X," RLATI",8X
S ,"RCOLAT",8X,"RMU",10X ,"RWT",12X,"RW0CS")')
DO 403 JLAT = 1, NJ
cjmb WRITE(NULOUT,FMT='(2X,I4,5(2X,G12.6))')
WRITE(NULOUT,FMT='(2X,I4,5(2X,G23.16))')
S JLAT,RLATI(JLAT),RCOLAT(JLAT), RMU(JLAT)
S ,RWT(JLAT),RWOCS(JLAT)
403 CONTINUE
C
WRITE(KULOUT,FMT='(//," JLAT:",4X,"R1MU2",8X
S ,"RSQM2",9X,"R1QM2",10X,"R1MUI",10X,"R1MUA")')
C
DO 404 JLAT = 1, NJ
cjmb WRITE(KULOUT,FMT='(2X,I4,5(2X,G12.6))')
WRITE(KULOUT,FMT='(2X,I4,5(2X,G23.16))')
S JLAT,R1MU2(JLAT),RSQM2(JLAT),R1QM2(JLAT)
S ,R1MUI(JLAT),R1MUA(JLAT)
404 CONTINUE
C
C* 5. Positioning within spectral arrays
C
DO JM = 0, NTRUNC
NIND(JM) = JM*(NTRUNC+1) - (JM*(JM-1))/2 + 1
NINDRH(JM) = JM*(NTRUNC+1) + 1
NCLM(JM) = NTRUNC - JM + 1
end do
C
WRITE(NULOUT,FMT='(/," NIND(0:NTRUNC):",/,10(2X,I6))')
S (NIND(JM),JM=0,NTRUNC)
WRITE(NULOUT,FMT='(" NINDRH(0:NTRUNC):",/,10(2X,I6))')
S (NINDRH(JM),JM=0,NTRUNC)
WRITE(NULOUT,FMT='(" NCLM(0:NTRUNC):",/,10(2X,I6))')
S (NCLM(JM),JM=0,NTRUNC)
C
C 6. Staggered grid latitude parameters
C
if (lstagwinds) then
allocate(rmu_s(njbeg:njend),rwt_s(njbeg:njend), rlati_s(njbeg:njend)
S ,r1mu2_s(njbeg:njend),rsqm2_s(njbeg:njend)
S ,r1qm2_s(njbeg:njend),r1mui_s(njbeg:njend), r1mua_s(njbeg:njend))
!
rmu_s(:) = 0.d0
rwt_s(:) = 0.d0
rlati_s(:) = 0.d0
r1mu2_s(:) = 0.d0
rsqm2_s(:) = 0.d0
r1qm2_s(:) = 0.d0
r1mui_s(:) = 0.d0
r1mua_s(:) = 0.d0
!
write(kulout, fmt='(/,4x,A,/,2x,A,6(8x,A))')
S 'Staggered grid in latitudes are defined','Lat.No.'
S ,'Lat. Stag.','Gaus Lat.','Mu','MU staggered','RWT','RWT_S'
do jlat = 1, nj-1
rlati_s(jlat) = (rlati(jlat) + rlati(jlat+1))/2.d0
rwt_s(jlat) = (rwt(jlat) + rwt(jlat+1))/2.d0
end do
!
do jlat = 1, nj-1
rmu_s(jlat) = sin(rlati_s(jlat))
r1mu2_s(jlat) = 1.d0 - rmu_s(jlat)*rmu_s(jlat)
rsqm2_s(jlat) = sqrt(r1mu2_s(jlat))
r1qm2_s(jlat) = 1.d0/rsqm2_s(jlat)
r1mui_s(jlat) = 1.d0/(r1mu2_s(jlat))
r1mua_s(jlat) = 1.d0/(ra*r1mu2_s(jlat))
end do
do jlat = 1, nj-1
write(kulout,fmt='(4x,i3,6(8x,g12.6))')jlat,rlati_S(jlat)
S , rlati(jlat), rmu_S(jlat),rmu(jlat),rwt(jlat),rwt_s(jlat)
end do
write(kulout, fmt='(/,4x,A,/,1x,A,4x,6(4x,A))')'Staggered grid parameters'
S ,'Lat.No.','MU','(1-MU**2)','RSQM2','R1QM2','R1MUI','R1MUA'
do jlat = 1, nj-1
WRITE(KULOUT,FMT='(1X,I3,6(4X,G12.6))')jlat,rmu_s(jlat),r1mu2_s(jlat)
S ,rsqm2_s(jlat),r1qm2_s(jlat),r1mui_s(jlat),r1mua_s(jlat)
end do
end if
END subroutine suleg