!--------------------------------------- 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 --------------------------------------
MODULE GAUSSGRID_MOD 6,3
use MathPhysConstants_mod
use EarthConstants_mod
use HorizontalCoord_mod
implicit none
save
private
! Public Variables
public :: gaus_rwt,gaus_conphy
! Public subroutines
public :: gaus_SetupFromHCO, gaus_setup, gaus_find_lat_index
real*8, allocatable :: gaus_rmu(:)
real*8, allocatable :: gaus_rwocs(:)
real*8, allocatable :: gaus_r1mu2(:)
real*8, allocatable :: gaus_rsqm2(:)
real*8, allocatable :: gaus_r1qm2(:)
real*8, allocatable :: gaus_r1mui(:)
real*8, allocatable :: gaus_r1mua(:)
real*8, allocatable :: gaus_rwt(:)
real*8, allocatable :: gaus_rlati(:)
real*8, allocatable :: gaus_rcolat(:)
real*8, allocatable :: gaus_conphy(:)
real*8, allocatable :: gaus_conima(:)
integer :: gaus_ni, gaus_nj
contains
!--------------------------------------------------------------------------
! gaus_SetupFromHCO
!--------------------------------------------------------------------------
subroutine gaus_SetupFromHCO(hco_in, lverbose_in) 3,1
!
!- Initialisation of Gaussian latitudes, weights and related quantities
! using the grid info from horizontalcoord_mod
!
implicit none
type(struct_hco), intent(in) :: hco_in
logical, optional :: lverbose_in
logical :: lverbose
integer :: njlath, jlat, my_mpi_id, my_mpi_idx_dummy, my_mpi_idy_dummy
real(8) :: zpisu2
if(present(lverbose_in)) then
lverbose = lverbose_in
else
lverbose = .false.
endif
!
!- 1. Tests on the input grid
!
if ( trim(hco_in % grtyp) /= 'G' ) then
write(*,*)
write(*,*) 'gaus_SetupFromHCO: The global analysis grid structure is not from'
write(*,*) ' a gaussian grid! ABORT'
write(*,*) 'hco_in % grtyp = ', trim(hco_in % grtyp)
stop
end if
if ( (hco_in % lat(2) - hco_in % lat(1)) > 0.0d0 ) then
write(*,*)
write(*,*) 'gaus_SetupFromHCO: The latitude of the global analysis grid '
write(*,*) ' are NOT ordered from North TO South'
stop
end if
!
!- 2. Dimension settings and Memory allocation
!
gaus_ni = hco_in % ni
gaus_nj = hco_in % nj
write(*,*) 'gaus_ni = ', gaus_ni
write(*,*) 'gaus_nj = ', gaus_nj
allocate(gaus_rmu(gaus_nj))
allocate(gaus_rwt(gaus_nj))
allocate(gaus_rwocs(gaus_nj))
allocate(gaus_r1mu2(gaus_nj))
allocate(gaus_rsqm2(gaus_nj))
allocate(gaus_rcolat(gaus_nj))
allocate(gaus_r1qm2(gaus_nj))
allocate(gaus_r1mui(gaus_nj))
allocate(gaus_r1mua(gaus_nj))
allocate(gaus_rlati((-1):(gaus_nj+2)))
! allocate(gaus_rlati(gaus_nj))
allocate(gaus_conphy(gaus_nj))
allocate(gaus_conima(gaus_nj))
call rpn_comm_mype(my_mpi_id, my_mpi_idx_dummy, my_mpi_idy_dummy)
njlath = (gaus_nj + 1)/2
if(my_mpi_id.eq.0) write(*,fmt='(//,6(" ***********"))')
if(my_mpi_id.eq.0) write(*,*)' SUGAUSSGRID: initialisation of Gaussian', &
' latitudes, weights, etc...'
if(my_mpi_id.eq.0) write(*,fmt='(6(" ***********"))')
! 1. GAUSSIAN LATITUDES AND WEIGHTS OVER AN HEMISPHERE
! -------------------------------------------------
call gauss8(njlath,gaus_rmu(1),gaus_rwt(1),gaus_rsqm2(1),gaus_rcolat(1),gaus_rwocs(1) &
,gaus_r1qm2(1),gaus_r1mui(1),gaus_r1mu2(1))
do jlat = 1, njlath
gaus_rlati(jlat) = asin(gaus_rmu(jlat))
gaus_r1mua(jlat) = r1sa*gaus_r1mui(jlat)
enddo
! 2. COMPLETION FOR THE SOUTHERN HEMISPHERE
! --------------------------------------
do jlat = njlath +1, gaus_nj
gaus_rmu(jlat) = -gaus_rmu(2*njlath +1 - jlat)
gaus_rwocs(jlat) = gaus_rwocs(2*njlath +1 - jlat)
gaus_r1mu2(jlat) = gaus_r1mu2(2*njlath +1 - jlat)
gaus_rsqm2(jlat) = gaus_rsqm2(2*njlath +1 - jlat)
gaus_r1qm2(jlat) = gaus_r1qm2(2*njlath +1 - jlat)
gaus_r1mui(jlat) = gaus_r1mui(2*njlath +1 - jlat)
gaus_r1mua(jlat) = gaus_r1mua(2*njlath +1 - jlat)
gaus_rwt(jlat) = gaus_rwt(2*njlath +1 - jlat)
gaus_rlati(jlat) = - gaus_rlati (2*njlath +1 - jlat)
enddo
zpisu2 = MPC_PI_R8/2.d0
do jlat = 1, gaus_nj
gaus_rcolat(jlat) = zpisu2 - gaus_rlati(jlat)
enddo
!* 3. Overdimensioning for interpolation
gaus_rlati(-1) = MPC_PI_R8-gaus_rlati(1)
gaus_rlati(0) = MPC_PI_R8*.5d0
gaus_rlati(gaus_nj+1) = -MPC_PI_R8*.5d0
gaus_rlati(gaus_nj+2) = -MPC_PI_R8-gaus_rlati(gaus_nj)
do jlat = 1, gaus_nj
gaus_conphy(jlat) = ra*gaus_r1qm2(jlat)
gaus_conima(jlat) = r1sa*gaus_rsqm2(jlat)
enddo
!* 4. Print the content of GAUS
if(lverbose.and.my_mpi_id.eq.0) write(*,fmt='(" JLAT:",4X," RLATI",8X,"RCOLAT",8X,"RMU",10X ,"RWT",12X,"RW0CS")')
do jlat = 1, gaus_nj
if(lverbose.and.my_mpi_id.eq.0) write(*,fmt='(2X,I4,5(2X,G23.16))') &
jlat,gaus_rlati(jlat),gaus_rcolat(jlat), gaus_rmu(jlat) &
,gaus_rwt(jlat),gaus_rwocs(jlat)
enddo
if(lverbose.and.my_mpi_id.eq.0) write(*,fmt='(//," JLAT:",4X,"R1MU2",8X,"RSQM2",9X,"R1QM2",10X,"R1MUI",10X,"R1MUA")')
do jlat = 1, gaus_nj
if(lverbose.and.my_mpi_id.eq.0) write(*,fmt='(2X,I4,5(2X,G23.16))') jlat,gaus_r1mu2(jlat),gaus_rsqm2(jlat),gaus_r1qm2(jlat) &
,gaus_r1mui(jlat),gaus_r1mua(jlat)
enddo
end subroutine gaus_SetupFromHCO
!--------------------------------------------------------------------------
! gaus_Setup
!--------------------------------------------------------------------------
SUBROUTINE GAUS_SETUP(ni_out, nj_out, ni_in, nj_in, lverbose_in),1
!
! GAUS_SETUP - Initialisation of Gaussian latitudes, weights and related
! quantities
implicit none
integer, intent(OUT) :: ni_out, nj_out
integer, intent(IN), optional :: ni_in , nj_in
logical, intent(IN), optional :: lverbose_in
logical :: lverbose
integer :: ni,nj,nulnam,fnom,fclos,ierr
integer njlath,jlat,my_mpi_id,my_mpi_idx_dummy,my_mpi_idy_dummy
real*8 zpisu2
NAMELIST /NAMDIM/NI, NJ
if(present(lverbose_in)) then
lverbose = lverbose_in
else
lverbose = .false.
endif
if(present(ni_in).and.present(nj_in)) then
ni=ni_in
nj=nj_in
else
ni=240
nj=120
nulnam=0
ierr=fnom(nulnam,'./flnml','FTN+SEQ+R/O',0)
if(ierr < 0) then
write(*,*) 'gaus_setup: Failed to open flnml to obtain ni and nj: ierr=', ierr
call qqexit(1)
end if
read(nulnam,nml=namdim,iostat=ierr)
write(*,nml=namdim)
ierr=fclos(nulnam)
endif
gaus_ni=ni
gaus_nj=nj
ni_out=gaus_ni
nj_out=gaus_nj
allocate(gaus_rmu(nj))
allocate(gaus_rwt(nj))
allocate(gaus_rwocs(nj))
allocate(gaus_r1mu2(nj))
allocate(gaus_rsqm2(nj))
allocate(gaus_rcolat(nj))
allocate(gaus_r1qm2(nj))
allocate(gaus_r1mui(nj))
allocate(gaus_r1mua(nj))
allocate(gaus_rlati((-1):(nj+2)))
allocate(gaus_conphy(nj))
allocate(gaus_conima(nj))
call rpn_comm_mype(my_mpi_id, my_mpi_idx_dummy, my_mpi_idy_dummy)
njlath = (nj + 1)/2
if(my_mpi_id.eq.0) write(*,fmt='(//,6(" ***********"))')
if(my_mpi_id.eq.0) write(*,*)' SUGAUSSGRID: initialisation of Gaussian', &
' latitudes, weights, etc...'
if(my_mpi_id.eq.0) write(*,fmt='(6(" ***********"))')
! 1. GAUSSIAN LATITUDES AND WEIGHTS OVER AN HEMISPHERE
! -------------------------------------------------
call gauss8(njlath,gaus_rmu(1),gaus_rwt(1),gaus_rsqm2(1),gaus_rcolat(1),gaus_rwocs(1) &
,gaus_r1qm2(1),gaus_r1mui(1),gaus_r1mu2(1))
do jlat = 1, njlath
gaus_rlati(jlat) = asin(gaus_rmu(jlat))
gaus_r1mua(jlat) = r1sa*gaus_r1mui(jlat)
enddo
! 2. COMPLETION FOR THE SOUTHERN HEMISPHERE
! --------------------------------------
do jlat = njlath +1, nj
gaus_rmu(jlat) = -gaus_rmu(2*njlath +1 - jlat)
gaus_rwocs(jlat) = gaus_rwocs(2*njlath +1 - jlat)
gaus_r1mu2(jlat) = gaus_r1mu2(2*njlath +1 - jlat)
gaus_rsqm2(jlat) = gaus_rsqm2(2*njlath +1 - jlat)
gaus_r1qm2(jlat) = gaus_r1qm2(2*njlath +1 - jlat)
gaus_r1mui(jlat) = gaus_r1mui(2*njlath +1 - jlat)
gaus_r1mua(jlat) = gaus_r1mua(2*njlath +1 - jlat)
gaus_rwt(jlat) = gaus_rwt(2*njlath +1 - jlat)
gaus_rlati(jlat) = - gaus_rlati (2*njlath +1 - jlat)
enddo
zpisu2 = MPC_PI_R8/2.d0
do jlat = 1, nj
gaus_rcolat(jlat) = zpisu2 - gaus_rlati(jlat)
enddo
!* 3. Overdimensioning for interpolation
gaus_rlati(-1) = MPC_PI_R8-gaus_rlati(1)
gaus_rlati(0) = MPC_PI_R8*.5d0
gaus_rlati(nj+1) = -MPC_PI_R8*.5d0
gaus_rlati(nj+2) = -MPC_PI_R8-gaus_rlati(nj)
do jlat = 1, nj
gaus_conphy(jlat) = ra*gaus_r1qm2(jlat)
gaus_conima(jlat) = r1sa*gaus_rsqm2(jlat)
enddo
!* 4. Print the content of GAUS
if(lverbose.and.my_mpi_id.eq.0) write(*,fmt='(" JLAT:",4X," RLATI",8X,"RCOLAT",8X,"RMU",10X ,"RWT",12X,"RW0CS")')
do jlat = 1, nj
if(lverbose.and.my_mpi_id.eq.0) write(*,fmt='(2X,I4,5(2X,G23.16))') &
jlat,gaus_rlati(jlat),gaus_rcolat(jlat), gaus_rmu(jlat) &
,gaus_rwt(jlat),gaus_rwocs(jlat)
enddo
if(lverbose.and.my_mpi_id.eq.0) write(*,fmt='(//," JLAT:",4X,"R1MU2",8X,"RSQM2",9X,"R1QM2",10X,"R1MUI",10X,"R1MUA")')
do jlat = 1, nj
if(lverbose.and.my_mpi_id.eq.0) write(*,fmt='(2X,I4,5(2X,G23.16))') jlat,gaus_r1mu2(jlat),gaus_rsqm2(jlat),gaus_r1qm2(jlat) &
,gaus_r1mui(jlat),gaus_r1mua(jlat)
enddo
END SUBROUTINE GAUS_SETUP
SUBROUTINE GAUSS8(NRACP,RACP,PG,SIA,RAD,PGSSIN2,SINM1,SINM2,SIN2) 3,8
!C *****************************************************************
!C CALCULE LES NRACP RACINES POSITIVES DU POLYNOME DE LEGENDRE DE
!C DEGRE 2*NRACP (ICI-APRES NOTE PN) DEFINI SUR L INTERVALLE DES
!C COLATITUDES ALLANT DE 0 (POLE NORD) A PI (POLE SUD). ON SAIT QUE
!C LES 2*NRACP RACINES SONT ANTI-SYMETRIQUES P/R A L EQUATEUR PI/2,
!C ETANT POSITIVES ENTRE COLAT=0 ET COLAT =PI/2.
!C ON CALCULE ENSUITE LES POIDS DE GAUSS ASSOCIES AUX COLATITUDES
!C GAUSSIENNES (ICI APRES NOTEES CG), AINSI QU UN CERTAIN NOMBRE DE
!C FONCTIONS DE CG DEFINIES PLUS LOIN. ON RAPPELLE ENFIN QUE LA LATI-
!C TUDE LAT=COLAT-PI/2, ET DONC QUE SIN(LAT)=COS(COLAT).
!C NRACP : NOMBRE DE RACINES POSITIVES DU POLYNOME DE LEGENDRE
!C : DE DEGRE 2*NRACP.
!C RACP(I) : RACINES DE PN, =SIN(LG)=COS(CG).
!C PG(I) : POIDS DE GAUSS CORRESPONDANTS.
!C SIA(I) : SIN(CG)=COS(LG).
!C RAD(I) : COLATITUDE CG EN RADIANS.
!C PGSSIN2(I) : POIDS DE GAUSS / (SIN(CG))**2.
!C SINM1(I) : (SIN(CG))**-1.
!C SINM2(I) : (SIN(CG))**-2.
!C VOIR NST 8, CHAP. A, PP.1-7, ET APPENDICE D12, PP. 26-27.
!C VERSION REVISEE PAR MICHEL BELAND, 9 DECEMBRE 1980.
!C VERSION "REAL*8" ... P. KOCLAS AVRIL 1993...
!C *****************************************************************
IMPLICIT NONE
INTEGER NRACP
REAL*8 RACP(*),PG(*),SIA(*),RAD(*),PGSSIN2(*),SINM1(*),SINM2(*),SIN2(*)
REAL*8 XLIM,PI,FI,FI1,FN,DOT,DN,DN1,A,B,C,G,GM,GP,GT,RACTEMP,GTEMP
INTEGER I,IR,IRM,IRP
!C
!C ON DEMANDE UNE PRECISION DE 1.E-13 POUR LES RACINES DE PN.
!C
XLIM=1.D-13
PI = 4.D0*ATAN(1.D0)
IR = 2*NRACP
FI=DBLE(IR)
FI1=FI+1.D0
FN=DBLE(NRACP)
!C
!C ON UTILISE UNE FORMULE ASYMPTOTIQUE POUR OBTENIR LES VALEURS
!C APPROXIMATIVES DES COLATITUDES GAUSSIENNES
!C CG(I) = (PI/2) * (2*I-1)/(2*NRACP).
!C VOIR ABRAMOWITZ AND STEGUN, P. 787, EQU. 22.16.6 .
!C
DO 20 I=1,NRACP
DOT=DBLE(I-1)
RACP(I)=-PI*.5D0*(DOT+.5D0)/FN + PI*.5D0
RACP(I) = SIN(RACP(I))
20 CONTINUE
!C
!C ON CALCULE ENSUITE LES CONSTANTES FACTEURS DE P(N+1) ET P(N-1)
!C DANS L EXPRESSION DE LA PSEUDO-DERIVEE DE PN.
!C
DN = FI/SQRT(4.D0*FI*FI-1.D0)
DN1=FI1/SQRT(4.D0*FI1*FI1-1.D0)
A = DN1*FI
B = DN*FI1
IRP = IR + 1
IRM = IR -1
!C
!C ON EMPLOIE ENSUITE UNE METHODE DE NEWTON POUR AUGMENTER LA PREC.
!C SI RACTEMP EST UNE SOL. APPROXIMATIVE DE PN(RACP)=0., ALORS LA
!C SEQUENCE RACTEMP(I+1)=RACTEMP(I)-PN(RACTEMP(I))/DER.PN(RACTEMP(I))
!C CONVERGE VERS RACP DE FACON QUADRATIQUE.
!C VOIR ABRAMOWITZ AND STEGUN, P.18, EQU. 3.9.5.
!C ORDLEG CALCULE LA VALEUR DE PN (RACP) , NORMALISE.
!C
DO 50 I=1,NRACP
42 CALL ORDLEG8(G,RACP(I),IR)
CALL ORDLEG8(GM,RACP(I),IRM)
CALL ORDLEG8(GP,RACP(I),IRP)
GT = (A*GP-B*GM)/(RACP(I)*RACP(I)-1.D0)
RACTEMP = RACP(I) - G/GT
GTEMP = RACP(I) - RACTEMP
RACP(I) = RACTEMP
IF( ABS(GTEMP).GT.XLIM) GO TO 42
50 CONTINUE
!C
!C ON CALCULE ENSUITE LES POIDS DE GAUSS SELON L ALGORITHME
!C PG(I) = 2./[(1.-RACP(I)**2)*(DER.PN(RACP(I)))**2].
!C VOIR ABRAMOWITZ AND STEGUN, P.887, EQU. 25.4.29.
!C NOTE: ON DOIT MULTIPLIER LA PRECEDENTE FORMULE PAR UN FACTEUR
!C DE DENORMALISATION, LES PN DONNES PAR ORDLEG ETANT NORMALISES.
!C ON SE SERT D UNE FORMULE DE RECURRENCE POUR LA DERIVEE DE PN.
!C
DO 60 I=1,NRACP
A=2.D0*(1.-RACP(I)**2)
CALL ORDLEG8(B,RACP(I),IRM)
B = B*B*FI*FI
PG(I)=A*(FI-.5D0)/B
RAD(I) = ACOS(RACP(I))
SIA(I) = SIN(RAD(I))
C=(SIA(I))**2
SINM1(I) = 1.D0/SIA(I)
SINM2(I) = 1.D0/C
PGSSIN2(I) =PG(I)/C
SIN2(I)=C
60 CONTINUE
RETURN
END SUBROUTINE GAUSS8
function gaus_find_lat_index(zlao)
!
!
! gaus_find_lat_index (previously ISRCHILA)
! - Locate index of first latitude to the north of ZLAO
!
! Author: Luc Fillion RPN/AES Jan 1993
!
implicit none
real*8 :: zlao
integer :: ifound, j, gaus_find_lat_index
100 continue
gaus_find_lat_index = 0
ifound = 0
j = -1
101 j = j + 1
if(zlao.ge.gaus_rlati(j)) then
gaus_find_lat_index = j - 1
ifound = 1
endif
if(ifound.eq.0.and.(j.lt.(gaus_nj+2))) go to 101
end function gaus_find_lat_index
END MODULE GAUSSGRID_MOD