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