Ignore:
Timestamp:
Jul 23, 2024, 8:22:55 AM (2 months ago)
Author:
abarral
Message:

Handle DEBUG_IO in lmdz_cppkeys_wrapper.F90
Transform some files .F -> .[fF]90
[ne compile pas à cause de writefield_u non défini - en attente de réponse Laurent]

Location:
LMDZ6/branches/Amaury_dev/libf/dyn3d
Files:
25 edited
1 moved

Legend:

Unmodified
Added
Removed

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/abort_gcm.F

    r5099 r5101  
    3737
    3838#ifdef CPP_IOIPSL
    39       call histclo
    40       call restclo
     39      CALL histclo
     40      CALL restclo
    4141#endif
    42       call getin_dump
    43 c     call histclo(2)
    44 c     call histclo(3)
    45 c     call histclo(4)
    46 c     call histclo(5)
     42      CALL getin_dump
     43c     CALL histclo(2)
     44c     CALL histclo(3)
     45c     CALL histclo(4)
     46c     CALL histclo(5)
    4747      write(lunout,*) 'Stopping in ', modname
    4848      write(lunout,*) 'Reason = ',message

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/addfi.F

    r5099 r5101  
    66     S          pdufi, pdvfi, pdhfi,pdqfi, pdpfi  )
    77
    8       USE infotrac, ONLY : nqtot
    9       USE control_mod, ONLY : planet_type
     8      USE infotrac, ONLY: nqtot
     9      USE control_mod, ONLY: planet_type
    1010      IMPLICIT NONE
    1111c

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/advtrac.f90

    r5100 r5101  
    11! $Id$
    22
    3 #define DEBUG_IO
    4 #undef DEBUG_IO
    5 SUBROUTINE advtrac(pbaru, pbarv, p, masse,q,iapptrac,teta, flxw, pk)
    6    !     Auteur :  F. Hourdin
    7 
    8    !     Modif. P. Le Van     (20/12/97)
    9    !            F. Codron     (10/99)
    10    !            D. Le Croller (07/2001)
    11    !            M.A Filiberti (04/2002)
    12 
    13    USE infotrac,     ONLY: nqtot, tracers, isoCheck
    14    USE control_mod,  ONLY: iapp_tracvl, day_step
    15    USE comconst_mod, ONLY: dtvr
    16 
    17    IMPLICIT NONE
    18 
    19    include "dimensions.h"
    20    include "paramet.h"
    21    include "comdissip.h"
    22    include "comgeom2.h"
    23    include "description.h"
    24    include "iniprint.h"
    25 
    26    !---------------------------------------------------------------------------
    27    !     Arguments
    28    !---------------------------------------------------------------------------
    29    INTEGER, INTENT(OUT) :: iapptrac
    30    REAL, INTENT(IN) :: pbaru(ip1jmp1,llm)
    31    REAL, INTENT(IN) :: pbarv(ip1jm,  llm)
    32    REAL, INTENT(INOUT) ::  q(ip1jmp1,llm,nqtot)
    33    REAL, INTENT(IN) :: masse(ip1jmp1,llm)
    34    REAL, INTENT(IN) ::     p(ip1jmp1,llmp1 )
    35    REAL, INTENT(IN) ::  teta(ip1jmp1,llm)
    36    REAL, INTENT(IN) ::    pk(ip1jmp1,llm)
    37    REAL, INTENT(OUT) :: flxw(ip1jmp1,llm)
    38    !---------------------------------------------------------------------------
    39    !     Ajout PPM
    40    !---------------------------------------------------------------------------
    41    REAL :: massebx(ip1jmp1,llm), masseby(ip1jm,llm)
    42    !---------------------------------------------------------------------------
    43    !     Variables locales
    44    !---------------------------------------------------------------------------
    45    INTEGER :: ij, l, iq, iadv
    46 !   REAL(KIND=KIND(1.d0)) :: t_initial, t_final, tps_cpu
    47    REAL :: zdp(ip1jmp1), zdpmin, zdpmax
    48    INTEGER, SAVE :: iadvtr=0
    49    REAL, DIMENSION(ip1jmp1,llm) :: pbaruc, pbarug, massem, wg
    50    REAL, DIMENSION(ip1jm,  llm) :: pbarvc, pbarvg
    51    EXTERNAL  minmax
    52    SAVE massem, pbaruc, pbarvc
    53    !---------------------------------------------------------------------------
    54    !     Rajouts pour PPM
    55    !---------------------------------------------------------------------------
    56    INTEGER indice, n
    57    REAL :: dtbon                       ! Pas de temps adaptatif pour que CFL<1
    58    REAL :: CFLmaxz, aaa, bbb           ! CFL maximum
    59    REAL, DIMENSION(iim,jjp1,llm) :: unatppm, vnatppm, fluxwppm
    60    REAL ::    qppm(iim*jjp1,llm,nqtot)
    61    REAL ::   psppm(iim,jjp1)           ! pression  au sol
    62    REAL, DIMENSION(llmp1) :: apppm, bpppm
    63    LOGICAL, SAVE :: dum=.TRUE., fill=.TRUE.
    64 
    65    INTEGER, SAVE :: countcfl=0
    66    REAL, DIMENSION(ip1jmp1,llm) :: cflx, cflz
    67    REAL, DIMENSION(ip1jm  ,llm) :: cfly
    68    REAL, DIMENSION(llm), SAVE :: cflxmax, cflymax, cflzmax
    69 
    70    IF(iadvtr == 0) THEN
    71       pbaruc(:,:)=0
    72       pbarvc(:,:)=0
    73    END IF
    74 
    75    !--- Accumulation des flux de masse horizontaux
    76    DO l=1,llm
    77       DO ij = 1,ip1jmp1
    78          pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
     3SUBROUTINE advtrac(pbaru, pbarv, p, masse, q, iapptrac, teta, flxw, pk)
     4  !     Auteur :  F. Hourdin
     5
     6  !     Modif. P. Le Van     (20/12/97)
     7  !            F. Codron     (10/99)
     8  !            D. Le Croller (07/2001)
     9  !            M.A Filiberti (04/2002)
     10
     11  USE infotrac, ONLY: nqtot, tracers, isoCheck
     12  USE control_mod, ONLY: iapp_tracvl, day_step
     13  USE comconst_mod, ONLY: dtvr
     14  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
     15  USE write_field, ONLY: int2str
     16
     17  IMPLICIT NONE
     18
     19  include "dimensions.h"
     20  include "paramet.h"
     21  include "comdissip.h"
     22  include "comgeom2.h"
     23  include "description.h"
     24  include "iniprint.h"
     25
     26  !---------------------------------------------------------------------------
     27  !     Arguments
     28  !---------------------------------------------------------------------------
     29  INTEGER, INTENT(OUT) :: iapptrac
     30  REAL, INTENT(IN) :: pbaru(ip1jmp1, llm)
     31  REAL, INTENT(IN) :: pbarv(ip1jm, llm)
     32  REAL, INTENT(INOUT) :: q(ip1jmp1, llm, nqtot)
     33  REAL, INTENT(IN) :: masse(ip1jmp1, llm)
     34  REAL, INTENT(IN) :: p(ip1jmp1, llmp1)
     35  REAL, INTENT(IN) :: teta(ip1jmp1, llm)
     36  REAL, INTENT(IN) :: pk(ip1jmp1, llm)
     37  REAL, INTENT(OUT) :: flxw(ip1jmp1, llm)
     38  !---------------------------------------------------------------------------
     39  !     Ajout PPM
     40  !---------------------------------------------------------------------------
     41  REAL :: massebx(ip1jmp1, llm), masseby(ip1jm, llm)
     42  !---------------------------------------------------------------------------
     43  !     Variables locales
     44  !---------------------------------------------------------------------------
     45  INTEGER :: ij, l, iq, iadv
     46  !   REAL(KIND=KIND(1.d0)) :: t_initial, t_final, tps_cpu
     47  REAL :: zdp(ip1jmp1), zdpmin, zdpmax
     48  INTEGER, SAVE :: iadvtr = 0
     49  REAL, DIMENSION(ip1jmp1, llm) :: pbaruc, pbarug, massem, wg
     50  REAL, DIMENSION(ip1jm, llm) :: pbarvc, pbarvg
     51  EXTERNAL  minmax
     52  SAVE massem, pbaruc, pbarvc
     53  !---------------------------------------------------------------------------
     54  !     Rajouts pour PPM
     55  !---------------------------------------------------------------------------
     56  INTEGER indice, n
     57  REAL :: dtbon                       ! Pas de temps adaptatif pour que CFL<1
     58  REAL :: CFLmaxz, aaa, bbb           ! CFL maximum
     59  REAL, DIMENSION(iim, jjp1, llm) :: unatppm, vnatppm, fluxwppm
     60  REAL :: qppm(iim * jjp1, llm, nqtot)
     61  REAL :: psppm(iim, jjp1)           ! pression  au sol
     62  REAL, DIMENSION(llmp1) :: apppm, bpppm
     63  LOGICAL, SAVE :: dum = .TRUE., fill = .TRUE.
     64
     65  INTEGER, SAVE :: countcfl = 0
     66  REAL, DIMENSION(ip1jmp1, llm) :: cflx, cflz
     67  REAL, DIMENSION(ip1jm, llm) :: cfly
     68  REAL, DIMENSION(llm), SAVE :: cflxmax, cflymax, cflzmax
     69
     70  IF(iadvtr == 0) THEN
     71    pbaruc(:, :) = 0
     72    pbarvc(:, :) = 0
     73  END IF
     74
     75  !--- Accumulation des flux de masse horizontaux
     76  DO l = 1, llm
     77    DO ij = 1, ip1jmp1
     78      pbaruc(ij, l) = pbaruc(ij, l) + pbaru(ij, l)
     79    END DO
     80    DO ij = 1, ip1jm
     81      pbarvc(ij, l) = pbarvc(ij, l) + pbarv(ij, l)
     82    END DO
     83  END DO
     84
     85  !--- Selection de la masse instantannee des mailles avant le transport.
     86  IF(iadvtr == 0) THEN
     87    CALL SCOPY(ip1jmp1 * llm, masse, 1, massem, 1)
     88    ! CALL filtreg ( massem ,jjp1, llm,-2, 2, .TRUE., 1 )
     89  END IF
     90
     91  iadvtr = iadvtr + 1
     92  iapptrac = iadvtr
     93
     94  !--- Test pour savoir si on advecte a ce pas de temps
     95  IF(iadvtr /= iapp_tracvl) RETURN
     96
     97  !   ..  Modif P.Le Van  ( 20/12/97 )  ....
     98
     99  !   traitement des flux de masse avant advection.
     100  !       1. calcul de w
     101  !       2. groupement des mailles pres du pole.
     102
     103  CALL groupe(massem, pbaruc, pbarvc, pbarug, pbarvg, wg)
     104
     105  !--- Flux de masse diaganostiques traceurs
     106  flxw = wg / REAL(iapp_tracvl)
     107
     108  !--- Test sur l'eventuelle creation de valeurs negatives de la masse
     109  DO l = 1, llm - 1
     110    DO ij = iip2 + 1, ip1jm
     111      zdp(ij) = pbarug(ij - 1, l) - pbarug(ij, l) &
     112              - pbarvg(ij - iip1, l) + pbarvg(ij, l) &
     113              + wg(ij, l + 1) - wg(ij, l)
     114    END DO
     115    ! ym  ---> pourquoi jjm-1 et non jjm ? a cause du pole ?
     116    CALL SCOPY(jjm - 1, zdp(iip1 + iip1), iip1, zdp(iip2), iip1)
     117    DO ij = iip2, ip1jm
     118      zdp(ij) = zdp(ij) * dtvr / massem(ij, l)
     119    END DO
     120
     121    CALL minmax (ip1jm - iip1, zdp(iip2), zdpmin, zdpmax)
     122
     123    IF(MAX(ABS(zdpmin), ABS(zdpmax)) > 0.5) &
     124            WRITE(*, *)'WARNING DP/P l=', l, '  MIN:', zdpmin, ' MAX:', zdpmax
     125
     126  END DO
     127
     128  !-------------------------------------------------------------------------
     129  ! Calcul des criteres CFL en X, Y et Z
     130  !-------------------------------------------------------------------------
     131  IF(countcfl == 0.) then
     132    cflxmax(:) = 0.
     133    cflymax(:) = 0.
     134    cflzmax(:) = 0.
     135  END IF
     136
     137  countcfl = countcfl + iapp_tracvl
     138  cflx(:, :) = 0.
     139  cfly(:, :) = 0.
     140  cflz(:, :) = 0.
     141  DO l = 1, llm
     142    DO ij = iip2, ip1jm - 1
     143      IF(pbarug(ij, l)>=0.) then
     144        cflx(ij, l) = pbarug(ij, l) * dtvr / masse(ij, l)
     145      ELSE
     146        cflx(ij, l) = -pbarug(ij, l) * dtvr / masse(ij + 1, l)
     147      END IF
     148    END DO
     149  END DO
     150
     151  DO l = 1, llm
     152    DO ij = iip2, ip1jm - 1, iip1
     153      cflx(ij + iip1, l) = cflx(ij, l)
     154    END DO
     155  END DO
     156
     157  DO l = 1, llm
     158    DO ij = 1, ip1jm
     159      IF(pbarvg(ij, l)>=0.) then
     160        cfly(ij, l) = pbarvg(ij, l) * dtvr / masse(ij, l)
     161      ELSE
     162        cfly(ij, l) = -pbarvg(ij, l) * dtvr / masse(ij + iip1, l)
     163      END IF
     164    END DO
     165  END DO
     166
     167  DO l = 2, llm
     168    DO ij = 1, ip1jm
     169      IF(wg(ij, l) >= 0.) THEN
     170        cflz(ij, l) = wg(ij, l) * dtvr / masse(ij, l)
     171      ELSE
     172        cflz(ij, l) = -wg(ij, l) * dtvr / masse(ij, l - 1)
     173      END IF
     174    END DO
     175  END DO
     176
     177  DO l = 1, llm
     178    cflxmax(l) = max(cflxmax(l), maxval(cflx(:, l)))
     179    cflymax(l) = max(cflymax(l), maxval(cfly(:, l)))
     180    cflzmax(l) = max(cflzmax(l), maxval(cflz(:, l)))
     181  END DO
     182
     183  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     184  ! Par defaut, on sort le diagnostic des CFL tous les jours.
     185  ! Si on veut le sortir a chaque pas d'advection en cas de plantage
     186  !       IF(countcfl==iapp_tracvl) then
     187  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     188  IF(countcfl==day_step) then
     189    DO l = 1, llm
     190      WRITE(lunout, *) 'L, CFL[xyz]max:', l, cflxmax(l), cflymax(l), cflzmax(l)
     191    END DO
     192    countcfl = 0
     193  END IF
     194
     195  !---------------------------------------------------------------------------
     196  !   Advection proprement dite (Modification Le Croller (07/2001)
     197  !---------------------------------------------------------------------------
     198
     199  !---------------------------------------------------------------------------
     200  !   Calcul des moyennes basees sur la masse
     201  !---------------------------------------------------------------------------
     202  CALL massbar(massem, massebx, masseby)
     203
     204  IF (CPPKEY_DEBUGIO) THEN
     205    CALL WriteField_u('massem', massem)
     206    CALL WriteField_u('wg', wg)
     207    CALL WriteField_u('pbarug', pbarug)
     208    CALL WriteField_v('pbarvg', pbarvg)
     209    CALL WriteField_u('p_tmp', p)
     210    CALL WriteField_u('pk_tmp', pk)
     211    CALL WriteField_u('teta_tmp', teta)
     212    DO iq = 1, nqtot
     213      CALL WriteField_u('q_adv' // trim(int2str(iq)), q(:, :, iq))
     214    END DO
     215  END IF
     216
     217  IF(isoCheck) WRITE(*, *) 'advtrac 227'
     218  CALL check_isotopes_seq(q, ip1jmp1, 'advtrac 162')
     219
     220  !-------------------------------------------------------------------------
     221  !       Appel des sous programmes d'advection
     222  !-------------------------------------------------------------------------
     223  DO iq = 1, nqtot
     224    !     CALL clock(t_initial)
     225    IF(tracers(iq)%parent /= 'air') CYCLE
     226    iadv = tracers(iq)%iadv
     227    !-----------------------------------------------------------------------
     228    SELECT CASE(iadv)
     229      !-----------------------------------------------------------------------
     230    CASE(0); CYCLE
     231    !--------------------------------------------------------------------
     232    CASE(10)  !--- Schema de Van Leer I MUSCL
     233      !--------------------------------------------------------------------
     234      !           WRITE(*,*) 'advtrac 239: iq,q(1721,19,:)=',iq,q(1721,19,:)
     235      CALL vlsplt(q, 2., massem, wg, pbarug, pbarvg, dtvr, iq)
     236
     237      !--------------------------------------------------------------------
     238    CASE(14)  !--- Schema "pseuDO amont" + test sur humidite specifique
     239      !--- pour la vapeur d'eau. F. Codron
     240      !--------------------------------------------------------------------
     241      !           WRITE(*,*) 'advtrac 248: iq,q(1721,19,:)=',iq,q(1721,19,:)
     242      CALL vlspltqs(q, 2., massem, wg, pbarug, pbarvg, dtvr, p, pk, teta, iq)
     243
     244      !--------------------------------------------------------------------
     245    CASE(12)  !--- Schema de Frederic Hourdin
     246      !--------------------------------------------------------------------
     247      CALL adaptdt(iadv, dtbon, n, pbarug, massem)   ! pas de temps adaptatif
     248      IF(n > 1) WRITE(*, *) 'WARNING horizontal dt=', dtbon, 'dtvr=', dtvr, 'n=', n
     249      DO indice = 1, n
     250        CALL advn(q(1, 1, iq), massem, wg, pbarug, pbarvg, dtbon, 1)
    79251      END DO
    80       DO ij = 1,ip1jm
    81          pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
     252
     253      !--------------------------------------------------------------------
     254    CASE(13)  !--- Pas de temps adaptatif
     255      !--------------------------------------------------------------------
     256      CALL adaptdt(iadv, dtbon, n, pbarug, massem)
     257      IF(n > 1) WRITE(*, *) 'WARNING horizontal dt=', dtbon, 'dtvr=', dtvr, 'n=', n
     258      DO indice = 1, n
     259        CALL advn(q(1, 1, iq), massem, wg, pbarug, pbarvg, dtbon, 2)
    82260      END DO
    83    END DO
    84 
    85    !--- Selection de la masse instantannee des mailles avant le transport.
    86    IF(iadvtr == 0) THEN
    87      CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
    88    ! CALL filtreg ( massem ,jjp1, llm,-2, 2, .TRUE., 1 )
    89    END IF
    90 
    91    iadvtr   = iadvtr+1
    92    iapptrac = iadvtr
    93 
    94    !--- Test pour savoir si on advecte a ce pas de temps
    95    IF(iadvtr /= iapp_tracvl) RETURN
    96 
    97    !   ..  Modif P.Le Van  ( 20/12/97 )  ....
    98 
    99    !   traitement des flux de masse avant advection.
    100    !       1. calcul de w
    101    !       2. groupement des mailles pres du pole.
    102 
    103    CALL groupe(massem, pbaruc, pbarvc, pbarug, pbarvg, wg)
    104 
    105    !--- Flux de masse diaganostiques traceurs
    106    flxw = wg / REAL(iapp_tracvl)
    107 
    108    !--- Test sur l'eventuelle creation de valeurs negatives de la masse
    109    DO l=1,llm-1
    110       DO ij = iip2+1,ip1jm
    111          zdp(ij) = pbarug(ij-1,l)    - pbarug(ij,l) &
    112                  - pbarvg(ij-iip1,l) + pbarvg(ij,l) &
    113                  +     wg(ij,l+1)    -     wg(ij,l)
     261
     262      !--------------------------------------------------------------------
     263    CASE(20)  !--- Schema de pente SLOPES
     264      !--------------------------------------------------------------------
     265      CALL pentes_ini (q(1, 1, iq), wg, massem, pbarug, pbarvg, 0)
     266
     267      !--------------------------------------------------------------------
     268    CASE(30)  !--- Schema de Prather
     269      !--------------------------------------------------------------------
     270      ! Pas de temps adaptatif
     271      CALL adaptdt(iadv, dtbon, n, pbarug, massem)
     272      IF(n > 1) WRITE(*, *) 'WARNING horizontal dt=', dtbon, 'dtvr=', dtvr, 'n=', n
     273      CALL prather(q(1, 1, iq), wg, massem, pbarug, pbarvg, n, dtbon)
     274
     275      !--------------------------------------------------------------------
     276    CASE(11, 16, 17, 18)   !--- Schemas PPM Lin et Rood
     277      !--------------------------------------------------------------------
     278      ! Test sur le flux horizontal
     279      CALL adaptdt(iadv, dtbon, n, pbarug, massem)   ! pas de temps adaptatif
     280      IF(n > 1) WRITE(*, *) 'WARNING horizontal dt=', dtbon, 'dtvr=', dtvr, 'n=', n
     281      ! Test sur le flux vertical
     282      CFLmaxz = 0.
     283      DO l = 2, llm
     284        DO ij = iip2, ip1jm
     285          aaa = wg(ij, l) * dtvr / massem(ij, l)
     286          CFLmaxz = max(CFLmaxz, aaa)
     287          bbb = -wg(ij, l) * dtvr / massem(ij, l - 1)
     288          CFLmaxz = max(CFLmaxz, bbb)
     289        END DO
    114290      END DO
    115 ! ym  ---> pourquoi jjm-1 et non jjm ? a cause du pole ?
    116       CALL SCOPY( jjm -1 ,zdp(iip1+iip1),iip1,zdp(iip2),iip1 )
    117       DO ij = iip2,ip1jm
    118          zdp(ij)= zdp(ij)*dtvr/ massem(ij,l)
     291      IF(CFLmaxz>=1) WRITE(*, *) 'WARNING vertical', 'CFLmaxz=', CFLmaxz
     292      !----------------------------------------------------------------
     293      !     Ss-prg interface LMDZ.4->PPM3d (ss-prg de Lin)
     294      !----------------------------------------------------------------
     295      CALL interpre(q(1, 1, iq), qppm(1, 1, iq), wg, fluxwppm, massem, &
     296              apppm, bpppm, massebx, masseby, pbarug, pbarvg, &
     297              unatppm, vnatppm, psppm)
     298
     299      !----------------------------------------------------------------
     300      DO indice = 1, n     !--- VL (version PPM) horiz. et PPM vert.
     301        !----------------------------------------------------------------
     302        SELECT CASE(iadv)
     303          !----------------------------------------------------------
     304        CASE(11)
     305          !----------------------------------------------------------
     306          CALL ppm3d(1, qppm(1, 1, iq), psppm, psppm, unatppm, vnatppm, fluxwppm, dtbon, &
     307                  2, 2, 2, 1, iim, jjp1, 2, llm, apppm, bpppm, 0.01, 6400000, fill, dum, 220.)
     308          !----------------------------------------------------------
     309        CASE(16) !--- Monotonic PPM
     310          !----------------------------------------------------------
     311          CALL ppm3d(1, qppm(1, 1, iq), psppm, psppm, unatppm, vnatppm, fluxwppm, dtbon, &
     312                  3, 3, 3, 1, iim, jjp1, 2, llm, apppm, bpppm, 0.01, 6400000, fill, dum, 220.)
     313          !----------------------------------------------------------
     314        CASE(17) !--- Semi monotonic PPM
     315          !----------------------------------------------------------
     316          CALL ppm3d(1, qppm(1, 1, iq), psppm, psppm, unatppm, vnatppm, fluxwppm, dtbon, &
     317                  4, 4, 4, 1, iim, jjp1, 2, llm, apppm, bpppm, 0.01, 6400000, fill, dum, 220.)
     318          !----------------------------------------------------------
     319        CASE(18) !--- Positive Definite PPM
     320          !----------------------------------------------------------
     321          CALL ppm3d(1, qppm(1, 1, iq), psppm, psppm, unatppm, vnatppm, fluxwppm, dtbon, &
     322                  5, 5, 5, 1, iim, jjp1, 2, llm, apppm, bpppm, 0.01, 6400000, fill, dum, 220.)
     323        END SELECT
     324        !----------------------------------------------------------------
    119325      END DO
    120 
    121       CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax )
    122 
    123       IF(MAX(ABS(zdpmin),ABS(zdpmax)) > 0.5) &
    124          WRITE(*,*)'WARNING DP/P l=',l,'  MIN:',zdpmin,' MAX:', zdpmax
    125 
    126    END DO
    127 
    128    !-------------------------------------------------------------------------
    129    ! Calcul des criteres CFL en X, Y et Z
    130    !-------------------------------------------------------------------------
    131    IF(countcfl == 0. ) then
    132       cflxmax(:)=0.
    133       cflymax(:)=0.
    134       cflzmax(:)=0.
    135    END IF
    136 
    137    countcfl=countcfl+iapp_tracvl
    138    cflx(:,:)=0.
    139    cfly(:,:)=0.
    140    cflz(:,:)=0.
    141    DO l=1,llm
    142       DO ij=iip2,ip1jm-1
    143          IF(pbarug(ij,l)>=0.) then
    144             cflx(ij,l)=pbarug(ij,l)*dtvr/masse(ij,l)
    145          ELSE
    146             cflx(ij,l)=-pbarug(ij,l)*dtvr/masse(ij+1,l)
    147          END IF
    148       END DO
    149    END DO
    150 
    151    DO l=1,llm
    152       DO ij=iip2,ip1jm-1,iip1
    153          cflx(ij+iip1,l)=cflx(ij,l)
    154       END DO
    155    END DO
    156 
    157    DO l=1,llm
    158       DO ij=1,ip1jm
    159          IF(pbarvg(ij,l)>=0.) then
    160             cfly(ij,l)=pbarvg(ij,l)*dtvr/masse(ij,l)
    161          ELSE
    162             cfly(ij,l)=-pbarvg(ij,l)*dtvr/masse(ij+iip1,l)
    163          END IF
    164       END DO
    165    END DO
    166 
    167    DO l=2,llm
    168       DO ij=1,ip1jm
    169          IF(wg(ij,l) >= 0.) THEN
    170             cflz(ij,l)=wg(ij,l)*dtvr/masse(ij,l)
    171          ELSE
    172             cflz(ij,l)=-wg(ij,l)*dtvr/masse(ij,l-1)
    173          END IF
    174       END DO
    175    END DO
    176 
    177    DO l=1,llm
    178       cflxmax(l)=max(cflxmax(l),maxval(cflx(:,l)))
    179       cflymax(l)=max(cflymax(l),maxval(cfly(:,l)))
    180       cflzmax(l)=max(cflzmax(l),maxval(cflz(:,l)))
    181    END DO
    182 
    183    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    184    ! Par defaut, on sort le diagnostic des CFL tous les jours.
    185    ! Si on veut le sortir a chaque pas d'advection en cas de plantage
    186    !       IF(countcfl==iapp_tracvl) then
    187    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    188    IF(countcfl==day_step) then
    189       DO l=1,llm
    190          WRITE(lunout,*) 'L, CFL[xyz]max:', l, cflxmax(l), cflymax(l), cflzmax(l)
    191       END DO
    192       countcfl=0
    193    END IF
    194 
    195    !---------------------------------------------------------------------------
    196    !   Advection proprement dite (Modification Le Croller (07/2001)
    197    !---------------------------------------------------------------------------
    198 
    199    !---------------------------------------------------------------------------
    200    !   Calcul des moyennes basees sur la masse
    201    !---------------------------------------------------------------------------
    202    CALL massbar(massem,massebx,masseby)
    203 
    204 #ifdef DEBUG_IO   
    205    CALL WriteField_u('massem',massem)
    206    CALL WriteField_u('wg',wg)
    207    CALL WriteField_u('pbarug',pbarug)
    208    CALL WriteField_v('pbarvg',pbarvg)
    209    CALL WriteField_u('p_tmp',p)
    210    CALL WriteField_u('pk_tmp',pk)
    211    CALL WriteField_u('teta_tmp',teta)
    212    DO iq=1,nqtot
    213       CALL WriteField_u('q_adv'//trim(int2str(iq)),q(:,:,iq))
    214    END DO
    215 #endif
    216 
    217    IF(isoCheck) WRITE(*,*) 'advtrac 227'
    218    CALL check_isotopes_seq(q,ip1jmp1,'advtrac 162')
    219 
    220    !-------------------------------------------------------------------------
    221    !       Appel des sous programmes d'advection
    222    !-------------------------------------------------------------------------
    223    DO iq = 1, nqtot
    224 !     CALL clock(t_initial)
    225       IF(tracers(iq)%parent /= 'air') CYCLE
    226       iadv = tracers(iq)%iadv
    227       !-----------------------------------------------------------------------
    228       SELECT CASE(iadv)
    229       !-----------------------------------------------------------------------
    230          CASE(0); CYCLE
    231          !--------------------------------------------------------------------
    232          CASE(10)  !--- Schema de Van Leer I MUSCL
    233          !--------------------------------------------------------------------
    234 !           WRITE(*,*) 'advtrac 239: iq,q(1721,19,:)=',iq,q(1721,19,:)     
    235             CALL vlsplt(q,2.,massem,wg,pbarug,pbarvg,dtvr,iq)
    236 
    237          !--------------------------------------------------------------------
    238          CASE(14)  !--- Schema "pseuDO amont" + test sur humidite specifique
    239                    !--- pour la vapeur d'eau. F. Codron
    240          !--------------------------------------------------------------------
    241 !           WRITE(*,*) 'advtrac 248: iq,q(1721,19,:)=',iq,q(1721,19,:)
    242             CALL vlspltqs(q,2.,massem,wg,pbarug,pbarvg,dtvr,p,pk,teta,iq)
    243 
    244          !--------------------------------------------------------------------
    245          CASE(12)  !--- Schema de Frederic Hourdin
    246          !--------------------------------------------------------------------
    247             CALL adaptdt(iadv,dtbon,n,pbarug,massem)   ! pas de temps adaptatif
    248             IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n
    249             DO indice=1,n
    250               CALL advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,1)
    251             END DO
    252 
    253          !--------------------------------------------------------------------
    254          CASE(13)  !--- Pas de temps adaptatif
    255          !--------------------------------------------------------------------
    256             CALL adaptdt(iadv,dtbon,n,pbarug,massem)
    257             IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n
    258             DO indice=1,n
    259                CALL advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,2)
    260             END DO
    261 
    262          !--------------------------------------------------------------------
    263          CASE(20)  !--- Schema de pente SLOPES
    264          !--------------------------------------------------------------------
    265             CALL pentes_ini (q(1,1,iq),wg,massem,pbarug,pbarvg,0)
    266 
    267          !--------------------------------------------------------------------
    268          CASE(30)  !--- Schema de Prather
    269          !--------------------------------------------------------------------
    270             ! Pas de temps adaptatif
    271             CALL adaptdt(iadv,dtbon,n,pbarug,massem)
    272             IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n
    273             CALL prather(q(1,1,iq),wg,massem,pbarug,pbarvg,n,dtbon)
    274 
    275          !--------------------------------------------------------------------
    276          CASE(11,16,17,18)   !--- Schemas PPM Lin et Rood
    277          !--------------------------------------------------------------------
    278             ! Test sur le flux horizontal
    279             CALL adaptdt(iadv,dtbon,n,pbarug,massem)   ! pas de temps adaptatif
    280             IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n
    281             ! Test sur le flux vertical
    282             CFLmaxz=0.
    283             DO l=2,llm
    284                DO ij=iip2,ip1jm
    285                   aaa=wg(ij,l)*dtvr/massem(ij,l)
    286                   CFLmaxz=max(CFLmaxz,aaa)
    287                   bbb=-wg(ij,l)*dtvr/massem(ij,l-1)
    288                   CFLmaxz=max(CFLmaxz,bbb)
    289                END DO
    290             END DO
    291             IF(CFLmaxz>=1) WRITE(*,*) 'WARNING vertical','CFLmaxz=', CFLmaxz
    292             !----------------------------------------------------------------
    293             !     Ss-prg interface LMDZ.4->PPM3d (ss-prg de Lin)
    294             !----------------------------------------------------------------
    295             CALL interpre(q(1,1,iq),qppm(1,1,iq),wg,fluxwppm,massem, &
    296                  apppm,bpppm,massebx,masseby,pbarug,pbarvg, &
    297                  unatppm,vnatppm,psppm)
    298 
    299             !----------------------------------------------------------------
    300             DO indice=1,n     !--- VL (version PPM) horiz. et PPM vert.
    301             !----------------------------------------------------------------
    302                SELECT CASE(iadv)
    303                   !----------------------------------------------------------
    304                   CASE(11)
    305                   !----------------------------------------------------------
    306                      CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, &
    307                                 2,2,2,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,fill,dum,220.)
    308                   !----------------------------------------------------------
    309                   CASE(16) !--- Monotonic PPM
    310                   !----------------------------------------------------------
    311                      CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, &
    312                                 3,3,3,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,fill,dum,220.)
    313                   !----------------------------------------------------------
    314                   CASE(17) !--- Semi monotonic PPM
    315                   !----------------------------------------------------------
    316                      CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, &
    317                                 4,4,4,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, fill,dum,220.)
    318                   !----------------------------------------------------------
    319                   CASE(18) !--- Positive Definite PPM
    320                   !----------------------------------------------------------
    321                      CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, &
    322                                 5,5,5,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,fill,dum,220.)
    323                END SELECT
    324             !----------------------------------------------------------------
    325             END DO
    326             !----------------------------------------------------------------
    327             !     Ss-prg interface PPM3d-LMDZ.4
    328             !----------------------------------------------------------------
    329             CALL interpost(q(1,1,iq),qppm(1,1,iq))
     326      !----------------------------------------------------------------
     327      !     Ss-prg interface PPM3d-LMDZ.4
     328      !----------------------------------------------------------------
     329      CALL interpost(q(1, 1, iq), qppm(1, 1, iq))
    330330      !----------------------------------------------------------------------
    331       END SELECT
    332       !----------------------------------------------------------------------
    333 
    334       !----------------------------------------------------------------------
    335       ! On impose une seule valeur du traceur au pole Sud j=jjm+1=jjp1 et Nord j=1
    336       !----------------------------------------------------------------------
    337       !  CALL traceurpole(q(1,1,iq),massem)
    338 
    339       !--- Calcul du temps cpu pour un schema donne
    340       !  CALL clock(t_final)
    341       !ym  tps_cpu=t_final-t_initial
    342       !ym  cpuadv(iq)=cpuadv(iq)+tps_cpu
    343 
    344    END DO
    345 
    346    IF(isoCheck) WRITE(*,*) 'advtrac 402'
    347    CALL check_isotopes_seq(q,ip1jmp1,'advtrac 397')
    348 
    349    !-------------------------------------------------------------------------
    350    !   on reinitialise a zero les flux de masse cumules
    351    !-------------------------------------------------------------------------
    352    iadvtr=0
     331    END SELECT
     332    !----------------------------------------------------------------------
     333
     334    !----------------------------------------------------------------------
     335    ! On impose une seule valeur du traceur au pole Sud j=jjm+1=jjp1 et Nord j=1
     336    !----------------------------------------------------------------------
     337    !  CALL traceurpole(q(1,1,iq),massem)
     338
     339    !--- Calcul du temps cpu pour un schema donne
     340    !  CALL clock(t_final)
     341    !ym  tps_cpu=t_final-t_initial
     342    !ym  cpuadv(iq)=cpuadv(iq)+tps_cpu
     343
     344  END DO
     345
     346  IF(isoCheck) WRITE(*, *) 'advtrac 402'
     347  CALL check_isotopes_seq(q, ip1jmp1, 'advtrac 397')
     348
     349  !-------------------------------------------------------------------------
     350  !   on reinitialise a zero les flux de masse cumules
     351  !-------------------------------------------------------------------------
     352  iadvtr = 0
    353353
    354354END SUBROUTINE advtrac

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

    r5099 r5101  
    185185           WRITE(lunout,*)'dt_app=',dt_app
    186186           WRITE(lunout,*)'dt_cum=',dt_cum
    187            call abort_gcm('bilan_dyn','stopped',1)
     187           CALL abort_gcm('bilan_dyn','stopped',1)
    188188        endif
    189189
    190190        if (i_sortie==1) then
    191191         file='dynzon'
    192          call inigrads(ifile,1
     192         CALL inigrads(ifile,1
    193193     s  ,0.,180./pi,0.,0.,jjm,rlatv,-90.,90.,180./pi
    194194     s  ,llm,presnivs,1.
    … …  
    226226      rlatg=rlatv*180./pi
    227227       
    228       call histbeg(infile, 1, rlong, jjm, rlatg,
     228      CALL histbeg(infile, 1, rlong, jjm, rlatg,
    229229     .             1, 1, 1, jjm,
    230230     .             tau0, zjulian, dt_cum, thoriid, fileid)
    … …  
    233233C  Appel a histvert pour la grille verticale
    234234C
    235       call histvert(fileid, 'presnivs', 'Niveaux sigma','mb',
     235      CALL histvert(fileid, 'presnivs', 'Niveaux sigma','mb',
    236236     .              llm, presnivs, zvertiid)
    237237C
    … …  
    258258     . WRITE(lunout,*)'var ',itr,iQ
    259259     .      ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ)
    260             call histdef(fileid,znom(itr,iQ),znoml(itr,iQ),
     260            CALL histdef(fileid,znom(itr,iQ),znoml(itr,iQ),
    261261     .        zunites(itr,iQ),1,jjm,thoriid,llm,1,llm,zvertiid,
    262262     .        32,'ave(X)',dt_cum,dt_cum)
    … …  
    264264c   Declarations pour les fonctions de courant
    265265c      print*,'2HISTDEF'
    266           call histdef(fileid,'psi'//nom(iQ)
     266          CALL histdef(fileid,'psi'//nom(iQ)
    267267     .      ,'stream fn. '//znoml(itot,iQ),
    268268     .      zunites(itot,iQ),1,jjm,thoriid,llm,1,llm,zvertiid,
    … …  
    273273c   Declarations pour les champs de transport d'air
    274274c      print*,'3HISTDEF'
    275       call histdef(fileid, 'masse', 'masse',
     275      CALL histdef(fileid, 'masse', 'masse',
    276276     .             'kg', 1, jjm, thoriid, llm, 1, llm, zvertiid,
    277277     .             32, 'ave(X)', dt_cum, dt_cum)
    278       call histdef(fileid, 'v', 'v',
     278      CALL histdef(fileid, 'v', 'v',
    279279     .             'm/s', 1, jjm, thoriid, llm, 1, llm, zvertiid,
    280280     .             32, 'ave(X)', dt_cum, dt_cum)
    281281c   Declarations pour les fonctions de courant
    282282c      print*,'4HISTDEF'
    283           call histdef(fileid,'psi','stream fn. MMC ','mega t/s',
     283          CALL histdef(fileid,'psi','stream fn. MMC ','mega t/s',
    284284     .      1,jjm,thoriid,llm,1,llm,zvertiid,
    285285     .      32,'ave(X)',dt_cum,dt_cum)
    … …  
    290290      do iQ=1,nQ
    291291         do itr=2,ntr
    292             call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ),
     292            CALL histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ),
    293293     .        zunites(itr,iQ),1,jjm,thoriid,1,1,1,-99,
    294294     .        32,'ave(X)',dt_cum,dt_cum)
    … …  
    391391
    392392c   convergence horizontale
    393       call  convflu(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ)
     393      CALL  convflu(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ)
    394394
    395395c   calcul de la vitesse verticale
    396       call convmas(flux_u_cum,flux_v_cum,convm)
     396      CALL convmas(flux_u_cum,flux_v_cum,convm)
    397397      CALL vitvert(convm,w)
    398398
    … …  
    447447      zv=0.
    448448      zmasse=0.
    449       call massbar(masse_cum,massebx,masseby)
     449      CALL massbar(masse_cum,massebx,masseby)
    450450      do l=1,llm
    451451         do j=1,jjm
    … …  
    537537      do iQ=1,nQ
    538538         do itr=1,ntr
    539             call histwrite(fileid,znom(itr,iQ),itau,zvQ(:,:,itr,iQ)
     539            CALL histwrite(fileid,znom(itr,iQ),itau,zvQ(:,:,itr,iQ)
    540540     s      ,jjm*llm,ndex3d)
    541541         enddo
    542          call histwrite(fileid,'psi'//nom(iQ),itau,psiQ(:,1:llm,iQ)
     542         CALL histwrite(fileid,'psi'//nom(iQ),itau,psiQ(:,1:llm,iQ)
    543543     s      ,jjm*llm,ndex3d)
    544544      enddo
    545545
    546       call histwrite(fileid,'masse',itau,zmasse
     546      CALL histwrite(fileid,'masse',itau,zmasse
    547547     s   ,jjm*llm,ndex3d)
    548       call histwrite(fileid,'v',itau,zv
     548      CALL histwrite(fileid,'v',itau,zv
    549549     s   ,jjm*llm,ndex3d)
    550550      psi=psi*1.e-9
    551       call histwrite(fileid,'psi',itau,psi(:,1:llm),jjm*llm,ndex3d)
     551      CALL histwrite(fileid,'psi',itau,psi(:,1:llm),jjm*llm,ndex3d)
    552552
    553553      endif
    … …  
    569569            enddo
    570570            zavQ(:,itr,iQ)=zavQ(:,itr,iQ)/zamasse(:)
    571             call histwrite(fileid,'a'//znom(itr,iQ),itau,zavQ(:,itr,iQ)
     571            CALL histwrite(fileid,'a'//znom(itr,iQ),itau,zavQ(:,itr,iQ)
    572572     s      ,jjm*llm,ndex3d)
    573573         enddo

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

    r5099 r5101  
    88     *                   flxw, pk)
    99c
    10       USE infotrac, ONLY : nqtot
    11       USE control_mod, ONLY : iapp_tracvl,planet_type
     10      USE infotrac, ONLY: nqtot
     11      USE control_mod, ONLY: iapp_tracvl,planet_type
    1212      USE comconst_mod, ONLY: dtvr
    1313 

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/caldyn.F

    r5099 r5101  
    8383      CALL massbar  (   masse, massebx , masseby                    )
    8484      ! compute XY-average of mass, massebxy()
    85       call massbarxy(   masse, massebxy                             )
     85      CALL massbarxy(   masse, massebxy                             )
    8686      ! compute mass fluxes pbaru() and pbarv()
    8787      CALL flumass  ( massebx, masseby , vcont, ucont ,pbaru, pbarv )

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

    r5082 r5101  
    1111  use ioipsl_getincom
    1212#endif
    13   USE infotrac, ONLY : type_trac
     13  USE infotrac, ONLY: type_trac
    1414  use assert_m, only: assert
    1515  USE comconst_mod, ONLY: dissip_deltaz, dissip_factz, dissip_zref, &
    … …  
    315315  CALL getin('maxlatfilter',maxlatfilter)
    316316  if (maxlatfilter > 90) &
    317        call abort_gcm("conf_gcm", 'maxlatfilter should be <=90', 1)
     317       CALL abort_gcm("conf_gcm", 'maxlatfilter should be <=90', 1)
    318318
    319319
    … …  
    329329  CALL getin('iflag_top_bound',iflag_top_bound)
    330330  IF (iflag_top_bound < 0 .or. iflag_top_bound > 2) &
    331        call abort_gcm("conf_gcm", 'iflag_top_bound must be 0, 1 or 2', 1)
     331       CALL abort_gcm("conf_gcm", 'iflag_top_bound must be 0, 1 or 2', 1)
    332332
    333333  ! mode_top_bound : fields towards which sponge relaxation will be done:
    … …  
    749749     dzoomx = 0.2
    750750     CALL getin('dzoomx',dzoomx)
    751      call assert(dzoomx < 1, "conf_gcm: dzoomx must be < 1")
     751     CALL assert(dzoomx < 1, "conf_gcm: dzoomx must be < 1")
    752752
    753753     !Config  Key  = dzoomy
    … …  
    758758     dzoomy = 0.2
    759759     CALL getin('dzoomy',dzoomy)
    760      call assert(dzoomy < 1, "conf_gcm: dzoomy must be < 1")
     760     CALL assert(dzoomy < 1, "conf_gcm: dzoomy must be < 1")
    761761
    762762     !Config  Key  = taux
    … …  
    836836     vert_prof_dissip = merge(1, 0, ok_strato .and. llm==39)
    837837     CALL getin('vert_prof_dissip', vert_prof_dissip)
    838      call assert(vert_prof_dissip == 0 .or. vert_prof_dissip ==  1, &
     838     CALL assert(vert_prof_dissip == 0 .or. vert_prof_dissip ==  1, &
    839839          "bad value for vert_prof_dissip")
    840840

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

    r5100 r5101  
    88  USE infotrac,    ONLY: nqtot, tracers, niso, iqIsoPha, iH2O, isoName
    99  USE strings_mod, ONLY: maxlen, msg, strStack, real2str, int2str
    10   USE netcdf,      ONLY: nf90_open,  nf90_nowrite, NF90_INQ_VARID, &
     10  USE netcdf,      ONLY: nf90_open,  nf90_nowrite, nf90_inq_varid, &
    1111                         nf90_close, nf90_get_var, nf90_noerr
    1212  USE readTracFiles_mod, ONLY: new2oldH2O, newHNO3, oldHNO3, getKey
    … …  
    116116  CALL get_var2("aire" ,aire)
    117117  var="temps"
    118   IF(NF90_INQ_VARID(fID,var,vID)/=nf90_noerr) THEN
     118  IF(nf90_inq_varid(fID,var,vID)/=nf90_noerr) THEN
    119119    CALL msg('missing field <temps> ; trying with <Time>', modname)
    120120    var="Time"
    121     CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
     121    CALL err(nf90_inq_varid(fID,var,vID),"inq",var)
    122122  END IF
    123123  CALL err(nf90_get_var(fID,vID,time),"get",var)
    … …  
    132132  ll=.FALSE.
    133133#ifdef REPROBUS
    134   ll = NF90_INQ_VARID(fID, 'HNO3tot', vID) /= nf90_noerr                                 !--- DETECT OLD REPRO start.nc FILE
     134  ll = nf90_inq_varid(fID, 'HNO3tot', vID) /= nf90_noerr                                 !--- DETECT OLD REPRO start.nc FILE
    135135#endif
    136136  DO iq=1,nqtot
    … …  
    145145    END IF
    146146    !--------------------------------------------------------------------------------------------------------------------------
    147     IF(NF90_INQ_VARID(fID, var, vID) == nf90_noerr .AND. .NOT.lSkip) THEN                !=== REGULAR CASE: AVAILABLE VARIABLE
     147    IF(nf90_inq_varid(fID, var, vID) == nf90_noerr .AND. .NOT.lSkip) THEN                !=== REGULAR CASE: AVAILABLE VARIABLE
    148148      CALL err(nf90_get_var(fID,vID,q(:,:,:,iq)),"get",var)
    149149    !--------------------------------------------------------------------------------------------------------------------------
    150     ELSE IF(NF90_INQ_VARID(fID, oldVar, vID) == nf90_noerr) THEN                         !=== TRY WITH ALTERNATE NAME
     150    ELSE IF(nf90_inq_varid(fID, oldVar, vID) == nf90_noerr) THEN                         !=== TRY WITH ALTERNATE NAME
    151151      CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized to <'//TRIM(oldVar)//'>', modname)
    152152      CALL err(nf90_get_var(fID,vID,q(:,:,:,iq)),"get",oldVar)
    … …  
    208208  CHARACTER(LEN=*), INTENT(IN)  :: var
    209209  REAL,             INTENT(OUT) :: v(:)
    210   CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
     210  CALL err(nf90_inq_varid(fID,var,vID),"inq",var)
    211211  CALL err(nf90_get_var(fID,vID,v),"get",var)
    212212END SUBROUTINE get_var1
    … …  
    216216  CHARACTER(LEN=*), INTENT(IN)  :: var
    217217  REAL,             INTENT(OUT) :: v(:,:)
    218   CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
     218  CALL err(nf90_inq_varid(fID,var,vID),"inq",var)
    219219  CALL err(nf90_get_var(fID,vID,v),"get",var)
    220220END SUBROUTINE get_var2
    … …  
    224224  CHARACTER(LEN=*), INTENT(IN)  :: var
    225225  REAL,             INTENT(OUT) :: v(:,:,:)
    226   CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
     226  CALL err(nf90_inq_varid(fID,var,vID),"inq",var)
    227227  CALL err(nf90_get_var(fID,vID,v),"get",var)
    228228END SUBROUTINE get_var3

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

    r5100 r5101  
    99  USE strings_mod, ONLY: maxlen
    1010  USE infotrac, ONLY: nqtot, tracers
    11   USE netcdf, ONLY: nf90_create, nf90_def_dim, NF90_INQ_VARID, nf90_global,    &
     11  USE netcdf, ONLY: nf90_create, nf90_def_dim, nf90_inq_varid, nf90_global,    &
    1212                    nf90_close,  nf90_put_att, nf90_unlimited, nf90_clobber,   &
    1313                    nf90_64bit_offset
    … …  
    169169  USE infotrac, ONLY: nqtot, tracers, type_trac
    170170  USE control_mod
    171   USE netcdf,   ONLY: nf90_open,  nf90_nowrite, nf90_get_var, NF90_INQ_VARID,  &
    172                       nf90_close, NF90_WRITE,   nf90_put_var, nf90_noerr
     171  USE netcdf,   ONLY: nf90_open,  nf90_nowrite, nf90_get_var, nf90_inq_varid,  &
     172                      nf90_close, nf90_write,   nf90_put_var, nf90_noerr
    173173  USE dynredem_mod, ONLY: dynredem_write_u, dynredem_write_v, dynredem_read_u, &
    174174                          err, modname, fil, msg
    … …  
    202202
    203203  modname='dynredem1'; fil=fichnom
    204   CALL err(nf90_open(fil,NF90_WRITE,nid),"open",fil)
     204  CALL err(nf90_open(fil,nf90_write,nid),"open",fil)
    205205
    206206!--- Write/extend time coordinate
    207207  nb = nb + 1
    208208  var="temps"
    209   CALL err(NF90_INQ_VARID(nid,var,vID),"inq",var)
     209  CALL err(nf90_inq_varid(nid,var,vID),"inq",var)
    210210  CALL err(nf90_put_var(nid,vID,[time]),"put",var)
    211211  WRITE(lunout,*)TRIM(modname)//": Saving for ", nb, time
    … …  
    213213!--- Rewrite control table (itaufin undefined in dynredem0)
    214214  var="controle"
    215   CALL err(NF90_INQ_VARID(nid,var,vID),"inq",var)
     215  CALL err(nf90_inq_varid(nid,var,vID),"inq",var)
    216216  CALL err(nf90_get_var(nid,vID,tab_cntrl),"get",var)
    217217  tab_cntrl(31)=DBLE(itau_dyn + itaufin)
    218   CALL err(NF90_INQ_VARID(nid,var,vID),"inq",var)
     218  CALL err(nf90_inq_varid(nid,var,vID),"inq",var)
    219219  CALL err(nf90_put_var(nid,vID,tab_cntrl),"put",var)
    220220
    … …  
    235235    IF(lread_inca) THEN                  !--- Possibly read from "start_trac.nc"
    236236      fil="start_trac.nc"
    237       ierr=NF90_INQ_VARID(nid_trac,var,vID_trac)
     237      ierr=nf90_inq_varid(nid_trac,var,vID_trac)
    238238      dum='inq'; IF(ierr==nf90_noerr) dum='fnd'
    239239      WRITE(lunout,*)msg(dum,var)

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

    r5100 r5101  
    3131!===============================================================================
    3232  start(:)=[1,1,1,1]; count(:)=[iip1,jjp1,ll,1]
    33   CALL err(NF90_INQ_VARID(ncid,id,nvarid),"inq",id)
     33  CALL err(nf90_inq_varid(ncid,id,nvarid),"inq",id)
    3434  CALL err(nf90_put_var(ncid,nvarid,var,start,count),"put",id)
    3535 
    … …  
    5454!===============================================================================
    5555  start(:)=[1,1,1,1]; count(:)=[iip1,jjm,ll,1]
    56   CALL err(NF90_INQ_VARID(ncid,id,nvarid),"inq",id)
     56  CALL err(nf90_inq_varid(ncid,id,nvarid),"inq",id)
    5757  CALL err(nf90_put_var(ncid,nvarid,var,start,count),"put",id)
    5858 
    … …  
    7777!===============================================================================
    7878  start(:)=[1,1,1,1]; count(:)=[iip1,jjp1,ll,1]
    79   CALL err(NF90_INQ_VARID(ncid,id,nvarid),"inq",id)
     79  CALL err(nf90_inq_varid(ncid,id,nvarid),"inq",id)
    8080  CALL err(nf90_get_var(ncid,nvarid,var,start,count),"get",id)
    8181 
    … …  
    121121  CALL err(nf90_enddef(ncid))
    122122  CALL err(nf90_put_var(ncid,nvarid,v),"put",var)
    123   CALL err(NF90_REDEF(ncid))
     123  CALL err(nf90_redef(ncid))
    124124
    125125END SUBROUTINE put_var1
    … …  
    144144  CALL err(nf90_enddef(ncid))
    145145  CALL err(nf90_put_var(ncid,nvarid,v),"put",var)
    146   CALL err(NF90_REDEF(ncid))
     146  CALL err(nf90_redef(ncid))
    147147
    148148END SUBROUTINE put_var2
    … …  
    188188  IF(ierr==nf90_noerr) RETURN
    189189  IF(.NOT.PRESENT(typ)) THEN
    190     CALL ABORT_gcm(modname,NF90_STRERROR(ierr),ierr)
     190    CALL ABORT_gcm(modname,nf90_strerror(ierr),ierr)
    191191  ELSE
    192192    CALL ABORT_gcm(modname,msg(typ,nam),ierr)

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/fluxstokenc.F

    r5099 r5101  
    6262       
    6363        ndex(1) = 0
    64         call histwrite(fluxid, 'phis', 1, phis, iip1*jjp1, ndex)
    65         call histwrite(fluxid, 'aire', 1, aire, iip1*jjp1, ndex)
     64        CALL histwrite(fluxid, 'phis', 1, phis, iip1*jjp1, ndex)
     65        CALL histwrite(fluxid, 'aire', 1, aire, iip1*jjp1, ndex)
    6666       
    6767        ndex(1) = 0
    6868        nscal = 1
    6969        tst(1) = time_step
    70         call histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex)
     70        CALL histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex)
    7171        ist(1)=istdyn
    72         call histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex)
     72        CALL histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex)
    7373        istp(1)= istphy
    74         call histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex)
     74        CALL histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex)
    7575       
    7676        first = .false.
    … …  
    140140        write(lunout,*)'ITAU auquel on stoke les fluxmasses',itau
    141141       
    142         call histwrite(fluxid, 'masse', itau, massem,
     142        CALL histwrite(fluxid, 'masse', itau, massem,
    143143     .               iip1*jjp1*llm, ndex)
    144144       
    145         call histwrite(fluxid, 'pbaru', itau, pbarug,
     145        CALL histwrite(fluxid, 'pbaru', itau, pbarug,
    146146     .               iip1*jjp1*llm, ndex)
    147147       
    148         call histwrite(fluxvid, 'pbarv', itau, pbarvg,
     148        CALL histwrite(fluxvid, 'pbarv', itau, pbarvg,
    149149     .               iip1*jjm*llm, ndex)
    150150       
    151         call histwrite(fluxid, 'w' ,itau, wg,
     151        CALL histwrite(fluxid, 'w' ,itau, wg,
    152152     .             iip1*jjp1*llm, ndex)
    153153       
    154         call histwrite(fluxid, 'teta' ,itau, tetac,
     154        CALL histwrite(fluxid, 'teta' ,itau, tetac,
    155155     .             iip1*jjp1*llm, ndex)
    156156       
    157         call histwrite(fluxid, 'phi' ,itau, phic,
     157        CALL histwrite(fluxid, 'phi' ,itau, phic,
    158158     .             iip1*jjp1*llm, ndex)
    159159       

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/friction.F

    r5099 r5101  
    5252      IF (firstcall) THEN
    5353        ! set friction type
    54         call getin("friction_type",friction_type)
     54        CALL getin("friction_type",friction_type)
    5555        if ((friction_type<0).or.(friction_type>1)) then
    5656          abort_message="wrong friction type"
    5757          write(lunout,*)'Friction: wrong friction type',friction_type
    58           call abort_gcm(modname,abort_message,42)
     58          CALL abort_gcm(modname,abort_message,42)
    5959        endif
    6060        firstcall=.false.

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

    r5099 r5101  
    143143  CALL conf_gcm( 99, .TRUE.)
    144144
    145   if (mod(iphysiq, iperiod) /= 0) call abort_gcm("conf_gcm", &
     145  if (mod(iphysiq, iperiod) /= 0) CALL abort_gcm("conf_gcm", &
    146146       "iphysiq must be a multiple of iperiod", 1)
    147147
    148148  use_filtre_fft=.FALSE.
    149149  CALL getin('use_filtre_fft',use_filtre_fft)
    150   IF (use_filtre_fft) call abort_gcm("gcm", 'FFT filter is not available in ' &
     150  IF (use_filtre_fft) CALL abort_gcm("gcm", 'FFT filter is not available in ' &
    151151          // 'the sequential version of the dynamics.', 1)
    152152
    … …  
    166166!#ifdef CPP_PHYS
    167167!  CALL Init_Phys_lmdz(iim,jjp1,llm,1,(/(jjm-1)*iim+2/))
    168 !  !      call InitComgeomphy ! now done in iniphysiq
     168!  !      CALL InitComgeomphy ! now done in iniphysiq
    169169!#endif
    170170!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    … …  
    177177#ifdef CPP_IOIPSL
    178178  if (calend == 'earth_360d') then
    179      call ioconf_calendar('360_day')
     179     CALL ioconf_calendar('360_day')
    180180     write(lunout,*)'CALENDRIER CHOISI: Terrestre a 360 jours/an'
    181181  else if (calend == 'earth_365d') then
    182      call ioconf_calendar('noleap')
     182     CALL ioconf_calendar('noleap')
    183183     write(lunout,*)'CALENDRIER CHOISI: Terrestre a 365 jours/an'
    184184  else if (calend == 'gregorian') then
    185      call ioconf_calendar('gregorian')
     185     CALL ioconf_calendar('gregorian')
    186186     write(lunout,*)'CALENDRIER CHOISI: Terrestre bissextile'
    187187  else
    188188     abort_message = 'Mauvais choix de calendrier'
    189      call abort_gcm(modname,abort_message,1)
     189     CALL abort_gcm(modname,abort_message,1)
    190190  endif
    191191#endif
    … …  
    203203  !  Choix du nombre de traceurs et du schema pour l'advection
    204204  !  dans fichier traceur.def, par default ou via INCA
    205   call init_infotrac
     205  CALL init_infotrac
    206206
    207207  ! Allocation de la tableau q : champs advectes   
    … …  
    253253     abort_message =  &
    254254          'Il faut choisir un nb de pas par jour multiple de iperiod'
    255      call abort_gcm(modname,abort_message,1)
     255     CALL abort_gcm(modname,abort_message,1)
    256256  ENDIF
    257257
    … …  
    259259     abort_message =  &
    260260          'Il faut choisir un nb de pas par jour multiple de iphysiq'
    261      call abort_gcm(modname,abort_message,1)
     261     CALL abort_gcm(modname,abort_message,1)
    262262  ENDIF
    263263
    … …  
    277277        start_time = starttime
    278278     ELSE
    279         call abort_gcm("gcm", "'Je m''arrete'", 1)
     279        CALL abort_gcm("gcm", "'Je m''arrete'", 1)
    280280     ENDIF
    281281  ENDIF
    … …  
    328328  mois = 1
    329329  heure = 0.
    330   call ymds2ju(annee_ref, mois, day_ref, heure, jD_ref)
     330  CALL ymds2ju(annee_ref, mois, day_ref, heure, jD_ref)
    331331  jH_ref = jD_ref - int(jD_ref)
    332332  jD_ref = int(jD_ref)
    333333
    334   call ioconf_startdate(INT(jD_ref), jH_ref)
     334  CALL ioconf_startdate(INT(jD_ref), jH_ref)
    335335
    336336  write(lunout,*)'DEBUG'
    337337  write(lunout,*)'annee_ref, mois, day_ref, heure, jD_ref'
    338338  write(lunout,*)annee_ref, mois, day_ref, heure, jD_ref
    339   call ju2ymds(jD_ref+jH_ref,an, mois, jour, heure)
     339  CALL ju2ymds(jD_ref+jH_ref,an, mois, jour, heure)
    340340  write(lunout,*)'jD_ref+jH_ref,an, mois, jour, heure'
    341341  write(lunout,*)jD_ref+jH_ref,an, mois, jour, heure
    … …  
    392392
    393393#ifdef CPP_IOIPSL
    394   call ju2ymds(jD_ref + day_ini - day_ref, an, mois, jour, heure)
     394  CALL ju2ymds(jD_ref + day_ini - day_ref, an, mois, jour, heure)
    395395  write (lunout,301)jour, mois, an
    396   call ju2ymds(jD_ref + day_end - day_ref, an, mois, jour, heure)
     396  CALL ju2ymds(jD_ref + day_end - day_ref, an, mois, jour, heure)
    397397  write (lunout,302)jour, mois, an
    398398301 FORMAT('1'/,15x,'run du ', i2,'/',i2,'/',i4)

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

    r5099 r5101  
    4949
    5050    ret_val=def_val
    51     call getin(TARGET,ret_val)
     51    CALL getin(TARGET,ret_val)
    5252
    5353    write(out_eff,*) '######################################'
    … …  
    7272
    7373    ret_val=def_val
    74     call getin(TARGET,ret_val)
     74    CALL getin(TARGET,ret_val)
    7575
    7676    write(out_eff,*) '######################################'
    … …  
    9696
    9797    ret_val=def_val
    98     call getin(TARGET,ret_val)
     98    CALL getin(TARGET,ret_val)
    9999
    100100    write(out_eff,*) '######################################'

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/groupe.F

    r5099 r5101  
    6060c   Champs 1D
    6161
    62       call convflu(pbaru,pbarv,llm,zconvm)
     62      CALL convflu(pbaru,pbarv,llm,zconvm)
    6363
    64       call scopy(ijp1llm,zconvm,1,zconvmm,1)
    65       call scopy(ijmllm,pbarv,1,pbarvm,1)
     64      CALL scopy(ijp1llm,zconvm,1,zconvmm,1)
     65      CALL scopy(ijmllm,pbarv,1,pbarvm,1)
    6666
    6767      if (groupe_ok) then
    68       call groupeun(jjp1,llm,zconvmm)
    69       call groupeun(jjm,llm,pbarvm)
     68      CALL groupeun(jjp1,llm,zconvmm)
     69      CALL groupeun(jjm,llm,pbarvm)
    7070
    7171c   Champs 3D

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

    r5100 r5101  
    8989! Lecture des parametres: 
    9090! ---------------------------------------------
    91     call ini_getparam("nudging_parameters_out.txt")
     91    CALL ini_getparam("nudging_parameters_out.txt")
    9292! Variables guidees
    9393    CALL getpar('guide_u',.true.,guide_u,'guidage de u')
    … …  
    102102    CALL getpar('guide_zon',.false.,guide_zon,'guidage moy zonale')
    103103    if (guide_zon .and. abs(grossismx - 1.) > 0.01) &
    104          call abort_gcm("guide_init", &
     104         CALL abort_gcm("guide_init", &
    105105         "zonal nudging requires grid regular in longitude", 1)
    106106
    … …  
    166166    CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P')
    167167
    168     call fin_getparam
     168    CALL fin_getparam
    169169   
    170170! ---------------------------------------------
    … …  
    400400! Calcul des constantes de rappel
    401401        factt=dtvr*iperiod/daysec
    402         call tau2alpha(3,iip1,jjm ,factt,tau_min_v,tau_max_v,alpha_v)
    403         call tau2alpha(2,iip1,jjp1,factt,tau_min_u,tau_max_u,alpha_u)
    404         call tau2alpha(1,iip1,jjp1,factt,tau_min_T,tau_max_T,alpha_T)
    405         call tau2alpha(1,iip1,jjp1,factt,tau_min_P,tau_max_P,alpha_P)
    406         call tau2alpha(1,iip1,jjp1,factt,tau_min_Q,tau_max_Q,alpha_Q)
     402        CALL tau2alpha(3,iip1,jjm ,factt,tau_min_v,tau_max_v,alpha_v)
     403        CALL tau2alpha(2,iip1,jjp1,factt,tau_min_u,tau_max_u,alpha_u)
     404        CALL tau2alpha(1,iip1,jjp1,factt,tau_min_T,tau_max_T,alpha_T)
     405        CALL tau2alpha(1,iip1,jjp1,factt,tau_min_P,tau_max_P,alpha_P)
     406        CALL tau2alpha(1,iip1,jjp1,factt,tau_min_Q,tau_max_Q,alpha_Q)
    407407! correction de rappel dans couche limite
    408408        if (guide_BL) then
    … …  
    503503      CALL pression(ip1jmp1,ap,bp,ps,p)
    504504      if (pressure_exner) then
    505         call exner_hyb(ip1jmp1,ps,p,pks,pk)
     505        CALL exner_hyb(ip1jmp1,ps,p,pks,pk)
    506506      else
    507         call exner_milieu(ip1jmp1,ps,p,pks,pk)
     507        CALL exner_milieu(ip1jmp1,ps,p,pks,pk)
    508508      endif
    509509      unskap=1./kappa
    … …  
    782782        enddo
    783783    enddo
    784     call massbar(pext, pbarx, pbary )
     784    CALL massbar(pext, pbarx, pbary )
    785785    do l=1,llm
    786786        do j=1,jjp1
    … …  
    16991699        ierr=nf90_def_var(nid,"au",nf90_float,(/id_lonu,id_latu/),vid_au)
    17001700        ierr=nf90_def_var(nid,"av",nf90_float,(/id_lonv,id_latv/),vid_av)
    1701         call nf95_def_var(nid, "alpha_T", nf90_float, (/id_lonv, id_latu/), &
     1701        CALL nf95_def_var(nid, "alpha_T", nf90_float, (/id_lonv, id_latu/), &
    17021702             varid_alpha_t)
    1703         call nf95_def_var(nid, "alpha_q", nf90_float, (/id_lonv, id_latu/), &
     1703        CALL nf95_def_var(nid, "alpha_q", nf90_float, (/id_lonv, id_latu/), &
    17041704             varid_alpha_q)
    17051705       
    … …  
    17161716        ierr = nf90_put_var(nid,vid_au,alpha_u)
    17171717        ierr = nf90_put_var(nid,vid_av,alpha_v)
    1718         call nf95_put_var(nid, varid_alpha_t, alpha_t)
    1719         call nf95_put_var(nid, varid_alpha_q, alpha_q)
     1718        CALL nf95_put_var(nid, varid_alpha_t, alpha_t)
     1719        CALL nf95_put_var(nid, varid_alpha_q, alpha_q)
    17201720! --------------------------------------------------------------------
    17211721! Création des variables sauvegardées

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

    r5100 r5101  
    2222  USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0
    2323  USE readTracFiles_mod, ONLY: addPhase
    24   use netcdf, only : nf90_nowrite,nf90_open,nf90_noerr,NF90_INQ_VARID,nf90_close,nf90_get_var
     24  use netcdf, ONLY: nf90_nowrite,nf90_open,nf90_noerr,nf90_inq_varid,nf90_close,nf90_get_var
    2525
    2626  !   Author:    Frederic Hourdin      original: 15/01/93
    … …  
    8989    write(lunout,*) "You most likely want an aquaplanet initialisation", &
    9090    " (iflag_phys >= 100)"
    91     call abort_gcm(modname,"incompatible iflag_phys==1 and read_start==.false.",1)
     91    CALL abort_gcm(modname,"incompatible iflag_phys==1 and read_start==.false.",1)
    9292  endif
    9393 
    … …  
    9797
    9898  ! initialize planet radius, rotation rate,...
    99   call conf_planete
     99  CALL conf_planete
    100100
    101101  time_0=0.
    … …  
    142142     ierr = nf90_open ('relief_in.nc', nf90_nowrite,nid_relief)
    143143     if (ierr==nf90_noerr) THEN
    144          ierr=NF90_INQ_VARID(nid_relief,'RELIEF',varid)
     144         ierr=nf90_inq_varid(nid_relief,'RELIEF',varid)
    145145         if (ierr==nf90_noerr) THEN
    146146              ierr=nf90_get_var(nid_relief,varid,relief(1:iim,1:jjp1))
    … …  
    172172       CALL exner_hyb( ip1jmp1, ps, p, pks, pk)
    173173     else
    174        call exner_milieu(ip1jmp1,ps,p,pks,pk)
     174       CALL exner_milieu(ip1jmp1,ps,p,pks,pk)
    175175     endif
    176176     CALL massdair(p,masse)
    … …  
    299299        ! winds
    300300        if (ok_geost) then
    301            call ugeostr(phi,ucov)
     301           CALL ugeostr(phi,ucov)
    302302        else
    303303           ucov(:,:)=0.
    … …  
    343343        endif ! of if (planet_type=="earth")
    344344
    345         call check_isotopes_seq(q,1,ip1jmp1,'iniacademic_loc')
     345        CALL check_isotopes_seq(q,1,ip1jmp1,'iniacademic_loc')
    346346
    347347        ! add random perturbation to temperature

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/integrd.F

    r5099 r5101  
    77     &  )
    88
    9       use control_mod, only : planet_type
     9      use control_mod, ONLY: planet_type
    1010      use comconst_mod, only: pi
    1111      USE logic_mod, ONLY: leapf
    … …  
    106106         write(lunout,*) " lon = ",rlonv(i)*180./pi, " deg",
    107107     &                   " lat = ",rlatu(j)*180./pi, " deg"
    108          call abort_gcm("integrd", "", 1)
     108         CALL abort_gcm("integrd", "", 1)
    109109        ENDIF
    110110      ENDDO

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

    r5086 r5101  
    6565
    6666
    67         call iniinterp_horiz (imo,jmo,imn,jmn ,kllm,
     67        CALL iniinterp_horiz (imo,jmo,imn,jmn ,kllm,
    6868     &       rlonuo,rlatvo,rlonun,rlatvn,
    6969     &          ktotal,iik,jjk,jk,ik,intersec,airen)

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/leapfrog.F

    r5099 r5101  
    1212#endif
    1313      USE infotrac, ONLY: nqtot, isoCheck
    14       USE guide_mod, ONLY : guide_main
     14      USE guide_mod, ONLY: guide_main
    1515      USE write_field, ONLY: writefield
    1616      USE control_mod, ONLY: nday, day_step, planet_type, offline,
    … …  
    239239      jH_cur = jH_cur - int(jH_cur)
    240240
    241       call check_isotopes_seq(q,ip1jmp1,'leapfrog 321')
     241      CALL check_isotopes_seq(q,ip1jmp1,'leapfrog 321')
    242242
    243243#ifdef CPP_IOIPSL
    244244      if (ok_guide) then
    245         call guide_main(itau,ucov,vcov,teta,q,masse,ps)
     245        CALL guide_main(itau,ucov,vcov,teta,q,masse,ps)
    246246      endif
    247247#endif
    … …  
    271271!      CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
    272272
    273       call check_isotopes_seq(q,ip1jmp1,'leapfrog 400')
     273      CALL check_isotopes_seq(q,ip1jmp1,'leapfrog 400')
    274274
    275275   2  CONTINUE ! Matsuno backward or leapfrog step begins here
    … …  
    322322
    323323
    324       call check_isotopes_seq(q,ip1jmp1,'leapfrog 589')
     324      CALL check_isotopes_seq(q,ip1jmp1,'leapfrog 589')
    325325
    326326c-----------------------------------------------------------------------
    … …  
    341341c   -------------------------------------------------------------
    342342
    343       call check_isotopes_seq(q,ip1jmp1,
     343      CALL check_isotopes_seq(q,ip1jmp1,
    344344     &           'leapfrog 686: avant caladvtrac')
    345345
    … …  
    371371
    372372       CALL msg('720', modname, isoCheck)
    373        call check_isotopes_seq(q,ip1jmp1,'leapfrog 756')
     373       CALL check_isotopes_seq(q,ip1jmp1,'leapfrog 756')
    374374       
    375375       CALL integrd ( nqtot,vcovm1,ucovm1,tetam1,psm1,massem1 ,
    … …  
    378378
    379379       CALL msg('724', modname, isoCheck)
    380        call check_isotopes_seq(q,ip1jmp1,'leapfrog 762')
     380       CALL check_isotopes_seq(q,ip1jmp1,'leapfrog 762')
    381381
    382382c .P.Le Van (26/04/94  ajout de  finvpold dans l'appel d'integrd)
    … …  
    429429           jH_cur = jH_cur - int(jH_cur)
    430430!         write(lunout,*)'itau, jD_cur = ', itau, jD_cur, jH_cur
    431 !         call ju2ymds(jD_cur+jH_cur, an, mois, jour, secondes)
     431!         CALL ju2ymds(jD_cur+jH_cur, an, mois, jour, secondes)
    432432!         write(lunout,*)'current date = ',an, mois, jour, secondes
    433433
    … …  
    514514        endif
    515515
    516         call friction(ucov,vcov,dtvr)
     516        CALL friction(ucov,vcov,dtvr)
    517517       
    518518        ! Sponge layer (if any)
    … …  
    542542        CALL massdair(p,masse)
    543543
    544         call check_isotopes_seq(q,ip1jmp1,'leapfrog 1196')
     544        CALL check_isotopes_seq(q,ip1jmp1,'leapfrog 1196')
    545545
    546546c-----------------------------------------------------------------------
    … …  
    552552
    553553c   calcul de l'energie cinetique avant dissipation
    554         call covcont(llm,ucov,vcov,ucont,vcont)
    555         call enercin(vcov,ucov,vcont,ucont,ecin0)
     554        CALL covcont(llm,ucov,vcov,ucont,vcont)
     555        CALL enercin(vcov,ucov,vcont,ucont,ecin0)
    556556
    557557c   dissipation
    … …  
    566566C       On rajoute la tendance due a la transform. Ec -> E therm. cree
    567567C       lors de la dissipation
    568             call covcont(llm,ucov,vcov,ucont,vcont)
    569             call enercin(vcov,ucov,vcont,ucont,ecin)
     568            CALL covcont(llm,ucov,vcov,ucont,vcont)
     569            CALL enercin(vcov,ucov,vcont,ucont,ecin)
    570570            dtetaecdt= (ecin0-ecin)/ pk
    571571c           teta=teta+dtetaecdt
    … …  
    616616c              IF( lafin ) then 
    617617c                abort_message = 'Simulation finished'
    618 c                call abort_gcm(modname,abort_message,0)
     618c                CALL abort_gcm(modname,abort_message,0)
    619619c              ENDIF
    620620       
    … …  
    627627c   preparation du pas d'integration suivant  ......
    628628
    629       call check_isotopes_seq(q,ip1jmp1,'leapfrog 1509')
     629      CALL check_isotopes_seq(q,ip1jmp1,'leapfrog 1509')
    630630
    631631      IF ( .NOT.purmats ) THEN
    … …  
    658658              abort_message = 'Simulation finished'
    659659
    660               call abort_gcm(modname,abort_message,0)
     660              CALL abort_gcm(modname,abort_message,0)
    661661            ENDIF
    662662c-----------------------------------------------------------------------
    … …  
    689689            ENDIF ! of IF((MOD(itau,iperiod).EQ.0).OR.(itau.EQ.itaufin))
    690690
    691             call check_isotopes_seq(q,ip1jmp1,'leapfrog 1584')
     691            CALL check_isotopes_seq(q,ip1jmp1,'leapfrog 1584')
    692692
    693693c-----------------------------------------------------------------------
    … …  
    706706#ifdef CPP_IOIPSL
    707707              if (ok_dyn_ins) then
    708 !               write(lunout,*) "leapfrog: call writehist, itau=",itau
     708!               write(lunout,*) "leapfrog: CALL writehist, itau=",itau
    709709               CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis)
    710 !               call WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
    711 !               call WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/)))
    712 !              call WriteField('teta',reshape(teta,(/iip1,jmp1,llm/)))
    713 !               call WriteField('ps',reshape(ps,(/iip1,jmp1/)))
    714 !               call WriteField('masse',reshape(masse,(/iip1,jmp1,llm/)))
     710!               CALL WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
     711!               CALL WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/)))
     712!              CALL WriteField('teta',reshape(teta,(/iip1,jmp1,llm/)))
     713!               CALL WriteField('ps',reshape(ps,(/iip1,jmp1/)))
     714!               CALL WriteField('masse',reshape(masse,(/iip1,jmp1,llm/)))
    715715              endif ! of if (ok_dyn_ins)
    716716#endif
    … …  
    774774      ELSE ! of IF (.not.purmats)
    775775
    776             call check_isotopes_seq(q,ip1jmp1,'leapfrog 1664')
     776            CALL check_isotopes_seq(q,ip1jmp1,'leapfrog 1664')
    777777
    778778c       ........................................................
    … …  
    793793               IF( itau == itaufinp1 ) then
    794794                 abort_message = 'Simulation finished'
    795                  call abort_gcm(modname,abort_message,0)
     795                 CALL abort_gcm(modname,abort_message,0)
    796796               ENDIF
    797797               GO TO 2
    … …  
    799799            ELSE ! of IF(forward) i.e. backward step
    800800 
    801               call check_isotopes_seq(q,ip1jmp1,'leapfrog 1698')
     801              CALL check_isotopes_seq(q,ip1jmp1,'leapfrog 1698')
    802802
    803803              IF(MOD(itau,iperiod)==0 .OR. itau==itaufin) THEN
    … …  
    836836#ifdef CPP_IOIPSL
    837837              if (ok_dyn_ins) then
    838 !                write(lunout,*) "leapfrog: call writehist (b)",
     838!                write(lunout,*) "leapfrog: CALL writehist (b)",
    839839!     &                        itau,iecri
    840840                CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis)

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/qminimum.F

    r5099 r5101  
    5858c
    5959
    60       call check_isotopes_seq(q,ip1jmp1,'qminimum 52')   
     60      CALL check_isotopes_seq(q,ip1jmp1,'qminimum 52')
    6161
    6262      zx_defau_diag(:,:,:)=0.0
    … …  
    158158       enddo !do k=2,llm
    159159
    160        call check_isotopes_seq(q,ip1jmp1,'qminimum 168')
     160       CALL check_isotopes_seq(q,ip1jmp1,'qminimum 168')
    161161       
    162162     
    … …  
    185185       enddo !do k=2,llm 
    186186
    187        call check_isotopes_seq(q,ip1jmp1,'qminimum 197')
     187       CALL check_isotopes_seq(q,ip1jmp1,'qminimum 197')
    188188
    189189      endif !if (niso > 0) then

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

    r5099 r5101  
    88
    99
    10 USE comvert_mod, only :  preff, pa
     10USE comvert_mod, ONLY:  preff, pa
    1111USE inigeomphy_mod, ONLY: inigeomphy
    1212
    … …  
    1818  USE logic_mod, ONLY: ecripar, iflag_phys, read_start
    1919
    20   USE serre_mod, ONLY : clon,clat,transx,transy,alphax,alphay,pxo,pyo,              &
     20  USE serre_mod, ONLY: clon,clat,transx,transy,alphax,alphay,pxo,pyo,              &
    2121        grossismx, grossismy, dzoomx, dzoomy,taux,tauy
    2222  USE mod_const_mpi, ONLY: comm_lmdz
    … …  
    101101  CALL conf_gcm( 99, .TRUE.)
    102102
    103   if (mod(iphysiq, iperiod) /= 0) call abort_gcm("conf_gcm", &
     103  if (mod(iphysiq, iperiod) /= 0) CALL abort_gcm("conf_gcm", &
    104104       "iphysiq must be a multiple of iperiod", 1)
    105105
    … …  
    139139  mois = 1
    140140  heure = 0.
    141 ! call ymds2ju(annee_ref, mois, day_ref, heure, jD_ref)
     141! CALL ymds2ju(annee_ref, mois, day_ref, heure, jD_ref)
    142142  jH_ref = jD_ref - int(jD_ref)
    143143  jD_ref = int(jD_ref)
    … …  
    170170! Initialisation de la parametrisation
    171171!---------------------------------------------------------------------
    172       call call_ini_replay
     172      CALL call_ini_replay
    173173
    174174!---------------------------------------------------------------------
    … …  
    177177      DO it=1,ntime
    178178         print*,'Pas de temps ',it,klon,klev
    179          call call_param_replay(klon,klev)
     179         CALL call_param_replay(klon,klev)
    180180      ENDDO
    181181

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/vlsplt.F

    r5098 r5101  
    7878
    7979cprint*,'Entree vlx1'
    80 c       call minmaxq(zq,qmin,qmax,'avant vlx     ')
    81       call vlx(zq,pente_max,zm,mu,iq)
     80c       CALL minmaxq(zq,qmin,qmax,'avant vlx     ')
     81      CALL vlx(zq,pente_max,zm,mu,iq)
    8282cprint*,'Sortie vlx1'
    83 c       call minmaxq(zq,qmin,qmax,'apres vlx1    ')
     83c       CALL minmaxq(zq,qmin,qmax,'apres vlx1    ')
    8484
    8585c print*,'Entree vly1'
    8686
    87       call vly(zq,pente_max,zm,mv,iq)
    88 c       call minmaxq(zq,qmin,qmax,'apres vly1     ')
     87      CALL vly(zq,pente_max,zm,mv,iq)
     88c       CALL minmaxq(zq,qmin,qmax,'apres vly1     ')
    8989cprint*,'Sortie vly1'
    90       call vlz(zq,pente_max,zm,mw,iq)
    91 c       call minmaxq(zq,qmin,qmax,'apres vlz     ')
    92 
    93 
    94       call vly(zq,pente_max,zm,mv,iq)
    95 c       call minmaxq(zq,qmin,qmax,'apres vly     ')
    96 
    97 
    98       call vlx(zq,pente_max,zm,mu,iq)
    99 c       call minmaxq(zq,qmin,qmax,'apres vlx2    ')
     90      CALL vlz(zq,pente_max,zm,mw,iq)
     91c       CALL minmaxq(zq,qmin,qmax,'apres vlz     ')
     92
     93
     94      CALL vly(zq,pente_max,zm,mv,iq)
     95c       CALL minmaxq(zq,qmin,qmax,'apres vly     ')
     96
     97
     98      CALL vlx(zq,pente_max,zm,mu,iq)
     99c       CALL minmaxq(zq,qmin,qmax,'apres vlx2    ')
    100100       
    101101
    … …  
    124124      END
    125125      RECURSIVE SUBROUTINE vlx(q,pente_max,masse,u_m,iq)
    126       USE infotrac, ONLY : nqtot,tracers, ! CRisi
     126      USE infotrac, ONLY: nqtot,tracers, ! CRisi
    127127     &                     min_qParent,min_qMass,min_ratio ! MVals et CRisi
    128128
    … …  
    414414      do ifils=1,tracers(iq)%nqChildren
    415415        iq2=tracers(iq)%iqDescen(ifils)
    416         call vlx(Ratio,pente_max,masseq,u_mq,iq2)
     416        CALL vlx(Ratio,pente_max,masseq,u_mq,iq2)
    417417      enddo
    418418! end CRisi
    … …  
    459459      END
    460460      RECURSIVE SUBROUTINE vly(q,pente_max,masse,masse_adv_v,iq)
    461       USE infotrac, ONLY : nqtot,tracers, ! CRisi
     461      USE infotrac, ONLY: nqtot,tracers, ! CRisi
    462462     &                     min_qParent,min_qMass,min_ratio ! MVals et CRisi
    463463c
    … …  
    739739      do ifils=1,tracers(iq)%nqDescen
    740740        iq2=tracers(iq)%iqDescen(ifils)
    741         call vly(Ratio,pente_max,masseq,qbyv,iq2)
     741        CALL vly(Ratio,pente_max,masseq,qbyv,iq2)
    742742      enddo
    743743
    … …  
    822822      END
    823823      RECURSIVE SUBROUTINE vlz(q,pente_max,masse,w,iq)
    824       USE infotrac, ONLY : nqtot,tracers, ! CRisi
     824      USE infotrac, ONLY: nqtot,tracers, ! CRisi
    825825     &                     min_qParent,min_qMass,min_ratio ! MVals et CRisi
    826826c
    … …  
    945945      do ifils=1,tracers(iq)%nqChildren
    946946        iq2=tracers(iq)%iqDescen(ifils)
    947         call vlz(Ratio,pente_max,masseq,wq,iq2)
     947        CALL vlz(Ratio,pente_max,masseq,wq,iq2)
    948948      enddo
    949949! end CRisi 
    … …  
    10171017      integer ismin,ismax
    10181018
    1019       call scopy (ip1jmp1*llm,zq,1,zzq,1)
     1019      CALL scopy (ip1jmp1*llm,zq,1,zzq,1)
    10201020
    10211021      ijlmin=ismin(ijp1llm,zq,1)

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

    r5098 r5101  
    127127      enddo 
    128128
    129 c      call minmaxq(zq,qmin,qmax,'avant vlxqs     ')
    130       call vlxqs(zq,pente_max,zm,mu,qsat,iq)
    131 
    132 c     call minmaxq(zq,qmin,qmax,'avant vlyqs     ')
    133 
    134       call vlyqs(zq,pente_max,zm,mv,qsat,iq)
    135 
    136 c      call minmaxq(zq,qmin,qmax,'avant vlz     ')
    137 
    138       call vlz(zq,pente_max,zm,mw,iq)
    139 
    140 c     call minmaxq(zq,qmin,qmax,'avant vlyqs     ')
    141 c     call minmaxq(zm,qmin,qmax,'M avant vlyqs     ')
    142 
    143       call vlyqs(zq,pente_max,zm,mv,qsat,iq)
    144 
    145 c     call minmaxq(zq,qmin,qmax,'avant vlxqs     ')
    146 c     call minmaxq(zm,qmin,qmax,'M avant vlxqs     ')
    147 
    148       call vlxqs(zq,pente_max,zm,mu,qsat,iq)
    149 
    150 c     call minmaxq(zq,qmin,qmax,'apres vlxqs     ')
    151 c     call minmaxq(zm,qmin,qmax,'M apres vlxqs     ')
     129c      CALL minmaxq(zq,qmin,qmax,'avant vlxqs     ')
     130      CALL vlxqs(zq,pente_max,zm,mu,qsat,iq)
     131
     132c     CALL minmaxq(zq,qmin,qmax,'avant vlyqs     ')
     133
     134      CALL vlyqs(zq,pente_max,zm,mv,qsat,iq)
     135
     136c      CALL minmaxq(zq,qmin,qmax,'avant vlz     ')
     137
     138      CALL vlz(zq,pente_max,zm,mw,iq)
     139
     140c     CALL minmaxq(zq,qmin,qmax,'avant vlyqs     ')
     141c     CALL minmaxq(zm,qmin,qmax,'M avant vlyqs     ')
     142
     143      CALL vlyqs(zq,pente_max,zm,mv,qsat,iq)
     144
     145c     CALL minmaxq(zq,qmin,qmax,'avant vlxqs     ')
     146c     CALL minmaxq(zm,qmin,qmax,'M avant vlxqs     ')
     147
     148      CALL vlxqs(zq,pente_max,zm,mu,qsat,iq)
     149
     150c     CALL minmaxq(zq,qmin,qmax,'apres vlxqs     ')
     151c     CALL minmaxq(zm,qmin,qmax,'M apres vlxqs     ')
    152152
    153153
    … …  
    177177      END
    178178      SUBROUTINE vlxqs(q,pente_max,masse,u_m,qsat,iq)
    179       USE infotrac, ONLY : nqtot,tracers ! CRisi
     179      USE infotrac, ONLY: nqtot,tracers ! CRisi
    180180
    181181c
    … …  
    471471      do ifils=1,tracers(iq)%nqChildren
    472472        iq2=tracers(iq)%iqDescen(ifils)
    473         call vlx(Ratio,pente_max,masseq,u_mq,iq2)
     473        CALL vlx(Ratio,pente_max,masseq,u_mq,iq2)
    474474      enddo
    475475! end CRisi
    … …  
    514514      END
    515515      SUBROUTINE vlyqs(q,pente_max,masse,masse_adv_v,qsat,iq)
    516       USE infotrac, ONLY : nqtot,tracers ! CRisi
     516      USE infotrac, ONLY: nqtot,tracers ! CRisi
    517517c
    518518c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    … …  
    779779        iq2=tracers(iq)%iqDescen(ifils)
    780780        !write(*,*) 'vlyqs 783: appel rec de vly, iq2=',iq2
    781         call vly(Ratio,pente_max,masseq,qbyv,iq2)
     781        CALL vly(Ratio,pente_max,masseq,qbyv,iq2)
    782782      enddo
    783783

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/wrgrads.F

    r5099 r5101  
    107107      write(unit(if),'(a12)') 'UNDEF 1.0E30'
    108108      write(unit(if),'(a5,1x,a40)') 'TITLE ',title(if)
    109       call formcoord(unit(if),im,xd(iii,if),1.,.false.,'XDEF')
    110       call formcoord(unit(if),jm,yd(iji,if),1.,.true.,'YDEF')
    111       call formcoord(unit(if),lm,zd(1,if),1.,.false.,'ZDEF')
     109      CALL formcoord(unit(if),im,xd(iii,if),1.,.false.,'XDEF')
     110      CALL formcoord(unit(if),jm,yd(iji,if),1.,.true.,'YDEF')
     111      CALL formcoord(unit(if),lm,zd(1,if),1.,.false.,'ZDEF')
    112112      write(unit(if),'(a4,i10,a30)')
    113113     &       'TDEF ',itime(if),' LINEAR 02JAN1987 1MO '

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/write_paramLMDZ_dyn.h

    r5099 r5101  
    241241c
    242242      if (ok_sync) then
    243         call histsync(nid_ctesGCM)
     243        CALL histsync(nid_ctesGCM)
    244244      endif
    245245c
Note: See TracChangeset for help on using the changeset viewer.