24 #include "dimensions.h"
32 REAL dlonu(
iim),dlatu(jjm)
33 REAL rlamda(
iim ), eignvl(
iim )
37 INTEGER i,j,modemax,imx,k,kf,ii
38 REAL dymin,dxmin,colat0
41 LOGICAL,
SAVE :: first_call_inifilr = .
true.
77 print *,
'inifilr: EIGNVL '
79 250
FORMAT( 1
x,5e14.6)
104 iymin = ismin( jjm, dlatu, 1 )
105 ixmineq = ismin(
iim, dlonu, 1 )
106 dymin = dlatu( iymin )
107 dxmin = dlonu( ixmineq )
111 dxmin = min( dxmin,dlonu(i) )
115 dymin = min( dymin,dlatu(j) )
126 colat0 = min( 0.5, dymin/dxmin )
128 IF( .NOT.
fxyhypb.AND.ysinus )
THEN
135 50
FORMAT(/15
x,
' Inifilr colat0 alphax ',2e16.7)
138 print *,
' Inifilr alphax doit etre < a 1. Corriger '
142 lamdamax =
iim / ( pi * colat0 * ( 1. -
alphax ) )
147 rlamda( i ) = lamdamax/ sqrt( abs( eignvl(i) ) )
156 coefilv2( i,j ) = 0.0
170 print *,
'inifilr: TRUNCATION AT ',imx
179 cof = cos(
rlatu(j) )/ colat0
180 IF ( cof .LT. 1. )
THEN
181 IF( rlamda(imx) * cos(
rlatu(j) ).LT.1. )
THEN
187 IF ( cof .LT. 1. )
THEN
188 IF( rlamda(imx) * cos(
rlatu(
jjp1-j+1) ).LT.1. )
THEN
195 cof = cos(
rlatv(j) )/ colat0
196 IF ( cof .LT. 1. )
THEN
197 IF( rlamda(imx) * cos(
rlatv(j) ).LT.1. )
THEN
202 cof = cos(
rlatv(jjm-j+1) )/ colat0
203 IF ( cof .LT. 1. )
THEN
204 IF( rlamda(imx) * cos(
rlatv(jjm-j+1) ).LT.1. )
THEN
211 IF(
jfiltnu.GT. jjm/2 +1 )
THEN
212 print *,
' jfiltnu en dehors des valeurs acceptables ' ,
jfiltnu
217 print *,
' jfiltsu en dehors des valeurs acceptables ' ,
jfiltsu
222 print *,
' jfiltnv en dehors des valeurs acceptables ' ,
jfiltnv
227 print *,
' jfiltsv en dehors des valeurs acceptables ' ,
jfiltsv
231 print *,
'inifilr: jfiltnv jfiltsv jfiltnu jfiltsu ' , &
234 IF(first_call_inifilr)
THEN
241 first_call_inifilr = .
false.
257 cof = rlamda(k) * cos(
rlatu(j) )
258 IF ( cof .LT. 1. )
GOTO 82
265 cof = rlamda(k) * cos(
rlatu(j) )
276 cof = rlamda(k) * cos(
rlatv(j) )
277 IF ( cof .LT. 1. )
GOTO 87
284 cof = rlamda(k) * cos(
rlatv(j) )
286 coefilv2(k,j) = cof*cof - 1.
293 cof = rlamda(k) * cos(
rlatu(j) )
294 IF ( cof .LT. 1. )
GOTO 92
301 cof = rlamda(k) * cos(
rlatu(j) )
310 cof = rlamda(k) * cos(
rlatv(j) )
311 IF ( cof .LT. 1. )
GOTO 97
318 cof = rlamda(k) * cos(
rlatv(j) )
320 coefilv2(k,j) = cof*cof - 1.
332 print *,
'jfiltnv jfiltsv jfiltnu jfiltsu' , &
336 print *,
' Modes premiers v '
338 print *,
' Modes premiers u '
354 eignft(i,k) =
eignfnv(k,i) * coff
361 CALL sgemm (
'N',
'N',
iim,
iim,
iim, 1.0, &
384 eignft(i,k) =
eignfnv(k,i) * coff
391 CALL sgemm (
'N',
'N',
iim,
iim,
iim, 1.0, &
421 eignft(i,k) =
eignfnu(k,i) * coff
428 CALL sgemm (
'N',
'N',
iim,
iim,
iim, 1.0, &
451 eignft(i,k) =
eignfnu(k,i) * coff
458 CALL sgemm (
'N',
'N',
iim,
iim,
iim, 1.0, &
488 eignft(i,k) =
eignfnv(k,i) * coff
495 CALL sgemm (
'N',
'N',
iim,
iim,
iim, 1.0, &
518 eignft(i,k) =
eignfnv(k,i) * coff
525 CALL sgemm (
'N',
'N',
iim,
iim,
iim, 1.0, &
554 755
FORMAT(1
x,6f10.3,i3)
!$Header!c!c!c include serre h!c REAL alphax
subroutine init_filtre_fft(coeffu, modfrstu, jfiltnu, jfiltsu, coeffv, modfrstv, jfiltnv, jfiltsv)
!$Id!COMMON coefils jfiltsu
real, dimension(:,:,:), allocatable matriceus
logical, save use_filtre_fft
real, dimension(:,:,:), allocatable matrinvs
!$Id!COMMON coefils eignfnv(iim, iim)&&
!$Id!COMMON coefils coefilu(iim, jjm)
!$Id!COMMON coefils eignfnu(iim, iim)
!$Id!COMMON coefils jfiltsv
!$Header!CDK comgeom COMMON comgeom rlatu
!$Header!CDK comgeom2 COMMON comgeom unsaire xprimu
!$Id!COMMON coefils jfiltnu
!$Id itapm1 ENDIF!IM on interpole les champs sur les niveaux STD de pression!IM a chaque pas de temps de la physique c!positionnement de l argument logique a false c!pour ne pas recalculer deux fois la meme chose!c!a cet effet un appel a plevel_new a ete deplace c!a la fin de la serie d appels c!la boucle DO nlevSTD a ete internalisee c!dans d ou la creation de cette routine c c!CALL false
!$Id!COMMON coefils && modfrstu(jjm)
!$Id!COMMON coefils coefilv(iim, jjm)
!$Id!COMMON coefils modfrstv(jjm)
!$Header!CDK comgeom COMMON comgeom rlatv
!$Header!c c INCLUDE fxyprim h c c c Fonctions in line c c REAL fyprim REAL rj c c il faut la calculer avant d appeler ces fonctions c c c Fonctions a changer selon x(x) et y(y) choisis.c-----------------------------------------------------------------c c.....ici
!$Id itapm1 ENDIF!IM on interpole les champs sur les niveaux STD de pression!IM a chaque pas de temps de la physique c!positionnement de l argument logique a false c!pour ne pas recalculer deux fois la meme chose!c!a cet effet un appel a plevel_new a ete deplace c!a la fin de la serie d appels c!la boucle DO nlevSTD a ete internalisee c!dans d ou la creation de cette routine c c!CALL ulevSTD CALL &zphi philevSTD CALL &zx_rh rhlevSTD!DO klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon du jour ou toutes les read_climoz CALL true
real, dimension(:,:,:), allocatable matrinvn
!$Id!COMMON coefils jfiltnv
!$Id!COMMON coefils coefilu2(iim, jjm)
c c zjulian c cym CALL iim cym klev iim
real, dimension(:,:,:), allocatable matriceun
real, dimension(:,:,:), allocatable matricevn
real, dimension(:,:,:), allocatable matricevs