Changeset 5106


Ignore:
Timestamp:
Jul 23, 2024, 10:21:18 PM (5 months ago)
Author:
abarral
Message:

Turn coefils.h into lmdz_coefils.f90
Put filtreg.F90 inside lmdz_filtreg.F90
Turn mod_filtreg_p.F90 into lmdz_filtreg_p.F90
Delete obsolete parafilt.h*
(lint) remove spaces between routine name and args

Location:
LMDZ6/branches/Amaury_dev/libf
Files:
4 deleted
126 edited
5 moved

Legend:

Unmodified
Added
Removed

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/bilan_dyn.F90

    r5105 r5106  
    11! $Id$
    22
    3 SUBROUTINE bilan_dyn (ntrac, dt_app, dt_cum, &
     3SUBROUTINE bilan_dyn(ntrac, dt_app, dt_cum, &
    44        ps, masse, pk, flux_u, flux_v, teta, phi, ucov, vcov, trac)
    55

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/caladvtrac.F90

    r5103 r5106  
    1010  USE control_mod, ONLY: iapp_tracvl, planet_type
    1111  USE comconst_mod, ONLY: dtvr
     12  USE lmdz_filtreg, ONLY: filtreg
    1213
    1314  IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/covnat.F90

    r5105 r5106  
    11! $Header$
    22
    3 SUBROUTINE covnat (klevel, ucov, vcov, unat, vnat)
     3SUBROUTINE covnat(klevel, ucov, vcov, unat, vnat)
    44  IMPLICIT NONE
    55

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/dteta1.F90

    r5105 r5106  
    11! $Header$
    22
    3 SUBROUTINE dteta1 (teta, pbaru, pbarv, dteta)
     3SUBROUTINE dteta1(teta, pbaru, pbarv, dteta)
     4  USE lmdz_filtreg, ONLY: filtreg
    45  IMPLICIT NONE
    56

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/dudv1.F90

    r5105 r5106  
    11! $Header$
    22
    3 SUBROUTINE dudv1 (vorpot, pbaru, pbarv, du, dv)
     3SUBROUTINE dudv1(vorpot, pbaru, pbarv, du, dv)
    44  IMPLICIT NONE
    55  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/dudv2.F90

    r5105 r5106  
    11! $Header$
    22
    3 SUBROUTINE dudv2 (teta, pkf, bern, du, dv)
     3SUBROUTINE dudv2(teta, pkf, bern, du, dv)
    44
    55  IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/gcm.F90

    r5103 r5106  
    77
    88  USE IOIPSL
    9 
    10 
    11 ! ug Pour les sorties XIOS
    12   USE wxios
    13 
    14   USE filtreg_mod
     9  USE wxios  ! ug Pour les sorties XIOS
     10
     11  USE lmdz_filtreg, ONLY: inifilr
    1512  USE infotrac, ONLY: nqtot, init_infotrac
    1613  USE control_mod

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/iniacademic.F90

    r5103 r5106  
    44SUBROUTINE iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
    55
    6   USE filtreg_mod, ONLY: inifilr
     6  USE lmdz_filtreg, ONLY: inifilr
    77  USE infotrac,    ONLY: nqtot, niso, iqIsoPha, tracers, getKey, isoName
    88  USE control_mod, ONLY: day_step,planet_type

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/iniinterp_horiz.F90

    r5105 r5106  
    22! $Header$
    33!
    4 SUBROUTINE iniinterp_horiz (imo, jmo, imn, jmn, kllm, &
     4SUBROUTINE iniinterp_horiz(imo, jmo, imn, jmn, kllm, &
    55        rlonuo, rlatvo, rlonun, rlatvn, &
    66        ktotal, iik, jjk, jk, ik, intersec, airen)

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/interp_horiz.F90

    r5105 r5106  
    22! $Id$
    33!
    4 SUBROUTINE interp_horiz (varo, varn, imo, jmo, imn, jmn, lm, &
     4SUBROUTINE interp_horiz(varo, varn, imo, jmo, imn, jmn, lm, &
    55        rlonuo, rlatvo, rlonun, rlatvn)
    66

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/vlspltqs.F90

    r5105 r5106  
    22! $Id$
    33!
    4 SUBROUTINE vlspltqs (q, pente_max, masse, w, pbaru, pbarv, pdt, &
     4SUBROUTINE vlspltqs(q, pente_max, masse, w, pbaru, pbarv, pdt, &
    55        p, pk, teta, iq)
    66  USE infotrac, ONLY: nqtot, tracers

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/bernoui.f90

    r5105 r5106  
    22! $Header$
    33
    4 SUBROUTINE bernoui (ngrid,nlay,pphi,pecin,pbern)
     4SUBROUTINE bernoui(ngrid,nlay,pphi,pecin,pbern)
     5  USE lmdz_filtreg, ONLY: filtreg
    56  IMPLICIT NONE
    67

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/convmas.F90

    r5099 r5106  
    1 SUBROUTINE convmas (pbaru, pbarv, convm)
     1SUBROUTINE convmas(pbaru, pbarv, convm)
    22
    33!-------------------------------------------------------------------------------
    … …  
    55!-------------------------------------------------------------------------------
    66! Purpose: Compute mass flux convergence at p levels.
     7  USE lmdz_filtreg, ONLY: filtreg
    78  IMPLICIT NONE
    89  include "dimensions.h"

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/covcont.F90

    r5099 r5106  
    1 SUBROUTINE covcont (klevel,ucov, vcov, ucont, vcont )
     1SUBROUTINE covcont(klevel,ucov, vcov, ucont, vcont )
    22
    33!-------------------------------------------------------------------------------

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divergf.f90

    r5105 r5106  
    1111  !          x et y  etant des composantes covariantes   ...
    1212  !  *********************************************************************
     13  USE lmdz_filtreg, ONLY: filtreg
    1314  IMPLICIT NONE
    1415  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divgrad.f90

    r5105 r5106  
    22! $Header$
    33
    4 SUBROUTINE divgrad (klevel,h, lh, divgra )
     4SUBROUTINE divgrad(klevel,h, lh, divgra )
     5  USE lmdz_filtreg, ONLY: filtreg
    56  IMPLICIT NONE
    67  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divgrad2.f90

    r5105 r5106  
    22! $Header$
    33
    4 SUBROUTINE divgrad2 ( klevel, h, deltapres, lh, divgra )
     4SUBROUTINE divgrad2( klevel, h, deltapres, lh, divgra )
    55  !
    66  ! P. Le Van

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/enercin.F90

    r5099 r5106  
    1 SUBROUTINE enercin ( vcov, ucov, vcont, ucont, ecin )
     1SUBROUTINE enercin( vcov, ucov, vcont, ucont, ecin )
    22
    33!-------------------------------------------------------------------------------

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/exner_hyb_m.F90

    r5103 r5106  
    55contains
    66
    7   SUBROUTINE  exner_hyb ( ngrid, ps, p, pks, pk, pkf )
     7  SUBROUTINE exner_hyb( ngrid, ps, p, pks, pk, pkf )
    88
    99    !     Auteurs :  P.Le Van  , Fr. Hourdin  .
    … …  
    3535    USE comconst_mod, ONLY: jmp1, cpp, kappa, r
    3636    USE comvert_mod, ONLY: preff
     37    USE lmdz_filtreg, ONLY: filtreg
    3738   
    3839    IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/exner_milieu_m.F90

    r5103 r5106  
    55contains
    66
    7   SUBROUTINE  exner_milieu ( ngrid, ps, p, pks, pk, pkf )
     7  SUBROUTINE exner_milieu( ngrid, ps, p, pks, pk, pkf )
    88
    99    !     Auteurs :  F. Forget , Y. Wanherdrick
    … …  
    3232    USE comconst_mod, ONLY: jmp1, cpp, kappa, r
    3333    USE comvert_mod, ONLY: preff
     34    USE lmdz_filtreg, ONLY: filtreg
    3435   
    3536    IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/extrapol.f90

    r5105 r5106  
    44!
    55!
    6 SUBROUTINE extrapol (pfild, kxlon, kylat, pmask, &
     6SUBROUTINE extrapol(pfild, kxlon, kylat, pmask, &
    77        norsud, ldper, knbor, pwork)
    88  IMPLICIT none

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/flumass.F90

    r5099 r5106  
    1 SUBROUTINE flumass (massebx,masseby, vcont, ucont, pbaru, pbarv )
     1SUBROUTINE flumass(massebx,masseby, vcont, ucont, pbaru, pbarv )
    22
    33!-------------------------------------------------------------------------------

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/fxy.f90

    r5105 r5106  
    22! $Id$
    33
    4 SUBROUTINE fxy (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, &
     4SUBROUTINE fxy(rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, &
    55        rlatu2,yprimu2, &
    66        rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/fxysinus.f90

    r5105 r5106  
    22! $Id$
    33
    4 SUBROUTINE fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, &
     4SUBROUTINE fxysinus(rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, &
    55        rlatu2,yprimu2, &
    66        rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/geopot.f90

    r5105 r5106  
    22! $Header$
    33
    4 SUBROUTINE geopot (ngrid, teta, pk, pks, phis, phi )
     4SUBROUTINE geopot(ngrid, teta, pk, pks, phis, phi )
    55  IMPLICIT NONE
    66

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gradiv.f90

    r5105 r5106  
    1717  !
    1818  !
     19  USE lmdz_filtreg, ONLY: filtreg
    1920  IMPLICIT NONE
    2021  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gradiv2.f90

    r5105 r5106  
    1616  !
    1717  !
     18  USE lmdz_filtreg, ONLY: filtreg
    1819  IMPLICIT NONE
    1920  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/inidissip.F90

    r5101 r5106  
    22! $Id$
    33
    4 SUBROUTINE inidissip ( lstardis,nitergdiv,nitergrot,niterh  , &
     4SUBROUTINE inidissip( lstardis,nitergdiv,nitergrot,niterh  , &
    55     tetagdiv,tetagrot,tetatemp, vert_prof_dissip)
    66  !=======================================================================
    … …  
    1515                          dtdiss, dtvr, rad
    1616  USE comvert_mod, ONLY: preff, presnivs
     17  USE lmdz_filtreg, ONLY: filtreg
    1718
    1819  IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien.f90

    r5105 r5106  
    22! $Header$
    33
    4 SUBROUTINE laplacien ( klevel, teta, divgra )
     4SUBROUTINE laplacien( klevel, teta, divgra )
    55  !
    66  ! P. Le Van
    … …  
    1212  !  divgra     est  un argument  de sortie pour le s-prog
    1313  !
     14  USE lmdz_filtreg, ONLY: filtreg
    1415  IMPLICIT NONE
    1516  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien_gam.f90

    r5105 r5106  
    22! $Header$
    33
    4 SUBROUTINE laplacien_gam ( klevel, cuvsga, cvusga, unsaigam , &
     4SUBROUTINE laplacien_gam( klevel, cuvsga, cvusga, unsaigam , &
    55        unsapolnga, unsapolsga, teta, divgra )
    66

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien_rot.f90

    r5105 r5106  
    22! $Header$
    33
    4 SUBROUTINE laplacien_rot ( klevel, rotin, rotout,ghx,ghy )
     4SUBROUTINE laplacien_rot( klevel, rotin, rotout,ghx,ghy )
    55  !
    66  !    P. Le Van
    … …  
    1313  !  rotout           est  un argument  de sortie pour le s-prog
    1414  !
     15  USE lmdz_filtreg, ONLY: filtreg
    1516  IMPLICIT NONE
    1617  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien_rotgam.f90

    r5105 r5106  
    22! $Header$
    33
    4 SUBROUTINE laplacien_rotgam ( klevel, rotin, rotout )
     4SUBROUTINE laplacien_rotgam( klevel, rotin, rotout )
    55  !
    66  ! P. Le Van

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrad.f90

    r5105 r5106  
    22! $Header$
    33
    4 SUBROUTINE nxgrad (klevel, rot, x, y )
     4SUBROUTINE nxgrad(klevel, rot, x, y )
    55  !
    66  ! P. Le Van

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgradst.f90

    r5105 r5106  
    22! $Header$
    33
    4 SUBROUTINE nxgradst (klevel,rot, x, y )
     4SUBROUTINE nxgradst(klevel,rot, x, y )
    55  !
    66  IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgraro2.f90

    r5105 r5106  
    22! $Header$
    33
    4  SUBROUTINE nxgraro2 (klevel,xcov, ycov, lr, grx, gry )
     4 SUBROUTINE nxgraro2(klevel,xcov, ycov, lr, grx, gry )
    55  !
    66  !  P.Le Van .
    … …  
    1515  !
    1616  !
     17  USE lmdz_filtreg, ONLY: filtreg
    1718  IMPLICIT NONE
    1819  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrarot.f90

    r5105 r5106  
    22! $Header$
    33
    4 SUBROUTINE nxgrarot (klevel,xcov, ycov, lr, grx, gry )
     4SUBROUTINE nxgrarot(klevel,xcov, ycov, lr, grx, gry )
    55  !   ***********************************************************
    66  !
    … …  
    1616  !
    1717  !
     18  USE lmdz_filtreg, ONLY: filtreg
    1819  IMPLICIT NONE
    1920  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/pbar.f90

    r5105 r5106  
    22! $Header$
    33
    4 SUBROUTINE pbar ( pext, pbarx, pbary, pbarxy )
     4SUBROUTINE pbar( pext, pbarx, pbary, pbarxy )
    55  IMPLICIT NONE
    66

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/pentes_ini.f90

    r5105 r5106  
    22! $Header$
    33
    4 SUBROUTINE pentes_ini (q,w,masse,pbaru,pbarv,mode)
     4SUBROUTINE pentes_ini(q,w,masse,pbaru,pbarv,mode)
    55
    66  USE comconst_mod, ONLY: pi, dtvr

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/ppm3d.f90

    r5105 r5106  
    17441744end subroutine cosc
    17451745!
    1746 SUBROUTINE qckxyz (Q,qtmp,IMR,JNP,NLAY,j1,j2,cosp,acosp, &
     1746SUBROUTINE qckxyz(Q,qtmp,IMR,JNP,NLAY,j1,j2,cosp,acosp, &
    17471747        cross,IC,NSTEP)
    17481748  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/prather.f90

    r5105 r5106  
    22! $Header$
    33
    4 SUBROUTINE prather (q,w,masse,pbaru,pbarv,nt,dt)
     4SUBROUTINE prather(q,w,masse,pbaru,pbarv,nt,dt)
    55
    66  USE comconst_mod, ONLY: pi

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/psextbar.f90

    r5105 r5106  
    22! $Header$
    33
    4 SUBROUTINE psextbar ( ps, psexbarxy )
     4SUBROUTINE psextbar( ps, psexbarxy )
    55  IMPLICIT NONE
    66

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotat.f90

    r5105 r5106  
    22! $Header$
    33
    4 SUBROUTINE rotat (klevel, x, y, rot )
     4SUBROUTINE rotat(klevel, x, y, rot )
    55  !
    66  ! Auteur : P.Le Van

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotat_nfil.f90

    r5105 r5106  
    22! $Header$
    33
    4 SUBROUTINE rotat_nfil (klevel, x, y, rot )
     4SUBROUTINE rotat_nfil(klevel, x, y, rot )
    55  !
    66  !    Auteur :   P.Le Van

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotatf.f90

    r5105 r5106  
    22! $Header$
    33
    4 SUBROUTINE rotatf (klevel, x, y, rot )
     4SUBROUTINE rotatf(klevel, x, y, rot )
    55  !
    66  ! Auteur : P.Le Van
    … …  
    1414  !        rot          est  un argument  de sortie pour le s-prog
    1515  !
     16  USE lmdz_filtreg, ONLY: filtreg
    1617  IMPLICIT NONE
    1718  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/rotatst.f90

    r5105 r5106  
    22! $Header$
    33
    4 SUBROUTINE rotatst (klevel,x, y, rot )
     4SUBROUTINE rotatst(klevel,x, y, rot )
    55  !
    66  !  P. Le Van

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/sortvarc.f90

    r5105 r5106  
    1212        etot0,ptot0,ztot0,stot0,ang0, &
    1313        rmsdpdt,rmsv
     14  USE lmdz_filtreg, ONLY: filtreg
    1415  IMPLICIT NONE
    1516

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/test_period.f90

    r5105 r5106  
    22! $Header$
    33
    4 SUBROUTINE test_period ( ucov, vcov, teta, q, p, phis )
     4SUBROUTINE test_period( ucov, vcov, teta, q, p, phis )
    55  !
    66  ! Auteur : P. Le Van

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/tourpot.F90

    r5099 r5106  
    1 SUBROUTINE tourpot ( vcov, ucov, massebxy, vorpot )
     1SUBROUTINE tourpot( vcov, ucov, massebxy, vorpot )
    22
    33!-------------------------------------------------------------------------------
    … …  
    55!-------------------------------------------------------------------------------
    66! Purpose: Compute potential vorticity.
     7  USE lmdz_filtreg, ONLY: filtreg
    78  IMPLICIT NONE
    89  include "dimensions.h"

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/vitvert.F90

    r5099 r5106  
    1 SUBROUTINE vitvert (convm, w)
     1SUBROUTINE vitvert(convm, w)
    22
    33!-------------------------------------------------------------------------------

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/bernoui_loc.f90

    r5105 r5106  
    1 SUBROUTINE bernoui_loc (ngrid,nlay,pphi,pecin,pbern)
     1SUBROUTINE bernoui_loc(ngrid,nlay,pphi,pecin,pbern)
    22  USE parallel_lmdz
    3   USE mod_filtreg_p
     3  USE lmdz_filtreg_p
    44  IMPLICIT NONE
    55

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/bilan_dyn_loc.f90

    r5105 r5106  
    22! $Id: bilan_dyn_p.F 1299 2010-01-20 14:27:21Z fairhead $
    33
    4 SUBROUTINE bilan_dyn_loc (ntrac,dt_app,dt_cum, &
     4SUBROUTINE bilan_dyn_loc(ntrac,dt_app,dt_cum, &
    55        ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac)
    66

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/convmas1_loc.F90

    r5099 r5106  
    1 SUBROUTINE convmas1_loc (pbaru, pbarv, convm)
     1SUBROUTINE convmas1_loc(pbaru, pbarv, convm)
    22
    33!-------------------------------------------------------------------------------
    … …  
    77!          Equivalent to convmas_loc if convmas2_loc is called after.
    88  USE parallel_lmdz
    9   USE mod_filtreg_p
     9  USE lmdz_filtreg_p
    1010  IMPLICIT NONE
    1111  include "dimensions.h"

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/convmas2_loc.F90

    r5099 r5106  
    1 SUBROUTINE convmas2_loc (convm)
     1SUBROUTINE convmas2_loc(convm)
    22
    33!-------------------------------------------------------------------------------

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/convmas_loc.F90

    r5099 r5106  
    1 SUBROUTINE convmas_loc (pbaru, pbarv, convm)
     1SUBROUTINE convmas_loc(pbaru, pbarv, convm)
    22
    33!-------------------------------------------------------------------------------
    … …  
    66! Purpose: Compute mass flux convergence at p levels.
    77  USE parallel_lmdz
    8   USE mod_filtreg_p
     8  USE lmdz_filtreg_p
    99  IMPLICIT NONE
    1010  include "dimensions.h"

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/covcont_loc.f90

    r5105 r5106  
    1 SUBROUTINE covcont_loc (klevel,ucov, vcov, ucont, vcont )
     1SUBROUTINE covcont_loc(klevel,ucov, vcov, ucont, vcont )
    22  USE parallel_lmdz
    33  IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/divergf_loc.f90

    r5105 r5106  
    99  !  *********************************************************************
    1010  USE parallel_lmdz
    11   USE mod_filtreg_p
     11  USE lmdz_filtreg_p
    1212  IMPLICIT NONE
    1313  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/divgrad2_loc.f90

    r5105 r5106  
    1 SUBROUTINE divgrad2_loc ( klevel, h, deltapres, lh, divgra_out )
     1SUBROUTINE divgrad2_loc( klevel, h, deltapres, lh, divgra_out )
    22  !
    33  ! P. Le Van

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dteta1_loc.f90

    r5105 r5106  
    1 SUBROUTINE dteta1_loc ( teta, pbaru, pbarv, dteta)
     1SUBROUTINE dteta1_loc( teta, pbaru, pbarv, dteta)
    22  USE parallel_lmdz
    33  USE write_field_p
    4   USE mod_filtreg_p
     4  USE lmdz_filtreg_p
    55  IMPLICIT NONE
    66

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dudv1_loc.f90

    r5105 r5106  
    1 SUBROUTINE dudv1_loc ( vorpot, pbaru, pbarv, du, dv )
     1SUBROUTINE dudv1_loc( vorpot, pbaru, pbarv, du, dv )
    22  USE parallel_lmdz
    33  IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/dudv2_loc.f90

    r5105 r5106  
    1 SUBROUTINE dudv2_loc ( teta, pkf, bern, du, dv  )
     1SUBROUTINE dudv2_loc( teta, pkf, bern, du, dv  )
    22  USE parallel_lmdz
    33  IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/enercin_loc.F90

    r5099 r5106  
    1 SUBROUTINE enercin_loc ( vcov, ucov, vcont, ucont, ecin )
     1SUBROUTINE enercin_loc( vcov, ucov, vcont, ucont, ecin )
    22
    33!-------------------------------------------------------------------------------

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/exner_hyb_loc_m.F90

    r5103 r5106  
    3232
    3333    USE parallel_lmdz
    34     USE mod_filtreg_p
     34    USE lmdz_filtreg_p
    3535    USE write_field_loc
    3636    USE comconst_mod, ONLY: cpp, kappa, r, jmp1

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/exner_milieu_loc_m.F90

    r5103 r5106  
    55contains
    66
    7   SUBROUTINE  exner_milieu_loc ( ngrid, ps, p, pks, pk, pkf )
     7  SUBROUTINE exner_milieu_loc( ngrid, ps, p, pks, pk, pkf )
    88
    99    !     Auteurs :  F. Forget , Y. Wanherdrick
    … …  
    3030
    3131    USE parallel_lmdz
    32     USE mod_filtreg_p
     32    USE lmdz_filtreg_p
    3333    USE comconst_mod, ONLY: cpp, kappa, r, jmp1
    3434    USE comvert_mod, ONLY: preff

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/filtreg_p.F90

    r5105 r5106  
    1 
    2 
    3 SUBROUTINE filtreg_p ( champ, ibeg, iend, nlat, nbniv, &
     1! Amaury: on a ce fichier + lmdz_filtreg_p ! C'est totalement incompréhensible ;_;
     2! A minima il faut un nom clair pour chaque
     3
     4SUBROUTINE filtreg_p( champ, ibeg, iend, nlat, nbniv, &
    45        ifiltre, iaire, griscal ,iter)
    56  USE parallel_lmdz, ONLY: OMP_CHUNK
    67  USE mod_filtre_fft
    78  USE timer_filtre
    8 
    9   USE filtreg_mod
     9  USE lmdz_coefils, ONLY: jfiltnu, jfiltnv, jfiltsu, jfiltsv, sddu, sddv, unsddu, unsddv, modfrstv, modfrstu
     10  USE lmdz_filtreg, ONLY: matrinvn, matrinvs, matriceun, matriceus, matricevn, matricevs
    1011
    1112  IMPLICIT NONE
    … …  
    5354  INCLUDE "dimensions.h"
    5455  INCLUDE "paramet.h"
    55   INCLUDE "coefils.h"
    56   !
     56
    5757  INTEGER :: ibeg,iend,nlat,nbniv,ifiltre,iter
    5858  INTEGER :: i,j,l,k

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/gcm.F90

    r5103 r5106  
    1111  USE mod_hallo
    1212  USE Bands
    13   USE filtreg_mod
     13  USE lmdz_filtreg
    1414  USE control_mod
    1515
    … …  
    2424                       dt,hour_ini,itaufin
    2525  USE mod_xios_dyn3dmem, ONLY: xios_dyn3dmem_init
     26  USE lmdz_filtreg, ONLY: inifilr
    2627
    2728  IMPLICIT NONE
    … …  
    6364  include "iniprint.h"
    6465  include "tracstoke.h"
    65 
    6666
    6767  REAL zdtvr

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/geopot_loc.f90

    r5105 r5106  
    1 SUBROUTINE geopot_loc ( ngrid, teta, pk, pks, phis, phi )
     1SUBROUTINE geopot_loc( ngrid, teta, pk, pks, phis, phi )
    22  USE parallel_lmdz
    33  IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/gradiv2_loc.f90

    r5105 r5106  
    1717  USE Write_field_p
    1818  USE mod_hallo
    19   USE mod_filtreg_p
     19  USE lmdz_filtreg_p
    2020  USE gradiv2_mod
    2121  IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/iniacademic_loc.F90

    r5103 r5106  
    44SUBROUTINE iniacademic_loc(vcov,ucov,teta,q,masse,ps,phis,time_0)
    55
    6   USE filtreg_mod, ONLY: inifilr
     6  USE lmdz_filtreg, ONLY: inifilr
    77  USE infotrac,    ONLY: nqtot, niso, iqIsoPha, tracers, getKey, isoName
    88  USE control_mod, ONLY: day_step,planet_type

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/integrd_loc.f90

    r5105 r5106  
    77  USE parallel_lmdz
    88  USE control_mod
    9   USE mod_filtreg_p
     9  USE lmdz_filtreg_p
    1010  USE write_field_loc
    1111  USE write_field

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_gam_loc.f90

    r5105 r5106  
    1 SUBROUTINE laplacien_gam_loc ( klevel, cuvsga, cvusga, unsaigam, &
     1SUBROUTINE laplacien_gam_loc( klevel, cuvsga, cvusga, unsaigam, &
    22        unsapolnga, unsapolsga, teta, divgra )
    33

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_loc.f90

    r5105 r5106  
    1 SUBROUTINE laplacien_loc ( klevel, teta, divgra )
     1SUBROUTINE laplacien_loc( klevel, teta, divgra )
    22  !
    33  ! P. Le Van
    … …  
    1010  !
    1111  USE parallel_lmdz
    12   USE mod_filtreg_p
     12  USE lmdz_filtreg_p
    1313  IMPLICIT NONE
    1414  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_rot_loc.f90

    r5105 r5106  
    1 SUBROUTINE laplacien_rot_loc ( klevel, rotin, rotout,ghx,ghy )
     1SUBROUTINE laplacien_rot_loc( klevel, rotin, rotout,ghx,ghy )
    22  !
    33  !    P. Le Van
    … …  
    1111  !
    1212  USE parallel_lmdz
    13   USE mod_filtreg_p
     13  USE lmdz_filtreg_p
    1414  IMPLICIT NONE
    1515  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/laplacien_rotgam_loc.f90

    r5105 r5106  
    1 SUBROUTINE laplacien_rotgam_loc ( klevel, rotin, rotout )
     1SUBROUTINE laplacien_rotgam_loc( klevel, rotin, rotout )
    22  !
    33  ! P. Le Van

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/leapfrog_loc.F90

    r5105 r5106  
    1717  USE getparam
    1818  USE control_mod
    19   USE mod_filtreg_p
     19  USE lmdz_filtreg_p
    2020  USE write_field_loc
    2121  USE allocate_field_mod

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/lmdz_filtreg_p.F90

    r5105 r5106  
    1 MODULE mod_filtreg_p
     1MODULE lmdz_filtreg_p
     2  USE lmdz_filtreg, ONLY: matrinvn, matrinvs, matriceun, matriceus, matricevn, matricevs
     3
     4  IMPLICIT NONE; PRIVATE
     5  PUBLIC filtreg_p
    26
    37CONTAINS
    48
    5   SUBROUTINE filtreg_p ( champ,jjb,jje, ibeg, iend, nlat, nbniv, &
    6           ifiltre, iaire, griscal ,iter)
     9  SUBROUTINE filtreg_p(champ, jjb, jje, ibeg, iend, nlat, nbniv, &
     10          ifiltre, iaire, griscal, iter)
    711    USE parallel_lmdz, ONLY: OMP_CHUNK
    812    USE mod_filtre_fft_loc, ONLY: use_filtre_fft, filtre_u_fft, &
    9           filtre_v_fft, filtre_inv_fft
     13            filtre_v_fft, filtre_inv_fft
    1014    USE timer_filtre, ONLY: init_timer, start_timer, stop_timer
    11 
    12     USE filtreg_mod, ONLY: matrinvn, matrinvs, matriceun, matriceus, &
    13           matricevn, matricevs
    14 
    15     IMPLICIT NONE
     15    USE lmdz_coefils, ONLY: jfiltnu, jfiltnv, jfiltsu, jfiltsv, sddu, sddv, unsddu, unsddv, modfrstv, modfrstu
    1616
    1717    !=======================================================================
    … …  
    5757    INCLUDE "dimensions.h"
    5858    INCLUDE "paramet.h"
    59     INCLUDE "coefils.h"
    60     !
    61     INTEGER,INTENT(IN) :: jjb,jje,ibeg,iend,nlat,nbniv,ifiltre,iter
    62     INTEGER,INTENT(IN) :: iaire
    63     LOGICAL,INTENT(IN) :: griscal
    64     REAL,INTENT(INOUT) ::  champ( iip1,jjb:jje,nbniv)
    65 
    66     INTEGER :: i,j,l,k
    67     INTEGER :: iim2,immjm
    68     INTEGER :: jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil
     59    !
     60    INTEGER, INTENT(IN) :: jjb, jje, ibeg, iend, nlat, nbniv, ifiltre, iter
     61    INTEGER, INTENT(IN) :: iaire
     62    LOGICAL, INTENT(IN) :: griscal
     63    REAL, INTENT(INOUT) :: champ(iip1, jjb:jje, nbniv)
     64
     65    INTEGER :: i, j, l, k
     66    INTEGER :: iim2, immjm
     67    INTEGER :: jdfil1, jdfil2, jffil1, jffil2, jdfil, jffil
    6968    INTEGER :: hemisph
    70     REAL :: champ_fft(iip1,jjb:jje,nbniv)
    71      ! REAL :: champ_in(iip1,jjb:jje,nbniv)
    72 
    73     LOGICAL,SAVE     :: first=.TRUE.
    74 !$OMP THREADPRIVATE(first)
    75 
    76     REAL, DIMENSION(iip1,jjb:jje,nbniv) :: champ_loc
     69    REAL :: champ_fft(iip1, jjb:jje, nbniv)
     70    ! REAL :: champ_in(iip1,jjb:jje,nbniv)
     71
     72    LOGICAL, SAVE :: first = .TRUE.
     73    !$OMP THREADPRIVATE(first)
     74
     75    REAL, DIMENSION(iip1, jjb:jje, nbniv) :: champ_loc
    7776    INTEGER :: ll_nb, nbniv_loc
    78     REAL, SAVE :: sdd12(iim,4)
    79 !$OMP THREADPRIVATE(sdd12)
    80 
    81     INTEGER, PARAMETER :: type_sddu=1
    82     INTEGER, PARAMETER :: type_sddv=2
    83     INTEGER, PARAMETER :: type_unsddu=3
    84     INTEGER, PARAMETER :: type_unsddv=4
     77    REAL, SAVE :: sdd12(iim, 4)
     78    !$OMP THREADPRIVATE(sdd12)
     79
     80    INTEGER, PARAMETER :: type_sddu = 1
     81    INTEGER, PARAMETER :: type_sddv = 2
     82    INTEGER, PARAMETER :: type_unsddu = 3
     83    INTEGER, PARAMETER :: type_unsddv = 4
    8584
    8685    INTEGER :: sdd1_type, sdd2_type
    87     CHARACTER (LEN=132) :: abort_message
     86    CHARACTER (LEN = 132) :: abort_message
    8887
    8988    IF (first) THEN
    90        sdd12(1:iim,type_sddu) = sddu(1:iim)
    91        sdd12(1:iim,type_sddv) = sddv(1:iim)
    92        sdd12(1:iim,type_unsddu) = unsddu(1:iim)
    93        sdd12(1:iim,type_unsddv) = unsddv(1:iim)
    94 
    95        CALL Init_timer
    96        first=.FALSE.
     89      sdd12(1:iim, type_sddu) = sddu(1:iim)
     90      sdd12(1:iim, type_sddv) = sddv(1:iim)
     91      sdd12(1:iim, type_unsddu) = unsddu(1:iim)
     92      sdd12(1:iim, type_unsddv) = unsddv(1:iim)
     93
     94      CALL Init_timer
     95      first = .FALSE.
    9796    ENDIF
    9897
    99 !$OMP MASTER
     98    !$OMP MASTER
    10099    CALL start_timer
    101 !$OMP END MASTER
     100    !$OMP END MASTER
    102101
    103102    !-------------------------------------------------------c
    104103
    105104    IF(ifiltre==1.or.ifiltre==-1) &
    106           CALL abort_gcm("mod_filtreg_p",'Pas de transformee&
    107           &simple dans cette version',1)
    108 
    109     IF( iter== 2 )  THEN
    110        PRINT *,' Pas d iteration du filtre dans cette version !'&
    111              &        , ' Utiliser old_filtreg et repasser !'
    112        CALL abort_gcm("mod_filtreg_p","stopped",1)
     105            CALL abort_gcm("lmdz_filtreg_p", 'Pas de transformee&
     106                    &simple dans cette version', 1)
     107
     108    IF(iter== 2)  THEN
     109      PRINT *, ' Pas d iteration du filtre dans cette version !'&
     110              &, ' Utiliser old_filtreg et repasser !'
     111      CALL abort_gcm("lmdz_filtreg_p", "stopped", 1)
    113112    ENDIF
    114113
    115     IF( ifiltre== -2 .AND..NOT.griscal )     THEN
    116        PRINT *,' Cette routine ne calcule le filtre inverse que ' &
    117              , ' sur la grille des scalaires !'
    118        CALL abort_gcm("mod_filtreg_p","stopped",1)
     114    IF(ifiltre== -2 .AND..NOT.griscal)     THEN
     115      PRINT *, ' Cette routine ne calcule le filtre inverse que ' &
     116              , ' sur la grille des scalaires !'
     117      CALL abort_gcm("lmdz_filtreg_p", "stopped", 1)
    119118    ENDIF
    120119
    121     IF( ifiltre/=2 .AND.ifiltre/= - 2 )  THEN
    122        PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2' &
    123              , ' corriger et repasser !'
    124        CALL abort_gcm("mod_filtreg_p","stopped",1)
     120    IF(ifiltre/=2 .AND.ifiltre/= - 2)  THEN
     121      PRINT *, ' Probleme dans filtreg car ifiltre NE 2 et NE -2' &
     122              , ' corriger et repasser !'
     123      CALL abort_gcm("lmdz_filtreg_p", "stopped", 1)
    125124    ENDIF
    126125    !
    127126
    128     iim2   = iim * iim
    129     immjm  = iim * jjm
    130     !
    131     !
    132     IF( griscal )   THEN
    133        IF( nlat /= jjp1 )  THEN
    134           CALL abort_gcm("mod_filtreg_p"," nlat. NE. jjp1",1)
    135        ELSE
    136     !
    137           IF( iaire==1 )  THEN
    138              sdd1_type = type_sddv
    139              sdd2_type = type_unsddv
     127    iim2 = iim * iim
     128    immjm = iim * jjm
     129    !
     130    !
     131    IF(griscal)   THEN
     132      IF(nlat /= jjp1)  THEN
     133        CALL abort_gcm("lmdz_filtreg_p", " nlat. NE. jjp1", 1)
     134      ELSE
     135        !
     136        IF(iaire==1)  THEN
     137          sdd1_type = type_sddv
     138          sdd2_type = type_unsddv
     139        ELSE
     140          sdd1_type = type_unsddv
     141          sdd2_type = type_sddv
     142        ENDIF
     143        !
     144        jdfil1 = 2
     145        jffil1 = jfiltnu
     146        jdfil2 = jfiltsu
     147        jffil2 = jjm
     148      ENDIF
     149    ELSE
     150      IF(nlat/=jjm)  THEN
     151        CALL abort_gcm("lmdz_filtreg_p", " nlat. NE. jjm", 1)
     152      ELSE
     153        !
     154        IF(iaire==1)  THEN
     155          sdd1_type = type_sddu
     156          sdd2_type = type_unsddu
     157        ELSE
     158          sdd1_type = type_unsddu
     159          sdd2_type = type_sddu
     160        ENDIF
     161        !
     162        jdfil1 = 1
     163        jffil1 = jfiltnv
     164        jdfil2 = jfiltsv
     165        jffil2 = jjm
     166      ENDIF
     167    ENDIF
     168    !
     169    DO hemisph = 1, 2
     170      !
     171      IF (hemisph==1)  THEN
     172        !ym
     173        jdfil = max(jdfil1, ibeg)
     174        jffil = min(jffil1, iend)
     175      ELSE
     176        !ym
     177        jdfil = max(jdfil2, ibeg)
     178        jffil = min(jffil2, iend)
     179      ENDIF
     180
     181
     182      !ccccccccccccccccccccccccccccccccccccccccccc
     183      ! Utilisation du filtre classique
     184      !ccccccccccccccccccccccccccccccccccccccccccc
     185
     186      IF (.NOT. use_filtre_fft) THEN
     187
     188        ! !---------------------------------!
     189        ! ! Agregation des niveau verticaux !
     190        ! ! uniquement necessaire pour une  !
     191        ! ! execution OpenMP                !
     192        ! !---------------------------------!
     193        ll_nb = 0
     194        !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     195        DO l = 1, nbniv
     196          ll_nb = ll_nb + 1
     197          DO j = jdfil, jffil
     198            DO i = 1, iim
     199              champ_loc(i, j, ll_nb) = &
     200                      champ(i, j, l) * sdd12(i, sdd1_type)
     201            ENDDO
     202          ENDDO
     203        ENDDO
     204        !$OMP END DO NOWAIT
     205
     206        nbniv_loc = ll_nb
     207
     208        IF(hemisph==1)      THEN
     209
     210          IF(ifiltre==-2)   THEN
     211            DO j = jdfil, jffil
     212#ifdef BLAS
     213                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
     214                         matrinvn(1,1,j), iim, &
     215                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
     216                         champ_fft(1,j,1), iip1*(jje-jjb+1))
     217#else
     218              champ_fft(1:iim, j, 1:nbniv_loc) = &
     219                      matmul(matrinvn(1:iim, 1:iim, j), &
     220                              champ_loc(1:iim, j, 1:nbniv_loc))
     221#endif
     222            ENDDO
     223
     224          ELSE IF (griscal)     THEN
     225            DO j = jdfil, jffil
     226#ifdef BLAS
     227                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
     228                         matriceun(1,1,j), iim, &
     229                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
     230                         champ_fft(1,j,1), iip1*(jje-jjb+1))
     231#else
     232              champ_fft(1:iim, j, 1:nbniv_loc) = &
     233                      matmul(matriceun(1:iim, 1:iim, j), &
     234                              champ_loc(1:iim, j, 1:nbniv_loc))
     235#endif
     236            ENDDO
     237
    140238          ELSE
    141              sdd1_type = type_unsddv
    142              sdd2_type = type_sddv
     239            DO j = jdfil, jffil
     240#ifdef BLAS
     241                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
     242                         matricevn(1,1,j), iim, &
     243                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
     244                         champ_fft(1,j,1), iip1*(jje-jjb+1))
     245#else
     246              champ_fft(1:iim, j, 1:nbniv_loc) = &
     247                      matmul(matricevn(1:iim, 1:iim, j), &
     248                              champ_loc(1:iim, j, 1:nbniv_loc))
     249#endif
     250            ENDDO
     251
    143252          ENDIF
    144     !
    145           jdfil1 = 2
    146           jffil1 = jfiltnu
    147           jdfil2 = jfiltsu
    148           jffil2 = jjm
    149        ENDIF
    150     ELSE
    151        IF( nlat/=jjm )  THEN
    152           CALL abort_gcm("mod_filtreg_p"," nlat. NE. jjm",1)
    153        ELSE
    154     !
    155           IF( iaire==1 )  THEN
    156              sdd1_type = type_sddu
    157              sdd2_type = type_unsddu
     253
     254        ELSE
     255
     256          IF(ifiltre==-2)   THEN
     257            DO j = jdfil, jffil
     258#ifdef BLAS
     259                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
     260                         matrinvs(1,1,j-jfiltsu+1), iim, &
     261                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
     262                         champ_fft(1,j,1), iip1*(jje-jjb+1))
     263#else
     264              champ_fft(1:iim, j, 1:nbniv_loc) = &
     265                      matmul(matrinvs(1:iim, 1:iim, j - jfiltsu + 1), &
     266                              champ_loc(1:iim, j, 1:nbniv_loc))
     267#endif
     268            ENDDO
     269
     270          ELSE IF (griscal)     THEN
     271
     272            DO j = jdfil, jffil
     273#ifdef BLAS
     274                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
     275                         matriceus(1,1,j-jfiltsu+1), iim, &
     276                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
     277                         champ_fft(1,j,1), iip1*(jje-jjb+1))
     278#else
     279              champ_fft(1:iim, j, 1:nbniv_loc) = &
     280                      matmul(matriceus(1:iim, 1:iim, j - jfiltsu + 1), &
     281                              champ_loc(1:iim, j, 1:nbniv_loc))
     282#endif
     283            ENDDO
     284
    158285          ELSE
    159              sdd1_type = type_unsddu
    160              sdd2_type = type_sddu
     286
     287            DO j = jdfil, jffil
     288#ifdef BLAS
     289                   CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
     290                         matricevs(1,1,j-jfiltsv+1), iim, &
     291                         champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
     292                         champ_fft(1,j,1), iip1*(jje-jjb+1))
     293#else
     294              champ_fft(1:iim, j, 1:nbniv_loc) = &
     295                      matmul(matricevs(1:iim, 1:iim, j - jfiltsv + 1), &
     296                              champ_loc(1:iim, j, 1:nbniv_loc))
     297#endif
     298            ENDDO
     299
    161300          ENDIF
    162     !
    163           jdfil1 = 1
    164           jffil1 = jfiltnv
    165           jdfil2 = jfiltsv
    166           jffil2 = jjm
    167        ENDIF
    168     ENDIF
    169     !
    170     DO hemisph = 1, 2
    171     !
    172        IF ( hemisph==1 )  THEN
    173     !ym
    174           jdfil = max(jdfil1,ibeg)
    175           jffil = min(jffil1,iend)
    176        ELSE
    177     !ym
    178           jdfil = max(jdfil2,ibeg)
    179           jffil = min(jffil2,iend)
    180        ENDIF
    181 
    182 
    183     !ccccccccccccccccccccccccccccccccccccccccccc
    184     ! Utilisation du filtre classique
    185     !ccccccccccccccccccccccccccccccccccccccccccc
    186 
    187        IF (.NOT. use_filtre_fft) THEN
    188 
    189     ! !---------------------------------!
    190     ! ! Agregation des niveau verticaux !
    191     ! ! uniquement necessaire pour une  !
    192     ! ! execution OpenMP                !
    193     ! !---------------------------------!
     301
     302        ENDIF
     303        ! c
     304        IF(ifiltre==2)  THEN
     305
     306          ! !-------------------------------------!
     307          ! ! Dés-agregation des niveau verticaux !
     308          ! ! uniquement necessaire pour une      !
     309          ! ! execution OpenMP                    !
     310          ! !-------------------------------------!
    194311          ll_nb = 0
    195 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     312          !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    196313          DO l = 1, nbniv
    197              ll_nb = ll_nb+1
    198              DO j = jdfil,jffil
    199                 DO i = 1, iim
    200                    champ_loc(i,j,ll_nb) = &
    201                          champ(i,j,l) * sdd12(i,sdd1_type)
    202                 ENDDO
    203              ENDDO
    204           ENDDO
    205 !$OMP END DO NOWAIT
    206 
    207           nbniv_loc = ll_nb
    208 
    209           IF( hemisph==1 )      THEN
    210 
    211              IF( ifiltre==-2 )   THEN
    212                 DO j = jdfil,jffil
    213 #ifdef BLAS
    214                    CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
    215                          matrinvn(1,1,j), iim, &
    216                          champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
    217                          champ_fft(1,j,1), iip1*(jje-jjb+1))
    218 #else
    219                    champ_fft(1:iim,j,1:nbniv_loc)= &
    220                          matmul(matrinvn(1:iim,1:iim,j), &
    221                          champ_loc(1:iim,j,1:nbniv_loc))
    222 #endif
    223                 ENDDO
    224 
    225              ELSE IF ( griscal )     THEN
    226                 DO j = jdfil,jffil
    227 #ifdef BLAS
    228                    CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
    229                          matriceun(1,1,j), iim, &
    230                          champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
    231                          champ_fft(1,j,1), iip1*(jje-jjb+1))
    232 #else
    233                    champ_fft(1:iim,j,1:nbniv_loc)= &
    234                          matmul(matriceun(1:iim,1:iim,j), &
    235                          champ_loc(1:iim,j,1:nbniv_loc))
    236 #endif
    237                 ENDDO
    238 
    239              ELSE
    240                 DO j = jdfil,jffil
    241 #ifdef BLAS
    242                    CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
    243                          matricevn(1,1,j), iim, &
    244                          champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
    245                          champ_fft(1,j,1), iip1*(jje-jjb+1))
    246 #else
    247                    champ_fft(1:iim,j,1:nbniv_loc)= &
    248                          matmul(matricevn(1:iim,1:iim,j), &
    249                          champ_loc(1:iim,j,1:nbniv_loc))
    250 #endif
    251                 ENDDO
    252 
    253              ENDIF
    254 
     314            ll_nb = ll_nb + 1
     315            DO j = jdfil, jffil
     316              DO i = 1, iim
     317                champ(i, j, l) = (champ_loc(i, j, ll_nb) &
     318                        + champ_fft(i, j, ll_nb)) &
     319                        * sdd12(i, sdd2_type)
     320              ENDDO
     321            ENDDO
     322          ENDDO
     323          !$OMP END DO NOWAIT
     324
     325        ELSE
     326
     327          ll_nb = 0
     328          !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     329          DO l = 1, nbniv
     330            ll_nb = ll_nb + 1
     331            DO j = jdfil, jffil
     332              DO i = 1, iim
     333                champ(i, j, l) = (champ_loc(i, j, ll_nb) &
     334                        - champ_fft(i, j, ll_nb)) &
     335                        * sdd12(i, sdd2_type)
     336              ENDDO
     337            ENDDO
     338          ENDDO
     339          !$OMP END DO NOWAIT
     340
     341        ENDIF
     342
     343        !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     344        DO l = 1, nbniv
     345          DO j = jdfil, jffil
     346            ! ! add redundant longitude
     347            champ(iip1, j, l) = champ(1, j, l)
     348          ENDDO
     349        ENDDO
     350        !$OMP END DO NOWAIT
     351
     352        !cccccccccccccccccccccccccccccccccccccccccccc
     353        ! Utilisation du filtre FFT
     354        !cccccccccccccccccccccccccccccccccccccccccccc
     355
     356      ELSE
     357
     358        !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     359        DO l = 1, nbniv
     360          DO j = jdfil, jffil
     361            DO  i = 1, iim
     362              champ(i, j, l) = champ(i, j, l) * sdd12(i, sdd1_type)
     363              champ_fft(i, j, l) = champ(i, j, l)
     364            ENDDO
     365          ENDDO
     366        ENDDO
     367        !$OMP END DO NOWAIT
     368
     369        IF (jdfil<=jffil) THEN
     370          IF(ifiltre == -2)   THEN
     371            CALL Filtre_inv_fft(champ_fft, jjb, jje, jdfil, jffil, nbniv)
     372          ELSE IF (griscal)     THEN
     373            CALL Filtre_u_fft(champ_fft, jjb, jje, jdfil, jffil, nbniv)
    255374          ELSE
    256 
    257              IF( ifiltre==-2 )   THEN
    258                 DO j = jdfil,jffil
    259 #ifdef BLAS
    260                    CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
    261                          matrinvs(1,1,j-jfiltsu+1), iim, &
    262                          champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
    263                          champ_fft(1,j,1), iip1*(jje-jjb+1))
    264 #else
    265                    champ_fft(1:iim,j,1:nbniv_loc)= &
    266                          matmul(matrinvs(1:iim,1:iim,j-jfiltsu+1), &
    267                          champ_loc(1:iim,j,1:nbniv_loc))
    268 #endif
    269                 ENDDO
    270 
    271              ELSE IF ( griscal )     THEN
    272 
    273                 DO j = jdfil,jffil
    274 #ifdef BLAS
    275                    CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
    276                          matriceus(1,1,j-jfiltsu+1), iim, &
    277                          champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
    278                          champ_fft(1,j,1), iip1*(jje-jjb+1))
    279 #else
    280                    champ_fft(1:iim,j,1:nbniv_loc)= &
    281                          matmul(matriceus(1:iim,1:iim,j-jfiltsu+1), &
    282                          champ_loc(1:iim,j,1:nbniv_loc))
    283 #endif
    284                 ENDDO
    285 
    286              ELSE
    287 
    288                 DO j = jdfil,jffil
    289 #ifdef BLAS
    290                    CALL SGEMM("N", "N", iim, nbniv_loc, iim, 1.0, &
    291                          matricevs(1,1,j-jfiltsv+1), iim, &
    292                          champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, &
    293                          champ_fft(1,j,1), iip1*(jje-jjb+1))
    294 #else
    295                    champ_fft(1:iim,j,1:nbniv_loc)= &
    296                          matmul(matricevs(1:iim,1:iim,j-jfiltsv+1), &
    297                          champ_loc(1:iim,j,1:nbniv_loc))
    298 #endif
    299                 ENDDO
    300 
    301              ENDIF
    302 
     375            CALL Filtre_v_fft(champ_fft, jjb, jje, jdfil, jffil, nbniv)
    303376          ENDIF
    304     ! c
    305           IF( ifiltre==2 )  THEN
    306 
    307     ! !-------------------------------------!
    308     ! ! Dés-agregation des niveau verticaux !
    309     ! ! uniquement necessaire pour une      !
    310     ! ! execution OpenMP                    !
    311     ! !-------------------------------------!
    312              ll_nb = 0
    313 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    314              DO l = 1, nbniv
    315                 ll_nb = ll_nb + 1
    316                 DO j = jdfil,jffil
    317                    DO i = 1, iim
    318                       champ( i,j,l ) = (champ_loc(i,j,ll_nb) &
    319                             + champ_fft(i,j,ll_nb)) &
    320                             * sdd12(i,sdd2_type)
    321                    ENDDO
    322                 ENDDO
    323              ENDDO
    324 !$OMP END DO NOWAIT
    325 
    326           ELSE
    327 
    328              ll_nb = 0
    329 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    330              DO l = 1, nbniv
    331                 ll_nb = ll_nb + 1
    332                 DO j = jdfil,jffil
    333                    DO i = 1, iim
    334                       champ( i,j,l ) = (champ_loc(i,j,ll_nb) &
    335                             - champ_fft(i,j,ll_nb)) &
    336                             * sdd12(i,sdd2_type)
    337                    ENDDO
    338                 ENDDO
    339              ENDDO
    340 !$OMP END DO NOWAIT
    341 
    342           ENDIF
    343 
    344 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     377        ENDIF
     378
     379        IF(ifiltre== 2)  THEN
     380          !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    345381          DO l = 1, nbniv
    346              DO j = jdfil,jffil
    347                 ! ! add redundant longitude
    348                 champ( iip1,j,l ) = champ( 1,j,l )
    349              ENDDO
    350           ENDDO
    351 !$OMP END DO NOWAIT
    352 
    353     !cccccccccccccccccccccccccccccccccccccccccccc
    354     ! Utilisation du filtre FFT
    355     !cccccccccccccccccccccccccccccccccccccccccccc
    356 
    357        ELSE
    358 
    359 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    360           DO l=1,nbniv
    361              DO j=jdfil,jffil
    362                 DO  i = 1, iim
    363                    champ( i,j,l)= champ(i,j,l)*sdd12(i,sdd1_type)
    364                    champ_fft( i,j,l) = champ(i,j,l)
    365                 ENDDO
    366              ENDDO
    367           ENDDO
    368 !$OMP END DO NOWAIT
    369 
    370           IF (jdfil<=jffil) THEN
    371              IF( ifiltre == -2 )   THEN
    372               CALL Filtre_inv_fft(champ_fft,jjb,jje,jdfil,jffil,nbniv)
    373              ELSE IF ( griscal )     THEN
    374                 CALL Filtre_u_fft(champ_fft,jjb,jje,jdfil,jffil,nbniv)
    375              ELSE
    376                 CALL Filtre_v_fft(champ_fft,jjb,jje,jdfil,jffil,nbniv)
    377              ENDIF
    378           ENDIF
    379 
    380 
    381           IF( ifiltre== 2 )  THEN
    382 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    383              DO l=1,nbniv
    384                 DO j=jdfil,jffil
    385                    DO  i = 1, iim
    386                       champ( i,j,l)=(champ(i,j,l)+champ_fft(i,j,l)) &
    387                             *sdd12(i,sdd2_type)
    388                    ENDDO
    389                 ENDDO
    390              ENDDO
    391 !$OMP END DO NOWAIT     
    392           ELSE
    393 
    394 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    395              DO l=1,nbniv
    396                 DO j=jdfil,jffil
    397                    DO  i = 1, iim
    398                       champ(i,j,l)=(champ(i,j,l)-champ_fft(i,j,l)) &
    399                             *sdd12(i,sdd2_type)
    400                    ENDDO
    401                 ENDDO
    402              ENDDO
    403 !$OMP END DO NOWAIT
    404           ENDIF
    405     !
    406 !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    407           DO l=1,nbniv
    408              DO j=jdfil,jffil
    409            ! champ_FFT( iip1,j,l ) = champ_FFT( 1,j,l )
    410            !      ! add redundant longitude
    411                 champ( iip1,j,l ) = champ( 1,j,l )
    412              ENDDO
    413           ENDDO
    414 !$OMP END DO NOWAIT             
    415        ENDIF
    416     ! Fin de la zone de filtrage
    417 
     382            DO j = jdfil, jffil
     383              DO  i = 1, iim
     384                champ(i, j, l) = (champ(i, j, l) + champ_fft(i, j, l)) &
     385                        * sdd12(i, sdd2_type)
     386              ENDDO
     387            ENDDO
     388          ENDDO
     389          !$OMP END DO NOWAIT
     390        ELSE
     391
     392          !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     393          DO l = 1, nbniv
     394            DO j = jdfil, jffil
     395              DO  i = 1, iim
     396                champ(i, j, l) = (champ(i, j, l) - champ_fft(i, j, l)) &
     397                        * sdd12(i, sdd2_type)
     398              ENDDO
     399            ENDDO
     400          ENDDO
     401          !$OMP END DO NOWAIT
     402        ENDIF
     403        !
     404        !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     405        DO l = 1, nbniv
     406          DO j = jdfil, jffil
     407            ! champ_FFT( iip1,j,l ) = champ_FFT( 1,j,l )
     408            !      ! add redundant longitude
     409            champ(iip1, j, l) = champ(1, j, l)
     410          ENDDO
     411        ENDDO
     412        !$OMP END DO NOWAIT
     413      ENDIF
     414      ! Fin de la zone de filtrage
    418415
    419416    ENDDO
    420417
    421      ! DO j=1,nlat
    422 
    423      !     PRINT *,"check FFT ----> Delta(",j,")=",
     418    ! DO j=1,nlat
     419
     420    !     PRINT *,"check FFT ----> Delta(",j,")=",
    424421    ! &            sum(champ(:,j,:)-champ_fft(:,j,:))/sum(champ(:,j,:)),
    425422    ! &            sum(champ(:,j,:)-champ_in(:,j,:))/sum(champ(:,j,:))
    … …  
    430427
    431428    !
    432 !$OMP MASTER
     429    !$OMP MASTER
    433430    CALL stop_timer
    434 !$OMP END MASTER
     431    !$OMP END MASTER
    435432
    436433  END SUBROUTINE filtreg_p
    437 END MODULE mod_filtreg_p
    438 
     434END MODULE lmdz_filtreg_p
     435

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/nxgrad_loc.f90

    r5105 r5106  
    1 SUBROUTINE nxgrad_loc (klevel, rot, x, y )
     1SUBROUTINE nxgrad_loc(klevel, rot, x, y )
    22  !
    33  ! P. Le Van

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/nxgraro2_loc.f90

    r5105 r5106  
    1616  USE times
    1717  USE mod_hallo
    18   USE mod_filtreg_p
     18  USE lmdz_filtreg_p
    1919  USE nxgraro2_mod
    2020  IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/rotat_nfil_loc.f90

    r5105 r5106  
    1 SUBROUTINE rotat_nfil_loc (klevel, x, y, rot )
     1SUBROUTINE rotat_nfil_loc(klevel, x, y, rot )
    22  !
    33  !    Auteur :   P.Le Van

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/rotat_p.f90

    r5105 r5106  
    1 SUBROUTINE rotat_p (klevel, x, y, rot )
     1SUBROUTINE rotat_p(klevel, x, y, rot )
    22  !
    33  ! Auteur : P.Le Van

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/rotatf_loc.f90

    r5105 r5106  
    1 SUBROUTINE rotatf_loc (klevel, x, y, rot )
     1SUBROUTINE rotatf_loc(klevel, x, y, rot )
    22  !
    33  ! Auteur : P.Le Van
    … …  
    1111  !
    1212  USE parallel_lmdz
    13   USE mod_filtreg_p
     13  USE lmdz_filtreg_p
    1414  IMPLICIT NONE
    1515  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/tourpot_loc.F90

    r5099 r5106  
    1 SUBROUTINE tourpot_loc ( vcov, ucov, massebxy, vorpot )
     1SUBROUTINE tourpot_loc( vcov, ucov, massebxy, vorpot )
    22
    33!-------------------------------------------------------------------------------
    … …  
    66! Purpose: Compute potential vorticity.
    77  USE parallel_lmdz
    8   USE mod_filtreg_p
     8  USE lmdz_filtreg_p
    99  IMPLICIT NONE
    1010  include "dimensions.h"

  • LMDZ6/branches/Amaury_dev/libf/dynphy_lonlat/phylmd/ce0l.F90

    r5103 r5106  
    2626  USE dimphy,         ONLY: klon
    2727  USE test_disvert_m, ONLY: test_disvert
    28   USE filtreg_mod,    ONLY: inifilr
     28  USE lmdz_filtreg,    ONLY: inifilr
    2929  USE iniphysiq_mod,  ONLY: iniphysiq
    3030  USE mod_const_mpi,  ONLY: comm_lmdz

  • LMDZ6/branches/Amaury_dev/libf/dynphy_lonlat/phylmd/etat0dyn_netcdf.F90

    r5099 r5106  
    7676  USE exner_milieu_m, ONLY: exner_milieu
    7777  USE infotrac,       ONLY: nqtot, tracers
    78   USE filtreg_mod
     78  USE lmdz_filtreg
    7979  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA
    8080  IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/filtrez/inifgn.f90

    r5105 r5106  
    1 
    21! $Header: /home/cvsroot/LMDZ4/libf/filtrez/inifgn.F,v 1.1.1.1 2004-05-19 12:53:09 lmdzadmin Exp $
    32
    … …  
    65  !    ...  H.Upadyaya , O.Sharma  ...
    76  !
     7  USE lmdz_coefils, ONLY: sddv, sddu, unsddu, unsddv, eignfnv, eignfnu
    88  IMPLICIT NONE
    99  !
    … …  
    1111  include "paramet.h"
    1212  include "comgeom.h"
    13 
    1413  !
    15   REAL :: vec(iim,iim),vec1(iim,iim)
    16   REAL :: dlonu(iim),dlonv(iim)
    17   REAL :: du(iim),dv(iim),d(iim)
     14  REAL :: vec(iim, iim), vec1(iim, iim)
     15  REAL :: dlonu(iim), dlonv(iim)
     16  REAL :: du(iim), dv(iim), d(iim)
    1817  REAL :: pi
    19   INTEGER :: i,j,k,imm1,nrot
    20   !
    21   include "coefils.h"
    22   !
    23   EXTERNAL SSUM, acc,eigen,jacobi
     18  INTEGER :: i, j, k, imm1, nrot
     19  EXTERNAL SSUM, acc, eigen, jacobi
    2420  REAL :: SSUM
    2521  !
    2622
    27   imm1  = iim -1
    28   pi = 2.* ASIN(1.)
     23  imm1 = iim - 1
     24  pi = 2. * ASIN(1.)
    2925  !
    30   DO i=1,iim
    31    dlonu(i)=  xprimu( i )
    32    dlonv(i)=  xprimv( i )
     26  DO i = 1, iim
     27    dlonu(i) = xprimu(i)
     28    dlonv(i) = xprimv(i)
    3329  END DO
    3430
    35   DO i=1,iim
    36   sddv(i)  = SQRT(dlonv(i))
    37   sddu(i)  = SQRT(dlonu(i))
    38   unsddu(i) = 1./sddu(i)
    39   unsddv(i) = 1./sddv(i)
     31  DO i = 1, iim
     32    sddv(i) = SQRT(dlonv(i))
     33    sddu(i) = SQRT(dlonu(i))
     34    unsddu(i) = 1. / sddu(i)
     35    unsddv(i) = 1. / sddv(i)
    4036  END DO
    4137  !
    42   DO j=1,iim
    43   DO i=1,iim
    44   vec(i,j)    = 0.
    45   vec1(i,j)    = 0.
    46   eignfnv(i,j) = 0.
    47   eignfnu(i,j) = 0.
    48   END DO
     38  DO j = 1, iim
     39    DO i = 1, iim
     40      vec(i, j) = 0.
     41      vec1(i, j) = 0.
     42      eignfnv(i, j) = 0.
     43      eignfnu(i, j) = 0.
     44    END DO
    4945  END DO
    5046  !
    5147  !
    52   eignfnv(1,1)    = -1.
    53   eignfnv(iim,1)  = 1.
    54   DO i=1,imm1
    55   eignfnv(i+1,i+1)= -1.
    56   eignfnv(i,i+1)  = 1.
     48  eignfnv(1, 1) = -1.
     49  eignfnv(iim, 1) = 1.
     50  DO i = 1, imm1
     51    eignfnv(i + 1, i + 1) = -1.
     52    eignfnv(i, i + 1) = 1.
    5753  END DO
    58   DO j=1,iim
    59   DO i=1,iim
    60   eignfnv(i,j) = eignfnv(i,j)/(sddu(i)*sddv(j))
     54  DO j = 1, iim
     55    DO i = 1, iim
     56      eignfnv(i, j) = eignfnv(i, j) / (sddu(i) * sddv(j))
     57    END DO
    6158  END DO
    62   END DO
    63   DO j=1,iim
    64   DO i=1,iim
    65   eignfnu(i,j) = -eignfnv(j,i)
    66   END DO
     59  DO j = 1, iim
     60    DO i = 1, iim
     61      eignfnu(i, j) = -eignfnv(j, i)
     62    END DO
    6763  END DO
    6864  !
    6965  DO j = 1, iim
    70   DO i = 1, iim
    71     vec (i,j) = 0.0
    72     vec1(i,j) = 0.0
    73    DO k = 1, iim
    74     vec (i,j) = vec(i,j)  + eignfnu(i,k) * eignfnv(k,j)
    75     vec1(i,j) = vec1(i,j) + eignfnv(i,k) * eignfnu(k,j)
    76    ENDDO
    77   ENDDO
     66    DO i = 1, iim
     67      vec (i, j) = 0.0
     68      vec1(i, j) = 0.0
     69      DO k = 1, iim
     70        vec (i, j) = vec(i, j) + eignfnu(i, k) * eignfnv(k, j)
     71        vec1(i, j) = vec1(i, j) + eignfnv(i, k) * eignfnu(k, j)
     72      ENDDO
     73    ENDDO
    7874  ENDDO
    7975
    8076  !
    81   CALL jacobi(vec,iim,iim,dv,eignfnv,nrot)
    82   CALL acc(eignfnv,d,iim)
    83   CALL eigen_sort(dv,eignfnv,iim,iim)
     77  CALL jacobi(vec, iim, iim, dv, eignfnv, nrot)
     78  CALL acc(eignfnv, d, iim)
     79  CALL eigen_sort(dv, eignfnv, iim, iim)
    8480  !
    85   CALL jacobi(vec1,iim,iim,du,eignfnu,nrot)
    86   CALL acc(eignfnu,d,iim)
    87   CALL eigen_sort(du,eignfnu,iim,iim)
     81  CALL jacobi(vec1, iim, iim, du, eignfnu, nrot)
     82  CALL acc(eignfnu, d, iim)
     83  CALL eigen_sort(du, eignfnu, iim, iim)
    8884
    8985  !c   ancienne version avec appels IMSL

  • LMDZ6/branches/Amaury_dev/libf/filtrez/lmdz_coefils.f90

    r5104 r5106  
     1! $Id $
     2! replacement for coefils.h
     3MODULE lmdz_coefils
     4  IMPLICIT NONE; PRIVATE
     5  INCLUDE "dimensions.h"
     6  PUBLIC jfiltnu, jfiltsu, jfiltnv, jfiltsv, sddu, sddv, unsddu, unsddv, coefilu, coefilv, &
     7          modfrstu, modfrstv, eignfnu, eignfnv, coefilu2, coefilv2
    18
    2 ! $Id $
    3 
    4       COMMON/coefils/jfiltnu,jfiltsu,jfiltnv,jfiltsv,sddu(iim),sddv(iim)&
    5      & ,unsddu(iim),unsddv(iim),coefilu(iim,jjm),coefilv(iim,jjm),      &
    6      & modfrstu(jjm),modfrstv(jjm),eignfnu(iim,iim),eignfnv(iim,iim)    &
    7      & ,coefilu2(iim,jjm),coefilv2(iim,jjm)
    8 !c
    9       INTEGER jfiltnu ! index of the last lat line filtered in NH (U grid)
    10       INTEGER jfiltsu ! index of the first lat line filtered in SH (U grid)
    11       INTEGER jfiltnv ! index of the last lat line filtered in NH (V grid)
    12       INTEGER jfiltsv ! index of the first lat line filtered in SH (V grid)
    13       INTEGER modfrstu ! number of retained (ie: unfiltered) modes on U grid
    14       INTEGER modfrstv ! number of retained (ie: unfiltered) modes on V grid
    15       REAL    sddu,sddv,unsddu,unsddv,coefilu,coefilv,eignfnu,eignfnv
    16       REAL    coefilu2,coefilv2
     9  INTEGER :: jfiltnu ! index of the last lat line filtered in NH (U grid)
     10  INTEGER :: jfiltsu ! index of the first lat line filtered in SH (U grid)
     11  INTEGER :: jfiltnv ! index of the last lat line filtered in NH (V grid)
     12  INTEGER :: jfiltsv ! index of the first lat line filtered in SH (V grid)
     13  INTEGER, DIMENSION(jjm) :: modfrstu ! number of retained (ie: unfiltered) modes on U grid
     14  INTEGER, DIMENSION(jjm) :: modfrstv ! number of retained (ie: unfiltered) modes on V grid
     15  REAL, DIMENSION(iim) :: sddu, sddv, unsddu, unsddv
     16  REAL, DIMENSION(iim, jjm) :: coefilu, coefilv, coefilu2, coefilv2
     17  REAL, DIMENSION(iim, iim) :: eignfnu, eignfnv
     18END MODULE lmdz_coefils

  • LMDZ6/branches/Amaury_dev/libf/filtrez/lmdz_filtreg.F90

    r5105 r5106  
    1 
    21! $Id$
    32
    4 MODULE filtreg_mod
    5 
    6   REAL, DIMENSION(:,:,:), ALLOCATABLE :: matriceun,matriceus,matricevn
    7   REAL, DIMENSION(:,:,:), ALLOCATABLE :: matricevs,matrinvn,matrinvs
     3MODULE lmdz_filtreg
     4  IMPLICIT NONE; PRIVATE
     5  PUBLIC matriceun, matriceus, matricevn, matricevs, matrinvn, matrinvs, &
     6          inifilr, filtreg
     7
     8  REAL, DIMENSION(:, :, :), ALLOCATABLE :: matriceun, matriceus, matricevn
     9  REAL, DIMENSION(:, :, :), ALLOCATABLE :: matricevs, matrinvn, matrinvs
    810
    911CONTAINS
     12
     13  SUBROUTINE filtreg(champ, nlat, nbniv, ifiltre, iaire, &
     14          griscal, iter)
     15    USE lmdz_coefils, ONLY: jfiltnu, jfiltnv, jfiltsu, jfiltsv, sddu, sddv, unsddu, unsddv, modfrstv, modfrstu
     16
     17    !=======================================================================
     18    !
     19    !   Auteur: P. Le Van        07/10/97
     20    !   ------
     21    !
     22    !   Objet: filtre matriciel longitudinal ,avec les matrices precalculees
     23    !                 pour l'operateur  Filtre    .
     24    !   ------
     25    !
     26    !   Arguments:
     27    !   ----------
     28    !
     29    !  nblat                 nombre de latitudes a filtrer
     30    !  nbniv                 nombre de niveaux verticaux a filtrer
     31    !  champ(iip1,nblat,nbniv)  en entree : champ a filtrer
     32    !                        en sortie : champ filtre
     33    !  ifiltre               +1  Transformee directe
     34    !                        -1  Transformee inverse
     35    !                        +2  Filtre directe
     36    !                        -2  Filtre inverse
     37    !
     38    !  iaire                 1   si champ intensif
     39    !                        2   si champ extensif (pondere par les aires)
     40    !
     41    !  iter                  1   filtre simple
     42    !
     43    !=======================================================================
     44    !
     45    !
     46    !                  Variable Intensive
     47    !            ifiltre = 1     filtre directe
     48    !            ifiltre =-1     filtre inverse
     49    !
     50    !                  Variable Extensive
     51    !            ifiltre = 2     filtre directe
     52    !            ifiltre =-2     filtre inverse
     53    !
     54    !
     55    INCLUDE "dimensions.h"
     56    INCLUDE "paramet.h"
     57
     58    INTEGER :: nlat, nbniv, ifiltre, iter
     59    INTEGER :: i, j, l, k
     60    INTEGER :: iim2, immjm
     61    INTEGER :: jdfil1, jdfil2, jffil1, jffil2, jdfil, jffil
     62
     63    REAL :: champ(iip1, nlat, nbniv)
     64
     65    REAL :: eignq(iim, nlat, nbniv), sdd1(iim), sdd2(iim)
     66    LOGICAL :: griscal
     67    INTEGER :: hemisph, iaire
     68
     69    LOGICAL, SAVE :: first = .TRUE.
     70
     71    REAL, SAVE :: sdd12(iim, 4)
     72
     73    INTEGER, PARAMETER :: type_sddu = 1
     74    INTEGER, PARAMETER :: type_sddv = 2
     75    INTEGER, PARAMETER :: type_unsddu = 3
     76    INTEGER, PARAMETER :: type_unsddv = 4
     77
     78    INTEGER :: sdd1_type, sdd2_type
     79
     80    if (iim == 1) return ! no filtre in 2D y-z
     81
     82    IF (first) THEN
     83      sdd12(1:iim, type_sddu) = sddu(1:iim)
     84      sdd12(1:iim, type_sddv) = sddv(1:iim)
     85      sdd12(1:iim, type_unsddu) = unsddu(1:iim)
     86      sdd12(1:iim, type_unsddv) = unsddv(1:iim)
     87
     88      first = .FALSE.
     89    ENDIF
     90
     91    IF(ifiltre==1.or.ifiltre==-1) &
     92            stop 'Pas de transformee simple dans cette version'
     93
     94    IF(iter== 2)  THEN
     95      PRINT *, ' Pas d iteration du filtre dans cette version !'&
     96              &, ' Utiliser old_filtreg et repasser !'
     97      STOP
     98    ENDIF
     99
     100    IF(ifiltre== -2 .AND..NOT.griscal)     THEN
     101      PRINT *, ' Cette routine ne calcule le filtre inverse que ' &
     102              , ' sur la grille des scalaires !'
     103      STOP
     104    ENDIF
     105
     106    IF(ifiltre/=2 .AND.ifiltre/= - 2)  THEN
     107      PRINT *, ' Probleme dans filtreg car ifiltre NE 2 et NE -2' &
     108              , ' corriger et repasser !'
     109      STOP
     110    ENDIF
     111
     112    iim2 = iim * iim
     113    immjm = iim * jjm
     114
     115    IF(griscal)   THEN
     116      IF(nlat /= jjp1)  THEN
     117        PRINT  1111
     118        STOP
     119      ELSE
     120
     121        IF(iaire==1)  THEN
     122          sdd1_type = type_sddv
     123          sdd2_type = type_unsddv
     124        ELSE
     125          sdd1_type = type_unsddv
     126          sdd2_type = type_sddv
     127        ENDIF
     128
     129        ! IF( iaire.EQ.1 )  THEN
     130        !    CALL SCOPY(  iim,    sddv, 1,  sdd1, 1 )
     131        !    CALL SCOPY(  iim,  unsddv, 1,  sdd2, 1 )
     132        ! ELSE
     133        !    CALL SCOPY(  iim,  unsddv, 1,  sdd1, 1 )
     134        !    CALL SCOPY(  iim,    sddv, 1,  sdd2, 1 )
     135        ! END IF
     136
     137        jdfil1 = 2
     138        jffil1 = jfiltnu
     139        jdfil2 = jfiltsu
     140        jffil2 = jjm
     141      END IF
     142    ELSE
     143      IF(nlat/=jjm)  THEN
     144        PRINT  2222
     145        STOP
     146      ELSE
     147
     148        IF(iaire==1)  THEN
     149          sdd1_type = type_sddu
     150          sdd2_type = type_unsddu
     151        ELSE
     152          sdd1_type = type_unsddu
     153          sdd2_type = type_sddu
     154        ENDIF
     155
     156        ! IF( iaire.EQ.1 )  THEN
     157        !    CALL SCOPY(  iim,    sddu, 1,  sdd1, 1 )
     158        !    CALL SCOPY(  iim,  unsddu, 1,  sdd2, 1 )
     159        ! ELSE
     160        !    CALL SCOPY(  iim,  unsddu, 1,  sdd1, 1 )
     161        !    CALL SCOPY(  iim,    sddu, 1,  sdd2, 1 )
     162        ! END IF
     163
     164        jdfil1 = 1
     165        jffil1 = jfiltnv
     166        jdfil2 = jfiltsv
     167        jffil2 = jjm
     168      END IF
     169    END IF
     170
     171    DO hemisph = 1, 2
     172
     173      IF (hemisph==1)  THEN
     174        jdfil = jdfil1
     175        jffil = jffil1
     176      ELSE
     177        jdfil = jdfil2
     178        jffil = jffil2
     179      END IF
     180
     181      DO l = 1, nbniv
     182        DO j = jdfil, jffil
     183          DO i = 1, iim
     184            champ(i, j, l) = champ(i, j, l) * sdd12(i, sdd1_type) ! sdd1(i)
     185          END DO
     186        END DO
     187      END DO
     188
     189      IF(hemisph == 1)      THEN
     190
     191        IF(ifiltre == -2)   THEN
     192
     193          DO j = jdfil, jffil
     194#ifdef BLAS
     195              CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, &
     196                    matrinvn(1,1,j), &
     197                    iim, champ(1,j,1), iip1*nlat, 0.0, &
     198                    eignq(1,j-jdfil+1,1), iim*nlat)
     199#else
     200            eignq(:, j - jdfil + 1, :) &
     201                    = matmul(matrinvn(:, :, j), champ(:iim, j, :))
     202#endif
     203          END DO
     204
     205        ELSE IF (griscal)     THEN
     206
     207          DO j = jdfil, jffil
     208#ifdef BLAS
     209              CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, &
     210                    matriceun(1,1,j), &
     211                    iim, champ(1,j,1), iip1*nlat, 0.0, &
     212                    eignq(1,j-jdfil+1,1), iim*nlat)
     213#else
     214            eignq(:, j - jdfil + 1, :) &
     215                    = matmul(matriceun(:, :, j), champ(:iim, j, :))
     216#endif
     217          END DO
     218
     219        ELSE
     220
     221          DO j = jdfil, jffil
     222#ifdef BLAS
     223              CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, &
     224                    matricevn(1,1,j), &
     225                    iim, champ(1,j,1), iip1*nlat, 0.0, &
     226                    eignq(1,j-jdfil+1,1), iim*nlat)
     227#else
     228            eignq(:, j - jdfil + 1, :) &
     229                    = matmul(matricevn(:, :, j), champ(:iim, j, :))
     230#endif
     231          END DO
     232
     233        ENDIF
     234
     235      ELSE
     236
     237        IF(ifiltre == -2)   THEN
     238
     239          DO j = jdfil, jffil
     240#ifdef BLAS
     241              CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, &
     242                    matrinvs(1,1,j-jfiltsu+1), &
     243                    iim, champ(1,j,1), iip1*nlat, 0.0, &
     244                    eignq(1,j-jdfil+1,1), iim*nlat)
     245#else
     246            eignq(:, j - jdfil + 1, :) &
     247                    = matmul(matrinvs(:, :, j - jfiltsu + 1), &
     248                    champ(:iim, j, :))
     249#endif
     250          END DO
     251
     252        ELSE IF (griscal)     THEN
     253
     254          DO j = jdfil, jffil
     255#ifdef BLAS
     256              CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, &
     257                    matriceus(1,1,j-jfiltsu+1), &
     258                    iim, champ(1,j,1), iip1*nlat, 0.0, &
     259                    eignq(1,j-jdfil+1,1), iim*nlat)
     260#else
     261            eignq(:, j - jdfil + 1, :) &
     262                    = matmul(matriceus(:, :, j - jfiltsu + 1), &
     263                    champ(:iim, j, :))
     264#endif
     265          END DO
     266
     267        ELSE
     268
     269          DO j = jdfil, jffil
     270#ifdef BLAS
     271              CALL SGEMM("N", "N", iim, nbniv, iim, 1.0, &
     272                    matricevs(1,1,j-jfiltsv+1), &
     273                    iim, champ(1,j,1), iip1*nlat, 0.0, &
     274                    eignq(1,j-jdfil+1,1), iim*nlat)
     275#else
     276            eignq(:, j - jdfil + 1, :) &
     277                    = matmul(matricevs(:, :, j - jfiltsv + 1), &
     278                    champ(:iim, j, :))
     279#endif
     280          END DO
     281
     282        ENDIF
     283
     284      ENDIF
     285
     286      IF(ifiltre== 2)  THEN
     287
     288        DO l = 1, nbniv
     289          DO j = jdfil, jffil
     290            DO i = 1, iim
     291              champ(i, j, l) = &
     292                      (champ(i, j, l) + eignq(i, j - jdfil + 1, l)) &
     293                              * sdd12(i, sdd2_type) ! sdd2(i)
     294            END DO
     295          END DO
     296        END DO
     297
     298      ELSE
     299
     300        DO l = 1, nbniv
     301          DO j = jdfil, jffil
     302            DO i = 1, iim
     303              champ(i, j, l) = &
     304                      (champ(i, j, l) - eignq(i, j - jdfil + 1, l)) &
     305                              * sdd12(i, sdd2_type) ! sdd2(i)
     306            END DO
     307          END DO
     308        END DO
     309
     310      ENDIF
     311
     312      DO l = 1, nbniv
     313        DO j = jdfil, jffil
     314          champ(iip1, j, l) = champ(1, j, l)
     315        END DO
     316      END DO
     317
     318    ENDDO
     319
     320    1111   FORMAT(//20x, 'ERREUR dans le dimensionnement du tableau  CHAMP a&
     321            &     filtrer, sur la grille des scalaires'/)
     322    2222   FORMAT(//20x, 'ERREUR dans le dimensionnement du tableau CHAMP a fi&
     323            &     ltrer, sur la grille de V ou de Z'/)
     324    RETURN
     325  END SUBROUTINE filtreg
    10326
    11327  SUBROUTINE inifilr
    … …  
    14330  USE mod_filtre_fft_loc, ONLY: Init_filtre_fft_loc=>Init_filtre_fft    !
    15331#endif
    16   USE serre_mod, ONLY: alphax
    17   USE logic_mod, ONLY: fxyhypb, ysinus
    18   USE comconst_mod, ONLY: maxlatfilter
    19 
    20     !    ... H. Upadhyaya, O.Sharma   ...
    21 
    22     IMPLICIT NONE
     332    USE serre_mod, ONLY: alphax
     333    USE logic_mod, ONLY: fxyhypb, ysinus
     334    USE comconst_mod, ONLY: maxlatfilter
     335    USE lmdz_coefils, ONLY: modfrstv, modfrstu, jfiltnu, jfiltnv, coefilu, coefilv, &
     336            coefilu2, coefilv2, eignfnv, eignfnu, jfiltsu, jfiltsv
     337
     338    !    ... H. Upfiltreg_modadhyaya, O.Sharma   ...
    23339
    24340    !     version 3 .....
    … …  
    28344    include "dimensions.h"
    29345    include "paramet.h"
    30     !  -------------------------------------------------------------------
    31346    include "comgeom.h"
    32     include "coefils.h"
    33 
    34     REAL  dlonu(iim),dlatu(jjm)
    35     REAL  rlamda( iim ),  eignvl( iim )
    36 
    37     REAL    lamdamax,pi,cof
    38     INTEGER i,j,modemax,imx,k,kf,ii
    39     REAL dymin,dxmin,colat0
    40     REAL eignft(iim,iim), coff
     347
     348    REAL  dlonu(iim), dlatu(jjm)
     349    REAL  rlamda(iim), eignvl(iim)
     350
     351    REAL    lamdamax, pi, cof
     352    INTEGER i, j, modemax, imx, k, kf, ii
     353    REAL dymin, dxmin, colat0
     354    REAL eignft(iim, iim), coff
    41355
    42356    LOGICAL, SAVE :: first_call_inifilr = .TRUE.
    … …  
    44358    INTEGER   ISMIN
    45359    EXTERNAL  ISMIN
    46     INTEGER iymin 
     360    INTEGER iymin
    47361    INTEGER ixmineq
    48362
    … …  
    65379    !-----------------------------------------------------------
    66380
    67     if ( iim == 1 ) return ! No filtre in 2D y-z
    68 
    69     pi       = 2. * ASIN( 1. )
    70 
    71     DO i = 1,iim
    72        dlonu(i) = xprimu( i )
     381    if (iim == 1) return ! No filtre in 2D y-z
     382
     383    pi = 2. * ASIN(1.)
     384
     385    DO i = 1, iim
     386      dlonu(i) = xprimu(i)
    73387    ENDDO
    74388
    75389    CALL inifgn(eignvl)
    76390
    77     PRINT *,'inifilr: EIGNVL '
    78     PRINT 250,eignvl
    79 250 FORMAT( 1x,5e14.6)
     391    PRINT *, 'inifilr: EIGNVL '
     392    PRINT 250, eignvl
     393    250 FORMAT(1x, 5e14.6)
    80394
    81395    ! compute eigenvalues and eigenfunctions
    … …  
    96410    !     .....  colat0 = minimum de ( 0.5, min dy/ min dx )   ...
    97411
    98 
    99     DO j = 1,jjm
    100        dlatu( j ) = rlatu( j ) - rlatu( j+1 )
    101     ENDDO
    102 
    103     dxmin   =  dlonu(1)
    104     DO  i  = 2, iim
    105        dxmin = MIN( dxmin,dlonu(i) )
    106     ENDDO
    107     dymin  = dlatu(1)
    108     DO j  = 2, jjm
    109        dymin = MIN( dymin,dlatu(j) )
     412    DO j = 1, jjm
     413      dlatu(j) = rlatu(j) - rlatu(j + 1)
     414    ENDDO
     415
     416    dxmin = dlonu(1)
     417    DO  i = 2, iim
     418      dxmin = MIN(dxmin, dlonu(i))
     419    ENDDO
     420    dymin = dlatu(1)
     421    DO j = 2, jjm
     422      dymin = MIN(dymin, dlatu(j))
    110423    ENDDO
    111424
    … …  
    118431
    119432    ! if maxlatfilter >0, prescribe the colat0 value from the .def files
    120    
     433
    121434    IF (maxlatfilter < 0.) THEN
    122435
    123     colat0  =  MIN( 0.5, dymin/dxmin )
    124     ! colat0  =  1.
    125 
    126     IF( .NOT.fxyhypb.AND.ysinus )  THEN
    127        colat0 = 0.6
    128        !         ...... a revoir  pour  ysinus !   .......
    129        alphax = 0.
    130     ENDIF
     436      colat0 = MIN(0.5, dymin / dxmin)
     437      ! colat0  =  1.
     438
     439      IF(.NOT.fxyhypb.AND.ysinus)  THEN
     440        colat0 = 0.6
     441        !         ...... a revoir  pour  ysinus !   .......
     442        alphax = 0.
     443      ENDIF
    131444
    132445    ELSE
    133446
    134     colat0=(90.0-maxlatfilter)/180.0*pi       
    135 
    136     ENDIF
    137 
    138     PRINT 50, colat0,alphax
    139 50  FORMAT(/15x,' Inifilr colat0 alphax ',2e16.7)
    140 
    141     IF(alphax==1. )  THEN
    142        PRINT *,' Inifilr  alphax doit etre  <  a 1.  Corriger '
    143        STOP
    144     ENDIF
    145 
    146     lamdamax = iim / ( pi * colat0 * ( 1. - alphax ) )
     447      colat0 = (90.0 - maxlatfilter) / 180.0 * pi
     448
     449    ENDIF
     450
     451    PRINT 50, colat0, alphax
     452    50  FORMAT(/15x, ' Inifilr colat0 alphax ', 2e16.7)
     453
     454    IF(alphax==1.)  THEN
     455      PRINT *, ' Inifilr  alphax doit etre  <  a 1.  Corriger '
     456      STOP
     457    ENDIF
     458
     459    lamdamax = iim / (pi * colat0 * (1. - alphax))
    147460
    148461    !                        ... Correction  le 28/10/97  ( P.Le Van ) ..
    149462
    150     DO i = 2,iim
    151        rlamda( i ) = lamdamax/ SQRT( ABS( eignvl(i) ) )
    152     ENDDO
    153 
    154     DO j = 1,jjm
    155        DO i = 1,iim
    156           coefilu( i,j ) = 0.0
    157           coefilv( i,j ) = 0.0
    158           coefilu2( i,j ) = 0.0
    159           coefilv2( i,j ) = 0.0
    160        ENDDO
     463    DO i = 2, iim
     464      rlamda(i) = lamdamax / SQRT(ABS(eignvl(i)))
     465    ENDDO
     466
     467    DO j = 1, jjm
     468      DO i = 1, iim
     469        coefilu(i, j) = 0.0
     470        coefilv(i, j) = 0.0
     471        coefilu2(i, j) = 0.0
     472        coefilv2(i, j) = 0.0
     473      ENDDO
    161474    ENDDO
    162475
    … …  
    166479    modemax = iim
    167480
    168 !!!!    imx = modemax - 4 * (modemax/iim)
    169 
    170     imx  = iim
    171 
    172     PRINT *,'inifilr: TRUNCATION AT ',imx
    173 
    174 ! Ehouarn: set up some defaults
    175     jfiltnu=2 ! avoid north pole
    176     jfiltsu=jjm ! avoid south pole (which is at jjm+1)
    177     jfiltnv=1 ! NB: no poles on the V grid
    178     jfiltsv=jjm
    179 
    180     DO j = 2, jjm/2+1
    181        cof = COS( rlatu(j) )/ colat0
    182        IF ( cof < 1. ) THEN
    183           IF( rlamda(imx) * COS(rlatu(j) )<1. ) THEN
    184             jfiltnu= j
    185           ENDIF
    186        ENDIF
    187 
    188        cof = COS( rlatu(jjp1-j+1) )/ colat0
    189        IF ( cof < 1. ) THEN
    190           IF( rlamda(imx) * COS(rlatu(jjp1-j+1) )<1. ) THEN
    191                jfiltsu= jjp1-j+1
    192           ENDIF
    193        ENDIF
    194     ENDDO
    195 
    196     DO j = 1, jjm/2
    197        cof = COS( rlatv(j) )/ colat0
    198        IF ( cof < 1. ) THEN
    199           IF( rlamda(imx) * COS(rlatv(j) )<1. ) THEN
    200             jfiltnv= j
    201           ENDIF
    202        ENDIF
    203 
    204        cof = COS( rlatv(jjm-j+1) )/ colat0
    205        IF ( cof < 1. ) THEN
    206           IF( rlamda(imx) * COS(rlatv(jjm-j+1) )<1. ) THEN
    207                jfiltsv= jjm-j+1
    208           ENDIF
    209        ENDIF
    210     ENDDO
    211 
    212     IF( jfiltnu> jjm/2 +1 )  THEN
    213        PRINT *,' jfiltnu en dehors des valeurs acceptables ' ,jfiltnu
    214        STOP
    215     ENDIF
    216 
    217     IF( jfiltsu>  jjm  +1 )  THEN
    218        PRINT *,' jfiltsu en dehors des valeurs acceptables ' ,jfiltsu
    219        STOP
    220     ENDIF
    221 
    222     IF( jfiltnv> jjm/2    )  THEN
    223        PRINT *,' jfiltnv en dehors des valeurs acceptables ' ,jfiltnv
    224        STOP
    225     ENDIF
    226 
    227     IF( jfiltsv>     jjm  )  THEN
    228        PRINT *,' jfiltsv en dehors des valeurs acceptables ' ,jfiltsv
    229        STOP
    230     ENDIF
    231 
    232     PRINT *,'inifilr: jfiltnv jfiltsv jfiltnu jfiltsu ' , &
    233          jfiltnv,jfiltsv,jfiltnu,jfiltsu
     481    !!!!    imx = modemax - 4 * (modemax/iim)
     482
     483    imx = iim
     484
     485    PRINT *, 'inifilr: TRUNCATION AT ', imx
     486
     487    ! Ehouarn: set up some defaults
     488    jfiltnu = 2 ! avoid north pole
     489    jfiltsu = jjm ! avoid south pole (which is at jjm+1)
     490    jfiltnv = 1 ! NB: no poles on the V grid
     491    jfiltsv = jjm
     492
     493    DO j = 2, jjm / 2 + 1
     494      cof = COS(rlatu(j)) / colat0
     495      IF (cof < 1.) THEN
     496        IF(rlamda(imx) * COS(rlatu(j))<1.) THEN
     497          jfiltnu = j
     498        ENDIF
     499      ENDIF
     500
     501      cof = COS(rlatu(jjp1 - j + 1)) / colat0
     502      IF (cof < 1.) THEN
     503        IF(rlamda(imx) * COS(rlatu(jjp1 - j + 1))<1.) THEN
     504          jfiltsu = jjp1 - j + 1
     505        ENDIF
     506      ENDIF
     507    ENDDO
     508
     509    DO j = 1, jjm / 2
     510      cof = COS(rlatv(j)) / colat0
     511      IF (cof < 1.) THEN
     512        IF(rlamda(imx) * COS(rlatv(j))<1.) THEN
     513          jfiltnv = j
     514        ENDIF
     515      ENDIF
     516
     517      cof = COS(rlatv(jjm - j + 1)) / colat0
     518      IF (cof < 1.) THEN
     519        IF(rlamda(imx) * COS(rlatv(jjm - j + 1))<1.) THEN
     520          jfiltsv = jjm - j + 1
     521        ENDIF
     522      ENDIF
     523    ENDDO
     524
     525    IF(jfiltnu> jjm / 2 + 1)  THEN
     526      PRINT *, ' jfiltnu en dehors des valeurs acceptables ', jfiltnu
     527      STOP
     528    ENDIF
     529
     530    IF(jfiltsu>  jjm + 1)  THEN
     531      PRINT *, ' jfiltsu en dehors des valeurs acceptables ', jfiltsu
     532      STOP
     533    ENDIF
     534
     535    IF(jfiltnv> jjm / 2)  THEN
     536      PRINT *, ' jfiltnv en dehors des valeurs acceptables ', jfiltnv
     537      STOP
     538    ENDIF
     539
     540    IF(jfiltsv>     jjm)  THEN
     541      PRINT *, ' jfiltsv en dehors des valeurs acceptables ', jfiltsv
     542      STOP
     543    ENDIF
     544
     545    PRINT *, 'inifilr: jfiltnv jfiltsv jfiltnu jfiltsu ', &
     546            jfiltnv, jfiltsv, jfiltnu, jfiltsu
    234547
    235548    IF(first_call_inifilr) THEN
    236        ALLOCATE(matriceun(iim,iim,jfiltnu))
    237        ALLOCATE(matriceus(iim,iim,jjm-jfiltsu+1))
    238        ALLOCATE(matricevn(iim,iim,jfiltnv))
    239        ALLOCATE(matricevs(iim,iim,jjm-jfiltsv+1))
    240        ALLOCATE( matrinvn(iim,iim,jfiltnu))
    241        ALLOCATE( matrinvs(iim,iim,jjm-jfiltsu+1))
    242        first_call_inifilr = .FALSE.
     549      ALLOCATE(matriceun(iim, iim, jfiltnu))
     550      ALLOCATE(matriceus(iim, iim, jjm - jfiltsu + 1))
     551      ALLOCATE(matricevn(iim, iim, jfiltnv))
     552      ALLOCATE(matricevs(iim, iim, jjm - jfiltsv + 1))
     553      ALLOCATE(matrinvn(iim, iim, jfiltnu))
     554      ALLOCATE(matrinvs(iim, iim, jjm - jfiltsu + 1))
     555      first_call_inifilr = .FALSE.
    243556    ENDIF
    244557
    … …  
    246559    !................................................................
    247560
    248 
    249     DO j = 1,jjm
    250     !default initialization: all modes are retained (i.e. no filtering)
    251        modfrstu( j ) = iim
    252        modfrstv( j ) = iim
    253     ENDDO
    254 
    255     DO j = 2,jfiltnu
    256        DO k = 2,modemax
    257           cof = rlamda(k) * COS( rlatu(j) )
    258           IF ( cof < 1. ) GOTO 82
    259        ENDDO
    260        GOTO 84
    261 82     modfrstu( j ) = k
    262 
    263        kf = modfrstu( j )
    264        DO k = kf , modemax
    265           cof = rlamda(k) * COS( rlatu(j) )
    266           coefilu(k,j) = cof - 1.
    267           coefilu2(k,j) = cof*cof - 1.
    268        ENDDO
    269 84     CONTINUE
    270     ENDDO
    271 
    272 
    273     DO j = 1,jfiltnv
    274 
    275        DO k = 2,modemax
    276           cof = rlamda(k) * COS( rlatv(j) )
    277           IF ( cof < 1. ) GOTO 87
    278        ENDDO
    279        GOTO 89
    280 87     modfrstv( j ) = k
    281 
    282        kf = modfrstv( j )
    283        DO k = kf , modemax
    284           cof = rlamda(k) * COS( rlatv(j) )
    285           coefilv(k,j) = cof - 1.
    286           coefilv2(k,j) = cof*cof - 1.
    287        ENDDO
    288 89     CONTINUE
    289     ENDDO
    290 
    291     DO j = jfiltsu,jjm
    292        DO k = 2,modemax
    293           cof = rlamda(k) * COS( rlatu(j) )
    294           IF ( cof < 1. ) GOTO 92
    295        ENDDO
    296        GOTO 94
    297 92     modfrstu( j ) = k
    298 
    299        kf = modfrstu( j )
    300        DO k = kf , modemax
    301           cof = rlamda(k) * COS( rlatu(j) )
    302           coefilu(k,j) = cof - 1.
    303           coefilu2(k,j) = cof*cof - 1.
    304        ENDDO
    305 94     CONTINUE
    306     ENDDO
    307 
    308     DO j = jfiltsv,jjm
    309        DO k = 2,modemax
    310           cof = rlamda(k) * COS( rlatv(j) )
    311           IF ( cof < 1. ) GOTO 97
    312        ENDDO
    313        GOTO 99
    314 97     modfrstv( j ) = k
    315 
    316        kf = modfrstv( j )
    317        DO k = kf , modemax
    318           cof = rlamda(k) * COS( rlatv(j) )
    319           coefilv(k,j) = cof - 1.
    320           coefilv2(k,j) = cof*cof - 1.
    321        ENDDO
    322 99     CONTINUE
    323     ENDDO
    324 
    325     IF(jfiltnv>=jjm/2 .OR. jfiltnu>=jjm/2)THEN
    326 ! Ehouarn: and what are these for??? Trying to handle a limit case
    327 !          where filters extend to and meet at the equator?
    328        IF(jfiltnv==jfiltsv)jfiltsv=1+jfiltnv
    329        IF(jfiltnu==jfiltsu)jfiltsu=1+jfiltnu
    330 
    331        PRINT *,'jfiltnv jfiltsv jfiltnu jfiltsu' , &
    332             jfiltnv,jfiltsv,jfiltnu,jfiltsu
    333     ENDIF
    334 
    335     PRINT *,'   Modes premiers  v  '
    336     PRINT 334,modfrstv
    337     PRINT *,'   Modes premiers  u  '
    338     PRINT 334,modfrstu
     561    DO j = 1, jjm
     562      !default initialization: all modes are retained (i.e. no filtering)
     563      modfrstu(j) = iim
     564      modfrstv(j) = iim
     565    ENDDO
     566
     567    DO j = 2, jfiltnu
     568      DO k = 2, modemax
     569        cof = rlamda(k) * COS(rlatu(j))
     570        IF (cof < 1.) GOTO 82
     571      ENDDO
     572      GOTO 84
     573      82     modfrstu(j) = k
     574
     575      kf = modfrstu(j)
     576      DO k = kf, modemax
     577        cof = rlamda(k) * COS(rlatu(j))
     578        coefilu(k, j) = cof - 1.
     579        coefilu2(k, j) = cof * cof - 1.
     580      ENDDO
     581      84     CONTINUE
     582    ENDDO
     583
     584    DO j = 1, jfiltnv
     585
     586      DO k = 2, modemax
     587        cof = rlamda(k) * COS(rlatv(j))
     588        IF (cof < 1.) GOTO 87
     589      ENDDO
     590      GOTO 89
     591      87     modfrstv(j) = k
     592
     593      kf = modfrstv(j)
     594      DO k = kf, modemax
     595        cof = rlamda(k) * COS(rlatv(j))
     596        coefilv(k, j) = cof - 1.
     597        coefilv2(k, j) = cof * cof - 1.
     598      ENDDO
     599      89     CONTINUE
     600    ENDDO
     601
     602    DO j = jfiltsu, jjm
     603      DO k = 2, modemax
     604        cof = rlamda(k) * COS(rlatu(j))
     605        IF (cof < 1.) GOTO 92
     606      ENDDO
     607      GOTO 94
     608      92     modfrstu(j) = k
     609
     610      kf = modfrstu(j)
     611      DO k = kf, modemax
     612        cof = rlamda(k) * COS(rlatu(j))
     613        coefilu(k, j) = cof - 1.
     614        coefilu2(k, j) = cof * cof - 1.
     615      ENDDO
     616      94     CONTINUE
     617    ENDDO
     618
     619    DO j = jfiltsv, jjm
     620      DO k = 2, modemax
     621        cof = rlamda(k) * COS(rlatv(j))
     622        IF (cof < 1.) GOTO 97
     623      ENDDO
     624      GOTO 99
     625      97     modfrstv(j) = k
     626
     627      kf = modfrstv(j)
     628      DO k = kf, modemax
     629        cof = rlamda(k) * COS(rlatv(j))
     630        coefilv(k, j) = cof - 1.
     631        coefilv2(k, j) = cof * cof - 1.
     632      ENDDO
     633      99     CONTINUE
     634    ENDDO
     635
     636    IF(jfiltnv>=jjm / 2 .OR. jfiltnu>=jjm / 2)THEN
     637      ! Ehouarn: and what are these for??? Trying to handle a limit case
     638      !          where filters extend to and meet at the equator?
     639      IF(jfiltnv==jfiltsv)jfiltsv = 1 + jfiltnv
     640      IF(jfiltnu==jfiltsu)jfiltsu = 1 + jfiltnu
     641
     642      PRINT *, 'jfiltnv jfiltsv jfiltnu jfiltsu', &
     643              jfiltnv, jfiltsv, jfiltnu, jfiltsu
     644    ENDIF
     645
     646    PRINT *, '   Modes premiers  v  '
     647    PRINT 334, modfrstv
     648    PRINT *, '   Modes premiers  u  '
     649    PRINT 334, modfrstu
    339650
    340651    !   ...................................................................
    … …  
    346657    DO j = 2, jfiltnu
    347658
    348        DO i=1,iim
    349           coff = coefilu(i,j)
    350           IF( i<modfrstu(j) ) coff = 0.
    351           DO k=1,iim
    352              eignft(i,k) = eignfnv(k,i) * coff
    353           ENDDO
    354        ENDDO ! of DO i=1,iim
     659      DO i = 1, iim
     660        coff = coefilu(i, j)
     661        IF(i<modfrstu(j)) coff = 0.
     662        DO k = 1, iim
     663          eignft(i, k) = eignfnv(k, i) * coff
     664        ENDDO
     665      ENDDO ! of DO i=1,iim
    355666
    356667#ifdef BLAS
    … …  
    358669            eignfnv, iim, eignft, iim, 0.0, matriceun(1,1,j), iim)
    359670#else
    360        DO k = 1, iim
    361           DO i = 1, iim
    362              matriceun(i,k,j) = 0.0
    363              DO ii = 1, iim
    364                 matriceun(i,k,j) = matriceun(i,k,j) &
    365                      + eignfnv(i,ii)*eignft(ii,k)
    366              ENDDO
     671      DO k = 1, iim
     672        DO i = 1, iim
     673          matriceun(i, k, j) = 0.0
     674          DO ii = 1, iim
     675            matriceun(i, k, j) = matriceun(i, k, j) &
     676                    + eignfnv(i, ii) * eignft(ii, k)
    367677          ENDDO
    368        ENDDO ! of DO k = 1, iim
     678        ENDDO
     679      ENDDO ! of DO k = 1, iim
    369680#endif
    370681
    … …  
    373684    DO j = jfiltsu, jjm
    374685
    375        DO i=1,iim
    376           coff = coefilu(i,j)
    377           IF( i<modfrstu(j) ) coff = 0.
    378           DO k=1,iim
    379              eignft(i,k) = eignfnv(k,i) * coff
    380           ENDDO
    381        ENDDO ! of DO i=1,iim
     686      DO i = 1, iim
     687        coff = coefilu(i, j)
     688        IF(i<modfrstu(j)) coff = 0.
     689        DO k = 1, iim
     690          eignft(i, k) = eignfnv(k, i) * coff
     691        ENDDO
     692      ENDDO ! of DO i=1,iim
    382693#ifdef BLAS
    383694       CALL SGEMM ('N', 'N', iim, iim, iim, 1.0, &
    … …  
    385696            matriceus(1,1,j-jfiltsu+1), iim)
    386697#else
    387        DO k = 1, iim
    388           DO i = 1, iim
    389              matriceus(i,k,j-jfiltsu+1) = 0.0
    390              DO ii = 1, iim
    391                 matriceus(i,k,j-jfiltsu+1) = matriceus(i,k,j-jfiltsu+1) &
    392                      + eignfnv(i,ii)*eignft(ii,k)
    393              ENDDO
     698      DO k = 1, iim
     699        DO i = 1, iim
     700          matriceus(i, k, j - jfiltsu + 1) = 0.0
     701          DO ii = 1, iim
     702            matriceus(i, k, j - jfiltsu + 1) = matriceus(i, k, j - jfiltsu + 1) &
     703                    + eignfnv(i, ii) * eignft(ii, k)
    394704          ENDDO
    395        ENDDO ! of DO k = 1, iim
     705        ENDDO
     706      ENDDO ! of DO k = 1, iim
    396707#endif
    397708
    … …  
    406717    DO j = 1, jfiltnv
    407718
    408        DO i = 1, iim
    409           coff = coefilv(i,j)
    410           IF( i<modfrstv(j) ) coff = 0.
    411           DO k = 1, iim
    412              eignft(i,k) = eignfnu(k,i) * coff
    413           ENDDO
    414        ENDDO
     719      DO i = 1, iim
     720        coff = coefilv(i, j)
     721        IF(i<modfrstv(j)) coff = 0.
     722        DO k = 1, iim
     723          eignft(i, k) = eignfnu(k, i) * coff
     724        ENDDO
     725      ENDDO
    415726
    416727#ifdef BLAS
    … …  
    418729            eignfnu, iim, eignft, iim, 0.0, matricevn(1,1,j), iim)
    419730#else
    420        DO k = 1, iim
    421           DO i = 1, iim
    422              matricevn(i,k,j) = 0.0
    423              DO ii = 1, iim
    424                 matricevn(i,k,j) = matricevn(i,k,j) &
    425                      + eignfnu(i,ii)*eignft(ii,k)
    426              ENDDO
     731      DO k = 1, iim
     732        DO i = 1, iim
     733          matricevn(i, k, j) = 0.0
     734          DO ii = 1, iim
     735            matricevn(i, k, j) = matricevn(i, k, j) &
     736                    + eignfnu(i, ii) * eignft(ii, k)
    427737          ENDDO
    428        ENDDO
     738        ENDDO
     739      ENDDO
    429740#endif
    430741
    … …  
    433744    DO j = jfiltsv, jjm
    434745
    435        DO i = 1, iim
    436           coff = coefilv(i,j)
    437           IF( i<modfrstv(j) ) coff = 0.
    438           DO k = 1, iim
    439              eignft(i,k) = eignfnu(k,i) * coff
    440           ENDDO
    441        ENDDO
     746      DO i = 1, iim
     747        coff = coefilv(i, j)
     748        IF(i<modfrstv(j)) coff = 0.
     749        DO k = 1, iim
     750          eignft(i, k) = eignfnu(k, i) * coff
     751        ENDDO
     752      ENDDO
    442753
    443754#ifdef BLAS
    … …  
    446757            matricevs(1,1,j-jfiltsv+1), iim)
    447758#else
    448        DO k = 1, iim
    449           DO i = 1, iim
    450              matricevs(i,k,j-jfiltsv+1) = 0.0
    451              DO ii = 1, iim
    452                 matricevs(i,k,j-jfiltsv+1) = matricevs(i,k,j-jfiltsv+1) &
    453                      + eignfnu(i,ii)*eignft(ii,k)
    454              ENDDO
     759      DO k = 1, iim
     760        DO i = 1, iim
     761          matricevs(i, k, j - jfiltsv + 1) = 0.0
     762          DO ii = 1, iim
     763            matricevs(i, k, j - jfiltsv + 1) = matricevs(i, k, j - jfiltsv + 1) &
     764                    + eignfnu(i, ii) * eignft(ii, k)
    455765          ENDDO
    456        ENDDO
     766        ENDDO
     767      ENDDO
    457768#endif
    458769
    … …  
    467778    DO j = 2, jfiltnu
    468779
    469        DO i = 1,iim
    470           coff = coefilu(i,j)/ ( 1. + coefilu(i,j) )
    471           IF( i<modfrstu(j) ) coff = 0.
    472           DO k=1,iim
    473              eignft(i,k) = eignfnv(k,i) * coff
    474           ENDDO
    475        ENDDO
     780      DO i = 1, iim
     781        coff = coefilu(i, j) / (1. + coefilu(i, j))
     782        IF(i<modfrstu(j)) coff = 0.
     783        DO k = 1, iim
     784          eignft(i, k) = eignfnv(k, i) * coff
     785        ENDDO
     786      ENDDO
    476787
    477788#ifdef BLAS
    … …  
    479790            eignfnv, iim, eignft, iim, 0.0, matrinvn(1,1,j), iim)
    480791#else
    481        DO k = 1, iim
    482           DO i = 1, iim
    483              matrinvn(i,k,j) = 0.0
    484              DO ii = 1, iim
    485                 matrinvn(i,k,j) = matrinvn(i,k,j) &
    486                      + eignfnv(i,ii)*eignft(ii,k)
    487              ENDDO
     792      DO k = 1, iim
     793        DO i = 1, iim
     794          matrinvn(i, k, j) = 0.0
     795          DO ii = 1, iim
     796            matrinvn(i, k, j) = matrinvn(i, k, j) &
     797                    + eignfnv(i, ii) * eignft(ii, k)
    488798          ENDDO
    489        ENDDO
     799        ENDDO
     800      ENDDO
    490801#endif
    491802
    … …  
    494805    DO j = jfiltsu, jjm
    495806
    496        DO i = 1,iim
    497           coff = coefilu(i,j) / ( 1. + coefilu(i,j) )
    498           IF( i<modfrstu(j) ) coff = 0.
    499           DO k=1,iim
    500              eignft(i,k) = eignfnv(k,i) * coff
    501           ENDDO
    502        ENDDO
     807      DO i = 1, iim
     808        coff = coefilu(i, j) / (1. + coefilu(i, j))
     809        IF(i<modfrstu(j)) coff = 0.
     810        DO k = 1, iim
     811          eignft(i, k) = eignfnv(k, i) * coff
     812        ENDDO
     813      ENDDO
    503814#ifdef BLAS
    504815       CALL SGEMM ('N', 'N', iim, iim, iim, 1.0, &
    505816            eignfnv, iim, eignft, iim, 0.0, matrinvs(1,1,j-jfiltsu+1), iim)
    506817#else
    507        DO k = 1, iim
    508           DO i = 1, iim
    509              matrinvs(i,k,j-jfiltsu+1) = 0.0
    510              DO ii = 1, iim
    511                 matrinvs(i,k,j-jfiltsu+1) = matrinvs(i,k,j-jfiltsu+1) &
    512                      + eignfnv(i,ii)*eignft(ii,k)
    513              ENDDO
     818      DO k = 1, iim
     819        DO i = 1, iim
     820          matrinvs(i, k, j - jfiltsu + 1) = 0.0
     821          DO ii = 1, iim
     822            matrinvs(i, k, j - jfiltsu + 1) = matrinvs(i, k, j - jfiltsu + 1) &
     823                    + eignfnv(i, ii) * eignft(ii, k)
    514824          ENDDO
    515        ENDDO
     825        ENDDO
     826      ENDDO
    516827#endif
    517828
    … …  
    528839    !   ...................................................................
    529840
    530 334 FORMAT(1x,24i3)
     841    334 FORMAT(1x, 24i3)
    531842
    532843  END SUBROUTINE inifilr
    533844
    534 END MODULE filtreg_mod
     845END MODULE lmdz_filtreg

  • LMDZ6/branches/Amaury_dev/libf/misc/chfev.f90

    r5105 r5106  
    11!DECK CHFEV
    2 SUBROUTINE CHFEV (X1, X2, F1, F2, D1, D2, NE, XE, FE, NEXT, IERR)
     2SUBROUTINE CHFEV(X1, X2, F1, F2, D1, D2, NE, XE, FE, NEXT, IERR)
    33  !***BEGIN PROLOGUE  CHFEV
    44  !***PURPOSE  Evaluate a cubic polynomial given in Hermite form at an

  • LMDZ6/branches/Amaury_dev/libf/misc/i1mach.f90

    r5105 r5106  
    11!DECK I1MACH
    2 INTEGER FUNCTION I1MACH (I)
     2INTEGER FUNCTION I1MACH(I)
    33  IMPLICIT NONE
    44  !***BEGIN PROLOGUE  I1MACH

  • LMDZ6/branches/Amaury_dev/libf/misc/j4save.f90

    r5105 r5106  
    11!DECK J4SAVE
    2 FUNCTION J4SAVE (IWHICH, IVALUE, ISET)
     2FUNCTION J4SAVE(IWHICH, IVALUE, ISET)
    33  IMPLICIT NONE
    44  !***BEGIN PROLOGUE  J4SAVE

  • LMDZ6/branches/Amaury_dev/libf/misc/lmdz_inca_wrappers.F90

    r5103 r5106  
    314314END SUBROUTINE INIT_INCA_DIM_REG
    315315
    316 SUBROUTINE AEROSOL_METEO_CALC (&
     316SUBROUTINE AEROSOL_METEO_CALC(&
    317317        calday, delt, pmid, pfull, t_seri, &
    318318        flxrcv, flxscv, flxrst, flxsst, pctsrf, &

  • LMDZ6/branches/Amaury_dev/libf/misc/pchdf.f90

    r5105 r5106  
    11!DECK PCHDF
    2 REAL FUNCTION PCHDF (K, X, S, IERR)
     2REAL FUNCTION PCHDF(K, X, S, IERR)
    33  !***BEGIN PROLOGUE  PCHDF
    44  !***SUBSIDIARY

  • LMDZ6/branches/Amaury_dev/libf/misc/pchfe.f90

    r5105 r5106  
    11!DECK PCHFE
    2 SUBROUTINE PCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR)
     2SUBROUTINE PCHFE(N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR)
    33  !***BEGIN PROLOGUE  PCHFE
    44  !***PURPOSE  Evaluate a piecewise cubic Hermite function at an array of

  • LMDZ6/branches/Amaury_dev/libf/misc/pchsp.f90

    r5105 r5106  
    11!DECK PCHSP
    2 SUBROUTINE PCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR)
     2SUBROUTINE PCHSP(IC, VC, N, X, F, D, INCFD, WK, NWK, IERR)
    33  !***BEGIN PROLOGUE  PCHSP
    44  !***PURPOSE  Set derivatives needed to determine the Hermite represen-

  • LMDZ6/branches/Amaury_dev/libf/misc/xercnt.f90

    r5105 r5106  
    11!DECK XERCNT
    2 SUBROUTINE XERCNT (LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL)
     2SUBROUTINE XERCNT(LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL)
    33  IMPLICIT NONE
    44  !***BEGIN PROLOGUE  XERCNT

  • LMDZ6/branches/Amaury_dev/libf/misc/xerhlt.f90

    r5105 r5106  
    11!DECK XERHLT
    2 SUBROUTINE XERHLT (MESSG)
     2SUBROUTINE XERHLT(MESSG)
    33  !***BEGIN PROLOGUE  XERHLT
    44  !***SUBSIDIARY

  • LMDZ6/branches/Amaury_dev/libf/misc/xermsg.f90

    r5105 r5106  
    11!DECK XERMSG
    2 SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL)
     2SUBROUTINE XERMSG(LIBRAR, SUBROU, MESSG, NERR, LEVEL)
    33  IMPLICIT NONE
    44  !***BEGIN PROLOGUE  XERMSG

  • LMDZ6/branches/Amaury_dev/libf/misc/xerprn.f90

    r5105 r5106  
    11!DECK XERPRN
    2 SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP)
     2SUBROUTINE XERPRN(PREFIX, NPREF, MESSG, NWRAP)
    33  IMPLICIT NONE
    44  !***BEGIN PROLOGUE  XERPRN

  • LMDZ6/branches/Amaury_dev/libf/misc/xersve.f90

    r5105 r5106  
    11!DECK XERSVE
    2 SUBROUTINE XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, &
     2SUBROUTINE XERSVE(LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, &
    33        ICOUNT)
    44  IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/misc/xgetua.f90

    r5105 r5106  
    11!DECK XGETUA
    2 SUBROUTINE XGETUA (IUNITA, N)
     2SUBROUTINE XGETUA(IUNITA, N)
    33  IMPLICIT NONE
    44  !***BEGIN PROLOGUE  XGETUA

  • LMDZ6/branches/Amaury_dev/libf/phydev/phyredem.F90

    r5101 r5106  
    22! $Id: $
    33
    4 SUBROUTINE phyredem (fichnom)
     4SUBROUTINE phyredem(fichnom)
    55
    66  USE geometry_mod, ONLY: longitude_deg, latitude_deg

  • LMDZ6/branches/Amaury_dev/libf/phydev/physiq_mod.F90

    r5103 r5106  
    66CONTAINS
    77
    8       SUBROUTINE physiq (nlon,nlev, &
     8      SUBROUTINE physiq(nlon,nlev, &
    99              debut,lafin,pdtphys, &
    1010              paprs,pplay,pphi,pphis,presnivs, &

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/phytracr_spl_mod.F90

    r5105 r5106  
    767767
    768768  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    769   SUBROUTINE phytracr_spl (debutphy, lafin, jD_cur, jH_cur, iflag_conv, &  ! I
     769  SUBROUTINE phytracr_spl(debutphy, lafin, jD_cur, jH_cur, iflag_conv, &  ! I
    770770          pdtphys, ftsol, &  ! I
    771771          t_seri, q_seri, paprs, pplay, RHcl, &  ! I

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/splaeropt_6bands_rrtm.f90

    r5101 r5106  
    22! $Id: splaeropt_6bands_rrtm.F90 2644 2016-10-02 16:55:08Z oboucher $
    33
    4 SUBROUTINE SPLAEROPT_6BANDS_RRTM (&
     4SUBROUTINE SPLAEROPT_6BANDS_RRTM(&
    55        zdm, tr_seri, RHcl, &
    66        tau_allaer, piz_allaer, cg_allaer)

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/tiedqneg.f90

    r5105 r5106  
    1 SUBROUTINE tiedqneg (pres_h, q, d_q)
     1SUBROUTINE tiedqneg(pres_h, q, d_q)
    22
    33  USE dimphy

  • LMDZ6/branches/Amaury_dev/libf/phylmd/add_phys_tend_mod.F90

    r5105 r5106  
    8686! $Id: add_phys_tend.F90 2611 2016-08-03 15:41:26Z jyg $
    8787
    88 SUBROUTINE add_phys_tend (zdu,zdv,zdt,zdq,zdql,zdqi,zdqbs,paprs,text, &
     88SUBROUTINE add_phys_tend(zdu,zdv,zdt,zdq,zdql,zdqi,zdqbs,paprs,text, &
    8989                          abortphy,flag_inhib_tend, itap, diag_mode)
    9090!======================================================================
    … …  
    488488END SUBROUTINE add_phys_tend
    489489
    490 SUBROUTINE diag_phys_tend (nlon, nlev, uu, vv, temp, qv, ql, qs, qbs, &
     490SUBROUTINE diag_phys_tend(nlon, nlev, uu, vv, temp, qv, ql, qs, qbs, &
    491491                          zdu,zdv,zdt,zdq,zdql,zdqs,zdqbs,paprs,text)
    492492!======================================================================
    … …  
    715715END SUBROUTINE integr_v
    716716
    717 SUBROUTINE prt_enerbil (text, itap)
     717SUBROUTINE prt_enerbil(text, itap)
    718718!======================================================================
    719719! Print enenrgy budget diagnotics for the 1D case

  • LMDZ6/branches/Amaury_dev/libf/phylmd/alpale.F90

    r5103 r5106  
    1 SUBROUTINE alpale ( debut, itap, dtime, paprs, omega, t_seri,   &
     1SUBROUTINE alpale( debut, itap, dtime, paprs, omega, t_seri,   &
    22                    alp_offset, it_wape_prescr,  wape_prescr, fip_prescr, &
    33                    ale_bl_prescr, alp_bl_prescr, &

  • LMDZ6/branches/Amaury_dev/libf/phylmd/alpale_th.F90

    r5105 r5106  
    22! $Id$
    33
    4 SUBROUTINE alpale_th ( dtime, lmax_th, t_seri, cell_area,  &
     4SUBROUTINE alpale_th( dtime, lmax_th, t_seri, cell_area,  &
    55                       cin, s2, n2, strig,  &
    66                       ale_bl_trig, ale_bl_stat, ale_bl,  &

  • LMDZ6/branches/Amaury_dev/libf/phylmd/alpale_wk.F90

    r5105 r5106  
    1 SUBROUTINE alpale_wk ( dtime, cell_area, zoccur, sigmaw, wdens, fip ,  &
     1SUBROUTINE alpale_wk( dtime, cell_area, zoccur, sigmaw, wdens, fip ,  &
    22                       fip_cond)
    33

  • LMDZ6/branches/Amaury_dev/libf/phylmd/atm2geo.F90

    r5099 r5106  
    22! $Id$
    33
    4 SUBROUTINE atm2geo ( im, jm, pte, ptn, plon, plat, pxx, pyy, pzz )
     4SUBROUTINE atm2geo( im, jm, pte, ptn, plon, plat, pxx, pyy, pzz )
    55  USE dimphy
    66  USE mod_phys_lmdz_para

  • LMDZ6/branches/Amaury_dev/libf/phylmd/coefcdrag.F90

    r5105 r5106  
    22
    33
    4       SUBROUTINE coefcdrag (klon, knon, nsrf, zxli, &
     4      SUBROUTINE coefcdrag(klon, knon, nsrf, zxli, &
    55                            speed, t, q, zgeop, psol, &
    66                            ts, qsurf, rugos, okri, ri1, &

  • LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/lmdz_1dutils.f90

    r5105 r5106  
    14251425
    14261426
    1427   Subroutine Nudge_RHT_init (paprs, pplay, t, q, t_targ, rh_targ)
     1427  SubROUTINE Nudge_RHT_init(paprs, pplay, t, q, t_targ, rh_targ)
    14281428    ! ========================================================
    14291429    USE dimphy
    … …  
    14731473  END SUBROUTINE nudge_rht_init
    14741474
    1475   Subroutine Nudge_UV_init (paprs, pplay, u, v, u_targ, v_targ)
     1475  SubROUTINE Nudge_UV_init(paprs, pplay, u, v, u_targ, v_targ)
    14761476    ! ========================================================
    14771477    USE dimphy
    … …  
    15051505  END
    15061506
    1507   Subroutine Nudge_RHT (dtime, paprs, pplay, t_targ, rh_targ, t, q, &
     1507  SubROUTINE Nudge_RHT(dtime, paprs, pplay, t_targ, rh_targ, t, q, &
    15081508          &                      d_t, d_q)
    15091509    ! ========================================================
    … …  
    15941594  END
    15951595
    1596   Subroutine Nudge_UV (dtime, paprs, pplay, u_targ, v_targ, u, v, &
     1596  SubROUTINE Nudge_UV(dtime, paprs, pplay, u_targ, v_targ, u, v, &
    15971597          &                      d_u, d_v)
    15981598    ! ========================================================

  • LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/surf_inlandsis_mod.F90

    r5105 r5106  
    10291029    !***************************************************************************
    10301030
    1031     SUBROUTINE sisvatetat0 (fichnom, ikl2i)
     1031    SUBROUTINE sisvatetat0(fichnom, ikl2i)
    10321032
    10331033        USE dimphy
    … …  
    12601260
    12611261    !======================================================================
    1262     SUBROUTINE sisvatredem (fichnom, ikl2i, rlon, rlat)
     1262    SUBROUTINE sisvatredem(fichnom, ikl2i, rlon, rlat)
    12631263
    12641264

  • LMDZ6/branches/Amaury_dev/libf/phylmd/iophy.F90

    r5103 r5106  
    452452
    453453
    454   SUBROUTINE histdef2d_old (iff,lpoint,flag_var,nomvar,titrevar,unitvar)
     454  SUBROUTINE histdef2d_old(iff,lpoint,flag_var,nomvar,titrevar,unitvar)
    455455
    456456    USE ioipsl, ONLY: histdef
    … …  
    528528  END SUBROUTINE histdef2d_old
    529529
    530   SUBROUTINE histdef3d_old (iff,lpoint,flag_var,nomvar,titrevar,unitvar)
     530  SUBROUTINE histdef3d_old(iff,lpoint,flag_var,nomvar,titrevar,unitvar)
    531531
    532532    USE ioipsl, ONLY: histdef
    … …  
    579579  END SUBROUTINE histdef3d_old
    580580
    581   SUBROUTINE histdef2d (iff,var)
     581  SUBROUTINE histdef2d(iff,var)
    582582
    583583    USE ioipsl, ONLY: histdef
    … …  
    694694  END SUBROUTINE histdef2d
    695695
    696   SUBROUTINE histdef3d (iff,var)
     696  SUBROUTINE histdef3d(iff,var)
    697697
    698698    USE ioipsl, ONLY: histdef

  • LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_wake.F90

    r5105 r5106  
    24102410
    24112411
    2412 SUBROUTINE pkupper (klon, klev, ptop, ph, p, pupper, kupper, &
     2412SUBROUTINE pkupper(klon, klev, ptop, ph, p, pupper, kupper, &
    24132413                    dth, hw_, rho, delta_t_min_in, &
    24142414                    ktop, wk_adv, h_zzz, ptop1, ktop1)
    … …  
    29692969    END SUBROUTINE wake_popdyn_1
    29702970   
    2971     SUBROUTINE wake_popdyn_2 ( klon, klev, wk_adv, dtimesub, wgen, &
     2971    SUBROUTINE wake_popdyn_2( klon, klev, wk_adv, dtimesub, wgen, &
    29722972                             wdensmin, &
    29732973                             sigmaw, wdens, awdens, &   !! states variables
    … …  
    31193119    END SUBROUTINE wake_popdyn_2 
    31203120 
    3121     SUBROUTINE wake_popdyn_3 ( klon, klev, phys_sub, wk_adv, dtimesub, wgen, &
     3121    SUBROUTINE wake_popdyn_3( klon, klev, phys_sub, wk_adv, dtimesub, wgen, &
    31223122                             wdensmin, &
    31233123                             sigmaw, asigmaw, wdens, awdens, &                       !! state variables

  • LMDZ6/branches/Amaury_dev/libf/phylmd/mo_simple_plumes.F90

    r5105 r5106  
    315315  ! optical properties on a host models vertical grid.
    316316
    317   SUBROUTINE sp_aop_profile                                                                           ( &
     317  SUBROUTINE sp_aop_profile( &
    318318       nlevels        ,ncol           ,lambda         ,oro            ,lon            ,lat            , &
    319319       year_fr        ,z              ,dz             ,dNovrN         ,aod_prof       ,ssa_prof       , &

  • LMDZ6/branches/Amaury_dev/libf/phylmd/phyetat0_mod.F90

    r5103 r5106  
    88CONTAINS
    99
    10 SUBROUTINE phyetat0 (fichnom, clesphy0, tabcntr0)
     10SUBROUTINE phyetat0(fichnom, clesphy0, tabcntr0)
    1111
    1212  USE dimphy, only: klon, zmasq, klev

  • LMDZ6/branches/Amaury_dev/libf/phylmd/phyredem.F90

    r5103 r5106  
    22! $Id$
    33
    4 SUBROUTINE phyredem (fichnom)
     4SUBROUTINE phyredem(fichnom)
    55
    66!-------------------------------------------------------------------------------

  • LMDZ6/branches/Amaury_dev/libf/phylmd/physiq_mod.F90

    r5103 r5106  
    88CONTAINS
    99
    10   SUBROUTINE physiq (nlon, nlev, &
     10  SUBROUTINE physiq(nlon, nlev, &
    1111          debut, lafin, pdtphys_, &
    1212          paprs, pplay, pphi, pphis, presnivs, &

  • LMDZ6/branches/Amaury_dev/libf/phylmd/physiqex_mod.F90

    r5103 r5106  
    66CONTAINS
    77
    8       SUBROUTINE physiqex (nlon,nlev, &
     8      SUBROUTINE physiqex(nlon,nlev, &
    99              debut,lafin,pdtphys, &
    1010              paprs,pplay,pphi,pphis,presnivs, &

  • LMDZ6/branches/Amaury_dev/libf/phylmd/phystokenc_mod.F90

    r5101 r5106  
    2424  END SUBROUTINE init_phystokenc
    2525
    26 SUBROUTINE phystokenc (nlon,nlev,pdtphys,rlon,rlat, &
     26SUBROUTINE phystokenc(nlon,nlev,pdtphys,rlon,rlat, &
    2727     pt,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, &
    2828     pfm_therm,pentr_therm, &

  • LMDZ6/branches/Amaury_dev/libf/phylmd/print_debug_phys.F90

    r5103 r5106  
    1 SUBROUTINE print_debug_phys (i,debug_lev,text)
     1SUBROUTINE print_debug_phys(i,debug_lev,text)
    22
    33USE dimphy, ONLY: klev

  • LMDZ6/branches/Amaury_dev/libf/phylmd/reevap.F90

    r5105 r5106  
    1   SUBROUTINE reevap (klon,klev,iflag_ice_thermo,t_seri,q_seri,ql_seri,qs_seri, &
     1  SUBROUTINE reevap(klon,klev,iflag_ice_thermo,t_seri,q_seri,ql_seri,qs_seri, &
    22           d_t_eva,d_q_eva,d_ql_eva,d_qs_eva)
    33

  • LMDZ6/branches/Amaury_dev/libf/phylmd/simu_airs.F90

    r5105 r5106  
    514514
    515515
    516         SUBROUTINE masque (ibeg, iend, som_tau, &
     516        SUBROUTINE masque(ibeg, iend, som_tau, &
    517517   visible, w)
    518518
    … …  
    555555
    556556
    557          SUBROUTINE caract (ibeg, iend, temp_cs, tau_cs, iwco_cs, &
     557         SUBROUTINE caract(ibeg, iend, temp_cs, tau_cs, iwco_cs, &
    558558   pres_cs, dz_cs, rhodz_cs, rad_cs, pcld, tcld, &
    559559   som_tau, som_iwc, som_dz, som_rad)

  • LMDZ6/branches/Amaury_dev/libf/phylmdiso/add_phys_tend_mod.F90

    r5105 r5106  
    123123! $Id$
    124124
    125 SUBROUTINE add_phys_tend (zdu,zdv,zdt,zdq,zdql,zdqi,zdqbs,paprs,text, &
     125SUBROUTINE add_phys_tend(zdu,zdv,zdt,zdq,zdql,zdqi,zdqbs,paprs,text, &
    126126                          abortphy,flag_inhib_tend, itap, diag_mode &
    127127#ifdef ISO
    … …  
    666666END SUBROUTINE add_phys_tend
    667667
    668 SUBROUTINE diag_phys_tend (nlon, nlev, uu, vv, temp, qv, ql, qs, qbs, &
     668SUBROUTINE diag_phys_tend(nlon, nlev, uu, vv, temp, qv, ql, qs, qbs, &
    669669                          zdu,zdv,zdt,zdq,zdql,zdqs,zdqbs,paprs,text)
    670670!======================================================================
    … …  
    896896END SUBROUTINE integr_v
    897897
    898 SUBROUTINE prt_enerbil (text, itap)
     898SUBROUTINE prt_enerbil(text, itap)
    899899!======================================================================
    900900! Print enenrgy budget diagnotics for the 1D case

  • LMDZ6/branches/Amaury_dev/libf/phylmdiso/isotopes_routines_mod.F90

    r5105 r5106  
    1584815848!***           
    1584915849
    15850       SUBROUTINE phyisoetat0 (snow,run_off_lic_0, &
     15850      SUBROUTINE phyisoetat0(snow,run_off_lic_0, &
    1585115851                 xtsnow,xtrun_off_lic_0, &
    1585215852                 Rland_ice)
    … …  
    1602116021     
    1602216022
    16023       SUBROUTINE phyiso_etat0_dur ( &
     16023      SUBROUTINE phyiso_etat0_dur( &
    1602416024                xtsnow, &
    1602516025               xtrun_off_lic_0, Rland_ice, &
    … …  
    1831718317#ifdef ISOVERIF
    1831818318      if (kmin_jessai.gt.kmax_jessai) then ! on plante si kmin>=kmax pour k<klev
    18319          write(*,*) 'Pb SUBROUTINE coord_prod_nucl_HTO (kmin>kmax)'
     18319         write(*,*) 'Pb SUBROUTINE coord_prod_nucl_HTO(kmin>kmax)'
    1832018320         write(*,*) 'coord_jessai', coord_jessai
    1832118321         write(*,*) 'lon_nucl, lat_nucl', lon_jessai, lat_jessai
    … …  
    1832618326
    1832718327      if ((kmin_jessai.eq.klev).and.(kmax_jessai.ne.klev)) then ! on plante si on n'a pas kmax=klev quand kmin=klev
    18328          write(*,*) 'Pb SUBROUTINE coord_prod_nucl_HTO (kmin=klev)'
     18328         write(*,*) 'Pb SUBROUTINE coord_prod_nucl_HTO(kmin=klev)'
    1832918329         write(*,*) 'coord_jessai', coord_jessai
    1833018330         write(*,*) 'lon_nucl, lat_nucl', lon_jessai, lat_jessai
    … …  
    1841118411#ifdef ISOVERIF
    1841218412       if (kmin_jessai.ge.kmax_jessai) then
    18413        write(*,*) 'Pb SUBROUTINE calcul_prod_nucl_HTO (k<klev)'
     18413       write(*,*) 'Pb SUBROUTINE calcul_prod_nucl_HTO(k<klev)'
    1841418414       write(*,*) 'kmin_HTO devrait etre plus petit que kmax_HTO'
    1841518415       write(*,*) 'kmin_HTO,kmax_HTO',kmin_jessai,kmax_jessai
    … …  
    1842118421       if ((prod_nucl_tmp(j,k).le.0.).or. &
    1842218422            (prod_nucl(ixt,j,k).le.0.)) then
    18423        write(*,*) 'Pb SUBROUTINE calcul_prod_nucl_HTO (k<klev)'
     18423       write(*,*) 'Pb SUBROUTINE calcul_prod_nucl_HTO(k<klev)'
    1842418424       write(*,*) 'prod_nucl_tmp(i,k) ou d_xt_prod_nucl devraient etre positifs'
    1842518425       write(*,*) 'ixt,i,k',ixt,j,k
    … …  
    1844618446       if ((kmin_jessai.ne.kmax_jessai).and. &
    1844718447           (kmin_jessai.ne.klev)) then
    18448        write(*,*) 'Pb SUBROUTINE calcul_prod_nucl_HTO (k=klev)'
     18448       write(*,*) 'Pb SUBROUTINE calcul_prod_nucl_HTO(k=klev)'
    1844918449       write(*,*) 'kmin_HTO et kmax_HTO devraient etre egaux a klev'
    1845018450       write(*,*) 'kmin_HTO,kmax_HTO',kmin_jessai,kmax_jessai
    … …  
    1845618456       if ((prod_nucl_tmp(j,k).le.0.).or. &
    1845718457           (prod_nucl(ixt,j,k).le.0.)) then
    18458        write(*,*) 'Pb SUBROUTINE calcul_prod_nucl_HTO (k=klev)'
     18458       write(*,*) 'Pb SUBROUTINE calcul_prod_nucl_HTO(k=klev)'
    1845918459       write(*,*) 'prod_nucl_tmp(i,k) ou d_xt_prod_nucl devraient etre positifs'
    1846018460       write(*,*) 'ixt,i,k',ixt,j,k

  • LMDZ6/branches/Amaury_dev/libf/phylmdiso/phyetat0_mod.F90

    r5103 r5106  
    88CONTAINS
    99
    10 SUBROUTINE phyetat0 (fichnom, clesphy0, tabcntr0)
     10SUBROUTINE phyetat0(fichnom, clesphy0, tabcntr0)
    1111
    1212  USE dimphy, only: klon, zmasq, klev

  • LMDZ6/branches/Amaury_dev/libf/phylmdiso/phyredem.F90

    r5103 r5106  
    22! $Id: phyredem.F90 3506 2019-05-16 14:38:11Z ymeurdesoif $
    33
    4 SUBROUTINE phyredem (fichnom)
     4SUBROUTINE phyredem(fichnom)
    55
    66!-------------------------------------------------------------------------------
    … …  
    486486! je voulais mettre cette SUBROUTINE dans isotopes_mod, mais elle a besoin de put_field_srf1 qui est contenue dans la SUBROUTINE phyredem. Si on veut mettre cette routine dans isotopes_mod, il faudrait convertir ce fichier en module pour pouvoir en appeler des routines
    487487
    488       SUBROUTINE phyisoredem (pass, &
     488      SUBROUTINE phyisoredem(pass, &
    489489                xtsnow, &
    490490                xtrun_off_lic_0,Rland_ice, &

  • LMDZ6/branches/Amaury_dev/libf/phylmdiso/physiq_mod.F90

    r5103 r5106  
    99CONTAINS
    1010
    11   SUBROUTINE physiq (nlon,nlev, &
     11  SUBROUTINE physiq(nlon,nlev, &
    1212       debut,lafin,pdtphys_, &
    1313       paprs,pplay,pphi,pphis,presnivs, &

  • LMDZ6/branches/Amaury_dev/libf/phylmdiso/reevap.F90

    r5105 r5106  
    1   SUBROUTINE reevap (klon,klev,iflag_ice_thermo,t_seri,qx, &
     1  SUBROUTINE reevap(klon,klev,iflag_ice_thermo,t_seri,qx, &
    22             d_t_eva,d_qx_eva)
    33
Note: See TracChangeset for help on using the changeset viewer.