!--------------------------------------- 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 CalcBMatrix_lam_mod (prefix="calcb_lam")
!
! Purpose: Compute homogeneous and isotropic background error covariances
! from forecast error estimate in model variable space
!
! - Subroutines
! calcb_lam_Setup (public)
! calcb_lam_computeStats (public)
!
! - Public variables
! NONE
!
! - Dependencies
! lamspectraltransform
!--------------------------------------------------------------------------
module calcbmatrix_lam_mod 1,4
use gridStateVector_mod
use LamSpectralTransform_mod
use LamAnalysisGrid_mod
use HorizontalCoord_mod
implicit none
save
private
! Public Subroutines
public :: calcb_lam_setup, calcb_lam_computeStats
type(struct_hco), pointer :: hco_ens ! Ensemble horizontal grid parameters
type(struct_hco), pointer :: hco_bhi ! B matrix horizontal grid parameters
type(struct_vco), pointer :: vco_bhi ! B matrix vertical grid parameters
type(struct_lst) :: lst_bhi ! Spectral transform Parameters
character(len=256), allocatable :: cflensin(:)
integer, parameter :: cv_model = 1
integer, parameter :: cv_bhi = 2
type :: calcb_cv
character(len=4) :: NomVar(2)
character(len=2) :: GridType ! TH=Thermo, MM=Momentum, NS=Non-staggered
integer :: nlev
integer :: kDimStart
integer :: kDimEnd
integer, allocatable :: ip1(:)
end type calcb_cv
integer,parameter :: nMaxControlVar = 10
type(calcb_cv) :: ControlVariable(nMaxControlVar)
integer :: nControlVariable
integer :: nens
integer :: ntrunc
integer :: nkgdim
logical :: initialized = .false.
logical :: NormByStdDev
character(len=12) :: WindTransform
real(8), pointer :: pressureProfile(:)
contains
!--------------------------------------------------------------------------
! CALCB_LAM_SETUP
!--------------------------------------------------------------------------
subroutine calcb_lam_setup( nens_in, cflens_in, hco_ens_in, vco_ens_in) 1,6
use vGrid_Descriptors , only: vgrid_descriptor, vgd_levels, VGD_OK
implicit none
integer, intent(in) :: nens_in
character(len=*), intent(in) :: cflens_in(nens_in)
type(struct_vco), pointer, intent(in) :: vco_ens_in
type(struct_hco), pointer, intent(in) :: hco_ens_in
integer :: nulnam, ier, mpiMode, status
integer :: fclos, fnom, fstouv, fstfrm
integer :: grd_ext_x, grd_ext_y
integer :: var, k
real(8) :: SurfacePressure
character(len=4) :: cgneed(nMaxControlVar)
logical :: mask(nMaxControlVar)
NAMELIST /NAMCALCB_LAM/ntrunc,grd_ext_x,grd_ext_y,NormByStdDev
NAMELIST /NAMSTATE/CGNEED
write(*,*)
write(*,*) 'calcb_lam_setup: Starting...'
!
!- 1. Initialized the info on the ensemble
!
nens=nens_in
allocate(cflensin(nens))
cflensin(:)=cflens_in(:)
hco_ens => hco_ens_in
vco_bhi => vco_ens_in
!
!- 2. Read namelist NAMCALCB_LAM
!
ntrunc = 75 ! Default value
grd_ext_x = 10 ! Default value
grd_ext_y = 10 ! Default value
NormByStdDev = .true. ! Default value
WindTransform = 'PsiChi' ! Hardwired
nulnam = 0
ier=fnom(nulnam,'./flnml','FTN+SEQ+R/O',0)
read (nulnam,nml=namcalcb_lam)
write(* ,nml=namcalcb_lam)
ier=fclos(nulnam)
write(*,*)
write(*,*) 'Truncation = ', ntrunc
!
!- 3. Initialized the extended (bi-periodic) grid
!
!- 3.1 Create the extended and non-extended grid prototype file
call CreateLamTemplateGrids('./analysisgrid',grd_ext_x,grd_ext_y) ! IN
!- 3.2 Setup the Extended B_HI grid
call hco_SetupFromFile( './analysisgrid', 'ANALYSIS', 'BHI' ) ! IN
hco_bhi => hco_Get('BHI')
!- 3.3 Setup the LAM analysis grid metrics
call lag_SetupFromHCO( 'BHI', 'Ensemble' ) ! IN
!- 3.4 Setup the LAM spectral transform
call lst_Setup( lst_bhi, & ! OUT
hco_bhi%ni, hco_bhi%nj, & ! IN
hco_bhi%dlon, ntrunc, & ! IN
'NoMpi' ) ! IN
!
!- 4. Setup the control variables (model space and B_hi space)
!
!- 4.1 Read NAMELIST NAMSTATE to find which fields are needed
cgneed(:) = 'NONE'
ier=fnom(nulnam,'./flnml','FTN+SEQ+R/O',0)
read (nulnam,nml=namstate)
write(* ,nml=namstate)
ier=fclos(nulnam)
mask = cgneed .ne. 'NONE'
nControlVariable = count(mask)
write(*,*)
write(*,*) 'Number of Control Variables = ', nControlVariable
!- 4.2 Set ControlVariable structure
nkgdim = 0
do var = 1, nControlVariable
!- Set variable name
ControlVariable(var)%nomvar(cv_model) = trim(cgneed(var))
if ( ControlVariable(var)%nomvar(cv_model) == 'UU' ) then
if ( trim(WindTransform) == 'PsiChi') then
ControlVariable(var)%nomvar(cv_bhi) = 'PP'
else
print*,'Only PsiChi Wind Trasnform is available'
stop
end if
else if ( ControlVariable(var)%nomvar(cv_model) == 'VV' ) then
if ( trim(WindTransform) == 'PsiChi') then
ControlVariable(var)%nomvar(cv_bhi) = 'CC'
else
print*,'Only PsiChi Wind Trasnform is available'
stop
end if
else
ControlVariable(var)%nomvar(cv_bhi) = ControlVariable(var)%nomvar(cv_model)
end if
!- Set Level info
if ( ControlVariable(var)%nomvar(cv_model) /= 'TG' ) then
call VarLevInfo(ControlVariable(var)%nlev, & ! OUT
ControlVariable(var)%GridType, & ! OUT
ControlVariable(var)%nomvar(cv_model), & ! IN
cflensin(1) ) ! IN
else
ControlVariable(var)%nlev = 1
ControlVariable(var)%GridType = 'NS'
end if
write(*,*)
write(*,*) 'Control Variable Name ', ControlVariable(var)%nomvar(cv_model)
write(*,*) ' Number of Levels = ', ControlVariable(var)%nlev
write(*,*) ' Type of Levels = ', ControlVariable(var)%GridType
allocate( ControlVariable(var)%ip1 (ControlVariable(var)%nlev) )
if (ControlVariable(var)%nlev /= 1) then
if (ControlVariable(var)%GridType == 'TH') then
ControlVariable(var)%ip1(:) = vco_bhi%ip1_T(:)
else
ControlVariable(var)%ip1(:) = vco_bhi%ip1_M(:)
end if
else
ControlVariable(var)%ip1(:) = 0
end if
ControlVariable(var)%kDimStart = nkgdim + 1
nkgdim = nkgdim + ControlVariable(var)%nlev
ControlVariable(var)%kDimEnd = nkgdim
end do
!
!- 5. Setup a pressure profile for vertical localization
!
!SurfacePressure = 101000.D0
!status = vgd_levels( vco_bhi%vgrid, ip1_list=vco_bhi%ip1_M, & ! IN
! levels=pressureProfile, & ! OUT
! sfc_field=SurfacePressure, in_log=.false.) ! IN
!if ( status /= VGD_OK ) then
! write(*,*)
! write(*,*) 'calcb_lam_setup: ERROR with vgd_levels for desired levels '
! stop
!else
! write(*,*)
! write(*,*) 'Pressure profile...'
! do k = 1, vco_bhi%nlev_M
! write(*,*) k, PressureProfile(k) / 100.d0, ' hPa'
! end do
!endif
!
!- 6. Ending
!
initialized = .true.
write(*,*)
write(*,*) 'calcb_lam_setup: Done!'
end subroutine calcb_lam_setup
!--------------------------------------------------------------------------
! CALCB_LAM_ComputeStats
!--------------------------------------------------------------------------
subroutine calcb_lam_computeStats 1,16
implicit none
integer :: ier
integer :: NumBins2d, NumBins2dGridPoint
real(4),pointer :: ensPerturbations(:,:,:,:)
real(8),allocatable :: ensMean3d(:,:,:)
real(8),allocatable :: StdDev3d(:,:,:)
real(8),allocatable :: StdDev3dGridPoint(:,:,:)
real(8),allocatable :: SpVertCorrel(:,:,:)
real(8),allocatable :: TotVertCorrel(:,:)
real(8),allocatable :: NormB(:,:,:)
real(8),allocatable :: NormBsqrt(:,:,:)
real(8),allocatable :: PowerSpectrum(:,:)
real(8),allocatable :: HorizScale(:)
integer,allocatable :: Bin2d(:,:)
integer,allocatable :: Bin2dGridPoint(:,:)
allocate(ensPerturbations(hco_bhi%ni,hco_bhi%nj,nkgdim,nens),stat=ier)
if(ier /= 0) then
write(*,*) 'Problem allocating ensPerturbations memory!',ier
call flush(6)
endif
allocate(ensMean3d(hco_bhi%ni,hco_bhi%nj,nkgdim),stat=ier)
if (ier /= 0) then
write(*,*) 'Problem allocating ensMean3d memory!',ier
call flush(6)
end if
allocate(Bin2d(hco_bhi%ni,hco_bhi%nj),stat=ier)
if (ier /= 0) then
write(*,*) 'Problem allocating Bin2d memory!',ier
call flush(6)
end if
allocate(Bin2dGridPoint(hco_bhi%ni,hco_bhi%nj),stat=ier)
if (ier /= 0) then
write(*,*) 'Problem allocating Bin2d memory!',ier
call flush(6)
end if
allocate(StdDev3d(hco_bhi%ni,hco_bhi%nj,nkgdim),stat=ier)
if (ier /= 0) then
write(*,*) 'Problem allocating StdDev3d memory!',ier
call flush(6)
end if
allocate(StdDev3dGridPoint(hco_bhi%ni,hco_bhi%nj,nkgdim),stat=ier)
if (ier /= 0) then
write(*,*) 'Problem allocating StdDev3dGridPoint memory!',ier
call flush(6)
end if
allocate(SpVertCorrel(nkgdim,nkgdim,0:ntrunc),stat=ier)
if(ier.ne.0) then
write(*,*) 'Problem allocating SpVertCorrel memory!',ier
call flush(6)
endif
allocate(TotVertCorrel(nkgdim,nkgdim),stat=ier)
if(ier.ne.0) then
write(*,*) 'Problem allocating TotVertCorrel memory!',ier
call flush(6)
endif
allocate(PowerSpectrum(nkgdim,0:ntrunc),stat=ier)
if(ier.ne.0) then
write(*,*) 'Problem allocating PowerSpectrum memory!',ier
call flush(6)
endif
allocate(NormB(nkgdim,nkgdim,0:ntrunc),stat=ier)
if(ier.ne.0) then
write(*,*) 'Problem allocating Bsqrt memory!',ier
call flush(6)
endif
allocate(NormBsqrt(nkgdim,nkgdim,0:ntrunc),stat=ier)
if(ier.ne.0) then
write(*,*) 'Problem allocating Bsqrt memory!',ier
call flush(6)
endif
allocate(HorizScale(nkgdim),stat=ier)
if(ier.ne.0) then
write(*,*) 'Problem allocating HorizScale memory!',ier
call flush(6)
endif
ensPerturbations(:,:,:,:) = 0.d0
!
!- 1. Read forecast error estimates (all variables, levels, ens. members)
!
call ReadEnsemble(ensPerturbations) ! INOUT
!
!- 2. Create periodic fields in X and Y directions
!
call BiPeriodization(ensPerturbations) ! INOUT
! call WriteEnsemble (ensPerturbations, './EnsWrite_A', cv_model ) ! IN
!
!- 3. Transform u-wind and v-wind to control variables
!
call UVToCtrlVar(ensPerturbations) ! INOUT
! call WriteEnsemble (ensPerturbations, './EnsWrite_B', cv_bhi ) ! IN
!
!- 4. Remove the ensemble mean
!
call RemoveMean(ensPerturbations, & ! INOUT
ensMean3d) ! OUT
!
!- 5. Calculate the Standard Deviations in grid point space
!
!- 5.1 Binned Std. Dev. to be used in the analysis step
call CreateBins(Bin2d, NumBins2d, & ! OUT
'HorizontalMean') ! IN
call CalcStdDev3d(ensPerturbations, & ! INOUT
StdDev3d, & ! OUT
Bin2d, NumBins2d) ! IN
!- 5.2 Non-binned Std. Dev. to be used for normalization and/or
! diagnostics
call CreateBins(Bin2dGridPoint, NumBins2dGridPoint, & ! OUT
'GridPoint') ! IN
call CalcStdDev3d(ensPerturbations, & ! INOUT
StdDev3dGridPoint, & ! OUT
Bin2dGridPoint, NumBins2dGridPoint) ! IN
!- 5.3 Normalization
if ( NormByStdDev ) then
call Normalize3d(ensPerturbations, & ! INOUT
StdDev3dGridPoint) ! IN
end if
!
!- 6. Covariance statistics in Spectral Space
!
!- 6.1 Vertical correlations and Power Spectra
call CalcSpectralStats(ensPerturbations, & ! IN
SpVertCorrel, PowerSpectrum, & ! OUT
NormB) ! OUT
!- 6.2 Calculate the horiontal correlation lenght scales
call CalcHorizScale(HorizScale, & ! OUT
NormB) ! IN
!- 6.3 Calculate the total vertical correlation matrix
call CalcTotVertCorrel(TotVertCorrel, & ! OUT
NormB) ! IN
!- 6.4 Set cross-correlations
call SetSpVertCorrel(NormB) ! INOUT
!- 6.5 Calculate the square-root of the correlation-based B matrix
call CalcBsqrt(NormBsqrt, & ! OUT
NormB ) ! IN
!
!- 7. Writing statistics to files
!
!- 7.1 Statistics needed by VAR in analysis mode
call WriteVarStats(NormBsqrt, StdDev3d) ! IN
!- 7.2 Diagnostics fields
call WriteDiagStats(NormB, SpVertCorrel, TotVertCorrel, EnsMean3d, & !
StdDev3dGridPoint, PowerSpectrum, HorizScale) ! IN
!- 7.3. Statistics for Background Check
! Not coded yet
deallocate(Bin2d)
deallocate(Bin2dGridPoint)
deallocate(ensPerturbations)
deallocate(StdDev3d)
deallocate(StdDev3dGridPoint)
deallocate(ensMean3d)
deallocate(SpVertCorrel)
deallocate(TotVertCorrel)
deallocate(PowerSpectrum)
deallocate(NormB)
deallocate(NormBsqrt)
deallocate(HorizScale)
end subroutine calcb_lam_computeStats
!--------------------------------------------------------------------------
! CreateLamTemplateGrids
!--------------------------------------------------------------------------
subroutine CreateLamTemplateGrids(TemplateFileName,grd_ext_x,grd_ext_y) 1,7
use MathPhysConstants_mod, only : MPC_DEGREES_PER_RADIAN_R8
implicit none
character(len=*), intent(in) :: TemplateFileName
integer , intent(in) :: grd_ext_x
integer , intent(in) :: grd_ext_y
integer :: ni_ext, nj_ext, i, j
integer :: iun = 0
integer :: ier, fnom, fstouv, fstfrm, fclos, vfstecr
real(8), allocatable :: Field2d(:,:)
real(8), allocatable :: lat_ext(:)
real(8), allocatable :: lon_ext(:)
real(8) :: work, dlat, dlon
integer :: dateo,npak
integer :: ip1,ip2,ip3,deet,npas,datyp,ig1,ig2,ig3,ig4
integer :: ig1_tictac,ig2_tictac,ig3_tictac,ig4_tictac
character(len=1) :: grtyp
character(len=2) :: typvar
character(len=12) :: etiket
!
!- 1. Opening the output template file
!
ier = fnom(iun, trim(TemplateFileName), 'RND', 0)
ier = fstouv(iun, 'RND')
npak = -32
!
!- 2. Writing the core grid (Ensemble) template
!
!- 2.1 Tic-Tac
deet = 0
ip1 = hco_ens%ig1
ip2 = hco_ens%ig2
ip3 = 0
npas = 0
datyp = 1
grtyp = 'E'
typvar = 'X'
etiket = 'COREGRID'
dateo = 0
call cxgaig ( grtyp, & ! IN
ig1_tictac, ig2_tictac, ig3_tictac, ig4_tictac, & ! OUT
real(hco_ens%xlat1), real(hco_ens%xlon1), & ! IN
real(hco_ens%xlat2), real(hco_ens%xlon2) ) ! IN
ig1 = ig1_tictac
ig2 = ig2_tictac
ig3 = ig3_tictac
ig4 = ig4_tictac
ier = vfstecr(hco_ens%lon*MPC_DEGREES_PER_RADIAN_R8, work, npak, &
iun, dateo, deet, npas, hco_ens%ni, 1, 1, ip1, &
ip2, ip3, typvar, '>>', etiket, grtyp, ig1, &
ig2, ig3, ig4, datyp, .true.)
ier = vfstecr(hco_ens%lat*MPC_DEGREES_PER_RADIAN_R8, work, npak, &
iun, dateo, deet, npas, 1, hco_ens%nj, 1, ip1, &
ip2, ip3, typvar, '^^', etiket, grtyp, ig1, &
ig2, ig3, ig4, datyp, .true.)
!- 2.2 2D Field
allocate(Field2d(hco_ens%ni,hco_ens%nj))
Field2d(:,:) = 10.d0
deet = 0
ip1 = 0
ip2 = 0
ip3 = 0
npas = 0
datyp = 1
grtyp = hco_ens%grtyp
typvar = 'A'
etiket = 'COREGRID'
dateo = 0
ig1 = hco_ens%ig1
ig2 = hco_ens%ig2
ig3 = hco_ens%ig3
ig4 = hco_ens%ig4
ier = vfstecr(Field2d, work, npak, &
iun, dateo, deet, npas, hco_ens%ni, hco_ens%nj, 1, ip1, &
ip2, ip3, typvar, 'P0', etiket, grtyp, ig1, &
ig2, ig3, ig4, datyp, .true.)
deallocate(Field2d)
!
!- 3. Create and Write the extended grid (Analysis) template
!
ni_ext = hco_ens%ni + grd_ext_x
nj_ext = hco_ens%nj + grd_ext_y
!- 3.1 Tic-Tac
allocate(lon_ext(ni_ext))
allocate(lat_ext(nj_ext))
!- Copy core grid info
lon_ext(1:hco_ens%ni) = hco_ens%lon(:)
lat_ext(1:hco_ens%nj) = hco_ens%lat(:)
!- Extend the lat lon
dlon = hco_ens%lon(2) - hco_ens%lon(1)
do i = hco_ens%ni + 1, ni_ext
lon_ext(i) = lon_ext(hco_ens%ni) + (i - hco_ens%ni) * dlon
end do
dlat = hco_ens%lat(2) - hco_ens%lat(1)
do j = hco_ens%nj + 1, nj_ext
lat_ext(j) = lat_ext(hco_ens%nj) + (j - hco_ens%nj) * dlat
end do
!- Write
deet = 0
ip1 = hco_ens%ig1 + 100 ! Must be different from the core grid
ip2 = hco_ens%ig2 + 100 ! Must be different from the core grid
ip3 = 0
npas = 0
datyp = 1
grtyp = 'E'
typvar = 'X'
etiket = 'ANALYSIS'
dateo = 0
ig1 = ig1_tictac
ig2 = ig2_tictac
ig3 = ig3_tictac
ig4 = ig4_tictac
ier = vfstecr(lon_ext*MPC_DEGREES_PER_RADIAN_R8, work, npak, &
iun, dateo, deet, npas, ni_ext, 1, 1, ip1, &
ip2, ip3, typvar, '>>', etiket, grtyp, ig1, &
ig2, ig3, ig4, datyp, .true.)
ier = vfstecr(lat_ext*MPC_DEGREES_PER_RADIAN_R8, work, npak, &
iun, dateo, deet, npas, 1, nj_ext, 1, ip1, &
ip2, ip3, typvar, '^^', etiket, grtyp, ig1, &
ig2, ig3, ig4, datyp, .true.)
deallocate(lon_ext)
deallocate(lat_ext)
!- 3.2 2D Field
allocate(Field2d(ni_ext,nj_ext))
Field2d(:,:) = 10.d0
deet = 0
ip1 = 0
ip2 = 0
ip3 = 0
npas = 0
datyp = 1
grtyp = hco_ens%grtyp
typvar = 'A'
etiket = 'ANALYSIS'
dateo = 0
ig1 = hco_ens%ig1 + 100 ! Must be different from the core grid
ig2 = hco_ens%ig2 + 100 ! Must be different from the core grid
ig3 = 0
ig4 = 0
ier = vfstecr(Field2d, work, npak, &
iun, dateo, deet, npas, ni_ext, nj_ext, 1, ip1, &
ip2, ip3, typvar, 'P0', etiket, grtyp, ig1, &
ig2, ig3, ig4, datyp, .true.)
deallocate(Field2d)
!
!- 4. Closing the output template file
!
ier = fstfrm(iun)
ier = fclos (iun)
end subroutine CreateLamTemplateGrids
!--------------------------------------------------------------------------
! VarLevInfo
!--------------------------------------------------------------------------
subroutine VarLevInfo( nlev, GridType, VarName, infile ) 1,3
implicit none
character(len=4), intent(in) :: VarName
character(len=*), intent(in) :: infile
integer , intent(out) :: nlev
character(len=2), intent(out) :: GridType
integer :: fstouv, fnom, fstfrm, fclos, iunens
integer :: key, fstinf, fstinl, fstprm, infon
integer, parameter :: nmax=2000
integer :: liste(nmax)
integer :: ip1, ip2, ip3, ier
integer :: ni_t, nj_t, nlev_t, dateo, deet, npas, nbits, datyp
integer :: ig1, ig2, ig3, ig4, extra1, extra2, extra3, swa, lng, dltf, ubc
character(len=4 ) :: nomvar
character(len=2 ) :: typvar
character(len=1 ) :: grtyp
character(len=12) :: etiket
!
!- 1. Open the input file
!
iunens = 0
ier = fnom(iunens,infile,'RND+OLD+R/O',0)
ier = fstouv(iunens,'RND+OLD')
!
!- 2. Find the number of records
!
dateo = -1
etiket = ' '
ip1 = -1
ip2 = -1
ip3 = -1
typvar = ' '
key = fstinl(iunens, & ! IN
ni_t, nj_t, nlev_t, & ! OUT
dateo, etiket, ip1, ip2, ip3, typvar, VarName, & ! IN
liste, infon, & ! OUT
nmax ) ! IN
if (key < 0) then
write(*,*)
write(*,*) 'VarLevInfo: Cannot find variable ', VarName
call abort3d('VarLevInfo')
end if
!
!- 3. Find de the Number of verical levels (ip1)
!
! We assume that the number of levels = number of records (this could be improve...)
nlev = infon
if ( nlev /= 1 .and. nlev /= vco_bhi%nlev_T .and. nlev /= vco_bhi%nlev_M ) then
write(*,*)
write(*,*) 'The number of levels found does not match with the vco structure !!!'
write(*,*) 'nlev found = ', nlev
write(*,*) 'vco nlevs = ', vco_bhi%nlev_T, vco_bhi%nlev_M
call abort3d('VarLevInfo')
end if
!
!- 4. Find the type of vertical grid
!
if ( nlev /=1 ) then
ier = fstprm( liste(1), & ! IN
dateo, deet, npas, ni_t, nj_t, nlev_t, & ! OUT
nbits, datyp, ip1, ip2, ip3, typvar, nomvar, etiket, & ! OUT
grtyp, ig1, ig2, ig3, ig4, swa, lng, dltf, ubc, & ! OUT
extra1, extra2, extra3 ) ! OUT
if ( ANY(vco_bhi%ip1_M == ip1) ) then
GridType = 'MM'
else if ( ANY(vco_bhi%ip1_T == ip1) ) then
GridType = 'TH'
else
write(*,*)
write(*,*) 'The ip1 found does not match with the vco structure !!!', ip1
call abort3d('VarLevInfo')
end if
else
GridType = 'NS'
end if
!
!- 5. Close the input file
!
ier = fstfrm(iunens)
ier = fclos (iunens)
end subroutine VarLevInfo
!--------------------------------------------------------------------------
! ReadEnsemble
!--------------------------------------------------------------------------
subroutine ReadEnsemble(ensPerturbations) 3,8
implicit none
real(4), intent(inout) :: ensPerturbations(hco_bhi%ni,hco_bhi%nj,nkgdim,nens)
real(4), allocatable :: work2d(:,:)
real(4) :: factor
integer :: ier, fstouv, fnom, fstfrm, fclos, fstecr, fstlir
integer :: iunens, ens, var, k, kgdim
integer :: ip1, ip2, ip3
integer :: ni_t, nj_t, nlev_t, dateo
character(len=4 ) :: nomvar
character(len=1 ) :: typvar
character(len=12) :: etiket
allocate(work2d(hco_ens%ni, hco_ens%nj))
!- Loop over the Ensemble members
do ens = 1, nens
write(*,*)
write(*,*) 'Reading ensemble member: ', ens, trim(cflensin(ens))
iunens = 0
ier = fnom(iunens,cflensin(ens),'RND+OLD+R/O',0)
ier = fstouv(iunens,'RND+OLD')
!- Loop over Control Variables
do var = 1, nControlVariable
!- Loop over vertical Levels
do k = 1, ControlVariable(var)%nlev
dateo = -1
ip1 = ControlVariable(var)%ip1(k)
ip2 = -1
ip3 = -1
typvar = ' '
nomvar = trim(ControlVariable(var)%nomvar(cv_model))
etiket = ' '
if ( trim(nomvar) == 'UU' .or. trim(nomvar) == 'VV') then
factor = 1.0/1.94246 ! knots -> m/s
else if ( trim(nomvar) == 'P0' ) then
factor = 100.0 ! hPa -> Pa
else if ( trim(nomvar) == 'TG' ) then
nomvar = 'TT'
ip1 = 93423264
factor = 0.0 ! On Force a ZERO !!!!!!!! JFC
else
factor = 1.0
end if
!- Reading
ier = fstlir( work2d, & ! OUT
iunens, & ! IN
ni_t, nj_t, nlev_t, & ! OUT
dateo, etiket, ip1, ip2, ip3, typvar, nomvar) ! IN
if (ier < 0) then
write(*,*)
write(*,*) 'Read Ensemble: Cannot find field ...'
write(*,*) 'nomvar =', trim(ControlVariable(var)%nomvar(cv_model))
write(*,*) 'etiket =', trim(etiket)
write(*,*) 'ip1 =', ControlVariable(var)%ip1(k)
stop
end if
if (ni_t /= hco_ens%ni .or. nj_t /= hco_ens%nj) then
write(*,*)
write(*,*) 'ReadEnsemble: Invalid dimensions for ...'
write(*,*) 'nomvar =', trim(ControlVariable(var)%nomvar(cv_model))
write(*,*) 'etiket =', trim(etiket)
write(*,*) 'ip1 =', ControlVariable(var)%ip1(k)
write(*,*) 'Found ni,nj =', ni_t, nj_t
write(*,*) 'Should be =', hco_ens%ni, hco_ens%nj
stop
end if
!- Insert in EnsPerturbations
kgdim = ControlVariable(var)%kDimStart + k - 1
EnsPerturbations(1:hco_ens%ni, 1:hco_ens%nj,kgdim,ens) = factor * work2d(:,:)
end do ! Vertical Levels
end do ! Variables
ier = fstfrm(iunens)
ier = fclos (iunens)
end do ! Ensemble members
deallocate(work2d)
end subroutine ReadEnsemble
!--------------------------------------------------------------------------
! UVToCtrlVar
!--------------------------------------------------------------------------
subroutine UVToCtrlVar(ensPerturbations) 1,2
implicit none
real(4), intent(inout) :: ensPerturbations(hco_bhi%ni,hco_bhi%nj,nkgdim,nens)
real(8), allocatable :: uwind_3d(:,:,:)
real(8), allocatable :: vwind_3d(:,:,:)
real(8), allocatable :: CtrlVar1_3d(:,:,:)
real(8), allocatable :: CtrlVar2_3d(:,:,:)
integer :: nlev, ens, kStart_u, kStart_v, kEnd_u, kEnd_v
!- Error traps
if ( ControlVariable(1)%nlev /= ControlVariable(2)%nlev ) then
write(*,*)
write(*,*) 'UVToCtrlVar: Error in Wind Field vertical grid !!!'
stop
end if
if ( ControlVariable(1)%nomvar(cv_model) /= 'UU' .or. &
ControlVariable(2)%nomvar(cv_model) /= 'VV' ) then
write(*,*)
write(*,*) 'UVToCtrlVar: Wind field(s) missing on input !!!'
write(*,*) 'nomvar(1) = ', ControlVariable(1)%nomvar(cv_model)
write(*,*) 'nomvar(2) = ', ControlVariable(2)%nomvar(cv_model)
stop
end if
!- Allocation
nlev = ControlVariable(1)%nlev
allocate(uwind_3d (hco_bhi%ni, hco_bhi%nj, nlev))
allocate(vwind_3d (hco_bhi%ni, hco_bhi%nj, nlev))
allocate(CtrlVar1_3d(hco_bhi%ni, hco_bhi%nj, nlev))
allocate(CtrlVar2_3d(hco_bhi%ni, hco_bhi%nj, nlev))
!- Loop over all ensemble members
do ens = 1, nens
!- Wind position in EnsPerturbations
kStart_u = ControlVariable(1)%kDimStart
kStart_v = ControlVariable(2)%kDimStart
kEnd_u = ControlVariable(1)%kDimEnd
kEnd_v = ControlVariable(2)%kDimEnd
!- Extract from EnsPerturbations
uwind_3d = real(ensPerturbations(:,:,kStart_u:kEnd_u,ens),8)
vwind_3d = real(ensPerturbations(:,:,kStart_v:kEnd_v,ens),8)
!- U-wind,V-wind -> Vorticity,Divergence
call lag_UVToVortDiv(CtrlVar1_3d, CtrlVar2_3d, & ! OUT
uwind_3d , vwind_3d , & ! IN
nlev ) ! IN
if (trim(WindTransform) == 'PsiChi') then
!- Vorticity,Divergence -> Stream Function,Velocity Potential
call VortDivToPsiChi(CtrlVar1_3d, CtrlVar2_3d, & ! INOUT
nlev) ! IN
end if
!- Insert results in EnsPerturbations
ensPerturbations(:,:,kStart_u:kEnd_u,ens) = real(CtrlVar1_3d(:,:,:),4)
ensPerturbations(:,:,kStart_v:kEnd_v,ens) = real(CtrlVar2_3d(:,:,:),4)
end do
deallocate(uwind_3d )
deallocate(vwind_3d )
deallocate(CtrlVar1_3d)
deallocate(CtrlVar2_3d)
end subroutine UVToCtrlVar
!--------------------------------------------------------------------------
! VortDivToPsiChi
!--------------------------------------------------------------------------
subroutine VortDivToPsiChi(VortPsi,DivChi,nk) 1,2
implicit none
integer, intent(in) :: nk
real(8), intent(inout) :: VortPsi(hco_bhi%ni, hco_bhi%nj,nk)
real(8), intent(inout) :: DivChi (hco_bhi%ni, hco_bhi%nj,nk)
call lst_Laplacian( lst_bhi%id, & ! IN
VortPsi, & ! INOUT
'Inverse', nk ) ! IN
call lst_Laplacian( lst_bhi%id, & ! IN
DivChi, & ! INOUT
'Inverse', nk ) ! IN
end subroutine VortDivToPsiChi
!--------------------------------------------------------------------------
! RemoveMean
!--------------------------------------------------------------------------
subroutine RemoveMean(ensPerturbations,ensMean3d) 3
implicit none
real(4), intent(inout) :: ensPerturbations(hco_bhi%ni,hco_bhi%nj,nkgdim,nens)
real(8), intent(out) :: ensMean3d(hco_bhi%ni,hco_bhi%nj,nkgdim)
real(8) :: inens
integer :: i,j,kgdim,ens
inens=1.0d0/real(nens,8)
ensMean3d(:,:,:) = 0.0d0
!$OMP PARALLEL
!$OMP DO PRIVATE (kgdim,ens,j,i)
do kgdim = 1, nkgdim
!- Sum
do ens = 1, nens
do j = 1 , hco_bhi%nj
do i = 1, hco_bhi%ni
ensMean3d(i,j,kgdim) = ensMean3d(i,j,kgdim) + real(ensPerturbations(i,j,kgdim,ens),8)
end do
end do
end do
!- Mean
do j = 1, hco_bhi%nj
do i = 1, hco_bhi%ni
ensMean3d(i,j,kgdim) = ensMean3d(i,j,kgdim) * inens
end do
end do
!- Remove Mean
do ens = 1, nens
do j = 1, hco_bhi%nj
do i = 1, hco_bhi%ni
ensPerturbations(i,j,kgdim,ens) = ensPerturbations(i,j,kgdim,ens) - &
real(ensMean3d(i,j,kgdim),4)
end do
end do
end do
end do
!$OMP END DO
!$OMP END PARALLEL
write(*,*)
write(*,*) 'finished removing the ensemble mean...'
end subroutine removeMean
!--------------------------------------------------------------------------
! CalcStdDev3d
!--------------------------------------------------------------------------
subroutine CalcStdDev3d(ensPerturbations,StdDev3d,Bin2d,NumBins2d) 6
implicit none
real(4), intent(inout) :: ensPerturbations(hco_bhi%ni,hco_bhi%nj,nkgdim,nens)
real(8), intent(out) :: StdDev3d(hco_bhi%ni,hco_bhi%nj,nkgdim)
integer, intent(in) :: Bin2d(hco_bhi%ni,hco_bhi%nj)
integer, intent(in) :: NumBins2d
integer :: BinCount (NumBins2d)
real(8) :: StdDevBin(NumBins2d)
real(8) :: inens
integer :: i,j,kgdim,ens,b
!$OMP PARALLEL
!$OMP DO PRIVATE (kgdim,BinCount,StdDevBin,b,ens,j,i)
do kgdim = 1, nkgdim
!- Sum of Squares per bin
BinCount (:) = 0
StdDevBin(:) = 0.d0
do ens = 1, nens
do j = 1, hco_bhi%nj
do i = 1, hco_bhi%ni
b = Bin2d(i,j)
BinCount(b) = BinCount(b) + 1
StdDevBin(b) = StdDevBin(b) + real(ensPerturbations(i,j,kgdim,ens),8)**2
end do
end do
end do
!- Convert to Standard Deviation
StdDevBin(:) = sqrt( StdDevBin(:) / real((BinCount(:)-1),8) )
!- Distribute bin values at each grid point
do j = 1, hco_bhi%nj
do i = 1, hco_bhi%ni
b = Bin2d(i,j)
StdDev3d(i,j,kgdim) = StdDevBin(b)
end do
end do
end do
!$OMP END DO
!$OMP END PARALLEL
write(*,*)
write(*,*) 'finished computing Standard Deviations...'
end subroutine CalcStdDev3d
!--------------------------------------------------------------------------
! Normalize3d
!--------------------------------------------------------------------------
subroutine normalize3d(ensPerturbations,StdDev3d) 3
implicit none
real(4), intent(inout) :: ensPerturbations(hco_bhi%ni,hco_bhi%nj,nkgdim,nens)
real(8), intent(in) :: StdDev3d(hco_bhi%ni,hco_bhi%nj,nkgdim)
integer :: ens, kgdim, j, i
real(4) :: fact
!$OMP PARALLEL
!$OMP DO PRIVATE (ens, kgdim, j, i)
do kgdim = 1, nkgdim
do j = 1, hco_bhi%nj
do i = 1, hco_bhi%ni
if (StdDev3d(i,j,kgdim) > 0.0d0 ) then
fact = real(1.0d0/StdDev3d(i,j,kgdim),4)
else
fact = 0.0
endif
do ens = 1, nens
ensPerturbations(i,j,kgdim,ens) = ensPerturbations(i,j,kgdim,ens) &
* fact
end do
end do
end do
end do
!$OMP END DO
!$OMP END PARALLEL
write(*,*)
write(*,*) 'finished normalizing by stddev3D...'
end subroutine normalize3d
!--------------------------------------------------------------------------
! CalcSpectralStats
!--------------------------------------------------------------------------
subroutine CalcSpectralStats(ensPerturbations,SpVertCorrel,PowerSpectrum, & 1,4
NormB)
implicit none
real(4), intent(in) :: ensPerturbations(hco_bhi%ni,hco_bhi%nj,nkgdim,nens)
real(8), intent(out) :: SpVertCorrel(nkgdim,nkgdim,0:ntrunc)
real(8), intent(out) :: PowerSpectrum(nkgdim,0:ntrunc)
real(8), intent(out) :: NormB(nkgdim,nkgdim,0:ntrunc)
real(8), allocatable :: NormPowerSpectrum(:,:)
real(8), allocatable :: SpectralStateVar(:,:,:)
real(8), allocatable :: GridState(:,:,:)
real(8), allocatable :: SumWeight(:)
real(8) :: fact, sum
integer :: i, j, k1, k2, ens, b, e, ila, p, k, totwvnb
character(len=24) :: kind
SpVertCorrel(:,:,:) = 0.d0
!
!- 1. Calculate the Vertical Covariances in Spectral Space
!
allocate( SpectralStateVar(lst_bhi%nla,lst_bhi%nphase,nkgdim) )
allocate( GridState(hco_bhi%ni, hco_bhi%nj, nkgdim) )
allocate(SumWeight(0:ntrunc))
SumWeight(:) = 0.d0
do ens = 1, nens
!- 1.1 Extract fields from ensPerturbations
GridState(:,:,:) = real(ensPerturbations(:,:,:,ens),8)
!- 1.2 Grid Point Space -> Spectral Space
kind = 'GridPointToSpectral'
call lst_VarTransform( lst_bhi%id, & ! IN
SpectralStateVar, & ! OUT
GridState, & ! IN
kind, nkgdim ) ! IN
!- 1.3 Compute the covariances
!$OMP PARALLEL
!$OMP DO PRIVATE (totwvnb,fact,e,ila,p,k2,k1)
do totwvnb = 0, ntrunc
do e = 1, lst_bhi%nePerK(totwvnb)
ila = lst_bhi%ilaFromEK(e,totwvnb)
do p = 1, lst_bhi%nphase
SumWeight(totwvnb) = SumWeight(totwvnb) + lst_bhi%Weight(ila)
do k2 = 1, nkgdim
do k1 = 1, nkgdim
SpVertCorrel(k1,k2,totwvnb) = SpVertCorrel(k1,k2,totwvnb) &
+ lst_bhi%Weight(ila) * (SpectralStateVar(ila,p,k1) * SpectralStateVar(ila,p,k2))
end do
end do
end do
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end do ! Loop in Ensemble
!- 1.4 Compute the weighted COVARIANCES for each total wavenumber
do totwvnb = 0, ntrunc
if ( SumWeight(totwvnb) /= 0.d0 ) then
SpVertCorrel(:,:,totwvnb) = SpVertCorrel(:,:,totwvnb) / SumWeight(totwvnb)
else
SpVertCorrel(:,:,totwvnb) = 0.d0
end if
end do
deallocate(SumWeight)
!- 1.5 Extract the power spectrum (the variances on the diagonal elements)
do k = 1, nkgdim
PowerSpectrum(k,:) = SpVertCorrel(k,k,:)
end do
!
!- 2. Calculate the Vertical Correlations in Spectral Space
!
!$OMP PARALLEL
!$OMP DO PRIVATE (totwvnb,k2,k1)
do totwvnb = 0, ntrunc
do k2 = 1, nkgdim
do k1 = 1, nkgdim
if ( PowerSpectrum(k1,totwvnb) /= 0.d0 .and. &
PowerSpectrum(k2,totwvnb) /= 0.d0 ) then
SpVertCorrel(k1,k2,totwvnb) = SpVertCorrel(k1,k2,totwvnb) / &
sqrt( PowerSpectrum(k1,totwvnb) * PowerSpectrum(k2,totwvnb) )
else
SpVertCorrel(k1,k2,totwvnb) = 0.d0
end if
end do
end do
end do
!$OMP END DO
!$OMP END PARALLEL
!
!- 3. Normalize the power spectrum (i.e. build normalised spectral densities of the variance)
!
allocate(NormPowerSpectrum(nkgdim,0:ntrunc))
!- 3.1 Part 1
!$OMP PARALLEL
!$OMP DO PRIVATE (totwvnb,k,sum)
do k = 1, nkgdim
sum = 0.0d0
do totwvnb = 0, ntrunc
sum = sum + real(totwvnb,8) * PowerSpectrum(k,totwvnb)
end do
do totwvnb = 0, ntrunc
if ( sum /= 0.0d0 ) then
NormPowerSpectrum(k,totwvnb) = PowerSpectrum(k,totwvnb) / sum
else
NormPowerSpectrum(k,totwvnb) = 0.d0
end if
end do
end do
!$OMP END DO
!$OMP END PARALLEL
!- 3.2 Part 2
!- 3.2.1 Spectral transform of a delta function (at the center of the domain)
GridState(:,:,:) = 0.d0
GridState(hco_bhi%ni/2,hco_bhi%nj/2,:) = 1.d0
kind = 'GridPointToSpectral'
call lst_VarTransform( lst_bhi%id, & ! IN
SpectralStateVar, & ! OUT
GridState, & ! IN
kind, nkgdim ) ! IN
!- 3.2.2 Apply the horizontal correlation function
!$OMP PARALLEL
!$OMP DO PRIVATE (totwvnb,e,ila,p,k)
do totwvnb = 0, ntrunc
do e = 1, lst_bhi%nePerK(totwvnb)
ila = lst_bhi%ilaFromEK(e,totwvnb)
do p = 1, lst_bhi%nphase
do k = 1, nkgdim
SpectralStateVar(ila,p,k) = SpectralStateVar(ila,p,k) * NormPowerSpectrum(k,totwvnb) * &
lst_bhi%NormFactor(ila,p) * lst_bhi%NormFactorAd(ila,p)
end do
end do
end do
end do
!$OMP END DO
!$OMP END PARALLEL
!- 3.2.3 Move back to physical space
kind = 'SpectralToGridPoint'
call lst_VarTransform( lst_bhi%id, & ! IN
SpectralStateVar, & ! IN
GridState, & ! OUT
kind, nkgdim ) ! IN
!- 3.2.4 Normalize to 1
do k = 1, nkgdim
if ( GridState(hco_bhi%ni/2,hco_bhi%nj/2,k) < 0.d0 ) then
write(*,*) 'CalcSpectralStats: Problem in normalization ', k, GridState(hco_bhi%ni/2,hco_bhi%nj/2,k)
call abort3d('aborting in CalcSpectralStats')
end if
if ( GridState(hco_bhi%ni/2,hco_bhi%nj/2,k) /= 0.d0 ) then
write(*,*) 'CalcSpectralStats: Normalization factor = ', k, GridState(hco_bhi%ni/2,hco_bhi%nj/2,k), 1.d0 / GridState(hco_bhi%ni/2,hco_bhi%nj/2,k)
NormPowerSpectrum(k,:) = NormPowerSpectrum(k,:) / GridState(hco_bhi%ni/2,hco_bhi%nj/2,k)
else
write(*,*) 'CalcSpectralStats: Setting NormPowerSpectrum to zero = ', k
NormPowerSpectrum(k,:) = 0.d0
end if
end do
deallocate(SpectralStateVar)
deallocate(GridState)
!
!- 4. Normalize the spectral vertical correlation matrix to ensure correlations in horizontal
!
!$OMP PARALLEL
!$OMP DO PRIVATE (totwvnb,k2,k1)
do totwvnb = 0, ntrunc
do k2 = 1, nkgdim
do k1 = 1, nkgdim
NormB(k1,k2,totwvnb) = SpVertCorrel(k1,k2,totwvnb) * &
sqrt( NormPowerSpectrum(k1,totwvnb) * NormPowerSpectrum(k2,totwvnb) )
end do
end do
end do
!$OMP END DO
!$OMP END PARALLEL
deallocate(NormPowerSpectrum)
write(*,*)
write(*,*) 'Calculating spectral covariance stats. Done!'
end subroutine CalcSpectralStats
!--------------------------------------------------------------------------
! CalcHorizScale
!--------------------------------------------------------------------------
subroutine CalcHorizScale(HorizScale,SpCovariance) 1,2
use MathPhysConstants_mod, only: MPC_PI_R8
use EarthConstants_mod, only: RA
implicit none
real(8), intent(out) :: HorizScale(nkgdim)
real(8), intent(in) :: SpCovariance(nkgdim,nkgdim,0:ntrunc)
real(8) :: circ_eq, cur_circ_eq, un_deg_lon, dx, dist
real(8) :: a, b, beta
integer :: totwvnb, k, var
write(*,*)
write(*,*) 'Calculating horizontal correlation length scale'
!
!- Computing distance-related variables
!
! Grid spacing in meters
dx = hco_bhi%dlon * RA
write(*,*)
write(*,*) 'grid spacing (m) =', dx
dist = max(hco_bhi%ni, hco_bhi %nj) * dx
beta = (dist/(2.d0*MPC_PI_R8))**2
!
!- Estimate horizontal correlation scales based on the power spectra
!
do k = 1, nkgdim
a = 0.d0
b = 0.d0
do totwvnb = 0, ntrunc
a = a + SpCovariance(k,k,totwvnb) * totwvnb
b = b + SpCovariance(k,k,totwvnb) * totwvnb**3
end do
if (b <= 0.d0) then
HorizScale(k) = 0.d0
else
HorizScale(k) = sqrt(2.d0*a*beta/b)
end if
end do
do var = 1, nControlVariable
write(*,*)
write(*,*) ControlVariable(var)%nomvar(cv_bhi)
do k = ControlVariable(var)%kDimStart, ControlVariable(var)%kDimEnd
write(*,'(i3,2X,f9.2,2X,a2)') k, HorizScale(k)/1000.d0, 'km'
end do
end do
write(*,*)
write(*,*) 'Calculating horizontal correlation length scale. Done!'
end subroutine CalcHorizScale
!--------------------------------------------------------------------------
! CalcTotVertCorrel
!--------------------------------------------------------------------------
subroutine CalcTotVertCorrel(TotVertCorrel, NormB) 1
implicit none
real(8), intent(out) :: TotVertCorrel(nkgdim,nkgdim)
real(8), intent(in) :: NormB(nkgdim,nkgdim,0:ntrunc)
real(8), allocatable :: TotVertCov(:,:)
real(8), allocatable :: SumWeight(:)
real(8) :: fact
integer :: k1, k2, totwvnb, e, p, ila
!
!- 1. Calculate the total Normalized Covariance Matrix
!
allocate(TotVertCov(nkgdim,nkgdim))
allocate(SumWeight(0:ntrunc))
TotVertCov(:,:) = 0.d0
SumWeight(:) = 0.d0
!- 1.1 Compute Weights
do totwvnb = 0, ntrunc
do e = 1, lst_bhi%nePerK(totwvnb)
ila = lst_bhi%ilaFromEK(e,totwvnb)
do p = 1, lst_bhi%nphase
SumWeight(totwvnb) = SumWeight(totwvnb) + lst_bhi%Weight(ila)
end do
end do
end do
!- 1.2 Compute Weighted Total Covariance matrix
do k2 = 1, nkgdim
do k1 = 1, nkgdim
do totwvnb = 0, ntrunc
TotVertCov(k1,k2) = TotVertCov(k1,k2) + &
SumWeight(totwvnb) * real(totwvnb,8) * NormB(k1,k2,totwvnb) * &
NormB(k1,k1,totwvnb) * NormB(k2,k2,totwvnb)
end do
end do
end do
deallocate(SumWeight)
!
!- 2. Transform into correlations
!
do k2 = 1, nkgdim
do k1 = 1, nkgdim
if ( TotVertCov(k1,k1) /= 0.d0 .and. &
TotVertCov(k2,k2) /= 0.d0 ) then
TotVertCorrel(k1,k2) = TotVertCov(k1,k2) / &
( sqrt(TotVertCov(k1,k1)) * sqrt(TotVertCov(k2,k2)) )
else
TotVertCorrel(k1,k2) = 0.d0
end if
end do
end do
deallocate(TotVertCov)
end subroutine CalcTotVertCorrel
!--------------------------------------------------------------------------
! CalcBsqrt
!--------------------------------------------------------------------------
subroutine CalcBsqrt(Bsqrt,B) 1
implicit none
!
! - produce matrix B^0.5 = V D^0.5 D^t where V and D are the
! eigenvectors and eigenvalues of B
!
real(8), intent(out) :: Bsqrt(nkgdim,nkgdim,0:ntrunc)
real(8), intent(in) :: B (nkgdim,nkgdim,0:ntrunc)
real(8), allocatable :: EigenValues(:)
real(8), allocatable :: Work(:)
real(8), allocatable :: EigenVectors(:,:)
integer :: sizework, info, totwvnb, k, k1, k2
sizework = 64 * nkgdim
allocate(work(sizework))
allocate(EigenValues(nkgdim))
allocate(EigenVectors(nkgdim,nkgdim))
!
!- Calculate B^0.5 for each total wave number
!
do totwvnb = 0, ntrunc
EigenVectors(:,:) = B(:,:,totwvnb)
!- Calculate EigenVectors (V) and EigenValues (D) of B matrix
call dsyev('V','U',nkgdim, & ! IN
EigenVectors, & ! INOUT
nkgdim, & ! IN
EigenValues, & ! OUT
work, sizework, & ! IN
info ) ! OUT
if ( info /= 0 ) then
write(*,*)
write(*,*) 'CalcBsqrt: DSYEV failed !!! ', totwvnb, info
stop
end if
!- Calculate B^0.5 = V D^0.5 V^t
where(EigenValues < 0.d0)
EigenValues = 0.d0
end where
do k1 = 1, nkgdim
do k2 = 1, nkgdim
Bsqrt(k1,k2,totwvnb) = sum ( EigenVectors (k1,1:nkgdim) &
* EigenVectors (k2,1:nkgdim) &
* sqrt(EigenValues(1:nkgdim)) )
end do
end do
end do ! total wave number
deallocate(EigenVectors)
deallocate(EigenValues)
deallocate(work)
end subroutine CalcBsqrt
!--------------------------------------------------------------------------
! SetSpVertCorrel
!--------------------------------------------------------------------------
subroutine SetSpVertCorrel(SpVertCorrel) 1
implicit none
real(8), intent(inout) :: SpVertCorrel(nkgdim,nkgdim,0:ntrunc)
real(8), allocatable :: KeepOrDiscard(:,:)
integer :: totwvnb, var1, var2, k1, k2
write(*,*)
write(*,*) 'Setting Vertical Correlations'
!
!- Determine which bloc of the correlation matrix to keep/discard
!
allocate(KeepOrDiscard(nControlVariable,nControlVariable))
!- Calculate upper half
do var2 = 1, nControlVariable
do var1 = 1, var2
if (var1 == var2) then
KeepOrDiscard(var1,var2) = 1.d0 ! Keep Auto-Correlations
elseif( (ControlVariable(var2)%nomvar(cv_bhi) == 'CC' .and. &
ControlVariable(var1)%nomvar(cv_bhi) == 'PP') .or. &
(ControlVariable(var2)%nomvar(cv_bhi) == 'TT' .and. &
ControlVariable(var1)%nomvar(cv_bhi) == 'PP') .or. &
(ControlVariable(var2)%nomvar(cv_bhi) == 'P0' .and. &
ControlVariable(var1)%nomvar(cv_bhi) == 'PP') .or. &
(ControlVariable(var2)%nomvar(cv_bhi) == 'P0' .and. &
ControlVariable(var1)%nomvar(cv_bhi) == 'TT') ) then
KeepOrDiscard(var1,var2) = 1.d0 ! Keep these Cross-Correlations
else
KeepOrDiscard(var1,var2) = 0.d0 ! Discard these Cross-Correlation
end if
write(*,*) var1, var2, ControlVariable(var1)%nomvar(cv_bhi), ControlVariable(var2)%nomvar(cv_bhi), KeepOrDiscard(var1,var2)
end do
end do
! Symmetrize
do var1 = 2, nControlVariable
do var2 = 1, var1-1
KeepOrDiscard(var1,var2) = KeepOrDiscard(var2,var1)
end do
end do
!
!- Modify the Vertical Correlation Matrix
!
do totwvnb = 0, ntrunc
do var2 = 1, nControlVariable
do var1 = 1, nControlVariable
do k2 = ControlVariable(var2)%kDimStart, ControlVariable(var2)%kDimEnd
do k1 = ControlVariable(var1)%kDimStart, ControlVariable(var1)%kDimEnd
SpVertCorrel(k1,k2,totwvnb) = KeepOrDiscard(var1,var2) * &
SpVertCorrel(k1,k2,totwvnb)
end do
end do
end do
end do
end do ! total wave number
deallocate(KeepOrDiscard)
write(*,*)
write(*,*) 'Setting Vertical Correlations. Done!'
end subroutine SetSpVertCorrel
!--------------------------------------------------------------------------
! CreateBins
!--------------------------------------------------------------------------
subroutine CreateBins(Bin2d,NumBins2d,BinningStrategy) 2
implicit none
integer, intent(out) :: Bin2d(hco_bhi%ni,hco_bhi%nj)
integer, intent(out) :: NumBins2d
character(*), intent(in) :: BinningStrategy
real(8) :: BinCat
integer :: i,j,kgdim,ens,b
select case(trim(BinningStrategy))
case ('GridPoint')
write(*,*) ' BIN_TYPE : No horizontal averaging '
write(*,*) ' = One bin per horizontal grid point'
NumBins2d = hco_bhi%ni * hco_bhi%nj
BinCat = 0
do j = 1, hco_bhi%nj
do i = 1, hco_bhi%ni
BinCat = BinCat + 1
bin2d(i,j) = BinCat
end do
end do
case ('YrowBand')
write(*,*)
write(*,*) ' BIN_TYPE : One bin per Y row'
NumBins2d = hco_bhi%nj
BinCat = 0
do j = 1, hco_bhi%nj
BinCat = BinCat + 1
bin2d(:,j) = BinCat
end do
case ('HorizontalMean')
write(*,*)
write(*,*) ' BIN_TYPE : Average over all horizontal points'
NumBins2d = 1
bin2d(:, :) = 1
case default
write(*,*)
write(*,*) 'Invalid Binning Strategy : ',trim(BinningStrategy)
stop
end select
end subroutine CreateBins
!--------------------------------------------------------------------------
! BiPeriodization
!--------------------------------------------------------------------------
subroutine BiPeriodization(ensPerturbations) 1,1
implicit none
real(4), intent(inout) :: ensPerturbations(hco_bhi%ni,hco_bhi%nj,nkgdim,nens)
real(8), allocatable :: work3d(:,:,:)
integer :: kgdim, ens
allocate(work3d(hco_bhi%ni, hco_bhi%nj, nkgdim))
!- Loop over all variables / levels / ensemble members
do ens = 1, nens
work3d(:,:,:) = real(ensPerturbations(:,:,:,ens),8)
call lag_mach(work3d, & ! INOUT
hco_bhi%ni, hco_bhi%nj, nkgdim) ! IN
ensPerturbations(:,:,:,ens) = real(work3d(:,:,:),4)
end do
deallocate(work3d)
end subroutine BiPeriodization
!--------------------------------------------------------------------------
! WriteVarStats
!--------------------------------------------------------------------------
subroutine WriteVarStats(Bsqrt,StdDev3d) 1,4
implicit none
real(8), intent(in) :: Bsqrt(nkgdim,nkgdim,0:ntrunc)
real(8), intent(in) :: StdDev3d(hco_bhi%ni,hco_bhi%nj,nkgdim)
integer :: ier, fstouv, fnom, fstfrm, fclos
integer :: iunstats
write(*,*)
write(*,*) 'Writing covariance statistics for VAR'
!
!- Opening Output file
!
iunstats = 0
ier = fnom(iunstats,'./bgcov.fst','RND',0)
ier = fstouv(iunstats,'RND')
!
!- Add Tic-Tac and Toc-Toc
!
call WriteTicTacToc(iunstats)
!
!- Add Control Variable Info
!
call WriteControlVarInfo(iunstats)
!
!- Bsqrt
!
call WriteSpVertCorrel(Bsqrt,iunstats,'ZN','B_SQUAREROOT') ! IN
!
!- 3D Standard Deviations
!
call Write3d(StdDev3d,iunstats,'STDDEV',cv_bhi) ! IN
!
!- Closing output file
!
ier = fstfrm(iunstats)
ier = fclos (iunstats)
end subroutine WriteVarStats
!--------------------------------------------------------------------------
! WriteDiagStats
!--------------------------------------------------------------------------
subroutine WriteDiagStats(NormB,SpVertCorrel,TotVertCorrel,EnsMean3d, & 1,8
StdDev3dGridPoint,PowerSpectrum,HorizScale)
implicit none
real(8), intent(in) :: NormB(nkgdim,nkgdim,0:ntrunc)
real(8), intent(in) :: SpVertCorrel(nkgdim,nkgdim,0:ntrunc)
real(8), intent(in) :: TotVertCorrel(nkgdim,nkgdim)
real(8), intent(in) :: EnsMean3d(hco_bhi%ni,hco_bhi%nj,nkgdim)
real(8), intent(in) :: StdDev3dGridPoint(hco_bhi%ni,hco_bhi%nj,nkgdim)
real(8), intent(in) :: PowerSpectrum(nkgdim,0:ntrunc)
real(8), intent(in) :: HorizScale(nkgdim)
integer :: ier, fstouv, fnom, fstfrm, fclos
integer :: iunstats
write(*,*)
write(*,*) 'Writing Diagnostics'
!
!- Opening Output file
!
iunstats = 0
ier = fnom(iunstats,'./bgcov_diag.fst','RND',0)
ier = fstouv(iunstats,'RND')
!
!- Add Tic-Tac and Toc-Toc
!
call WriteTicTacToc(iunstats)
!
!- Spectral Vertical correlations
!
!- Spectral Vertical Correlations
call WriteSpVertCorrel(SpVertCorrel,iunstats,'ZZ','SPVERTCORREL') ! IN
!- Total Vertical Correlations
call WriteTotVertCorrel(TotVertCorrel,iunstats,'ZT','TTVERTCORREL') ! IN
!- Normalized Vertical Correlations
call WriteSpVertCorrel(NormB,iunstats,'ZN','NRVERTCORREL') ! IN
!
!- 3D Grid Point Ensemble Mean
!
call Write3d(EnsMean3d,iunstats,'ENSMEAN',cv_bhi) ! IN
!
!- 3D Grid Point Standard Deviation
!
call Write3d(StdDev3dGridPoint,iunstats,'STDDEV_GRIDP',cv_bhi) ! IN
!
!- Power Spectrum
!
call WritePowerSpectrum(PowerSpectrum,iunstats,'POWERSPECT',cv_bhi) ! IN
!
!- Horizontal Correlation Length scale
!
call WriteHorizScale(HorizScale,iunstats,'HORIZSCALE',cv_bhi) ! IN
!
!- Closing output file
!
ier = fstfrm(iunstats)
ier = fclos (iunstats)
end subroutine WriteDiagStats
!--------------------------------------------------------------------------
! WriteSpVertCorrel
!--------------------------------------------------------------------------
subroutine WriteSpVertCorrel(SpVertCorrel,iun,nomvar_in,etiket_in) 3
implicit none
real(8), intent(in) :: SpVertCorrel(nkgdim,nkgdim,0:ntrunc)
integer, intent(in) :: iun
character(len=*), intent(in) :: nomvar_in
character(len=*), intent(in) :: etiket_in
real(4), allocatable :: work2d(:,:)
real(4) :: work
integer :: ier, fstecr
integer :: k, kgdim, totwvnb
integer :: dateo, npak, ni, nj, nk
integer :: ip1, ip2, ip3, deet, npas, datyp
integer :: ig1 ,ig2 ,ig3 ,ig4
character(len=1) :: grtyp
character(len=4) :: nomvar
character(len=2) :: typvar
character(len=12) :: etiket
allocate(work2d(nkgdim, nkgdim))
!- Loop over Total Wavenumbers
do totwvnb = 0, ntrunc
npak = -32
dateo = 0
deet = 0
npas = 0
ni = nkgdim
nj = nkgdim
nk = 1
ip1 = 0
ip2 = totwvnb
ip3 = nens
typvar = 'XX'
nomvar = nomvar_in
etiket = etiket_in
grtyp = 'X'
ig1 = 0
ig2 = 0
ig3 = 0
ig4 = 0
datyp = 5
!- Extract from full Matrix
work2d(:,:) = real(SpVertCorrel(:,:,totwvnb),4)
!- Writing
ier = fstecr(work2d, work, npak, iun, dateo, deet, npas, ni, nj, &
nk, ip1, ip2, ip3, typvar, nomvar, etiket, grtyp, &
ig1, ig2, ig3, ig4, datyp, .true.)
end do ! Total Wavenumbers
deallocate(work2d)
end subroutine WriteSpVertCorrel
!--------------------------------------------------------------------------
! WriteSpVertCorrel
!--------------------------------------------------------------------------
subroutine WriteTotVertCorrel(TotVertCorrel,iun,nomvar_in,etiket_in) 1
implicit none
real(8), intent(in) :: TotVertCorrel(nkgdim,nkgdim)
integer, intent(in) :: iun
character(len=*), intent(in) :: nomvar_in
character(len=*), intent(in) :: etiket_in
real(4), allocatable :: workecr(:,:)
real(4) :: work
integer :: ier, fstecr
integer :: dateo, npak, ni, nj, nk
integer :: ip1, ip2, ip3, deet, npas, datyp
integer :: ig1 ,ig2 ,ig3 ,ig4
character(len=1) :: grtyp
character(len=4) :: nomvar
character(len=2) :: typvar
character(len=12) :: etiket
allocate(workecr(nkgdim, nkgdim))
npak = -32
dateo = 0
deet = 0
npas = 0
ni = nkgdim
nj = nkgdim
nk = 1
ip1 = 0
ip2 = 0
ip3 = nens
typvar = 'XX'
nomvar = nomvar_in
etiket = etiket_in
grtyp = 'X'
ig1 = 0
ig2 = 0
ig3 = 0
ig4 = 0
datyp = 5
!- Covert to real 4
workecr(:,:) = real(TotVertCorrel(:,:),4)
!- Writing
ier = fstecr(workecr, work, npak, iun, dateo, deet, npas, ni, nj, &
nk, ip1, ip2, ip3, typvar, nomvar, etiket, grtyp, &
ig1, ig2, ig3, ig4, datyp, .true.)
deallocate(workecr)
end subroutine WriteTotVertCorrel
!--------------------------------------------------------------------------
! WriteEnsemble
!--------------------------------------------------------------------------
subroutine WriteEnsemble(ensPerturbations, OutputBaseName, cv_type)
implicit none
real(4), intent(in) :: ensPerturbations(hco_bhi%ni,hco_bhi%nj,nkgdim,nens)
integer, intent(in) :: cv_type
character(len=*), intent(in) :: OutputBaseName
real(4), allocatable :: work2d(:,:)
real(4) :: factor, work
integer :: ier, fstouv, fnom, fstfrm, fclos, fstecr
integer :: iunens, ens, var, k, kgdim
integer :: dateo, npak, ni, nj, nk
integer :: ip1, ip2, ip3, deet, npas, datyp
integer :: ig1 ,ig2 ,ig3 ,ig4
character(len=1) :: grtyp
character(len=4) :: nomvar
character(len=2) :: typvar
character(len=12) :: etiket
character(len=128):: OutputFileName
character(len=3) :: cens
allocate(work2d(hco_bhi%ni, hco_bhi%nj))
!- Loop over the Ensemble members
do ens = 1, nens
if (ens < 10) then
write( cens, '(i1)' ) ens
cens='00'//cens
else if (ens < 100) then
write( cens, '(i2)' ) ens
cens='0'//cens
else
write( cens, '(i3)' ) ens
end if
OutputFileName= trim(OutputBaseName) // '_' // cens // '.fst'
write(*,*)
write(*,*) 'Writing ensemble member: ', ens, trim(OutputFileName)
iunens = 0
ier = fnom(iunens,trim(OutputFileName),'RND',0)
ier = fstouv(iunens,'RND')
!- Loop over Control Variables
do var = 1, nControlVariable
!- Loop over vertical Levels
do k = 1, ControlVariable(var)%nlev
npak = -32
dateo = 0
deet = 0
npas = 0
ni = hco_bhi%ni
nj = hco_bhi%nj
nk = 1
ip1 = ControlVariable(var)%ip1(k)
ip2 = 0
ip3 = 0
typvar = 'E'
nomvar = trim(ControlVariable(var)%nomvar(cv_type))
etiket = 'DEBUG'
grtyp = hco_bhi%grtyp
ig1 = hco_bhi%ig1
ig2 = hco_bhi%ig2
ig3 = hco_bhi%ig3
ig4 = hco_bhi%ig4
datyp = 1
if ( trim(nomvar) == 'UU' .or. trim(nomvar) == 'VV') then
factor = 1.94246 ! m/s -> knots
else if ( trim(nomvar) == 'P0' ) then
factor = 0.01 ! Pa -> hPa
else
factor = 1.0
end if
!- Extract from EnsPerturbations
kgdim = ControlVariable(var)%kDimStart + k - 1
work2d(:,:) = factor * EnsPerturbations(:,:,kgdim,ens)
!- Writing
ier = fstecr(work2d, work, npak, iunens, dateo, deet, npas, ni, nj, &
nk, ip1, ip2, ip3, typvar, nomvar, etiket, grtyp, &
ig1, ig2, ig3, ig4, datyp, .true.)
end do ! Vertical Levels
end do ! Variables
ier = fstfrm(iunens)
ier = fclos (iunens)
end do ! Ensemble members
deallocate(work2d)
end subroutine WriteEnsemble
!--------------------------------------------------------------------------
! Write3D
!--------------------------------------------------------------------------
subroutine Write3D(Field3d, iun, Etiket_in, cv_type) 3
implicit none
real(8), intent(in) :: Field3d(hco_bhi%ni,hco_bhi%nj,nkgdim)
integer, intent(in) :: iun
integer, intent(in) :: cv_type
character(len=*), intent(in) :: Etiket_in
real(4), allocatable :: work2d(:,:)
real(4) :: factor, work
integer :: ier, fstecr
integer :: var, k, kgdim
integer :: dateo, npak, ni, nj, nk
integer :: ip1, ip2, ip3, deet, npas, datyp
integer :: ig1 ,ig2 ,ig3 ,ig4
character(len=1) :: grtyp
character(len=4) :: nomvar
character(len=2) :: typvar
character(len=12) :: etiket
character(len=3) :: cens
allocate(work2d(hco_bhi%ni, hco_bhi%nj))
!- Loop over Control Variables
do var = 1, nControlVariable
!- Loop over vertical Levels
do k = 1, ControlVariable(var)%nlev
npak = -32
dateo = 0
deet = 0
npas = 0
ni = hco_bhi%ni
nj = hco_bhi%nj
nk = 1
ip1 = ControlVariable(var)%ip1(k)
ip2 = 0
ip3 = 0
typvar = 'E'
nomvar = trim(ControlVariable(var)%nomvar(cv_type))
etiket = trim(Etiket_in)
grtyp = hco_bhi%grtyp
ig1 = hco_bhi%ig1
ig2 = hco_bhi%ig2
ig3 = hco_bhi%ig3
ig4 = hco_bhi%ig4
datyp = 1
if ( trim(nomvar) == 'UU' .or. trim(nomvar) == 'VV') then
factor = 1.94246 ! m/s -> knots
else if ( trim(nomvar) == 'P0' ) then
factor = 0.01 ! Pa -> hPa
else
factor = 1.0
end if
!- Extract from EnsPerturbations
kgdim = ControlVariable(var)%kDimStart + k - 1
work2d(:,:) = factor * real(Field3d(:,:,kgdim),4)
!- Writing
ier = fstecr(work2d, work, npak, iun, dateo, deet, npas, ni, nj, &
nk, ip1, ip2, ip3, typvar, nomvar, etiket, grtyp, &
ig1, ig2, ig3, ig4, datyp, .true.)
end do ! Vertical Levels
end do ! Variables
deallocate(work2d)
end subroutine Write3D
!--------------------------------------------------------------------------
! WritePowerSpectrum
!--------------------------------------------------------------------------
subroutine WritePowerSpectrum(PowerSpectrum,iun,etiket_in,cv_type) 1
implicit none
real(8), intent(in) :: PowerSpectrum(nkgdim,0:ntrunc)
integer, intent(in) :: iun
integer, intent(in) :: cv_type
character(len=*), intent(in) :: Etiket_in
real(4), allocatable :: workecr(:,:)
real(4) :: factor, work
integer :: ier, fstecr
integer :: var, k, kgdim
integer :: dateo, npak, ni, nj, nk
integer :: ip1, ip2, ip3, deet, npas, datyp
integer :: ig1 ,ig2 ,ig3 ,ig4
character(len=1) :: grtyp
character(len=4) :: nomvar
character(len=2) :: typvar
character(len=12) :: etiket
character(len=3) :: cens
allocate(workecr(ntrunc+1, 1))
!- Loop over Control Variables
do var = 1, nControlVariable
!- Loop over vertical Levels
do k = 1, ControlVariable(var)%nlev
npak = -32
dateo = 0
deet = 0
npas = 0
ni = ntrunc + 1
nj = 1
nk = 1
ip1 = ControlVariable(var)%ip1(k)
ip2 = 0
ip3 = 0
typvar = 'E'
nomvar = trim(ControlVariable(var)%nomvar(cv_type))
etiket = trim(Etiket_in)
grtyp = 'X'
ig1 = 0
ig2 = 0
ig3 = 0
ig4 = 0
datyp = 1
!- Extract
kgdim = ControlVariable(var)%kDimStart + k - 1
workecr(:,1) = real(PowerSpectrum(kgdim,:),4)
!- Writing
ier = fstecr(workecr, work, npak, iun, dateo, deet, npas, ni, nj, &
nk, ip1, ip2, ip3, typvar, nomvar, etiket, grtyp, &
ig1, ig2, ig3, ig4, datyp, .true.)
end do ! Vertical Levels
end do ! Variables
deallocate(workecr)
end subroutine WritePowerSpectrum
!--------------------------------------------------------------------------
! WriteHorizScale
!--------------------------------------------------------------------------
subroutine WriteHorizScale(HorizScale,iun,etiket_in,cv_type) 1
implicit none
real(8), intent(in) :: HorizScale(nkgdim)
integer, intent(in) :: iun
integer, intent(in) :: cv_type
character(len=*), intent(in) :: Etiket_in
real(4), allocatable :: workecr(:,:,:)
real(4) :: factor, work
integer :: ier, fstecr
integer :: var, k, kgdim
integer :: dateo, npak, ni, nj, nk
integer :: ip1, ip2, ip3, deet, npas, datyp
integer :: ig1 ,ig2 ,ig3 ,ig4
character(len=1) :: grtyp
character(len=4) :: nomvar
character(len=2) :: typvar
character(len=12) :: etiket
character(len=3) :: cens
!- Loop over Control Variables
do var = 1, nControlVariable
allocate(workecr(1,1,ControlVariable(var)%nlev))
npak = -32
dateo = 0
deet = 0
npas = 0
ni = 1
nj = 1
nk = ControlVariable(var)%nlev
ip1 = 0
ip2 = 0
ip3 = 0
typvar = 'E'
nomvar = trim(ControlVariable(var)%nomvar(cv_type))
etiket = trim(Etiket_in)
grtyp = 'X'
ig1 = 0
ig2 = 0
ig3 = 0
ig4 = 0
datyp = 1
!- Extract
workecr(1,1,:) = real(HorizScale(ControlVariable(var)%kDimStart:ControlVariable(var)%kDimEnd),4)
!- Writing
ier = fstecr(workecr, work, npak, iun, dateo, deet, npas, ni, nj, &
nk, ip1, ip2, ip3, typvar, nomvar, etiket, grtyp, &
ig1, ig2, ig3, ig4, datyp, .true.)
deallocate(workecr)
end do ! Variables
end subroutine WriteHorizScale
!--------------------------------------------------------------------------
! WriteTicTacToc
!--------------------------------------------------------------------------
subroutine WriteTicTacToc(iun) 2,3
use vGrid_Descriptors , only: vgrid_descriptor, vgd_write, VGD_OK
use MathPhysConstants_mod, only : MPC_DEGREES_PER_RADIAN_R8
implicit none
integer, intent(in) :: iun
integer :: ier, vfstecr
real(8) :: work
integer :: dateo,npak, status
integer :: ip1,ip2,ip3,deet,npas,datyp,ig1,ig2,ig3,ig4
integer :: ig1_tictac,ig2_tictac,ig3_tictac,ig4_tictac
character(len=1) :: grtyp
character(len=2) :: typvar
character(len=12) :: etiket
!
!- 1. Writing Tic-Tac
!
npak = -32
deet = 0
ip1 = hco_bhi%ig1
ip2 = hco_bhi%ig2
ip3 = 0
npas = 0
datyp = 1
grtyp = 'E'
typvar = 'X'
etiket = 'EXTENDEDGRID'
dateo = 0
call cxgaig ( grtyp, & ! IN
ig1_tictac, ig2_tictac, ig3_tictac, ig4_tictac, & ! OUT
real(hco_bhi%xlat1), real(hco_bhi%xlon1), & ! IN
real(hco_bhi%xlat2), real(hco_bhi%xlon2) ) ! IN
ig1 = ig1_tictac
ig2 = ig2_tictac
ig3 = ig3_tictac
ig4 = ig4_tictac
ier = vfstecr(hco_bhi%lon*MPC_DEGREES_PER_RADIAN_R8, work, npak, &
iun, dateo, deet, npas, hco_bhi%ni, 1, 1, ip1, &
ip2, ip3, typvar, '>>', etiket, grtyp, ig1, &
ig2, ig3, ig4, datyp, .true.)
ier = vfstecr(hco_bhi%lat*MPC_DEGREES_PER_RADIAN_R8, work, npak, &
iun, dateo, deet, npas, 1, hco_bhi%nj, 1, ip1, &
ip2, ip3, typvar, '^^', etiket, grtyp, ig1, &
ig2, ig3, ig4, datyp, .true.)
!
!- Writing Toc-Toc
!
status = vgd_write(vco_bhi%vgrid,iun,'fst')
if ( status /= VGD_OK ) then
write(*,*)
write(*,*) 'WriteTicTacToc: ERROR with vgd_write '
stop
end if
end subroutine WriteTicTacToc
!--------------------------------------------------------------------------
! WriteControlVarInfo
!--------------------------------------------------------------------------
subroutine WriteControlVarInfo(iun) 1
implicit none
integer, intent(in) :: iun
integer :: ier, fstecr, fstecr_s
real(8) :: work
integer :: npak, var, dateo, ni, nj
integer :: ip1,ip2,ip3,deet,npas,datyp,ig1,ig2,ig3,ig4
integer :: ig1_tictac,ig2_tictac,ig3_tictac,ig4_tictac
character(len=1) :: grtyp
character(len=2) :: typvar
character(len=4) :: nomvar
character(len=12) :: etiket
character(len=4) :: ControlModelVarnameList(nControlVariable)
character(len=4) :: ControlBhiVarnameList (nControlVariable)
character(len=2) :: ControlVarGridTypeList (nControlVariable)
integer :: ControlVarNlevList (nControlVariable)
!
!- 1. Gathering the info
!
!- Loop over Control Variables
do var = 1, nControlVariable
ControlModelVarnameList(var) = trim(ControlVariable(var)%nomvar(cv_model))
ControlBhiVarnameList(var) = trim(ControlVariable(var)%nomvar(cv_bhi))
ControlVarNlevList(var) = ControlVariable(var)%nlev
ControlVarGridTypeList(var) = ControlVariable(var)%GridType
end do
write(*,*)
write(*,*) 'ControlModelVarnameList = ',ControlModelVarnameList(:)
write(*,*) 'ControlBhiVarnameList = ',ControlBhiVarnameList(:)
write(*,*) 'ControlVarNlevList = ',ControlVarNlevList(:)
write(*,*) 'ControlVarGridTypeList = ',ControlVarGridTypeList(:)
!
!- 2. Writing the list of control variables and number of vertical levels
!
npak = -32
dateo = 0
deet = 0
ip1 = 0
ip2 = 0
ip3 = 0
npas = 0
grtyp = 'X'
typvar = 'X'
ig1 = 0
ig2 = 0
ig3 = 0
ig4 = 0
nomvar = 'CVN'
ni = 4 ! 4 Characters
nj = nControlVariable
datyp = 7 ! Character
ier = fstecr_s(ControlModelVarnameList, work, npak, &
iun, dateo, deet, npas, ni, nj, 1, ip1, &
ip2, ip3, typvar, nomvar, 'MODEL', grtyp, ig1, &
ig2, ig3, ig4, datyp, .true.)
ier = fstecr_s(ControlBhiVarnameList, work, npak, &
iun, dateo, deet, npas, ni, nj, 1, ip1, &
ip2, ip3, typvar, nomvar, 'B_HI', grtyp, ig1, &
ig2, ig3, ig4, datyp, .true.)
nomvar = 'CVL'
ni = 2 ! 2 Characters
ier = fstecr_s(ControlVarGridTypeList, work, npak, &
iun, dateo, deet, npas, ni, nj, 1, ip1, &
ip2, ip3, typvar, nomvar, 'LEVTYPE', grtyp, ig1, &
ig2, ig3, ig4, datyp, .true.)
datyp = 2 ! Integer
ni = nControlVariable
nj = 1
ier = fstecr(ControlVarNlevList, work, npak, &
iun, dateo, deet, npas, ni, nj, 1, ip1, &
ip2, ip3, typvar, nomvar, 'NLEV', grtyp, ig1, &
ig2, ig3, ig4, datyp, .true.)
end subroutine WriteControlVarInfo
end module calcbmatrix_lam_mod