Changeset 776


Ignore:
Timestamp:
Sep 7, 2012, 2:49:58 PM (12 years ago)
Author:
emillour
Message:

Common dynamics: updates to keep up with LMDZ5 Earth (rev 1649)
See file "DOC/chantiers/commit_importants.log" for details.
EM

Location:
trunk
Files:
2 added
48 edited
4 moved

Legend:

Unmodified
Added
Removed

  • trunk/DOC/chantiers/commit_importants.log

    r492 r776  
    10421042- filtreg_p.F : ajout de flags cpp autour de l'utilisation de la BLAS et
    10431043                realisation des calculs via matmul() sinon
     1044
     1045*********************
     1046**** commit_v776 ****
     1047*********************
     1048Ehouarn: Updates in the dynamics (seq and //) to keep up with updates
     1049in LMDZ5 (up to LMDZ5 trunk, rev 1649):
     1050
     1051* bibio:
     1052- initdynav.F => initdynav.F90
     1053- writedynav.F => writedynav.F90
     1054- new_unit.F90 : added this new module
     1055- nf95_get_var_m.F90 : added this new module
     1056- netcdf95.F90, nf95_get_att_m.F90, nf95_gw_var_m.F90, nf95_put_var_m.F90,
     1057  simple.F90 : updated as they were in LMDZ5
     1058
     1059* dyn3d:
     1060- guide_mod.F90 : keep up with minor changes (pressure_exner flag)
     1061- inigrads.F : keep up with minor changes
     1062- integrd.F : keep up with changes (get rid of finvmaold which was not used)
     1063- calfis.F : keep up with minor changes (#CPP_...)
     1064- iniacademic.F90 : keep up with minor changes (pressure_exner flag)
     1065- inidissip.F90 : keep up with minor changes (simplify computation of zh)
     1066- ce0l.F90 : keep up with minor changes
     1067- dynetat0.F : keep up with minor changes (use netcdf90 function)
     1068- iniconst.F => iniconst.F90 (+ introduce pressure_exner flag)
     1069- exner_milieu.F : keep up with minor changes (can be used for all planets)
     1070- exner_hyb.F : keep up with minor changes (can be used for all planets)
     1071- gcm.F : keep up with minor changes (CPP_PHYS instead of CPP_EARTH)
     1072- comvert.h : keep up with minor changes (pressure_exner flag)
     1073- etat0_netcdf.F : keep up with minor changes (pressure_exner flag)
     1074- wrgrads.F : keep up with minor changes (lnblnk => trim)
     1075- disvert.F90 : keep up with changes (Earth version of disvert anyways)
     1076- dynredem.F : keep up with minor changes (use netcdf90 functions)
     1077- leapfrog.F : updates (get rid of finvmold , pressure_exner flag, updated
     1078               computation of time, get rid of "dissipation bug"
     1079               that kills 1+1=2 in dynamics)
     1080
     1081* dyn3dpar:
     1082- same updates as in dyn3 for routines : inigrads.F, iniacademic.F90,
     1083  inidissip.F90, dynetat0.F, iniconst.F90, exner_milieu.F, exner_hyb.F,
     1084  comvert.h, etat0_netcdf.F90, wrgrads.F, disvert.F90, dynredem.F
     1085- guide_p_mod.F : keep up with minor changes (pressure_exner flag)
     1086- gr_fi_dyn_p.F : keep up with minor changes (CPP_PHYS condition)
     1087- gr_dyn_fi_p.F : keep up with minor changes (CPP_PHYS condition)
     1088- integrd_p.F : keep up with changes (get rid of finvmaold which was not used)
     1089- calfis_p.F : keep up with minor changes (CPP_PHYS condition)
     1090- mod_interface_dyn_phys.F90 : keep up with minor changes (CPP_PHYS condition)
     1091- ce0l.F : keep up with minor changes
     1092- exner_milieu_p.F : keep up with minor changes (can be used for all planets)
     1093- exner_hyb_p.F : keep up with minor changes (can be used for all planets)
     1094- gcm.F : keep up with minor changes (CPP_PHYS)
     1095- bands.F : keep up with minor changes (CPP_PHYS)
     1096- dynredem_p.F : keep up with minor changes (use netcdf90 functions)
     1097- leapfrog_p.F : updates (get rid of finvmold , pressure_exner flag, updated
     1098                 computation of time, get rid of "dissipation bug"
     1099                 that kills 1+1=2 in dynamics)
     1100

  • trunk/DOC/chantiers/meschantiers-Ehouarn.txt

    r492 r776  
    1414 
    1515- dernière mise à jour des dynamiques (par rapport au trunk de LMDZ5
    16   "Terrestre" rev. 1605) avec la rev 492.
     16  "Terrestre" rev. 1649) avec la rev 776.
    1717  Reste à faire l'exercice de validation des modifs en //...
    1818

  • trunk/LMDZ.COMMON/libf/bibio/initdynav.F90

    r775 r776  
    1 !
    2 ! $Id: initdynav.F 1403 2010-07-01 09:02:53Z fairhead $
    3 !
    4       subroutine initdynav(day0,anne0,tstep,t_ops,t_wrt)
     1! $Id: initdynav.F90 1611 2012-01-25 14:31:54Z lguez $
     2
     3subroutine initdynav(day0,anne0,tstep,t_ops,t_wrt)
    54
    65#ifdef CPP_IOIPSL
    7        USE IOIPSL
     6  USE IOIPSL
    87#endif
    9        USE infotrac, ONLY : nqtot, ttext
    10       use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid,      &
    11      &        dynhistave_file,dynhistvave_file,dynhistuave_file
    12       implicit none
     8  USE infotrac, ONLY : nqtot, ttext
     9  use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid, &
     10       dynhistave_file,dynhistvave_file,dynhistuave_file
     11  implicit none
    1312
    14 C
    15 C   Routine d'initialisation des ecritures des fichiers histoires LMDZ
    16 C   au format IOIPSL. Initialisation du fichier histoire moyenne.
    17 C
    18 C   Appels succesifs des routines: histbeg
    19 C                                  histhori
    20 C                                  histver
    21 C                                  histdef
    22 C                                  histend
    23 C
    24 C   Entree:
    25 C
    26 C      infile: nom du fichier histoire a creer
    27 C      day0,anne0: date de reference
    28 C      tstep : frequence d'ecriture
    29 C      t_ops: frequence de l'operation pour IOIPSL
    30 C      t_wrt: frequence d'ecriture sur le fichier
    31 C
    32 C
    33 C   L. Fairhead, LMD, 03/99
    34 C
    35 C =====================================================================
    36 C
    37 C   Declarations
    38 #include "dimensions.h"
    39 #include "paramet.h"
    40 #include "comconst.h"
    41 #include "comvert.h"
    42 #include "comgeom.h"
    43 #include "temps.h"
    44 #include "ener.h"
    45 #include "logic.h"
    46 #include "description.h"
    47 #include "serre.h"
    48 #include "iniprint.h"
    4913
    50 C   Arguments
    51 C
    52       integer day0, anne0
    53       real tstep, t_ops, t_wrt
     14  !   Routine d'initialisation des ecritures des fichiers histoires LMDZ
     15  !   au format IOIPSL. Initialisation du fichier histoire moyenne.
     16
     17  !   Appels succesifs des routines: histbeg
     18  !                                  histhori
     19  !                                  histver
     20  !                                  histdef
     21  !                                  histend
     22
     23  !   Entree:
     24
     25  !      infile: nom du fichier histoire a creer
     26  !      day0,anne0: date de reference
     27  !      tstep : frequence d'ecriture
     28  !      t_ops: frequence de l'operation pour IOIPSL
     29  !      t_wrt: frequence d'ecriture sur le fichier
     30
     31
     32  !   L. Fairhead, LMD, 03/99
     33
     34  include "dimensions.h"
     35  include "paramet.h"
     36  include "comconst.h"
     37  include "comvert.h"
     38  include "comgeom.h"
     39  include "temps.h"
     40  include "ener.h"
     41  include "logic.h"
     42  include "description.h"
     43  include "serre.h"
     44  include "iniprint.h"
     45
     46  !   Arguments
     47
     48  integer day0, anne0
     49  real tstep, t_ops, t_wrt
    5450
    5551#ifdef CPP_IOIPSL
    56 ! This routine needs IOIPSL to work
    57 C   Variables locales
    58 C
    59       integer tau0
    60       real zjulian
    61       integer iq
    62       real rlong(iip1,jjp1), rlat(iip1,jjp1)
    63       integer uhoriid, vhoriid, thoriid, zvertiid
    64       integer ii,jj
    65       integer zan, dayref
    66 C
    67 C  Initialisations
    68 C
    69       pi = 4. * atan (1.)
    70 C
    71 C  Appel a histbeg: creation du fichier netcdf et initialisations diverses
    72 C         
     52  ! This routine needs IOIPSL to work
     53  !   Variables locales
    7354
    74       zan = anne0
    75       dayref = day0
    76       CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
    77       tau0 = itau_dyn
    78      
    79       do jj = 1, jjp1
    80         do ii = 1, iip1
    81           rlong(ii,jj) = rlonv(ii) * 180. / pi
    82           rlat(ii,jj)  = rlatu(jj) * 180. / pi
    83         enddo
    84       enddo
    85        
    86 ! Creation de 3 fichiers pour les differentes grilles horizontales
    87 ! Restriction de IOIPSL: seulement 2 coordonnees dans le meme fichier
    88 ! Grille Scalaire       
    89       call histbeg(dynhistave_file, iip1, rlong(:,1), jjp1, rlat(1,:),
    90      .             1, iip1, 1, jjp1,
    91      .             tau0, zjulian, tstep, thoriid,histaveid)
     55  integer tau0
     56  real zjulian
     57  integer iq
     58  real rlong(iip1,jjp1), rlat(iip1,jjp1)
     59  integer uhoriid, vhoriid, thoriid, zvertiid
     60  integer ii,jj
     61  integer zan, dayref
    9262
    93 C  Creation du fichier histoire pour les grilles en V et U (oblige pour l'instant,
    94 C  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
    95 C  un meme fichier)
    96 ! Grille V
    97       do jj = 1, jjm
    98         do ii = 1, iip1
    99           rlong(ii,jj) = rlonv(ii) * 180. / pi
    100           rlat(ii,jj) = rlatv(jj) * 180. / pi
    101         enddo
    102       enddo
     63  !--------------------------------------------------------------------
    10364
    104       call histbeg(dynhistvave_file, iip1, rlong(:,1), jjm, rlat(1,:),
    105      .             1, iip1, 1, jjm,
    106      .             tau0, zjulian, tstep, vhoriid,histvaveid)
    107 ! Grille U
    108       do jj = 1, jjp1
    109         do ii = 1, iip1
    110           rlong(ii,jj) = rlonu(ii) * 180. / pi
    111           rlat(ii,jj) = rlatu(jj) * 180. / pi
    112         enddo
    113       enddo
     65  !  Initialisations
    11466
    115       call histbeg(dynhistuave_file, iip1, rlong(:,1),jjp1, rlat(1,:),
    116      .             1, iip1, 1, jjp1,
    117      .             tau0, zjulian, tstep, uhoriid,histuaveid)
    118 C
    119 C  Appel a histvert pour la grille verticale
    120 C
    121       call histvert(histaveid,'presnivs','Niveaux Pression
    122      &     approximatifs','mb',llm, presnivs/100., zvertiid,'down')
    123       call histvert(histuaveid,'presnivs','Niveaux Pression
    124      &     approximatifs','mb',llm, presnivs/100., zvertiid,'down')
    125       call histvert(histvaveid,'presnivs','Niveaux Pression
    126      &     approximatifs','mb',llm, presnivs/100., zvertiid,'down')
    127 C
    128 C  Appels a histdef pour la definition des variables a sauvegarder
    129 C
    130 C  Vents U
    131 C
    132 !      write(6,*)'inithistave',tstep
    133       call histdef(histuaveid, 'u', 'vent u moyen ',
    134      .             'm/s', iip1, jjp1, uhoriid, llm, 1, llm, zvertiid,
    135      .             32, 'ave(X)', t_ops, t_wrt)
     67  pi = 4. * atan (1.)
    13668
    137 C  Vents V
    138 C
    139       call histdef(histvaveid, 'v', 'vent v moyen',
    140      .             'm/s', iip1, jjm, vhoriid, llm, 1, llm, zvertiid,
    141      .             32, 'ave(X)', t_ops, t_wrt)
     69  !  Appel a histbeg: creation du fichier netcdf et initialisations diverses
    14270
    143 C
    144 C  Temperature
    145 C
    146       call histdef(histaveid, 'temp', 'temperature moyenne', 'K',
    147      .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
    148      .             32, 'ave(X)', t_ops, t_wrt)
    149 C
    150 C  Temperature potentielle
    151 C
    152       call histdef(histaveid, 'theta', 'temperature potentielle', 'K',
    153      .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
    154      .             32, 'ave(X)', t_ops, t_wrt)
    155 C
    156 C  Geopotentiel
    157 C
    158       call histdef(histaveid, 'phi', 'geopotentiel moyen', '-',
    159      .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
    160      .             32, 'ave(X)', t_ops, t_wrt)
    161 C
    162 C  Traceurs
    163 C
    164 !        DO iq=1,nqtot
    165 !          call histdef(histaveid, ttext(iq), ttext(iq), '-',
    166 !     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
    167 !     .             32, 'ave(X)', t_ops, t_wrt)
    168 !        enddo
    169 C
    170 C  Masse
    171 C
    172       call histdef(histaveid, 'masse', 'masse', 'kg',
    173      .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
    174      .             32, 'ave(X)', t_ops, t_wrt)
    175 C
    176 C  Pression au sol
    177 C
    178       call histdef(histaveid, 'ps', 'pression naturelle au sol', 'Pa',
    179      .             iip1, jjp1, thoriid, 1, 1, 1, -99,
    180      .             32, 'ave(X)', t_ops, t_wrt)
    181 C
    182 C  Geopotentiel au sol
    183 C
    184 !      call histdef(histaveid, 'phis', 'geopotentiel au sol', '-',
    185 !     .             iip1, jjp1, thoriid, 1, 1, 1, -99,
    186 !     .             32, 'ave(X)', t_ops, t_wrt)
    187 !C
    188 C  Fin
    189 C
    190       call histend(histaveid)
    191       call histend(histuaveid)
    192       call histend(histvaveid)
     71
     72  zan = anne0
     73  dayref = day0
     74  CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
     75  tau0 = itau_dyn
     76
     77  do jj = 1, jjp1
     78     do ii = 1, iip1
     79        rlong(ii,jj) = rlonv(ii) * 180. / pi
     80        rlat(ii,jj)  = rlatu(jj) * 180. / pi
     81     enddo
     82  enddo
     83
     84  ! Creation de 3 fichiers pour les differentes grilles horizontales
     85  ! Restriction de IOIPSL: seulement 2 coordonnees dans le meme fichier
     86  ! Grille Scalaire       
     87  call histbeg(dynhistave_file, iip1, rlong(:,1), jjp1, rlat(1,:), &
     88       1, iip1, 1, jjp1, &
     89       tau0, zjulian, tstep, thoriid,histaveid)
     90
     91  ! Creation du fichier histoire pour les grilles en V et U (oblige
     92  ! pour l'instant, IOIPSL ne permet pas de grilles avec des nombres
     93  ! de point differents dans  un meme fichier)
     94  ! Grille V
     95  do jj = 1, jjm
     96     do ii = 1, iip1
     97        rlong(ii,jj) = rlonv(ii) * 180. / pi
     98        rlat(ii,jj) = rlatv(jj) * 180. / pi
     99     enddo
     100  enddo
     101
     102  call histbeg(dynhistvave_file, iip1, rlong(:,1), jjm, rlat(1,:), &
     103       1, iip1, 1, jjm, &
     104       tau0, zjulian, tstep, vhoriid,histvaveid)
     105  ! Grille U
     106  do jj = 1, jjp1
     107     do ii = 1, iip1
     108        rlong(ii,jj) = rlonu(ii) * 180. / pi
     109        rlat(ii,jj) = rlatu(jj) * 180. / pi
     110     enddo
     111  enddo
     112
     113  call histbeg(dynhistuave_file, iip1, rlong(:,1),jjp1, rlat(1,:), &
     114       1, iip1, 1, jjp1, &
     115       tau0, zjulian, tstep, uhoriid,histuaveid)
     116
     117  !  Appel a histvert pour la grille verticale
     118
     119  call histvert(histaveid,'presnivs','Niveaux Pression approximatifs','mb', &
     120       llm, presnivs/100., zvertiid,'down')
     121  call histvert(histuaveid,'presnivs','Niveaux Pression approximatifs','mb', &
     122       llm, presnivs/100., zvertiid,'down')
     123  call histvert(histvaveid,'presnivs','Niveaux Pression approximatifs','mb', &
     124       llm, presnivs/100., zvertiid,'down')
     125
     126  !  Appels a histdef pour la definition des variables a sauvegarder
     127
     128  !  Vents U
     129
     130  call histdef(histuaveid, 'u', 'vent u moyen ', &
     131       'm/s', iip1, jjp1, uhoriid, llm, 1, llm, zvertiid, &
     132       32, 'ave(X)', t_ops, t_wrt)
     133
     134  !  Vents V
     135
     136  call histdef(histvaveid, 'v', 'vent v moyen', &
     137       'm/s', iip1, jjm, vhoriid, llm, 1, llm, zvertiid, &
     138       32, 'ave(X)', t_ops, t_wrt)
     139
     140
     141  !  Temperature
     142
     143  call histdef(histaveid, 'temp', 'temperature moyenne', 'K', &
     144       iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
     145       32, 'ave(X)', t_ops, t_wrt)
     146
     147  !  Temperature potentielle
     148
     149  call histdef(histaveid, 'theta', 'temperature potentielle', 'K', &
     150       iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
     151       32, 'ave(X)', t_ops, t_wrt)
     152
     153  !  Geopotentiel
     154
     155  call histdef(histaveid, 'phi', 'geopotentiel moyen', '-', &
     156       iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
     157       32, 'ave(X)', t_ops, t_wrt)
     158
     159  !  Traceurs
     160
     161  !        DO iq=1,nqtot
     162  !          call histdef(histaveid, ttext(iq), ttext(iq), '-', &
     163  !                  iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
     164  !                  32, 'ave(X)', t_ops, t_wrt)
     165  !        enddo
     166
     167  !  Masse
     168
     169  call histdef(histaveid, 'masse', 'masse', 'kg', &
     170       iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
     171       32, 'ave(X)', t_ops, t_wrt)
     172
     173  !  Pression au sol
     174
     175  call histdef(histaveid, 'ps', 'pression naturelle au sol', 'Pa', &
     176       iip1, jjp1, thoriid, 1, 1, 1, -99, &
     177       32, 'ave(X)', t_ops, t_wrt)
     178
     179  !  Geopotentiel au sol
     180
     181  !      call histdef(histaveid, 'phis', 'geopotentiel au sol', '-', &
     182  !                  iip1, jjp1, thoriid, 1, 1, 1, -99, &
     183  !                  32, 'ave(X)', t_ops, t_wrt)
     184
     185  call histend(histaveid)
     186  call histend(histuaveid)
     187  call histend(histvaveid)
    193188#else
    194 ! tell the user this routine should be run with ioipsl
    195       write(lunout,*)"initdynav: Warning this routine should not be",
    196      &               " used without ioipsl"
     189  write(lunout,*)"initdynav: Warning this routine should not be", &
     190       " used without ioipsl"
    197191#endif
    198 ! of #ifdef CPP_IOIPSL
    199       return
    200       end
     192  ! of #ifdef CPP_IOIPSL
     193
     194end subroutine initdynav

  • trunk/LMDZ.COMMON/libf/bibio/netcdf95.F90

    r1 r776  
    33
    44  ! Author: Lionel GUEZ
    5 
    6   ! Three criticisms may be made about the Fortran 90 NetCDF interface:
    7 
    8   ! -- NetCDF procedures are usually functions with side effects.
    9   ! First, they have "intent(out)" arguments.
    10   ! Furthermore, there is obviously data transfer inside the procedures.
    11   ! Any data transfer inside a function is considered as a side effect.
    12 
    13   ! -- The caller of a NetCDF procedure usually has to handle the error
    14   ! status. NetCDF procedures would be much friendlier if they behaved
    15   ! like the Fortran input/output statements. That is, the error status
    16   ! should be an optional output argument.
    17   ! If the caller does not request the error status and there is an
    18   ! error then the NetCDF procedure should produce an error message
    19   ! and stop the program.
    20 
    21   ! -- Some procedures use array arguments with assumed size.
    22   ! It would be better to use the pointer attribute.
    23 
    24   ! This module produces a NetCDF interface that answers those three
    25   ! criticisms for some (not all) procedures.
    26 
    27   ! "nf95_get_att" is more secure than "nf90_get_att" because it
    28   ! checks that the "values" argument is long enough and removes the
    29   ! null terminator, if any.
    30 
    31   ! This module replaces some of the official NetCDF procedures.
    32   ! This module also provides the procedures "handle_err" and "nf95_gw_var".
    33 
    34   ! This module provides only a partial replacement for some generic
    35   ! procedures such as "nf90_def_var".
     5  ! See:
     6  ! http://www.lmd.jussieu.fr/~lglmd/NetCDF95
    367
    378  use nf95_def_var_m
    389  use nf95_put_var_m
     10  use nf95_get_var_m
    3911  use nf95_gw_var_m
    4012  use nf95_put_att_m

  • trunk/LMDZ.COMMON/libf/bibio/nf95_get_att_m.F90

    r1 r776  
    11! $Id$
    22module nf95_get_att_m
     3
     4  use handle_err_m, only: handle_err
     5  use netcdf, only: nf90_get_att, nf90_noerr
     6  use simple, only: nf95_inquire_attribute
    37
    48  implicit none
    59
    610  interface nf95_get_att
    7      module procedure nf95_get_att_text
     11     module procedure nf95_get_att_text, nf95_get_att_one_FourByteInt
     12
     13     ! The difference between the specific procedures is the type of
     14     ! argument "values".
    815  end interface
    916
    … …  
    1522  subroutine nf95_get_att_text(ncid, varid, name, values, ncerr)
    1623
    17     use netcdf, only: nf90_get_att, nf90_inquire_attribute, nf90_noerr
    18     use handle_err_m, only: handle_err
    19 
    2024    integer,                          intent( in) :: ncid, varid
    2125    character(len = *),               intent( in) :: name
    … …  
    2327    integer, intent(out), optional:: ncerr
    2428
    25     ! Variable local to the procedure:
     29    ! Variables local to the procedure:
    2630    integer ncerr_not_opt
    2731    integer att_len
    … …  
    3034
    3135    ! Check that the length of "values" is large enough:
    32     ncerr_not_opt = nf90_inquire_attribute(ncid, varid, name, len=att_len)
    33     call handle_err("nf95_get_att_text nf90_inquire_attribute " &
    34          // trim(name), ncerr_not_opt, ncid, varid)
    35     if (len(values) < att_len) then
    36        print *, "nf95_get_att_text"
    37        print *, "varid = ", varid
    38        print *, "attribute name: ", name
    39        print *, 'length of "values" is not large enough'
    40        print *, "len(values) = ", len(values)
    41        print *, "number of characters in attribute: ", att_len
    42        stop 1
     36    call nf95_inquire_attribute(ncid, varid, name, nclen=att_len, &
     37         ncerr=ncerr_not_opt)
     38    if (ncerr_not_opt == nf90_noerr) then
     39       if (len(values) < att_len) then
     40          print *, "nf95_get_att_text"
     41          print *, "varid = ", varid
     42          print *, "attribute name: ", name
     43          print *, 'length of "values" is not large enough'
     44          print *, "len(values) = ", len(values)
     45          print *, "number of characters in attribute: ", att_len
     46          stop 1
     47       end if
    4348    end if
    4449
    … …  
    4853       ncerr = ncerr_not_opt
    4954    else
    50        call handle_err("nf95_get_att_text", ncerr_not_opt, ncid, varid)
     55       call handle_err("nf95_get_att_text " // trim(name), ncerr_not_opt, &
     56            ncid, varid)
    5157    end if
    5258
    … …  
    5864  end subroutine nf95_get_att_text
    5965
     66  !***********************
     67
     68  subroutine nf95_get_att_one_FourByteInt(ncid, varid, name, values, ncerr)
     69
     70    integer,                                    intent( in) :: ncid, varid
     71    character(len = *),                         intent( in) :: name
     72    integer ,               intent(out) :: values
     73    integer, intent(out), optional:: ncerr
     74
     75    ! Variables local to the procedure:
     76    integer ncerr_not_opt
     77    integer att_len
     78
     79    !-------------------
     80
     81    ! Check that the attribute contains a single value:
     82    call nf95_inquire_attribute(ncid, varid, name, nclen=att_len, &
     83         ncerr=ncerr_not_opt)
     84    if (ncerr_not_opt == nf90_noerr) then
     85       if (att_len /= 1) then
     86          print *, "nf95_get_att_one_FourByteInt"
     87          print *, "varid = ", varid
     88          print *, "attribute name: ", name
     89          print *, 'the attribute does not contain a single value'
     90          print *, "number of values in attribute: ", att_len
     91          stop 1
     92       end if
     93    end if
     94
     95    ncerr_not_opt = nf90_get_att(ncid, varid, name, values)
     96    if (present(ncerr)) then
     97       ncerr = ncerr_not_opt
     98    else
     99       call handle_err("nf95_get_att_one_FourByteInt " // trim(name), &
     100            ncerr_not_opt, ncid, varid)
     101    end if
     102
     103  end subroutine nf95_get_att_one_FourByteInt
     104
    60105end module nf95_get_att_m

  • trunk/LMDZ.COMMON/libf/bibio/nf95_gw_var_m.F90

    r1 r776  
    11! $Id$
    22module nf95_gw_var_m
     3
     4  use nf95_get_var_m, only: NF95_GET_VAR
     5  use simple, only: nf95_inquire_variable, nf95_inquire_dimension
    36
    47  implicit none
    … …  
    811     ! These procedures read a whole NetCDF variable (coordinate or
    912     ! primary) into an array.
    10      ! The difference between the procedures is the rank of the array
    11      ! and the type of Fortran values.
     13     ! The difference between the procedures is the rank and type of
     14     ! argument "values".
    1215     ! The procedures do not check the type of the NetCDF variable.
    1316
    14 !!$     module procedure nf95_gw_var_real_1d, nf95_gw_var_real_2d, &
    15 !!$          nf95_gw_var_real_3d, nf95_gw_var_real_4d, nf95_gw_var_dble_1d, &
    16 !!$          nf95_gw_var_dble_3d, nf95_gw_var_int_1d, nf95_gw_var_int_3d
     17     ! Not including double precision procedures in the generic
     18     ! interface because we use a compilation option that changes default
     19     ! real precision.
    1720     module procedure nf95_gw_var_real_1d, nf95_gw_var_real_2d, &
    18           nf95_gw_var_real_3d, nf95_gw_var_real_4d, nf95_gw_var_int_1d, &
    19           nf95_gw_var_int_3d
     21          nf95_gw_var_real_3d, nf95_gw_var_real_4d, nf95_gw_var_real_5d, &
     22          nf95_gw_var_int_1d, nf95_gw_var_int_3d
    2023  end interface
    2124
    … …  
    2932    ! Real type, the array has rank 1.
    3033
    31     use netcdf, only: NF90_GET_VAR
    32     use simple, only: nf95_inquire_variable, nf95_inquire_dimension
    33     use handle_err_m, only: handle_err
    34 
    3534    integer, intent(in):: ncid
    3635    integer, intent(in):: varid
    … …  
    3837
    3938    ! Variables local to the procedure:
    40     integer ierr, len
    41     integer, pointer :: dimids(:)
     39    integer nclen
     40    integer, pointer:: dimids(:)
    4241
    4342    !---------------------
    … …  
    4645
    4746    if (size(dimids) /= 1) then
    48        print *, "nf95_gw_var_real_1d: NetCDF variable is not of rank 1"
    49        stop 1
    50     end if
    51 
    52     call nf95_inquire_dimension(ncid, dimids(1), len=len)
    53     deallocate(dimids) ! pointer
    54 
    55     allocate(values(len))
    56     if (len /= 0) then
    57        ierr = NF90_GET_VAR(ncid, varid, values)
    58        call handle_err("NF90_GET_VAR", ierr, ncid, varid)
    59     end if
     47       print *, "nf95_gw_var_real_1d:"
     48       print *, "varid = ", varid
     49       print *, "rank of NetCDF variable is ", size(dimids), ", not 1"
     50       stop 1
     51    end if
     52
     53    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen)
     54    deallocate(dimids) ! pointer
     55
     56    allocate(values(nclen))
     57    if (nclen /= 0) call NF95_GET_VAR(ncid, varid, values)
    6058
    6159  end subroutine nf95_gw_var_real_1d
    … …  
    6765    ! Real type, the array has rank 2.
    6866
    69     use netcdf, only: NF90_GET_VAR
    70     use simple, only: nf95_inquire_variable, nf95_inquire_dimension
    71     use handle_err_m, only: handle_err
    72 
    7367    integer, intent(in):: ncid
    7468    integer, intent(in):: varid
    … …  
    7670
    7771    ! Variables local to the procedure:
    78     integer ierr, len1, len2
    79     integer, pointer :: dimids(:)
     72    integer nclen1, nclen2
     73    integer, pointer:: dimids(:)
    8074
    8175    !---------------------
    … …  
    8478
    8579    if (size(dimids) /= 2) then
    86        print *, "nf95_gw_var_real_2d: NetCDF variable is not of rank 2"
    87        stop 1
    88     end if
    89 
    90     call nf95_inquire_dimension(ncid, dimids(1), len=len1)
    91     call nf95_inquire_dimension(ncid, dimids(2), len=len2)
    92     deallocate(dimids) ! pointer
    93 
    94     allocate(values(len1, len2))
    95     if (len1 /= 0 .and. len2 /= 0) then
    96        ierr = NF90_GET_VAR(ncid, varid, values)
    97        call handle_err("NF90_GET_VAR", ierr, ncid, varid)
    98     end if
     80       print *, "nf95_gw_var_real_2d:"
     81       print *, "varid = ", varid
     82       print *, "rank of NetCDF variable is ", size(dimids), ", not 2"
     83       stop 1
     84    end if
     85
     86    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen1)
     87    call nf95_inquire_dimension(ncid, dimids(2), nclen=nclen2)
     88    deallocate(dimids) ! pointer
     89
     90    allocate(values(nclen1, nclen2))
     91    if (nclen1 /= 0 .and. nclen2 /= 0) call NF95_GET_VAR(ncid, varid, values)
    9992
    10093  end subroutine nf95_gw_var_real_2d
    … …  
    10699    ! Real type, the array has rank 3.
    107100
    108     use netcdf, only: NF90_GET_VAR
    109     use simple, only: nf95_inquire_variable, nf95_inquire_dimension
    110     use handle_err_m, only: handle_err
    111 
    112101    integer, intent(in):: ncid
    113102    integer, intent(in):: varid
    … …  
    115104
    116105    ! Variables local to the procedure:
    117     integer ierr, len1, len2, len3
    118     integer, pointer :: dimids(:)
     106    integer nclen1, nclen2, nclen3
     107    integer, pointer:: dimids(:)
    119108
    120109    !---------------------
    … …  
    123112
    124113    if (size(dimids) /= 3) then
    125        print *, "nf95_gw_var_real_3d: NetCDF variable is not of rank 3"
    126        stop 1
    127     end if
    128 
    129     call nf95_inquire_dimension(ncid, dimids(1), len=len1)
    130     call nf95_inquire_dimension(ncid, dimids(2), len=len2)
    131     call nf95_inquire_dimension(ncid, dimids(3), len=len3)
    132     deallocate(dimids) ! pointer
    133 
    134     allocate(values(len1, len2, len3))
    135     if (len1 * len2 * len3 /= 0) then
    136        ierr = NF90_GET_VAR(ncid, varid, values)
    137        call handle_err("NF90_GET_VAR", ierr, ncid, varid)
    138     end if
     114       print *, "nf95_gw_var_real_3d:"
     115       print *, "varid = ", varid
     116       print *, "rank of NetCDF variable is ", size(dimids), ", not 3"
     117       stop 1
     118    end if
     119
     120    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen1)
     121    call nf95_inquire_dimension(ncid, dimids(2), nclen=nclen2)
     122    call nf95_inquire_dimension(ncid, dimids(3), nclen=nclen3)
     123    deallocate(dimids) ! pointer
     124
     125    allocate(values(nclen1, nclen2, nclen3))
     126    if (nclen1 * nclen2 * nclen3 /= 0) call NF95_GET_VAR(ncid, varid, values)
    139127
    140128  end subroutine nf95_gw_var_real_3d
    … …  
    146134    ! Real type, the array has rank 4.
    147135
    148     use netcdf, only: NF90_GET_VAR
    149     use simple, only: nf95_inquire_variable, nf95_inquire_dimension
    150     use handle_err_m, only: handle_err
    151 
    152136    integer, intent(in):: ncid
    153137    integer, intent(in):: varid
    … …  
    155139
    156140    ! Variables local to the procedure:
    157     integer ierr, len_dim(4), i
    158     integer, pointer :: dimids(:)
     141    integer len_dim(4), i
     142    integer, pointer:: dimids(:)
    159143
    160144    !---------------------
    … …  
    163147
    164148    if (size(dimids) /= 4) then
    165        print *, "nf95_gw_var_real_4d: NetCDF variable is not of rank 4"
     149       print *, "nf95_gw_var_real_4d:"
     150       print *, "varid = ", varid
     151       print *, "rank of NetCDF variable is ", size(dimids), ", not 4"
    166152       stop 1
    167153    end if
    168154
    169155    do i = 1, 4
    170        call nf95_inquire_dimension(ncid, dimids(i), len=len_dim(i))
     156       call nf95_inquire_dimension(ncid, dimids(i), nclen=len_dim(i))
    171157    end do
    172158    deallocate(dimids) ! pointer
    173159
    174160    allocate(values(len_dim(1), len_dim(2), len_dim(3), len_dim(4)))
    175     if (all(len_dim /= 0)) then
    176        ierr = NF90_GET_VAR(ncid, varid, values)
    177        call handle_err("NF90_GET_VAR", ierr, ncid, varid)
    178     end if
     161    if (all(len_dim /= 0)) call NF95_GET_VAR(ncid, varid, values)
    179162
    180163  end subroutine nf95_gw_var_real_4d
    … …  
    182165  !************************************
    183166
     167  subroutine nf95_gw_var_real_5d(ncid, varid, values)
     168
     169    ! Real type, the array has rank 5.
     170
     171    integer, intent(in):: ncid
     172    integer, intent(in):: varid
     173    real, pointer:: values(:, :, :, :, :)
     174
     175    ! Variables local to the procedure:
     176    integer len_dim(5), i
     177    integer, pointer:: dimids(:)
     178
     179    !---------------------
     180
     181    call nf95_inquire_variable(ncid, varid, dimids=dimids)
     182
     183    if (size(dimids) /= 5) then
     184       print *, "nf95_gw_var_real_5d:"
     185       print *, "varid = ", varid
     186       print *, "rank of NetCDF variable is ", size(dimids), ", not 5"
     187       stop 1
     188    end if
     189
     190    do i = 1, 5
     191       call nf95_inquire_dimension(ncid, dimids(i), nclen=len_dim(i))
     192    end do
     193    deallocate(dimids) ! pointer
     194
     195    allocate(values(len_dim(1), len_dim(2), len_dim(3), len_dim(4), len_dim(5)))
     196    if (all(len_dim /= 0)) call NF95_GET_VAR(ncid, varid, values)
     197
     198  end subroutine nf95_gw_var_real_5d
     199
     200  !************************************
     201
    184202!!$  subroutine nf95_gw_var_dble_1d(ncid, varid, values)
    185203!!$
    186204!!$    ! Double precision, the array has rank 1.
    187 !!$
    188 !!$    use netcdf, only: NF90_GET_VAR
    189 !!$    use simple, only: nf95_inquire_variable, nf95_inquire_dimension
    190 !!$    use handle_err_m, only: handle_err
    191205!!$
    192206!!$    integer, intent(in):: ncid
    … …  
    195209!!$
    196210!!$    ! Variables local to the procedure:
    197 !!$    integer ierr, len
    198 !!$    integer, pointer :: dimids(:)
     211!!$    integer nclen
     212!!$    integer, pointer:: dimids(:)
    199213!!$
    200214!!$    !---------------------
    … …  
    203217!!$
    204218!!$    if (size(dimids) /= 1) then
    205 !!$       print *, "nf95_gw_var_dble_1d: NetCDF variable is not of rank 1"
    206 !!$       stop 1
     219!!$       print *, "nf95_gw_var_dble_1d:"
     220!!$       print *, "varid = ", varid
     221!!$       print *, "rank of NetCDF variable is ", size(dimids), ", not 1"
     222!!$        stop 1
    207223!!$    end if
    208224!!$
    209 !!$    call nf95_inquire_dimension(ncid, dimids(1), len=len)
     225!!$    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen)
    210226!!$    deallocate(dimids) ! pointer
    211227!!$
    212 !!$    allocate(values(len))
    213 !!$    if (len /= 0) then
    214 !!$       ierr = NF90_GET_VAR(ncid, varid, values)
    215 !!$       call handle_err("NF90_GET_VAR", ierr, ncid, varid)
    216 !!$    end if
     228!!$    allocate(values(nclen))
     229!!$    if (nclen /= 0) call NF95_GET_VAR(ncid, varid, values)
    217230!!$
    218231!!$  end subroutine nf95_gw_var_dble_1d
    … …  
    223236!!$
    224237!!$    ! Double precision, the array has rank 3.
    225 !!$
    226 !!$    use netcdf, only: NF90_GET_VAR
    227 !!$    use simple, only: nf95_inquire_variable, nf95_inquire_dimension
    228 !!$    use handle_err_m, only: handle_err
    229238!!$
    230239!!$    integer, intent(in):: ncid
    … …  
    233242!!$
    234243!!$    ! Variables local to the procedure:
    235 !!$    integer ierr, len1, len2, len3
    236 !!$    integer, pointer :: dimids(:)
     244!!$    integer nclen1, nclen2, nclen3
     245!!$    integer, pointer:: dimids(:)
    237246!!$
    238247!!$    !---------------------
    … …  
    241250!!$
    242251!!$    if (size(dimids) /= 3) then
    243 !!$       print *, "nf95_gw_var_dble_3d: NetCDF variable is not of rank 3"
     252!!$       print *, "nf95_gw_var_dble_3d:"
     253!!$       print *, "varid = ", varid
     254!!$       print *, "rank of NetCDF variable is ", size(dimids), ", not 3"
    244255!!$       stop 1
    245256!!$    end if
    246257!!$
    247 !!$    call nf95_inquire_dimension(ncid, dimids(1), len=len1)
    248 !!$    call nf95_inquire_dimension(ncid, dimids(2), len=len2)
    249 !!$    call nf95_inquire_dimension(ncid, dimids(3), len=len3)
     258!!$    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen1)
     259!!$    call nf95_inquire_dimension(ncid, dimids(2), nclen=nclen2)
     260!!$    call nf95_inquire_dimension(ncid, dimids(3), nclen=nclen3)
    250261!!$    deallocate(dimids) ! pointer
    251262!!$
    252 !!$    allocate(values(len1, len2, len3))
    253 !!$    if (len1 * len2 * len3 /= 0) then
    254 !!$       ierr = NF90_GET_VAR(ncid, varid, values)
    255 !!$       call handle_err("NF90_GET_VAR", ierr, ncid, varid)
    256 !!$    end if
     263!!$    allocate(values(nclen1, nclen2, nclen3))
     264!!$    if (nclen1 * nclen2 * nclen3 /= 0) call NF95_GET_VAR(ncid, varid, values)
    257265!!$
    258266!!$  end subroutine nf95_gw_var_dble_3d
    259 
     267!!$
    260268  !************************************
    261269
    … …  
    264272    ! Integer type, the array has rank 1.
    265273
    266     use netcdf, only: NF90_GET_VAR
    267     use simple, only: nf95_inquire_variable, nf95_inquire_dimension
    268     use handle_err_m, only: handle_err
    269 
    270274    integer, intent(in):: ncid
    271275    integer, intent(in):: varid
    … …  
    273277
    274278    ! Variables local to the procedure:
    275     integer ierr, len
    276     integer, pointer :: dimids(:)
     279    integer nclen
     280    integer, pointer:: dimids(:)
    277281
    278282    !---------------------
    … …  
    281285
    282286    if (size(dimids) /= 1) then
    283        print *, "nf95_gw_var_int_1d: NetCDF variable is not of rank 1"
    284        stop 1
    285     end if
    286 
    287     call nf95_inquire_dimension(ncid, dimids(1), len=len)
    288     deallocate(dimids) ! pointer
    289 
    290     allocate(values(len))
    291     if (len /= 0) then
    292        ierr = NF90_GET_VAR(ncid, varid, values)
    293        call handle_err("NF90_GET_VAR", ierr, ncid, varid)
    294     end if
     287       print *, "nf95_gw_var_int_1d:"
     288       print *, "varid = ", varid
     289       print *, "rank of NetCDF variable is ", size(dimids), ", not 1"
     290       stop 1
     291    end if
     292
     293    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen)
     294    deallocate(dimids) ! pointer
     295
     296    allocate(values(nclen))
     297    if (nclen /= 0) call NF95_GET_VAR(ncid, varid, values)
    295298
    296299  end subroutine nf95_gw_var_int_1d
    … …  
    302305    ! Integer type, the array has rank 3.
    303306
    304     use netcdf, only: NF90_GET_VAR
    305     use simple, only: nf95_inquire_variable, nf95_inquire_dimension
    306     use handle_err_m, only: handle_err
    307 
    308307    integer, intent(in):: ncid
    309308    integer, intent(in):: varid
    … …  
    311310
    312311    ! Variables local to the procedure:
    313     integer ierr, len1, len2, len3
    314     integer, pointer :: dimids(:)
     312    integer nclen1, nclen2, nclen3
     313    integer, pointer:: dimids(:)
    315314
    316315    !---------------------
    … …  
    319318
    320319    if (size(dimids) /= 3) then
    321        print *, "nf95_gw_var_int_3d: NetCDF variable is not of rank 3"
    322        stop 1
    323     end if
    324 
    325     call nf95_inquire_dimension(ncid, dimids(1), len=len1)
    326     call nf95_inquire_dimension(ncid, dimids(2), len=len2)
    327     call nf95_inquire_dimension(ncid, dimids(3), len=len3)
    328     deallocate(dimids) ! pointer
    329 
    330     allocate(values(len1, len2, len3))
    331     if (len1 * len2 * len3 /= 0) then
    332        ierr = NF90_GET_VAR(ncid, varid, values)
    333        call handle_err("NF90_GET_VAR", ierr, ncid, varid)
    334     end if
     320       print *, "nf95_gw_var_int_3d:"
     321       print *, "varid = ", varid
     322       print *, "rank of NetCDF variable is ", size(dimids), ", not 3"
     323       stop 1
     324    end if
     325
     326    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen1)
     327    call nf95_inquire_dimension(ncid, dimids(2), nclen=nclen2)
     328    call nf95_inquire_dimension(ncid, dimids(3), nclen=nclen3)
     329    deallocate(dimids) ! pointer
     330
     331    allocate(values(nclen1, nclen2, nclen3))
     332    if (nclen1 * nclen2 * nclen3 /= 0) call NF95_GET_VAR(ncid, varid, values)
    335333
    336334  end subroutine nf95_gw_var_int_3d

  • trunk/LMDZ.COMMON/libf/bibio/nf95_put_var_m.F90

    r1 r776  
    99          nf95_put_var_2D_FourByteReal, nf95_put_var_3D_FourByteReal, &
    1010          nf95_put_var_4D_FourByteReal
    11 !!$     module procedure nf95_put_var_1D_FourByteReal, &
    12 !!$          nf95_put_var_2D_FourByteReal, nf95_put_var_3D_FourByteReal, &
    13 !!$          nf95_put_var_4D_FourByteReal, nf90_put_var_1D_EightByteReal, &
    14 !!$          nf90_put_var_3D_EightByteReal
    1511  end interface
    1612
    … …  
    2521    use handle_err_m, only: handle_err
    2622
    27     integer, intent( in) :: ncid, varid
    28     real, intent( in) :: values
    29     integer, dimension(:), optional, intent( in) :: start
     23    integer, intent(in) :: ncid, varid
     24    real, intent(in) :: values
     25    integer, dimension(:), optional, intent(in) :: start
    3026    integer, intent(out), optional:: ncerr
    3127
    … …  
    5248    use handle_err_m, only: handle_err
    5349
    54     integer, intent( in) :: ncid, varid
    55     integer, intent( in) :: values
    56     integer, dimension(:), optional, intent( in) :: start
     50    integer, intent(in) :: ncid, varid
     51    integer, intent(in) :: values
     52    integer, dimension(:), optional, intent(in) :: start
    5753    integer, intent(out), optional:: ncerr
    5854
    … …  
    7470  !***********************
    7571
    76   subroutine nf95_put_var_1D_FourByteReal(ncid, varid, values, start, count, &
    77        stride, map, ncerr)
     72  subroutine nf95_put_var_1D_FourByteReal(ncid, varid, values, start, &
     73       count_nc, stride, map, ncerr)
    7874
    7975    use netcdf, only: nf90_put_var
    … …  
    8278    integer,                         intent(in) :: ncid, varid
    8379    real, intent(in) :: values(:)
    84     integer, dimension(:), optional, intent(in) :: start, count, stride, map
    85     integer, intent(out), optional:: ncerr
    86 
    87     ! Variable local to the procedure:
    88     integer ncerr_not_opt
    89 
    90     !-------------------
    91 
    92     ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count, stride, &
    93          map)
     80    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
     81    integer, intent(out), optional:: ncerr
     82
     83    ! Variable local to the procedure:
     84    integer ncerr_not_opt
     85
     86    !-------------------
     87
     88    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
     89         stride, map)
    9490    if (present(ncerr)) then
    9591       ncerr = ncerr_not_opt
    … …  
    10399  !***********************
    104100
    105   subroutine nf95_put_var_1D_FourByteInt(ncid, varid, values, start, count, &
    106        stride, map, ncerr)
     101  subroutine nf95_put_var_1D_FourByteInt(ncid, varid, values, start, &
     102       count_nc, stride, map, ncerr)
    107103
    108104    use netcdf, only: nf90_put_var
    … …  
    111107    integer,                         intent(in) :: ncid, varid
    112108    integer, intent(in) :: values(:)
    113     integer, dimension(:), optional, intent(in) :: start, count, stride, map
    114     integer, intent(out), optional:: ncerr
    115 
    116     ! Variable local to the procedure:
    117     integer ncerr_not_opt
    118 
    119     !-------------------
    120 
    121     ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count, stride, &
    122          map)
     109    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
     110    integer, intent(out), optional:: ncerr
     111
     112    ! Variable local to the procedure:
     113    integer ncerr_not_opt
     114
     115    !-------------------
     116
     117    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
     118         stride, map)
    123119    if (present(ncerr)) then
    124120       ncerr = ncerr_not_opt
    … …  
    132128  !***********************
    133129
    134   subroutine nf95_put_var_2D_FourByteReal(ncid, varid, values, start, count, &
    135        stride, map, ncerr)
    136 
    137     use netcdf, only: nf90_put_var
    138     use handle_err_m, only: handle_err
    139 
    140     integer,                         intent( in) :: ncid, varid
    141     real, intent( in) :: values(:, :)
    142     integer, dimension(:), optional, intent( in) :: start, count, stride, map
    143     integer, intent(out), optional:: ncerr
    144 
    145     ! Variable local to the procedure:
    146     integer ncerr_not_opt
    147 
    148     !-------------------
    149 
    150     ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count, stride, &
    151          map)
     130  subroutine nf95_put_var_1D_EightByteReal(ncid, varid, values, start, &
     131       count_nc, stride, map, ncerr)
     132
     133    use typesizes, only: eightByteReal
     134    use netcdf, only: nf90_put_var
     135    use handle_err_m, only: handle_err
     136
     137    integer,                         intent(in) :: ncid, varid
     138    real (kind = EightByteReal),     intent(in) :: values(:)
     139    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
     140    integer, intent(out), optional:: ncerr
     141
     142    ! Variable local to the procedure:
     143    integer ncerr_not_opt
     144
     145    !-------------------
     146
     147    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
     148         stride, map)
     149    if (present(ncerr)) then
     150       ncerr = ncerr_not_opt
     151    else
     152       call handle_err("nf95_put_var_1D_eightByteReal", ncerr_not_opt, ncid, &
     153            varid)
     154    end if
     155
     156  end subroutine nf95_put_var_1D_EightByteReal
     157
     158  !***********************
     159
     160  subroutine nf95_put_var_2D_FourByteReal(ncid, varid, values, start, &
     161       count_nc, stride, map, ncerr)
     162
     163    use netcdf, only: nf90_put_var
     164    use handle_err_m, only: handle_err
     165
     166    integer,                         intent(in) :: ncid, varid
     167    real, intent(in) :: values(:, :)
     168    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
     169    integer, intent(out), optional:: ncerr
     170
     171    ! Variable local to the procedure:
     172    integer ncerr_not_opt
     173
     174    !-------------------
     175
     176    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
     177         stride, map)
    152178    if (present(ncerr)) then
    153179       ncerr = ncerr_not_opt
    … …  
    161187  !***********************
    162188
    163   subroutine nf95_put_var_3D_FourByteReal(ncid, varid, values, start, count, &
    164        stride, map, ncerr)
    165 
    166     use netcdf, only: nf90_put_var
    167     use handle_err_m, only: handle_err
    168 
    169     integer,                         intent( in) :: ncid, varid
    170     real, intent( in) :: values(:, :, :)
    171     integer, dimension(:), optional, intent( in) :: start, count, stride, map
    172     integer, intent(out), optional:: ncerr
    173 
    174     ! Variable local to the procedure:
    175     integer ncerr_not_opt
    176 
    177     !-------------------
    178 
    179     ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count, stride, &
    180          map)
     189  subroutine nf95_put_var_2D_EightByteReal(ncid, varid, values, start, &
     190       count_nc, stride, map, ncerr)
     191
     192    use typesizes, only: EightByteReal
     193    use netcdf, only: nf90_put_var
     194    use handle_err_m, only: handle_err
     195
     196    integer,                         intent(in) :: ncid, varid
     197    real (kind = EightByteReal), intent(in) :: values(:, :)
     198    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
     199    integer, intent(out), optional:: ncerr
     200
     201    ! Variable local to the procedure:
     202    integer ncerr_not_opt
     203
     204    !-------------------
     205
     206    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
     207         stride, map)
     208    if (present(ncerr)) then
     209       ncerr = ncerr_not_opt
     210    else
     211       call handle_err("nf95_put_var_2D_EightByteReal", ncerr_not_opt, ncid, &
     212            varid)
     213    end if
     214
     215  end subroutine nf95_put_var_2D_EightByteReal
     216
     217  !***********************
     218
     219  subroutine nf95_put_var_3D_FourByteReal(ncid, varid, values, start, &
     220       count_nc, stride, map, ncerr)
     221
     222    use netcdf, only: nf90_put_var
     223    use handle_err_m, only: handle_err
     224
     225    integer,                         intent(in) :: ncid, varid
     226    real, intent(in) :: values(:, :, :)
     227    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
     228    integer, intent(out), optional:: ncerr
     229
     230    ! Variable local to the procedure:
     231    integer ncerr_not_opt
     232
     233    !-------------------
     234
     235    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
     236         stride, map)
    181237    if (present(ncerr)) then
    182238       ncerr = ncerr_not_opt
    … …  
    190246  !***********************
    191247
    192   subroutine nf95_put_var_4D_FourByteReal(ncid, varid, values, start, count, &
    193        stride, map, ncerr)
    194 
    195     use netcdf, only: nf90_put_var
    196     use handle_err_m, only: handle_err
    197 
    198     integer,                         intent( in) :: ncid, varid
    199     real, intent( in) :: values(:, :, :, :)
    200     integer, dimension(:), optional, intent( in) :: start, count, stride, map
    201     integer, intent(out), optional:: ncerr
    202 
    203     ! Variable local to the procedure:
    204     integer ncerr_not_opt
    205 
    206     !-------------------
    207 
    208     ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count, stride, &
    209          map)
     248  subroutine nf95_put_var_3D_EightByteReal(ncid, varid, values, start, &
     249       count_nc, stride, map, ncerr)
     250
     251    use typesizes, only: eightByteReal
     252    use netcdf, only: nf90_put_var
     253    use handle_err_m, only: handle_err
     254
     255    integer,                         intent(in) :: ncid, varid
     256    real (kind = EightByteReal),     intent(in) :: values(:, :, :)
     257    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
     258    integer, intent(out), optional:: ncerr
     259
     260    ! Variable local to the procedure:
     261    integer ncerr_not_opt
     262
     263    !-------------------
     264
     265    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
     266         stride, map)
     267    if (present(ncerr)) then
     268       ncerr = ncerr_not_opt
     269    else
     270       call handle_err("nf95_put_var_3D_eightByteReal", ncerr_not_opt, ncid, &
     271            varid)
     272    end if
     273
     274  end subroutine nf95_put_var_3D_EightByteReal
     275
     276  !***********************
     277
     278  subroutine nf95_put_var_4D_FourByteReal(ncid, varid, values, start, &
     279       count_nc, stride, map, ncerr)
     280
     281    use netcdf, only: nf90_put_var
     282    use handle_err_m, only: handle_err
     283
     284    integer,                         intent(in) :: ncid, varid
     285    real, intent(in) :: values(:, :, :, :)
     286    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
     287    integer, intent(out), optional:: ncerr
     288
     289    ! Variable local to the procedure:
     290    integer ncerr_not_opt
     291
     292    !-------------------
     293
     294    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
     295         stride, map)
    210296    if (present(ncerr)) then
    211297       ncerr = ncerr_not_opt
    … …  
    219305  !***********************
    220306
    221 !!$  subroutine nf90_put_var_1D_EightByteReal(ncid, varid, values, start, count, &
    222 !!$       stride, map, ncerr)
    223 !!$
    224 !!$    use typesizes, only: eightByteReal
    225 !!$    use netcdf, only: nf90_put_var
    226 !!$    use handle_err_m, only: handle_err
    227 !!$
    228 !!$    integer,                         intent( in) :: ncid, varid
    229 !!$    real (kind = EightByteReal),     intent( in) :: values(:)
    230 !!$    integer, dimension(:), optional, intent( in) :: start, count, stride, map
    231 !!$    integer, intent(out), optional:: ncerr
    232 !!$
    233 !!$    ! Variable local to the procedure:
    234 !!$    integer ncerr_not_opt
    235 !!$
    236 !!$    !-------------------
    237 !!$
    238 !!$    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count, stride, &
    239 !!$         map)
    240 !!$    if (present(ncerr)) then
    241 !!$       ncerr = ncerr_not_opt
    242 !!$    else
    243 !!$       call handle_err("nf95_put_var_1D_eightByteReal", ncerr_not_opt, ncid, &
    244 !!$            varid)
    245 !!$    end if
    246 !!$
    247 !!$  end subroutine nf90_put_var_1D_EightByteReal
    248 !!$
    249 !!$  !***********************
    250 !!$
    251 !!$  subroutine nf90_put_var_3D_EightByteReal(ncid, varid, values, start, count, &
    252 !!$       stride, map, ncerr)
    253 !!$
    254 !!$    use typesizes, only: eightByteReal
    255 !!$    use netcdf, only: nf90_put_var
    256 !!$    use handle_err_m, only: handle_err
    257 !!$
    258 !!$    integer,                         intent( in) :: ncid, varid
    259 !!$    real (kind = EightByteReal),     intent( in) :: values(:, :, :)
    260 !!$    integer, dimension(:), optional, intent( in) :: start, count, stride, map
    261 !!$    integer, intent(out), optional:: ncerr
    262 !!$
    263 !!$    ! Variable local to the procedure:
    264 !!$    integer ncerr_not_opt
    265 !!$
    266 !!$    !-------------------
    267 !!$
    268 !!$    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count, stride, &
    269 !!$         map)
    270 !!$    if (present(ncerr)) then
    271 !!$       ncerr = ncerr_not_opt
    272 !!$    else
    273 !!$       call handle_err("nf95_put_var_3D_eightByteReal", ncerr_not_opt, ncid, &
    274 !!$            varid)
    275 !!$    end if
    276 !!$
    277 !!$  end subroutine nf90_put_var_3D_EightByteReal
     307  subroutine nf95_put_var_4D_EightByteReal(ncid, varid, values, start, &
     308       count_nc, stride, map, ncerr)
     309
     310    use typesizes, only: EightByteReal
     311    use netcdf, only: nf90_put_var
     312    use handle_err_m, only: handle_err
     313
     314    integer, intent(in):: ncid, varid
     315    real(kind = EightByteReal), intent(in):: values(:, :, :, :)
     316    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
     317    integer, intent(out), optional:: ncerr
     318
     319    ! Variable local to the procedure:
     320    integer ncerr_not_opt
     321
     322    !-------------------
     323
     324    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
     325         stride, map)
     326    if (present(ncerr)) then
     327       ncerr = ncerr_not_opt
     328    else
     329       call handle_err("nf95_put_var_4D_EightByteReal", ncerr_not_opt, ncid, &
     330            varid)
     331    end if
     332
     333  end subroutine nf95_put_var_4D_EightByteReal
    278334
    279335end module nf95_put_var_m

  • trunk/LMDZ.COMMON/libf/bibio/simple.F90

    r1 r776  
    22module simple
    33
     4  use handle_err_m, only: handle_err
     5 
    46  implicit none
    57
     8  private handle_err
     9
    610contains
    711
    … …  
    913
    1014    use netcdf, only: nf90_open
    11     use handle_err_m, only: handle_err
    1215
    1316    character(len=*), intent(in):: path
    … …  
    3639
    3740    use netcdf, only: nf90_inq_dimid
    38     use handle_err_m, only: handle_err
    39 
    40     integer,             intent( in) :: ncid
    41     character (len = *), intent( in) :: name
     41
     42    integer,             intent(in) :: ncid
     43    character (len = *), intent(in) :: name
    4244    integer,             intent(out) :: dimid
    4345    integer, intent(out), optional:: ncerr
    … …  
    5254       ncerr = ncerr_not_opt
    5355    else
    54        call handle_err("nf95_inq_dimid", ncerr_not_opt, ncid)
     56       call handle_err("nf95_inq_dimid " // name, ncerr_not_opt, ncid)
    5557    end if
    5658
    … …  
    5961  !************************
    6062
    61   subroutine nf95_inquire_dimension(ncid, dimid, name, len, ncerr)
     63  subroutine nf95_inquire_dimension(ncid, dimid, name, nclen, ncerr)
    6264
    6365    use netcdf, only: nf90_inquire_dimension
    64     use handle_err_m, only: handle_err
    6566
    6667    integer,                       intent( in) :: ncid, dimid
    6768    character (len = *), optional, intent(out) :: name
    68     integer,             optional, intent(out) :: len
    69     integer, intent(out), optional:: ncerr
    70 
    71     ! Variable local to the procedure:
    72     integer ncerr_not_opt
    73 
    74     !-------------------
    75 
    76     ncerr_not_opt = nf90_inquire_dimension(ncid, dimid, name, len)
     69    integer,             optional, intent(out) :: nclen
     70    integer, intent(out), optional:: ncerr
     71
     72    ! Variable local to the procedure:
     73    integer ncerr_not_opt
     74
     75    !-------------------
     76
     77    ncerr_not_opt = nf90_inquire_dimension(ncid, dimid, name, nclen)
    7778    if (present(ncerr)) then
    7879       ncerr = ncerr_not_opt
    … …  
    8889
    8990    use netcdf, only: nf90_inq_varid
    90     use handle_err_m, only: handle_err
    9191
    9292    integer,             intent(in) :: ncid
    93     character (len = *), intent(in) :: name
     93    character(len=*), intent(in):: name
    9494    integer,             intent(out) :: varid
    9595    integer, intent(out), optional:: ncerr
    … …  
    115115
    116116    ! In "nf90_inquire_variable", "dimids" is an assumed-size array.
    117     ! This is the classical case of an array the size of which is
     117    ! This is not optimal.
     118    ! We are in the classical case of an array the size of which is
    118119    ! unknown in the calling procedure, before the call.
    119120    ! Here we use a better solution: a pointer argument array.
    … …  
    121122
    122123    use netcdf, only: nf90_inquire_variable, nf90_max_var_dims
    123     use handle_err_m, only: handle_err
    124124
    125125    integer, intent(in):: ncid, varid
    … …  
    151151       ncerr = ncerr_not_opt
    152152    else
    153        call handle_err("nf95_inquire_variable", ncerr_not_opt, ncid)
     153       call handle_err("nf95_inquire_variable", ncerr_not_opt, ncid, varid)
    154154    end if
    155155
    … …  
    161161   
    162162    use netcdf, only: nf90_create
    163     use handle_err_m, only: handle_err
    164163
    165164    character (len = *), intent(in   ) :: path
    … …  
    186185  !************************
    187186
    188   subroutine nf95_def_dim(ncid, name, len, dimid, ncerr)
     187  subroutine nf95_def_dim(ncid, name, nclen, dimid, ncerr)
    189188
    190189    use netcdf, only: nf90_def_dim
    191     use handle_err_m, only: handle_err
    192190
    193191    integer,             intent( in) :: ncid
    194192    character (len = *), intent( in) :: name
    195     integer,             intent( in) :: len
     193    integer,             intent( in) :: nclen
    196194    integer,             intent(out) :: dimid
    197195    integer, intent(out), optional :: ncerr
    … …  
    202200    !-------------------
    203201
    204     ncerr_not_opt = nf90_def_dim(ncid, name, len, dimid)
    205     if (present(ncerr)) then
    206        ncerr = ncerr_not_opt
    207     else
    208        call handle_err("nf95_def_dim", ncerr_not_opt, ncid)
     202    ncerr_not_opt = nf90_def_dim(ncid, name, nclen, dimid)
     203    if (present(ncerr)) then
     204       ncerr = ncerr_not_opt
     205    else
     206       call handle_err("nf95_def_dim " // name, ncerr_not_opt, ncid)
    209207    end if
    210208
    … …  
    216214
    217215    use netcdf, only: nf90_redef
    218     use handle_err_m, only: handle_err
    219216
    220217    integer, intent( in) :: ncid
    … …  
    240237
    241238    use netcdf, only: nf90_enddef
    242     use handle_err_m, only: handle_err
    243239
    244240    integer,           intent( in) :: ncid
    … …  
    265261
    266262    use netcdf, only: nf90_close
    267     use handle_err_m, only: handle_err
    268263
    269264    integer, intent( in) :: ncid
    … …  
    289284
    290285    use netcdf, only: nf90_copy_att
    291     use handle_err_m, only: handle_err
    292286
    293287    integer, intent( in):: ncid_in,  varid_in
    … …  
    305299       ncerr = ncerr_not_opt
    306300    else
    307        call handle_err("nf95_copy_att", ncerr_not_opt, ncid_out)
     301       call handle_err("nf95_copy_att " // name, ncerr_not_opt, ncid_out)
    308302    end if
    309303
    310304  end subroutine nf95_copy_att
    311305
     306  !***********************
     307
     308  subroutine nf95_inquire_attribute(ncid, varid, name, xtype, nclen, attnum, &
     309       ncerr)
     310
     311    use netcdf, only: nf90_inquire_attribute
     312
     313    integer,             intent( in)           :: ncid, varid
     314    character (len = *), intent( in)           :: name
     315    integer,             intent(out), optional :: xtype, nclen, attnum
     316    integer, intent(out), optional:: ncerr
     317
     318    ! Variable local to the procedure:
     319    integer ncerr_not_opt
     320
     321    !-------------------
     322
     323    ncerr_not_opt = nf90_inquire_attribute(ncid, varid, name, xtype, nclen, &
     324         attnum)
     325    if (present(ncerr)) then
     326       ncerr = ncerr_not_opt
     327    else
     328       call handle_err("nf95_inquire_attribute " // name, ncerr_not_opt, &
     329            ncid, varid)
     330    end if
     331
     332  end subroutine nf95_inquire_attribute
     333
     334  !***********************
     335
     336  subroutine nf95_inquire(ncid, nDimensions, nVariables, nAttributes, &
     337       unlimitedDimId, formatNum, ncerr)
     338
     339    use netcdf, only: nf90_inquire
     340
     341    integer,           intent( in) :: ncid
     342    integer, optional, intent(out) :: nDimensions, nVariables, nAttributes
     343    integer, optional, intent(out) :: unlimitedDimId, formatNum
     344    integer, intent(out), optional:: ncerr
     345
     346    ! Variable local to the procedure:
     347    integer ncerr_not_opt
     348
     349    !-------------------
     350
     351    ncerr_not_opt = nf90_inquire(ncid, nDimensions, nVariables, nAttributes, &
     352         unlimitedDimId, formatNum)
     353    if (present(ncerr)) then
     354       ncerr = ncerr_not_opt
     355    else
     356       call handle_err("nf95_inquire", ncerr_not_opt, ncid)
     357    end if
     358
     359  end subroutine nf95_inquire
     360
    312361end module simple

  • trunk/LMDZ.COMMON/libf/bibio/writedynav.F90

    r775 r776  
    1 !
    2 ! $Id: writedynav.F 1403 2010-07-01 09:02:53Z fairhead $
    3 !
    4       subroutine writedynav(time, vcov,
    5      ,                ucov,teta,ppk,phi,q,masse,ps,phis)
     1! $Id: writedynav.F90 1612 2012-01-31 10:11:48Z lguez $
     2
     3subroutine writedynav(time, vcov, ucov, teta, ppk, phi, q, masse, ps, phis)
    64
    75#ifdef CPP_IOIPSL
    8       USE ioipsl
     6  USE ioipsl
    97#endif
    10       USE infotrac, ONLY : nqtot, ttext
    11       use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid
    12       implicit none
     8  USE infotrac, ONLY : nqtot, ttext
     9  use com_io_dyn_mod, only : histaveid, histvaveid, histuaveid
    1310
    14 C
    15 C   Ecriture du fichier histoire au format IOIPSL
    16 C
    17 C   Appels succesifs des routines: histwrite
    18 C
    19 C   Entree:
    20 C      time: temps de l'ecriture
    21 C      vcov: vents v covariants
    22 C      ucov: vents u covariants
    23 C      teta: temperature potentielle
    24 C      phi : geopotentiel instantane
    25 C      q   : traceurs
    26 C      masse: masse
    27 C      ps   :pression au sol
    28 C      phis : geopotentiel au sol
    29 C     
    30 C
    31 C
    32 C   L. Fairhead, LMD, 03/99
    33 C
    34 C =====================================================================
    35 C
    36 C   Declarations
    37 #include "dimensions.h"
    38 #include "paramet.h"
    39 #include "comconst.h"
    40 #include "comvert.h"
    41 #include "comgeom.h"
    42 #include "temps.h"
    43 #include "ener.h"
    44 #include "logic.h"
    45 #include "description.h"
    46 #include "serre.h"
    47 #include "iniprint.h"
     11  implicit none
    4812
    49 C
    50 C   Arguments
    51 C
     13  !   Ecriture du fichier histoire au format IOIPSL
    5214
    53       REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm)
    54       REAL teta(ip1jmp1*llm),phi(ip1jmp1,llm),ppk(ip1jmp1*llm)     
    55       REAL ps(ip1jmp1),masse(ip1jmp1,llm)                   
    56       REAL phis(ip1jmp1)                 
    57       REAL q(ip1jmp1,llm,nqtot)
    58       integer time
     15  !   Appels succesifs des routines: histwrite
    5916
     17  !   Entree:
     18  !      time: temps de l'ecriture
     19  !      vcov: vents v covariants
     20  !      ucov: vents u covariants
     21  !      teta: temperature potentielle
     22  !      phi : geopotentiel instantane
     23  !      q   : traceurs
     24  !      masse: masse
     25  !      ps   :pression au sol
     26  !      phis : geopotentiel au sol
     27
     28  !   L. Fairhead, LMD, 03/99
     29
     30  !   Declarations
     31  include "dimensions.h"
     32  include "paramet.h"
     33  include "comconst.h"
     34  include "comvert.h"
     35  include "comgeom.h"
     36  include "temps.h"
     37  include "ener.h"
     38  include "logic.h"
     39  include "description.h"
     40  include "serre.h"
     41  include "iniprint.h"
     42
     43  !   Arguments
     44
     45  REAL vcov(ip1jm, llm), ucov(ip1jmp1, llm)
     46  REAL teta(ip1jmp1*llm), phi(ip1jmp1, llm), ppk(ip1jmp1*llm)     
     47  REAL ps(ip1jmp1), masse(ip1jmp1, llm)                   
     48  REAL phis(ip1jmp1)                 
     49  REAL q(ip1jmp1, llm, nqtot)
     50  integer time
    6051
    6152#ifdef CPP_IOIPSL
    62 ! This routine needs IOIPSL to work
    63 C   Variables locales
    64 C
    65       integer ndex2d(ip1jmp1),ndexu(ip1jmp1*llm),ndexv(ip1jm*llm)
    66       INTEGER iq, ii, ll
    67       real tm(ip1jmp1*llm)
    68       REAL vnat(ip1jm,llm),unat(ip1jmp1,llm)
    69       logical ok_sync
    70       integer itau_w
    71 C
    72 C  Initialisations
    73 C
    74       ndexu = 0
    75       ndexv = 0
    76       ndex2d = 0
    77       ok_sync = .TRUE.
    78       tm = 999.999
    79       vnat = 999.999
    80       unat = 999.999
    81       itau_w = itau_dyn + time
     53  ! This routine needs IOIPSL to work
     54  !   Variables locales
    8255
    83 C Passage aux composantes naturelles du vent
    84       call covnat(llm, ucov, vcov, unat, vnat)
     56  integer ndex2d(ip1jmp1), ndexu(ip1jmp1*llm), ndexv(ip1jm*llm)
     57  INTEGER iq, ii, ll
     58  real tm(ip1jmp1*llm)
     59  REAL vnat(ip1jm, llm), unat(ip1jmp1, llm)
     60  logical ok_sync
     61  integer itau_w
    8562
    86 C
    87 C  Appels a histwrite pour l'ecriture des variables a sauvegarder
    88 C
    89 C  Vents U
    90 C
    91       call histwrite(histuaveid, 'u', itau_w, unat,
    92      .               iip1*jjp1*llm, ndexu)
    93 C
    94 C  Vents V
    95 C
    96       call histwrite(histvaveid, 'v', itau_w, vnat,
    97      .               iip1*jjm*llm, ndexv)
    98 C
    99 C  Temperature potentielle moyennee
    100 C
    101       call histwrite(histaveid, 'theta', itau_w, teta,
    102      .                iip1*jjp1*llm, ndexu)
    103 C
    104 C  Temperature moyennee
    105 C
    106       do ii = 1, ijp1llm
    107         tm(ii) = teta(ii) * ppk(ii)/cpp
    108       enddo
    109       call histwrite(histaveid, 'temp', itau_w, tm,
    110      .                iip1*jjp1*llm, ndexu)
    111 C
    112 C  Geopotentiel
    113 C
    114       call histwrite(histaveid, 'phi', itau_w, phi,
    115      .                iip1*jjp1*llm, ndexu)
    116 C
    117 C  Traceurs
    118 C
    119 !        DO iq=1,nqtot
    120 !          call histwrite(histaveid, ttext(iq), itau_w, q(:,:,iq),
    121 !     .                   iip1*jjp1*llm, ndexu)
    122 !        enddo
    123 C
    124 C  Masse
    125 C
    126        call histwrite(histaveid, 'masse', itau_w, masse,
    127      $                   iip1*jjp1*llm, ndexu)
    128 C
    129 C  Pression au sol
    130 C
    131        call histwrite(histaveid, 'ps', itau_w, ps, iip1*jjp1, ndex2d)
    132 C
    133 C  Geopotentiel au sol
    134 C
    135 !       call histwrite(histaveid,'phis',itau_w, phis,iip1*jjp1, ndex2d)
    136 C
    137 C  Fin
    138 C
    139       if (ok_sync) then
    140           call histsync(histaveid)
    141           call histsync(histvaveid)
    142           call histsync(histuaveid)
    143       ENDIF
     63  !-----------------------------------------------------------------
     64
     65  !  Initialisations
     66
     67  ndexu = 0
     68  ndexv = 0
     69  ndex2d = 0
     70  ok_sync = .TRUE.
     71  tm = 999.999
     72  vnat = 999.999
     73  unat = 999.999
     74  itau_w = itau_dyn + time
     75
     76  ! Passage aux composantes naturelles du vent
     77  call covnat(llm, ucov, vcov, unat, vnat)
     78
     79  !  Appels a histwrite pour l'ecriture des variables a sauvegarder
     80
     81  !  Vents U
     82
     83  call histwrite(histuaveid, 'u', itau_w, unat,  &
     84       iip1*jjp1*llm, ndexu)
     85
     86  !  Vents V
     87
     88  call histwrite(histvaveid, 'v', itau_w, vnat,  &
     89       iip1*jjm*llm, ndexv)
     90
     91  !  Temperature potentielle moyennee
     92
     93  call histwrite(histaveid, 'theta', itau_w, teta,  &
     94       iip1*jjp1*llm, ndexu)
     95
     96  !  Temperature moyennee
     97
     98  do ii = 1, ijp1llm
     99     tm(ii) = teta(ii) * ppk(ii)/cpp
     100  enddo
     101  call histwrite(histaveid, 'temp', itau_w, tm,  &
     102       iip1*jjp1*llm, ndexu)
     103
     104  !  Geopotentiel
     105
     106  call histwrite(histaveid, 'phi', itau_w, phi,  &
     107       iip1*jjp1*llm, ndexu)
     108
     109  !  Traceurs
     110
     111  !  DO iq=1, nqtot
     112  !       call histwrite(histaveid, ttext(iq), itau_w, q(:, :, iq), &
     113  !                   iip1*jjp1*llm, ndexu)
     114  ! enddo
     115
     116  !  Masse
     117
     118  call histwrite(histaveid, 'masse', itau_w, masse,  &
     119       iip1*jjp1*llm, ndexu)
     120
     121  !  Pression au sol
     122
     123  call histwrite(histaveid, 'ps', itau_w, ps, iip1*jjp1, ndex2d)
     124
     125  ! Geopotentiel au sol
     126
     127  ! call histwrite(histaveid, 'phis', itau_w, phis, iip1*jjp1, ndex2d)
     128
     129  if (ok_sync) then
     130     call histsync(histaveid)
     131     call histsync(histvaveid)
     132     call histsync(histuaveid)
     133  ENDIF
    144134
    145135#else
    146 ! tell the user this routine should be run with ioipsl
    147       write(lunout,*)"writedynav: Warning this routine should not be",
    148      &               " used without ioipsl"
     136  write(lunout, *) "writedynav: Warning this routine should not be", &
     137       " used without ioipsl"
    149138#endif
    150 ! of #ifdef CPP_IOIPSL
    151       return
    152       end
     139  ! of #ifdef CPP_IOIPSL
     140
     141end subroutine writedynav

  • trunk/LMDZ.COMMON/libf/dyn3d/calfis.F

    r108 r776  
    170170      PARAMETER(ntetaSTD=3)
    171171      REAL rtetaSTD(ntetaSTD)
    172       DATA rtetaSTD/350., 380., 405./
     172      DATA rtetaSTD/350., 380., 405./ ! Earth-specific values, beware !!
    173173      REAL PVteta(ngridmx,ntetaSTD)
    174174c
    … …  
    461461      if (planet_type=="earth") then
    462462#ifdef CPP_EARTH
     463! PVtheta calls tetalevel, which is in the (Earth) physics
    463464cIM calcul PV a teta=350, 380, 405K
    464465      CALL PVtheta(ngridmx,llm,pucov,pvcov,pteta,
    … …  
    482483! ne pose pas de probleme a priori.
    483484
    484 #ifdef CPP_PHYS
    485 
    486485!      write(lunout,*) 'PHYSIQUE AVEC NSPLIT_PHYS=',nsplit_phys
    487486      zdt_split=dtphys/nsplit_phys
    … …  
    490489      zdtfic(:,:)=0.
    491490      zdqfic(:,:,:)=0.
     491
     492#ifdef CPP_PHYS
    492493
    493494      do isplit=1,nsplit_phys
    … …  
    563564         zdqfic(:,:,:)=zdqfic(:,:,:)+zdqfi(:,:,:)
    564565
    565       enddo
     566      enddo ! of do isplit=1,nsplit_phys
     567
     568#endif
     569! #endif of #ifdef CPP_PHYS
     570
    566571      zdufi(:,:)=zdufic(:,:)/nsplit_phys
    567572      zdvfi(:,:)=zdvfic(:,:)/nsplit_phys
    … …  
    569574      zdqfi(:,:,:)=zdqfic(:,:,:)/nsplit_phys
    570575
    571 #endif
    572 ! #endif of #ifdef CPP_PHYS
    573576
    574577500   CONTINUE

  • trunk/LMDZ.COMMON/libf/dyn3d/ce0l.F90

    r492 r776  
    2828  IMPLICIT NONE
    2929#ifndef CPP_EARTH
    30   WRITE(*,*)'limit_netcdf: Earth-specific program, needs Earth physics'
     30#include "iniprint.h"
     31  WRITE(lunout,*)'limit_netcdf: Earth-specific program, needs Earth physics'
    3132#else
    3233!-------------------------------------------------------------------------------

  • trunk/LMDZ.COMMON/libf/dyn3d/comvert.h

    r127 r776  
    11!
    2 ! $Id: comvert.h 1520 2011-05-23 11:37:09Z emillour $
     2! $Id: comvert.h 1625 2012-05-09 13:14:48Z lguez $
    33!
    44!-----------------------------------------------------------------------
    … …  
    99     &               aps(llm),bps(llm),scaleheight
    1010
    11       common/comverti/disvert_type
     11      common/comverti/disvert_type, pressure_exner
    1212
    1313      real ap     ! hybrid pressure contribution at interlayers
    … …  
    3030                           !     using 'z2sig.def' (or 'esasig.def) file
    3131
     32      logical pressure_exner
     33!     compute pressure inside layers using Exner function, else use mean
     34!     of pressure values at interfaces
     35
    3236 !-----------------------------------------------------------------------

  • trunk/LMDZ.COMMON/libf/dyn3d/disvert.F90

    r128 r776  
    1 ! $Id: disvert.F90 1520 2011-05-23 11:37:09Z emillour $
     1! $Id: disvert.F90 1645 2012-07-30 16:01:50Z lguez $
    22
    33SUBROUTINE disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig,scaleheight)
    44
    55  ! Auteur : P. Le Van
     6
     7  use new_unit_m, only: new_unit
     8  use ioipsl, only: getin
     9  use assert_m, only: assert
    610
    711  IMPLICIT NONE
    … …  
    1822
    1923  real,intent(in) :: pa, preff
    20   real,intent(out) :: ap(llmp1), bp(llmp1)
     24  real,intent(out) :: ap(llmp1) ! in Pa
     25  real, intent(out):: bp(llmp1)
    2126  real,intent(out) :: dpres(llm), nivsigs(llm), nivsig(llmp1)
    2227  real,intent(out) :: presnivs(llm)
    … …  
    2631  real zk, zkm1, dzk1, dzk2, k0, k1
    2732
    28   INTEGER l
     33  INTEGER l, unit
    2934  REAL dsigmin
    3035  REAL alpha, beta, deltaz
    31   INTEGER iostat
    3236  REAL x
    3337  character(len=*),parameter :: modname="disvert"
    3438
     39  character(len=6):: vert_sampling
     40  ! (allowed values are "param", "tropo", "strato" and "read")
     41
    3542  !-----------------------------------------------------------------------
     43
     44  print *, "Call sequence information: disvert"
    3645
    3746  ! default scaleheight is 8km for earth
    3847  scaleheight=8.
    3948
    40   OPEN(99, file='sigma.def', status='old', form='formatted', iostat=iostat)
     49  vert_sampling = merge("strato", "tropo ", ok_strato) ! default value
     50  call getin('vert_sampling', vert_sampling)
     51  print *, 'vert_sampling = ' // vert_sampling
    4152
    42   IF (iostat == 0) THEN
    43      ! cas 1 on lit les options dans sigma.def:
     53  select case (vert_sampling)
     54  case ("param")
     55     ! On lit les options dans sigma.def:
     56     OPEN(99, file='sigma.def', status='old', form='formatted')
    4457     READ(99, *) scaleheight ! hauteur d'echelle 8.
    4558     READ(99, *) deltaz ! epaiseur de la premiere couche 0.04
    … …  
    6982     sig(llm+1)=0.
    7083
    71      DO l = 1, llm
    72         dsig(l) = sig(l)-sig(l+1)
    73      end DO
    74   ELSE
    75      if (ok_strato) then
    76         if (llm==39) then
    77            dsigmin=0.3
    78         else if (llm==50) then
    79            dsigmin=1.
    80         else
    81            write(lunout,*) trim(modname), &
    82            ' ATTENTION discretisation z a ajuster'
    83            dsigmin=1.
    84         endif
    85         write(lunout,*) trim(modname), &
    86         ' Discretisation verticale DSIGMIN=',dsigmin
    87      endif
     84     bp(: llm) = EXP(1. - 1. / sig(: llm)**2)
     85     bp(llmp1) = 0.
    8886
     87     ap = pa * (sig - bp)
     88  case("tropo")
    8989     DO l = 1, llm
    9090        x = 2*asin(1.) * (l - 0.5) / (llm + 1)
    91 
    92         IF (ok_strato) THEN
    93            dsig(l) =(dsigmin + 7. * SIN(x)**2) &
    94                 *(0.5*(1.-tanh(1.*(x-asin(1.))/asin(1.))))**2
    95         ELSE
    96            dsig(l) = 1.0 + 7.0 * SIN(x)**2
    97         ENDIF
     91        dsig(l) = 1.0 + 7.0 * SIN(x)**2
    9892     ENDDO
    9993     dsig = dsig / sum(dsig)
    … …  
    10296        sig(l) = sig(l+1) + dsig(l)
    10397     ENDDO
    104   ENDIF
     98
     99     bp(1)=1.
     100     bp(2: llm) = EXP(1. - 1. / sig(2: llm)**2)
     101     bp(llmp1) = 0.
     102
     103     ap(1)=0.
     104     ap(2: llm + 1) = pa * (sig(2: llm + 1) - bp(2: llm + 1))
     105  case("strato")
     106     if (llm==39) then
     107        dsigmin=0.3
     108     else if (llm==50) then
     109        dsigmin=1.
     110     else
     111        write(lunout,*) trim(modname), ' ATTENTION discretisation z a ajuster'
     112        dsigmin=1.
     113     endif
     114     WRITE(LUNOUT,*) trim(modname), 'Discretisation verticale DSIGMIN=',dsigmin
     115
     116     DO l = 1, llm
     117        x = 2*asin(1.) * (l - 0.5) / (llm + 1)
     118        dsig(l) =(dsigmin + 7. * SIN(x)**2) &
     119             *(0.5*(1.-tanh(1.*(x-asin(1.))/asin(1.))))**2
     120     ENDDO
     121     dsig = dsig / sum(dsig)
     122     sig(llm+1) = 0.
     123     DO l = llm, 1, -1
     124        sig(l) = sig(l+1) + dsig(l)
     125     ENDDO
     126
     127     bp(1)=1.
     128     bp(2: llm) = EXP(1. - 1. / sig(2: llm)**2)
     129     bp(llmp1) = 0.
     130
     131     ap(1)=0.
     132     ap(2: llm + 1) = pa * (sig(2: llm + 1) - bp(2: llm + 1))
     133  case("read")
     134     ! Read "ap" and "bp". First line is skipped (title line). "ap"
     135     ! should be in Pa. First couple of values should correspond to
     136     ! the surface, that is : "bp" should be in descending order.
     137     call new_unit(unit)
     138     open(unit, file="hybrid.txt", status="old", action="read", &
     139          position="rewind")
     140     read(unit, fmt=*) ! skip title line
     141     do l = 1, llm + 1
     142        read(unit, fmt=*) ap(l), bp(l)
     143     end do
     144     close(unit)
     145     call assert(ap(1) == 0., ap(llm + 1) == 0., bp(1) == 1., &
     146          bp(llm + 1) == 0., "disvert: bad ap or bp values")
     147  case default
     148     call abort_gcm("disvert", 'Wrong value for "vert_sampling"', 1)
     149  END select
    105150
    106151  DO l=1, llm
    … …  
    111156     nivsig(l)= REAL(l)
    112157  ENDDO
    113 
    114   ! .... Calculs de ap(l) et de bp(l) ....
    115   ! ..... pa et preff sont lus sur les fichiers start par lectba .....
    116 
    117   bp(llmp1) = 0.
    118 
    119   DO l = 1, llm
    120      bp(l) = EXP( 1. -1./( sig(l)*sig(l)) )
    121      ap(l) = pa * ( sig(l) - bp(l) )
    122   ENDDO
    123 
    124   bp(1)=1.
    125   ap(1)=0.
    126 
    127   ap(llmp1) = pa * ( sig(llmp1) - bp(llmp1) )
    128158
    129159  write(lunout, *)  trim(modname),': BP '

  • trunk/LMDZ.COMMON/libf/dyn3d/dynetat0.F

    r492 r776  
    66
    77      USE infotrac
     8      use netcdf, only: nf90_get_var
    89      IMPLICIT NONE
    910
    … …  
    2829#include "comconst.h"
    2930#include "comvert.h"
    30 #include "comgeom.h"
     31#include "comgeom2.h"
    3132#include "ener.h"
    3233#include "netcdf.inc"
    … …  
    4041
    4142      CHARACTER*(*) fichnom
    42       REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
    43       REAL q(ip1jmp1,llm,nqtot),masse(ip1jmp1,llm)
    44       REAL ps(ip1jmp1),phis(ip1jmp1)
     43      REAL vcov(iip1, jjm,llm),ucov(iip1, jjp1,llm),teta(iip1, jjp1,llm)
     44      REAL q(iip1,jjp1,llm,nqtot),masse(iip1, jjp1,llm)
     45      REAL ps(iip1, jjp1),phis(iip1, jjp1)
    4546
    4647      REAL time
    … …  
    7071         CALL abort
    7172      ENDIF
    72 #ifdef NC_DOUBLE
    73       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
    74 #else
    75       ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
    76 #endif
     73      ierr = nf90_get_var(nid, nvarid, tab_cntrl)
    7774      IF (ierr .NE. NF_NOERR) THEN
    7875         write(lunout,*)"dynetat0: Lecture echoue pour <controle>"
    … …  
    142139         CALL abort
    143140      ENDIF
    144 #ifdef NC_DOUBLE
    145       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonu)
    146 #else
    147       ierr = NF_GET_VAR_REAL(nid, nvarid, rlonu)
    148 #endif
     141      ierr = nf90_get_var(nid, nvarid, rlonu)
    149142      IF (ierr .NE. NF_NOERR) THEN
    150143         write(lunout,*)"dynetat0: Lecture echouee pour <rlonu>"
    … …  
    157150         CALL abort
    158151      ENDIF
    159 #ifdef NC_DOUBLE
    160       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatu)
    161 #else
    162       ierr = NF_GET_VAR_REAL(nid, nvarid, rlatu)
    163 #endif
     152      ierr = nf90_get_var(nid, nvarid, rlatu)
    164153      IF (ierr .NE. NF_NOERR) THEN
    165154         write(lunout,*)"dynetat0: Lecture echouee pour <rlatu>"
    … …  
    172161         CALL abort
    173162      ENDIF
    174 #ifdef NC_DOUBLE
    175       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonv)
    176 #else
    177       ierr = NF_GET_VAR_REAL(nid, nvarid, rlonv)
    178 #endif
     163      ierr = nf90_get_var(nid, nvarid, rlonv)
    179164      IF (ierr .NE. NF_NOERR) THEN
    180165         write(lunout,*)"dynetat0: Lecture echouee pour <rlonv>"
    … …  
    187172         CALL abort
    188173      ENDIF
    189 #ifdef NC_DOUBLE
    190       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatv)
    191 #else
    192       ierr = NF_GET_VAR_REAL(nid, nvarid, rlatv)
    193 #endif
     174      ierr = nf90_get_var(nid, nvarid, rlatv)
    194175      IF (ierr .NE. NF_NOERR) THEN
    195176         write(lunout,*)"dynetat0: Lecture echouee pour rlatv"
    … …  
    202183         CALL abort
    203184      ENDIF
    204 #ifdef NC_DOUBLE
    205       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cu)
    206 #else
    207       ierr = NF_GET_VAR_REAL(nid, nvarid, cu)
    208 #endif
     185      ierr = nf90_get_var(nid, nvarid, cu)
    209186      IF (ierr .NE. NF_NOERR) THEN
    210187         write(lunout,*)"dynetat0: Lecture echouee pour <cu>"
    … …  
    217194         CALL abort
    218195      ENDIF
    219 #ifdef NC_DOUBLE
    220       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cv)
    221 #else
    222       ierr = NF_GET_VAR_REAL(nid, nvarid, cv)
    223 #endif
     196      ierr = nf90_get_var(nid, nvarid, cv)
    224197      IF (ierr .NE. NF_NOERR) THEN
    225198         write(lunout,*)"dynetat0: Lecture echouee pour <cv>"
    … …  
    232205         CALL abort
    233206      ENDIF
    234 #ifdef NC_DOUBLE
    235       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, aire)
    236 #else
    237       ierr = NF_GET_VAR_REAL(nid, nvarid, aire)
    238 #endif
     207      ierr = nf90_get_var(nid, nvarid, aire)
    239208      IF (ierr .NE. NF_NOERR) THEN
    240209         write(lunout,*)"dynetat0: Lecture echouee pour <aire>"
    … …  
    247216         CALL abort
    248217      ENDIF
    249 #ifdef NC_DOUBLE
    250       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phis)
    251 #else
    252       ierr = NF_GET_VAR_REAL(nid, nvarid, phis)
    253 #endif
     218      ierr = nf90_get_var(nid, nvarid, phis)
    254219      IF (ierr .NE. NF_NOERR) THEN
    255220         write(lunout,*)"dynetat0: Lecture echouee pour <phisinit>"
    … …  
    262227         CALL abort
    263228      ENDIF
    264 #ifdef NC_DOUBLE
    265       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, time)
    266 #else
    267       ierr = NF_GET_VAR_REAL(nid, nvarid, time)
    268 #endif
     229      ierr = nf90_get_var(nid, nvarid, time)
    269230      IF (ierr .NE. NF_NOERR) THEN
    270231         write(lunout,*)"dynetat0: Lecture echouee <temps>"
    … …  
    277238         CALL abort
    278239      ENDIF
    279 #ifdef NC_DOUBLE
    280       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ucov)
    281 #else
    282       ierr = NF_GET_VAR_REAL(nid, nvarid, ucov)
    283 #endif
     240      ierr = nf90_get_var(nid, nvarid, ucov)
    284241      IF (ierr .NE. NF_NOERR) THEN
    285242         write(lunout,*)"dynetat0: Lecture echouee pour <ucov>"
    … …  
    292249         CALL abort
    293250      ENDIF
    294 #ifdef NC_DOUBLE
    295       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, vcov)
    296 #else
    297       ierr = NF_GET_VAR_REAL(nid, nvarid, vcov)
    298 #endif
     251      ierr = nf90_get_var(nid, nvarid, vcov)
    299252      IF (ierr .NE. NF_NOERR) THEN
    300253         write(lunout,*)"dynetat0: Lecture echouee pour <vcov>"
    … …  
    307260         CALL abort
    308261      ENDIF
    309 #ifdef NC_DOUBLE
    310       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, teta)
    311 #else
    312       ierr = NF_GET_VAR_REAL(nid, nvarid, teta)
    313 #endif
     262      ierr = nf90_get_var(nid, nvarid, teta)
    314263      IF (ierr .NE. NF_NOERR) THEN
    315264         write(lunout,*)"dynetat0: Lecture echouee pour <teta>"
    … …  
    325274     &                    "> est absent"
    326275           write(lunout,*)"          Il est donc initialise a zero"
    327            q(:,:,iq)=0.
     276           q(:,:,:,iq)=0.
    328277        ELSE
    329 #ifdef NC_DOUBLE
    330           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q(1,1,iq))
    331 #else
    332           ierr = NF_GET_VAR_REAL(nid, nvarid, q(1,1,iq))
    333 #endif
     278           ierr = NF90_GET_VAR(nid, nvarid, q(:,:,:,iq))
    334279          IF (ierr .NE. NF_NOERR) THEN
    335280            write(lunout,*)"dynetat0: Lecture echouee pour "//tname(iq)
    … …  
    345290         CALL abort
    346291      ENDIF
    347 #ifdef NC_DOUBLE
    348       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, masse)
    349 #else
    350       ierr = NF_GET_VAR_REAL(nid, nvarid, masse)
    351 #endif
     292      ierr = nf90_get_var(nid, nvarid, masse)
    352293      IF (ierr .NE. NF_NOERR) THEN
    353294         write(lunout,*)"dynetat0: Lecture echouee pour <masse>"
    … …  
    360301         CALL abort
    361302      ENDIF
    362 #ifdef NC_DOUBLE
    363       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ps)
    364 #else
    365       ierr = NF_GET_VAR_REAL(nid, nvarid, ps)
    366 #endif
     303      ierr = nf90_get_var(nid, nvarid, ps)
    367304      IF (ierr .NE. NF_NOERR) THEN
    368305         write(lunout,*)"dynetat0: Lecture echouee pour <ps>"

  • trunk/LMDZ.COMMON/libf/dyn3d/dynredem.F

    r492 r776  
    11!
    2 ! $Id: dynredem.F 1403 2010-07-01 09:02:53Z fairhead $
     2! $Id: dynredem.F 1635 2012-07-12 11:37:16Z lguez $
    33!
    44c
    … …  
    88#endif
    99      USE infotrac
     10      use netcdf95, only: NF95_PUT_VAR
    1011 
    1112      IMPLICIT NONE
    … …  
    1920#include "comconst.h"
    2021#include "comvert.h"
    21 #include "comgeom.h"
     22#include "comgeom2.h"
    2223#include "temps.h"
    2324#include "ener.h"
    … …  
    3132c   ----------
    3233      INTEGER iday_end
    33       REAL phis(ip1jmp1)
     34      REAL phis(iip1, jjp1)
    3435      CHARACTER*(*) fichnom
    3536
    … …  
    138139c
    139140      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27,
    140      .                       "Fichier demarrage dynamique")
     141     .                       "Fichier demmarage dynamique")
    141142c
    142143c Definir les dimensions du fichiers:
    … …  
    166167     .                       "Parametres de controle")
    167168      ierr = NF_ENDDEF(nid)
    168 #ifdef NC_DOUBLE
    169       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
    170 #else
    171       ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
    172 #endif
     169      call NF95_PUT_VAR(nid,nvarid,tab_cntrl)
    173170c
    174171      ierr = NF_REDEF (nid)
    … …  
    183180     .                       "Longitudes des points U")
    184181      ierr = NF_ENDDEF(nid)
    185 #ifdef NC_DOUBLE
    186       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu)
    187 #else
    188       ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu)
    189 #endif
     182      call NF95_PUT_VAR(nid,nvarid,rlonu)
    190183c
    191184      ierr = NF_REDEF (nid)
    … …  
    200193     .                       "Latitudes des points U")
    201194      ierr = NF_ENDDEF(nid)
    202 #ifdef NC_DOUBLE
    203       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu)
    204 #else
    205       ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu)
    206 #endif
     195      call NF95_PUT_VAR (nid,nvarid,rlatu)
    207196c
    208197      ierr = NF_REDEF (nid)
    … …  
    217206     .                       "Longitudes des points V")
    218207      ierr = NF_ENDDEF(nid)
    219 #ifdef NC_DOUBLE
    220       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv)
    221 #else
    222       ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv)
    223 #endif
     208      call NF95_PUT_VAR(nid,nvarid,rlonv)
    224209c
    225210      ierr = NF_REDEF (nid)
    … …  
    234219     .                       "Latitudes des points V")
    235220      ierr = NF_ENDDEF(nid)
    236 #ifdef NC_DOUBLE
    237       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv)
    238 #else
    239       ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv)
    240 #endif
     221      call NF95_PUT_VAR(nid,nvarid,rlatv)
    241222c
    242223      ierr = NF_REDEF (nid)
    … …  
    251232     .                       "Numero naturel des couches s")
    252233      ierr = NF_ENDDEF(nid)
    253 #ifdef NC_DOUBLE
    254       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs)
    255 #else
    256       ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs)
    257 #endif
     234      call NF95_PUT_VAR(nid,nvarid,nivsigs)
    258235c
    259236      ierr = NF_REDEF (nid)
    … …  
    268245     .                       "Numero naturel des couches sigma")
    269246      ierr = NF_ENDDEF(nid)
    270 #ifdef NC_DOUBLE
    271       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig)
    272 #else
    273       ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig)
    274 #endif
     247      call NF95_PUT_VAR(nid,nvarid,nivsig)
    275248c
    276249      ierr = NF_REDEF (nid)
    … …  
    285258     .                       "Coefficient A pour hybride")
    286259      ierr = NF_ENDDEF(nid)
    287 #ifdef NC_DOUBLE
    288       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap)
    289 #else
    290       ierr = NF_PUT_VAR_REAL (nid,nvarid,ap)
    291 #endif
     260      call NF95_PUT_VAR(nid,nvarid,ap)
    292261c
    293262      ierr = NF_REDEF (nid)
    … …  
    302271     .                       "Coefficient B pour hybride")
    303272      ierr = NF_ENDDEF(nid)
    304 #ifdef NC_DOUBLE
    305       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp)
    306 #else
    307       ierr = NF_PUT_VAR_REAL (nid,nvarid,bp)
    308 #endif
     273      call NF95_PUT_VAR(nid,nvarid,bp)
    309274c
    310275      ierr = NF_REDEF (nid)
    … …  
    317282cIM 220306 END
    318283      ierr = NF_ENDDEF(nid)
    319 #ifdef NC_DOUBLE
    320       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs)
    321 #else
    322       ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs)
    323 #endif
     284      call NF95_PUT_VAR(nid,nvarid,presnivs)
    324285c
    325286c Coefficients de passage cov. <-> contra. <--> naturel
    … …  
    338299     .                       "Coefficient de passage pour U")
    339300      ierr = NF_ENDDEF(nid)
    340 #ifdef NC_DOUBLE
    341       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu)
    342 #else
    343       ierr = NF_PUT_VAR_REAL (nid,nvarid,cu)
    344 #endif
     301      call NF95_PUT_VAR(nid,nvarid,cu)
    345302c
    346303      ierr = NF_REDEF (nid)
    … …  
    357314     .                       "Coefficient de passage pour V")
    358315      ierr = NF_ENDDEF(nid)
    359 #ifdef NC_DOUBLE
    360       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv)
    361 #else
    362       ierr = NF_PUT_VAR_REAL (nid,nvarid,cv)
    363 #endif
     316      call NF95_PUT_VAR(nid,nvarid,cv)
    364317c
    365318c Aire de chaque maille:
    … …  
    378331     .                       "Aires de chaque maille")
    379332      ierr = NF_ENDDEF(nid)
    380 #ifdef NC_DOUBLE
    381       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire)
    382 #else
    383       ierr = NF_PUT_VAR_REAL (nid,nvarid,aire)
    384 #endif
     333      call NF95_PUT_VAR(nid,nvarid,aire)
    385334c
    386335c Geopentiel au sol:
    … …  
    399348     .                       "Geopotentiel au sol")
    400349      ierr = NF_ENDDEF(nid)
    401 #ifdef NC_DOUBLE
    402       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis)
    403 #else
    404       ierr = NF_PUT_VAR_REAL (nid,nvarid,phis)
    405 #endif
     350      call NF95_PUT_VAR(nid,nvarid,phis)
    406351c
    407352c Definir les variables pour pouvoir les enregistrer plus tard:
    … …  
    524469      USE infotrac
    525470      USE control_mod
     471      use netcdf, only: NF90_get_VAR
     472      use netcdf95, only: NF95_PUT_VAR
    526473 
    527474      IMPLICIT NONE
    … …  
    538485#include "iniprint.h"
    539486
     487
    540488      INTEGER l
    541       REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm)
    542       REAL teta(ip1jmp1,llm)                   
    543       REAL ps(ip1jmp1),masse(ip1jmp1,llm)                   
    544       REAL q(ip1jmp1,llm,nqtot)
     489      REAL vcov(iip1,jjm,llm),ucov(iip1, jjp1,llm)
     490      REAL teta(iip1, jjp1,llm)                   
     491      REAL ps(iip1, jjp1),masse(iip1, jjp1,llm)                   
     492      REAL q(iip1, jjp1, llm, nqtot)
    545493      CHARACTER*(*) fichnom
    546494     
    … …  
    576524         CALL abort_gcm(modname,abort_message,ierr)
    577525      ENDIF
    578 #ifdef NC_DOUBLE
    579       ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time)
    580 #else
    581       ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time)
    582 #endif
     526      call NF95_PUT_VAR(nid,nvarid,time,start=(/nb/))
    583527      write(lunout,*) "dynredem1: Enregistrement pour ", nb, time
    584528
    … …  
    592536         CALL abort_gcm(modname,abort_message,ierr)
    593537      ENDIF
    594 #ifdef NC_DOUBLE
    595       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
    596 #else
    597       ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
    598 #endif
     538      ierr = NF90_GET_VAR(nid, nvarid, tab_cntrl)
    599539       tab_cntrl(31) = REAL(itau_dyn + itaufin)
    600 #ifdef NC_DOUBLE
    601       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
    602 #else
    603       ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
    604 #endif
     540      call NF95_PUT_VAR(nid,nvarid,tab_cntrl)
    605541
    606542c  Ecriture des champs
    … …  
    612548         CALL abort_gcm(modname,abort_message,ierr)
    613549      ENDIF
    614 #ifdef NC_DOUBLE
    615       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ucov)
    616 #else
    617       ierr = NF_PUT_VAR_REAL (nid,nvarid,ucov)
    618 #endif
     550      call NF95_PUT_VAR(nid,nvarid,ucov)
    619551
    620552      ierr = NF_INQ_VARID(nid, "vcov", nvarid)
    … …  
    624556         CALL abort_gcm(modname,abort_message,ierr)
    625557      ENDIF
    626 #ifdef NC_DOUBLE
    627       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vcov)
    628 #else
    629       ierr = NF_PUT_VAR_REAL (nid,nvarid,vcov)
    630 #endif
     558      call NF95_PUT_VAR(nid,nvarid,vcov)
    631559
    632560      ierr = NF_INQ_VARID(nid, "teta", nvarid)
    … …  
    636564         CALL abort_gcm(modname,abort_message,ierr)
    637565      ENDIF
    638 #ifdef NC_DOUBLE
    639       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,teta)
    640 #else
    641       ierr = NF_PUT_VAR_REAL (nid,nvarid,teta)
    642 #endif
     566      call NF95_PUT_VAR(nid,nvarid,teta)
    643567
    644568      IF (type_trac == 'inca') THEN
    … …  
    662586               CALL abort_gcm(modname,abort_message,ierr)
    663587            ENDIF
    664 #ifdef NC_DOUBLE
    665             ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq))
    666 #else
    667             ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq))
    668 #endif
     588            call NF95_PUT_VAR(nid,nvarid,q(:,:,:,iq))
    669589        ELSE ! type_trac = inca
    670590! lecture de la valeur du traceur dans start_trac.nc
    … …  
    681601                   CALL abort_gcm(modname,abort_message,ierr)
    682602                ENDIF
    683 #ifdef NC_DOUBLE
    684                 ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq))
    685 #else
    686                 ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq))
    687 #endif
     603                call NF95_PUT_VAR(nid,nvarid,q(:,:,:,iq))
    688604               
    689605             ELSE
    690606                write(lunout,*) "dynredem1: ",trim(tname(iq)),
    691607     &              " est present dans start_trac.nc"
    692 #ifdef NC_DOUBLE
    693                ierr = NF_GET_VAR_DOUBLE(nid_trac, nvarid_trac, trac_tmp)
    694 #else
    695                ierr = NF_GET_VAR_REAL(nid_trac, nvarid_trac, trac_tmp)
    696 #endif
     608               ierr = NF90_GET_VAR(nid_trac, nvarid_trac, trac_tmp)
    697609                IF (ierr .NE. NF_NOERR) THEN
    698610                   abort_message="dynredem1: Lecture echouee pour"//
    … …  
    708620                   CALL abort_gcm(modname,abort_message,ierr)
    709621                ENDIF
    710 #ifdef NC_DOUBLE
    711                 ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,trac_tmp)
    712 #else
    713                 ierr = NF_PUT_VAR_REAL (nid,nvarid,trac_tmp)
    714 #endif
     622                call NF95_PUT_VAR(nid, nvarid, trac_tmp)
    715623               
    716624             ENDIF ! IF (ierr .NE. NF_NOERR)
    … …  
    725633                   CALL abort_gcm(modname,abort_message,ierr)
    726634             ENDIF
    727 #ifdef NC_DOUBLE
    728              ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq))
    729 #else
    730              ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq))
    731 #endif
     635             call NF95_PUT_VAR(nid,nvarid,q(:,:,:,iq))
    732636          ENDIF ! (ierr_file .ne. 2)
    733637       END IF   !type_trac
    … …  
    742646         CALL abort_gcm(modname,abort_message,ierr)
    743647      ENDIF
    744 #ifdef NC_DOUBLE
    745       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masse)
    746 #else
    747       ierr = NF_PUT_VAR_REAL (nid,nvarid,masse)
    748 #endif
     648      call NF95_PUT_VAR(nid,nvarid,masse)
    749649c
    750650      ierr = NF_INQ_VARID(nid, "ps", nvarid)
    … …  
    754654         CALL abort_gcm(modname,abort_message,ierr)
    755655      ENDIF
    756 #ifdef NC_DOUBLE
    757       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ps)
    758 #else
    759       ierr = NF_PUT_VAR_REAL (nid,nvarid,ps)
    760 #endif
     656      call NF95_PUT_VAR(nid,nvarid,ps)
    761657
    762658      ierr = NF_CLOSE(nid)

  • trunk/LMDZ.COMMON/libf/dyn3d/etat0_netcdf.F90

    r127 r776  
    11!
    2 ! $Id: etat0_netcdf.F90 1520 2011-05-23 11:37:09Z emillour $
     2! $Id: etat0_netcdf.F90 1625 2012-05-09 13:14:48Z lguez $
    33!
    44!-------------------------------------------------------------------------------
    … …  
    251251!*******************************************************************************
    252252  CALL pression(ip1jmp1, ap, bp, psol, p3d)
    253   if (disvert_type.eq.1) then
     253  if (pressure_exner) then
    254254    CALL exner_hyb(ip1jmp1, psol, p3d, alpha, beta, pks, pk, y)
    255   else ! we assume that we are in the disvert_type==2 case
     255  else
    256256    CALL exner_milieu(ip1jmp1,psol,p3d,beta,pks,pk,y)
    257257  endif

  • trunk/LMDZ.COMMON/libf/dyn3d/exner_hyb.F

    r127 r776  
    5656      ! Sanity check
    5757      if (firstcall) then
    58         ! check that vertical discretization is compatible
    59         ! with this routine
    60         if (disvert_type.ne.1) then
    61           call abort_gcm(modname,
    62      &     "this routine should only be called if disvert_type==1",42)
    63         endif
    64        
    6558        ! sanity checks for Shallow Water case (1 vertical layer)
    6659        if (llm.eq.1) then

  • trunk/LMDZ.COMMON/libf/dyn3d/exner_milieu.F

    r127 r776  
    5353      ! Sanity check
    5454      if (firstcall) then
    55         ! check that vertical discretization is compatible
    56         ! with this routine
    57         if (disvert_type.ne.2) then
    58           call abort_gcm(modname,
    59      &     "this routine should only be called if disvert_type==2",42)
    60         endif
    61        
    6255        ! sanity checks for Shallow Water case (1 vertical layer)
    6356        if (llm.eq.1) then

  • trunk/LMDZ.COMMON/libf/dyn3d/gcm.F

    r492 r776  
    2121! A nettoyer. On ne veut qu'une ou deux routines d'interface
    2222! dynamique -> physique pour l'initialisation
    23 ! Ehouarn: for now these only apply to Earth:
     23! Ehouarn: the following are needed with (parallel) physics:
    2424#ifdef CPP_PHYS
    2525      USE dimphy
    2626      USE comgeomphy
    27 #endif
    28 #ifdef CPP_EARTH
    2927      USE mod_phys_lmdz_para, ONLY : klon_mpi_para_nb
    3028#endif
    … …  
    177175! A nettoyer. On ne veut qu'une ou deux routines d'interface
    178176! dynamique -> physique pour l'initialisation
    179 ! Ehouarn : temporarily (?) keep this only for Earth
    180 !      if (planet_type.eq."earth") then
    181 !#ifdef CPP_EARTH
    182177#ifdef CPP_PHYS
    183178      CALL init_phys_lmdz(iim,jjp1,llm,1,(/(jjm-1)*iim+2/))
    184179      call initcomgeomphy
    185180#endif
    186 !      endif
    187181!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    188182c
    … …  
    465459         CALL iniphysiq(ngridmx,llm,daysec,day_ini,dtphys/nsplit_phys ,
    466460     ,                latfi,lonfi,airefi,zcufi,zcvfi,rad,g,r,cpp     )
    467 #endif ! CPP_PHYS
     461#endif
    468462         call_iniphys=.false.
    469463      ENDIF ! of IF (call_iniphys.and.(iflag_phys.eq.1))
    470 !#endif
    471464
    472465c  numero de stockage pour les fichiers de redemarrage:

  • trunk/LMDZ.COMMON/libf/dyn3d/guide_mod.F90

    r127 r776  
    644644! -----------------------------------------------------------------
    645645    CALL pression( ip1jmp1, ap, bp, psi, p )
    646     if (disvert_type==1) then
     646    if (pressure_exner) then
    647647      CALL exner_hyb(ip1jmp1,psi,p,alpha,beta,pks,pk,pkf)
    648     else ! we assume that we are in the disvert_type==2 case
     648    else
    649649      CALL exner_milieu(ip1jmp1,psi,p,beta,pks,pk,pkf)
    650650    endif

  • trunk/LMDZ.COMMON/libf/dyn3d/iniacademic.F90

    r492 r776  
    11!
    2 ! $Id: iniacademic.F90 1529 2011-05-26 15:17:33Z fairhead $
     2! $Id: iniacademic.F90 1625 2012-05-09 13:14:48Z lguez $
    33!
    44SUBROUTINE iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
    … …  
    222222
    223223        CALL pression ( ip1jmp1, ap, bp, ps, p       )
    224         if (disvert_type.eq.1) then
     224        if (pressure_exner) then
    225225          CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
    226         elseif (disvert_type.eq.2) then
     226        else
    227227          call exner_milieu(ip1jmp1,ps,p,beta,pks,pk,pkf)
    228         else
    229           write(abort_message,*) "Wrong value for disvert_type: ", &
    230                               disvert_type
    231           call abort_gcm(modname,abort_message,0)
    232228        endif
    233229        CALL massdair(p,masse)

  • trunk/LMDZ.COMMON/libf/dyn3d/iniconst.F90

    r775 r776  
    11!
    2 ! $Id: iniconst.F 1520 2011-05-23 11:37:09Z emillour $
     2! $Id: iniconst.F90 1625 2012-05-09 13:14:48Z lguez $
    33!
    4       SUBROUTINE iniconst
     4SUBROUTINE iniconst
    55
    6       USE control_mod
     6  USE control_mod
    77#ifdef CPP_IOIPSL
    8       use IOIPSL
     8  use IOIPSL
    99#else
    10 ! if not using IOIPSL, we still need to use (a local version of) getin
    11       use ioipsl_getincom
     10  ! if not using IOIPSL, we still need to use (a local version of) getin
     11  use ioipsl_getincom
    1212#endif
    1313
    14       IMPLICIT NONE
    15 c
    16 c      P. Le Van
    17 c
    18 c-----------------------------------------------------------------------
    19 c   Declarations:
    20 c   -------------
    21 c
    22 #include "dimensions.h"
    23 #include "paramet.h"
    24 #include "comconst.h"
    25 #include "temps.h"
    26 #include "comvert.h"
    27 #include "iniprint.h"
     14  IMPLICIT NONE
     15  !
     16  !      P. Le Van
     17  !
     18  !   Declarations:
     19  !   -------------
     20  !
     21  include "dimensions.h"
     22  include "paramet.h"
     23  include "comconst.h"
     24  include "temps.h"
     25  include "comvert.h"
     26  include "iniprint.h"
    2827
     28  character(len=*),parameter :: modname="iniconst"
     29  character(len=80) :: abort_message
     30  !
     31  !
     32  !
     33  !-----------------------------------------------------------------------
     34  !   dimension des boucles:
     35  !   ----------------------
    2936
    30       character(len=*),parameter :: modname="iniconst"
    31       character(len=80) :: abort_message
    32 c
    33 c
    34 c
    35 c-----------------------------------------------------------------------
    36 c   dimension des boucles:
    37 c   ----------------------
     37  im      = iim
     38  jm      = jjm
     39  lllm    = llm
     40  imp1    = iim
     41  jmp1    = jjm + 1
     42  lllmm1  = llm - 1
     43  lllmp1  = llm + 1
    3844
    39       im      = iim
    40       jm      = jjm
    41       lllm    = llm
    42       imp1    = iim
    43       jmp1    = jjm + 1
    44       lllmm1  = llm - 1
    45       lllmp1  = llm + 1
     45  !-----------------------------------------------------------------------
    4646
    47 c-----------------------------------------------------------------------
     47  dtphys  = iphysiq * dtvr
     48  unsim   = 1./iim
     49  pi      = 2.*ASIN( 1. )
    4850
    49       dtphys  = iphysiq * dtvr
    50       unsim   = 1./iim
    51       pi      = 2.*ASIN( 1. )
     51  !-----------------------------------------------------------------------
     52  !
    5253
    53 c-----------------------------------------------------------------------
    54 c
     54  r       = cpp * kappa
    5555
    56       r       = cpp * kappa
     56  write(lunout,*) trim(modname),': R  CP  Kappa ',r,cpp,kappa
     57  !
     58  !-----------------------------------------------------------------------
    5759
    58       write(lunout,*) trim(modname),': R  CP  Kappa ',r,cpp,kappa
    59 c
    60 c-----------------------------------------------------------------------
     60  ! vertical discretization: default behavior depends on planet_type flag
     61  if (planet_type=="earth") then
     62     disvert_type=1
     63  else
     64     disvert_type=2
     65  endif
     66  ! but user can also specify using one or the other in run.def:
     67  call getin('disvert_type',disvert_type)
     68  write(lunout,*) trim(modname),': disvert_type=',disvert_type
    6169
    62 ! vertical discretization: default behavior depends on planet_type flag
    63       if (planet_type=="earth") then
    64         disvert_type=1
    65       else
    66         disvert_type=2
    67       endif
    68       ! but user can also specify using one or the other in run.def:
    69       call getin('disvert_type',disvert_type)
    70       write(lunout,*) trim(modname),': disvert_type=',disvert_type
    71      
    72       if (disvert_type==1) then
    73        ! standard case for Earth (automatic generation of levels)
    74        call disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig,
    75      &              scaleheight)
    76       else if (disvert_type==2) then
    77         ! standard case for planets (levels generated using z2sig.def file)
    78         call disvert_noterre
    79       else
    80         write(abort_message,*) "Wrong value for disvert_type: ",
    81      &                        disvert_type
    82         call abort_gcm(modname,abort_message,0)
    83       endif
     70  pressure_exner = disvert_type == 1 ! default value
     71  call getin('pressure_exner', pressure_exner)
    8472
    85       END
     73  if (disvert_type==1) then
     74     ! standard case for Earth (automatic generation of levels)
     75     call disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig, scaleheight)
     76  else if (disvert_type==2) then
     77     ! standard case for planets (levels generated using z2sig.def file)
     78     call disvert_noterre
     79  else
     80     write(abort_message,*) "Wrong value for disvert_type: ", disvert_type
     81     call abort_gcm(modname,abort_message,0)
     82  endif
     83
     84END SUBROUTINE iniconst

  • trunk/LMDZ.COMMON/libf/dyn3d/inidissip.F90

    r270 r776  
    2828! Local variables:
    2929  REAL fact,zvert(llm),zz
    30   REAL zh(ip1jmp1),zu(ip1jmp1),zv(ip1jm),deltap(ip1jmp1,llm)
     30  REAL zh(ip1jmp1),zu(ip1jmp1), gx(ip1jmp1), divgra(ip1jmp1)
     31  real zv(ip1jm), gy(ip1jm), deltap(ip1jmp1,llm)
    3132  REAL ullm,vllm,umin,vmin,zhmin,zhmax
    32   REAL zllm,z1llm
     33  REAL zllm
    3334
    3435  INTEGER l,ij,idum,ii
    … …  
    7879  DO l = 1,50
    7980     IF(lstardis) THEN
    80         CALL divgrad2(1,zh,deltap,niterh,zh)
     81        CALL divgrad2(1,zh,deltap,niterh,divgra)
    8182     ELSE
    82         CALL divgrad (1,zh,niterh,zh)
     83        CALL divgrad (1,zh,niterh,divgra)
    8384     ENDIF
    8485
    85      CALL minmax(iip1*jjp1,zh,zhmin,zhmax )
    86 
    87      zllm  = ABS( zhmax )
    88      z1llm = 1./zllm
    89      DO ij = 1,ip1jmp1
    90         zh(ij) = zh(ij)* z1llm
    91      ENDDO
     86     zllm  = ABS(maxval(divgra))
     87     zh = divgra / zllm
    9288  ENDDO
    9389
    … …  
    123119           !cccc             CALL covcont( 1,zu,zv,zu,zv )
    124120           IF(lstardis) THEN
    125               CALL gradiv2( 1,zu,zv,nitergdiv,zu,zv )
     121              CALL gradiv2( 1,zu,zv,nitergdiv,gx,gy )
    126122           ELSE
    127               CALL gradiv ( 1,zu,zv,nitergdiv,zu,zv )
     123              CALL gradiv ( 1,zu,zv,nitergdiv,gx,gy )
    128124           ENDIF
    129125        ELSE
    130126           IF(lstardis) THEN
    131               CALL nxgraro2( 1,zu,zv,nitergrot,zu,zv )
     127              CALL nxgraro2( 1,zu,zv,nitergrot,gx,gy )
    132128           ELSE
    133               CALL nxgrarot( 1,zu,zv,nitergrot,zu,zv )
     129              CALL nxgrarot( 1,zu,zv,nitergrot,gx,gy )
    134130           ENDIF
    135131        ENDIF
    136132
    137         CALL minmax(iip1*jjp1,zu,umin,ullm )
    138         CALL minmax(iip1*jjm, zv,vmin,vllm )
    139 
    140         ullm = ABS  ( ullm )
    141         vllm = ABS  ( vllm )
    142 
    143         zllm  = MAX( ullm,vllm )
    144         z1llm = 1./ zllm
    145         DO ij = 1, ip1jmp1
    146            zu(ij) = zu(ij)* z1llm
    147         ENDDO
    148         DO ij = 1, ip1jm
    149            zv(ij) = zv(ij)* z1llm
    150         ENDDO
     133        zllm = max(abs(maxval(gx)), abs(maxval(gy)))
     134        zu = gx / zllm
     135        zv = gy / zllm
    151136     end DO
    152137

  • trunk/LMDZ.COMMON/libf/dyn3d/inigrads.F

    r1 r776  
    99      implicit none
    1010
    11       integer if,im,jm,lm,i,j,l,lnblnk
     11      integer if,im,jm,lm,i,j,l
    1212      real x(im),y(jm),z(lm),fx,fy,fz,dt
    1313      real xmin,xmax,ymin,ymax
    … …  
    4040      ivar(if)=0
    4141
    42       fichier(if)=file(1:lnblnk(file))
     42      fichier(if)=trim(file)
    4343
    4444      firsttime(if)=.true.
    … …  
    7070
    7171      print*,4*(ifd(if)-iid(if))*(jfd(if)-jid(if))
    72       print*,file(1:lnblnk(file))//'.dat'
     72      print*,trim(file)//'.dat'
    7373
    74       OPEN (unit(if)+1,FILE=file(1:lnblnk(file))//'.dat'
     74      OPEN (unit(if)+1,FILE=trim(file)//'.dat'
    7575     s   ,FORM='unformatted',
    7676     s   ACCESS='direct'

  • trunk/LMDZ.COMMON/libf/dyn3d/integrd.F

    r270 r776  
    11!
    2 ! $Id: integrd.F 1550 2011-07-05 09:44:55Z lguez $
     2! $Id: integrd.F 1616 2012-02-17 11:59:00Z emillour $
    33!
    44      SUBROUTINE integrd
    55     $  (  nq,vcovm1,ucovm1,tetam1,psm1,massem1,
    6      $     dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis,finvmaold )
     6     $     dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis !,finvmaold
     7     &  )
    78
    89      use control_mod, only : planet_type
    … …  
    3435#include "temps.h"
    3536#include "serre.h"
     37#include "iniprint.h"
    3638
    3739c   Arguments:
    3840c   ----------
    3941
    40       INTEGER nq
    41 
    42       REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
    43       REAL q(ip1jmp1,llm,nq)
    44       REAL ps(ip1jmp1),masse(ip1jmp1,llm),phis(ip1jmp1)
    45 
    46       REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm)
    47       REAL tetam1(ip1jmp1,llm),psm1(ip1jmp1),massem1(ip1jmp1,llm)
    48 
    49       REAL dv(ip1jm,llm),du(ip1jmp1,llm)
    50       REAL dteta(ip1jmp1,llm),dp(ip1jmp1)
    51       REAL dq(ip1jmp1,llm,nq), finvmaold(ip1jmp1,llm)
     42      integer,intent(in) :: nq ! number of tracers to handle in this routine
     43      real,intent(inout) :: vcov(ip1jm,llm) ! covariant meridional wind
     44      real,intent(inout) :: ucov(ip1jmp1,llm) ! covariant zonal wind
     45      real,intent(inout) :: teta(ip1jmp1,llm) ! potential temperature
     46      real,intent(inout) :: q(ip1jmp1,llm,nq) ! advected tracers
     47      real,intent(inout) :: ps(ip1jmp1) ! surface pressure
     48      real,intent(inout) :: masse(ip1jmp1,llm) ! atmospheric mass
     49      real,intent(in) :: phis(ip1jmp1) ! ground geopotential !!! unused
     50      ! values at previous time step
     51      real,intent(inout) :: vcovm1(ip1jm,llm)
     52      real,intent(inout) :: ucovm1(ip1jmp1,llm)
     53      real,intent(inout) :: tetam1(ip1jmp1,llm)
     54      real,intent(inout) :: psm1(ip1jmp1)
     55      real,intent(inout) :: massem1(ip1jmp1,llm)
     56      ! the tendencies to add
     57      real,intent(in) :: dv(ip1jm,llm)
     58      real,intent(in) :: du(ip1jmp1,llm)
     59      real,intent(in) :: dteta(ip1jmp1,llm)
     60      real,intent(in) :: dp(ip1jmp1)
     61      real,intent(in) :: dq(ip1jmp1,llm,nq) !!! unused
     62!      real,intent(out) :: finvmaold(ip1jmp1,llm) !!! unused
    5263
    5364c   Local:
    … …  
    5566
    5667      REAL vscr( ip1jm ),uscr( ip1jmp1 ),hscr( ip1jmp1 ),pscr(ip1jmp1)
    57       REAL massescr( ip1jmp1,llm ), finvmasse(ip1jmp1,llm)
     68      REAL massescr( ip1jmp1,llm )
     69!      REAL finvmasse(ip1jmp1,llm)
    5870      REAL p(ip1jmp1,llmp1)
    5971      REAL tpn,tps,tppn(iim),tpps(iim)
    … …  
    6173      REAL deltap( ip1jmp1,llm )
    6274
    63       INTEGER  l,ij,iq
     75      INTEGER  l,ij,iq,i,j
    6476
    6577      REAL SSUM
    … …  
    88100      DO ij = 1,ip1jmp1
    89101        IF( ps(ij).LT.0. ) THEN
    90          PRINT*,' Au point ij = ',ij, ' , pression sol neg. ', ps(ij)
    91          print *, ' dans integrd'
    92          stop 1
     102         write(lunout,*) "integrd: negative surface pressure ",ps(ij)
     103         write(lunout,*) " at node ij =", ij
     104         ! since ij=j+(i-1)*jjp1 , we have
     105         j=modulo(ij,jjp1)
     106         i=1+(ij-j)/jjp1
     107         write(lunout,*) " lon = ",rlonv(i)*180./pi, " deg",
     108     &                   " lat = ",rlatu(j)*180./pi, " deg"
     109         stop
    93110        ENDIF
    94111      ENDDO
    … …  
    110127      CALL massdair (     p  , masse         )
    111128
    112       CALL   SCOPY( ijp1llm  , masse, 1, finvmasse,  1      )
    113       CALL filtreg( finvmasse, jjp1, llm, -2, 2, .TRUE., 1  )
     129! Ehouarn : we don't use/need finvmaold and finvmasse,
     130!           so might as well not compute them
     131!      CALL   SCOPY( ijp1llm  , masse, 1, finvmasse,  1      )
     132!      CALL filtreg( finvmasse, jjp1, llm, -2, 2, .TRUE., 1  )
    114133c
    115134
    … …  
    218237       ENDDO
    219238
    220 
    221       CALL  SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
     239! Ehouarn: forget about finvmaold
     240!      CALL  SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
    222241
    223242      endif ! of if (planet_type.eq."earth")

  • trunk/LMDZ.COMMON/libf/dyn3d/leapfrog.F

    r500 r776  
    124124
    125125      REAL  SSUM
    126       REAL time_0 , finvmaold(ip1jmp1,llm)
     126      REAL time_0
     127!     REAL finvmaold(ip1jmp1,llm)
    127128
    128129cym      LOGICAL  lafin
    … …  
    243244      dq(:,:,:)=0.
    244245      CALL pression ( ip1jmp1, ap, bp, ps, p       )
    245       if (disvert_type==1) then
     246      if (pressure_exner) then
    246247        CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
    247       else ! we assume that we are in the disvert_type==2 case
     248      else
    248249        CALL exner_milieu( ip1jmp1, ps, p, beta, pks, pk, pkf )
    249250      endif
    … …  
    271272c   ----------------------------------
    272273
    273    1  CONTINUE
     274   1  CONTINUE ! Matsuno Forward step begins here
    274275
    275276      jD_cur = jD_ref + day_ini - day_ref +                             &
    276      &          int (itau * dtvr / daysec)
     277     &          itau/day_step
    277278      jH_cur = jH_ref + start_time +                                    &
    278      &          (itau * dtvr / daysec - int(itau * dtvr / daysec))
     279     &          mod(itau,day_step)/float(day_step)
    279280      jD_cur = jD_cur + int(jH_cur)
    280281      jH_cur = jH_cur - int(jH_cur)
    … …  
    307308
    308309c   ...    P.Le Van .26/04/94  ....
    309 
    310       CALL SCOPY   ( ijp1llm,   masse, 1, finvmaold,     1 )
    311       CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
    312 
    313    2  CONTINUE
     310! Ehouarn: finvmaold is actually not used
     311!      CALL SCOPY   ( ijp1llm,   masse, 1, finvmaold,     1 )
     312!      CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
     313
     314   2  CONTINUE ! Matsuno backward or leapfrog step begins here
    314315
    315316c-----------------------------------------------------------------------
    … …  
    357358      call tpot2t(ijp1llm,teta,temp,pk)
    358359      tsurpk = cpp*temp/pk
     360      ! compute geopotential phi()
    359361      CALL geopot  ( ip1jmp1, tsurpk  , pk , pks,  phis  , phi   )
    360362
    … …  
    372374
    373375!      IF( forward. OR . leapf )  THEN
     376! Ehouarn: NB: at this point p with ps are not synchronized
     377!              (whereas mass and ps are...)
    374378      IF((.not.forward).OR. leapf )  THEN
    375379        ! Ehouarn: gather mass fluxes during backward Matsuno or LF step
    … …  
    398402
    399403       CALL integrd ( 2,vcovm1,ucovm1,tetam1,psm1,massem1 ,
    400      $         dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis ,
    401      $              finvmaold                                    )
     404     $         dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis )
     405!     $              finvmaold                                    )
    402406
    403407       IF ((planet_type.eq."titan").and.(tidal)) then
    … …  
    431435
    432436         CALL pression (  ip1jmp1, ap, bp, ps,  p      )
    433          if (disvert_type==1) then
     437         if (pressure_exner) then
    434438           CALL exner_hyb(  ip1jmp1, ps, p,alpha,beta,pks, pk, pkf )
    435          else ! we assume that we are in the disvert_type==2 case
     439         else
    436440           CALL exner_milieu( ip1jmp1, ps, p, beta, pks, pk, pkf )
    437441         endif
    438442
    439443           jD_cur = jD_ref + day_ini - day_ref +                        &
    440      &          int (itau * dtvr / daysec)
     444     &          itau/day_step
    441445           jH_cur = jH_ref + start_time +                               &
    442      &          (itau * dtvr / daysec - int(itau * dtvr / daysec))
     446     &          mod(itau,day_step)/float(day_step)
    443447           jD_cur = jD_cur + int(jH_cur)
    444448           jH_cur = jH_cur - int(jH_cur)
    … …  
    545549
    546550        CALL pression ( ip1jmp1, ap, bp, ps, p                  )
    547         if (disvert_type==1) then
     551        if (pressure_exner) then
    548552          CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
    549         else ! we assume that we are in the disvert_type==2 case
     553        else
    550554          CALL exner_milieu( ip1jmp1, ps, p, beta, pks, pk, pkf )
    551555        endif
    … …  
    613617        ENDDO
    614618
    615         DO ij =  1,iim
    616           tppn(ij)  = aire(  ij    ) * ps (  ij    )
    617           tpps(ij)  = aire(ij+ip1jm) * ps (ij+ip1jm)
    618         ENDDO
    619           tpn  = SSUM(iim,tppn,1)/apoln
    620           tps  = SSUM(iim,tpps,1)/apols
    621 
    622         DO ij = 1, iip1
    623           ps(  ij    ) = tpn
    624           ps(ij+ip1jm) = tps
    625         ENDDO
    626 
     619        if (1 == 0) then
     620!!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics
     621!!!                     2) should probably not be here anyway
     622!!! but are kept for those who would want to revert to previous behaviour
     623           DO ij =  1,iim
     624             tppn(ij)  = aire(  ij    ) * ps (  ij    )
     625             tpps(ij)  = aire(ij+ip1jm) * ps (ij+ip1jm)
     626           ENDDO
     627             tpn  = SSUM(iim,tppn,1)/apoln
     628             tps  = SSUM(iim,tpps,1)/apols
     629
     630           DO ij = 1, iip1
     631             ps(  ij    ) = tpn
     632             ps(ij+ip1jm) = tps
     633           ENDDO
     634        endif ! of if (1 == 0)
    627635
    628636      END IF ! of IF(apdiss)
    … …  
    749757
    750758              CLOSE(99)
     759              !!! Ehouarn: Why not stop here and now?
    751760            ENDIF ! of IF (itau.EQ.itaufin)
    752761

  • trunk/LMDZ.COMMON/libf/dyn3d/wrgrads.F

    r1 r776  
    2626c   local
    2727
    28       integer im,jm,lm,i,j,l,lnblnk,iv,iii,iji,iif,ijf
     28      integer im,jm,lm,i,j,l,iv,iii,iji,iif,ijf
    2929
    3030      logical writectl
    … …  
    5959            nvar(if)=ivar(if)
    6060            var(ivar(if),if)=name
    61             tvar(ivar(if),if)=titlevar(1:lnblnk(titlevar))
     61            tvar(ivar(if),if)=trim(titlevar)
    6262            nld(ivar(if),if)=nl
    6363c           print*,'initialisation ecriture de ',var(ivar(if),if)
    … …  
    101101      file=fichier(if)
    102102c   WARNING! on reecrase le fichier .ctl a chaque ecriture
    103       open(unit(if),file=file(1:lnblnk(file))//'.ctl'
     103      open(unit(if),file=trim(file)//'.ctl'
    104104     &         ,form='formatted',status='unknown')
    105105      write(unit(if),'(a5,1x,a40)')
    106      &       'DSET ','^'//file(1:lnblnk(file))//'.dat'
     106     &       'DSET ','^'//trim(file)//'.dat'
    107107
    108108      write(unit(if),'(a12)') 'UNDEF 1.0E30'

  • trunk/LMDZ.COMMON/libf/dyn3dpar/bands.F90

    r1 r776  
    11!
    2 ! $Id: bands.F90 1279 2009-12-10 09:02:56Z fairhead $
     2! $Id: bands.F90 1615 2012-02-10 15:42:26Z emillour $
    33!
    44  module Bands
    … …  
    9393   SUBROUTINE  Set_Bands
    9494     USE parallel
    95 #ifdef CPP_EARTH
    96 ! Ehouarn: what follows is only related to // physics; for now only for Earth
     95#ifdef CPP_PHYS
     96! Ehouarn: what follows is only related to // physics
    9797     USE mod_phys_lmdz_para, ONLY : jj_para_begin,jj_para_end
    9898#endif
    … …  
    106106      enddo
    107107         
    108 #ifdef CPP_EARTH
    109 ! Ehouarn: what follows is only related to // physics; for now only for Earth         
     108#ifdef CPP_PHYS
    110109      do i=0,MPI_Size-1
    111110        jj_Nb_physic(i)=jj_para_end(i)-jj_para_begin(i)+1
    … …  
    332331    subroutine AdjustBands_physic
    333332      use times
    334 #ifdef CPP_EARTH
    335 ! Ehouarn: what follows is only related to // physics; for now only for Earth
     333#ifdef CPP_PHYS
     334! Ehouarn: what follows is only related to // physics
    336335      USE mod_phys_lmdz_para, only : klon_mpi_para_nb
    337336#endif
    … …  
    359358      medium=medium/mpi_size     
    360359      NbTot=0
    361 #ifdef CPP_EARTH
    362 ! Ehouarn: what follows is only related to // physics; for now only for Earth
     360#ifdef CPP_PHYS
    363361      do i=0,mpi_size-1
    364362        Inc(i)=nint(klon_mpi_para_nb(i)*(medium-value(i))/value(i))

  • trunk/LMDZ.COMMON/libf/dyn3dpar/calfis_p.F

    r108 r776  
    2727     $                  pdpsfi)
    2828#ifdef CPP_PHYS
    29 ! Ehouarn: For now, calfis_p needs Earth physics
    30 c
    31 c    Auteur :  P. Le Van, F. Hourdin
    32 c   .........
     29! Ehouarn: if using (parallelized) physics
    3330      USE dimphy
    3431      USE mod_phys_lmdz_para, mpi_root_xx=>mpi_root
    … …  
    225222      PARAMETER(ntetaSTD=3)
    226223      REAL rtetaSTD(ntetaSTD)
    227       DATA rtetaSTD/350., 380., 405./
     224      DATA rtetaSTD/350., 380., 405./ ! Earth-specific values, beware !!
    228225      REAL PVteta(klon,ntetaSTD)
    229226     
    … …  
    512509
    513510
    514       IF (is_sequential) THEN
    515 c
     511      IF (is_sequential.and.(planet_type=="earth")) THEN
     512#ifdef CPP_PHYS
     513! PVtheta calls tetalevel, which is in the physics
    516514cIM calcul PV a teta=350, 380, 405K
    517515        CALL PVtheta(ngridmx,llm,pucov,pvcov,pteta,
    … …  
    519517     $           ntetaSTD,rtetaSTD,PVteta)
    520518c
     519#endif
    521520      ENDIF
    522521
    … …  
    666665      zdqfic_omp(:,:,:)=0.
    667666
     667#ifdef CPP_PHYS
    668668      do isplit=1,nsplit_phys
    669669
    … …  
    742742      enddo
    743743
     744#endif
     745! of #ifdef CPP_PHYS
     746
    744747      zdufi_omp(:,:)=zdufic_omp(:,:)/nsplit_phys
    745748      zdvfi_omp(:,:)=zdvfic_omp(:,:)/nsplit_phys

  • trunk/LMDZ.COMMON/libf/dyn3dpar/ce0l.F90

    r492 r776  
    11!
    2 ! $Id: ce0l.F90 1600 2011-12-06 13:16:30Z jghattas $
     2! $Id: ce0l.F90 1615 2012-02-10 15:42:26Z emillour $
    33!
    44!-------------------------------------------------------------------------------
    … …  
    3131  IMPLICIT NONE
    3232#ifndef CPP_EARTH
    33   WRITE(*,*)'limit_netcdf: Earth-specific routine, needs Earth physics'
     33#include "iniprint.h"
     34  WRITE(lunout,*)'limit_netcdf: Earth-specific routine, needs Earth physics'
    3435#else
    3536!-------------------------------------------------------------------------------

  • trunk/LMDZ.COMMON/libf/dyn3dpar/comvert.h

    r127 r776  
    11!
    2 ! $Id: comvert.h 1520 2011-05-23 11:37:09Z emillour $
     2! $Id: comvert.h 1625 2012-05-09 13:14:48Z lguez $
    33!
    44!-----------------------------------------------------------------------
    … …  
    99     &               aps(llm),bps(llm),scaleheight
    1010
    11       common/comverti/disvert_type
     11      common/comverti/disvert_type, pressure_exner
    1212
    1313      real ap     ! hybrid pressure contribution at interlayers
    … …  
    3030                           !     using 'z2sig.def' (or 'esasig.def) file
    3131
     32      logical pressure_exner
     33!     compute pressure inside layers using Exner function, else use mean
     34!     of pressure values at interfaces
     35
    3236 !-----------------------------------------------------------------------

  • trunk/LMDZ.COMMON/libf/dyn3dpar/disvert.F90

    r128 r776  
    1 ! $Id: disvert.F90 1520 2011-05-23 11:37:09Z emillour $
     1! $Id: disvert.F90 1645 2012-07-30 16:01:50Z lguez $
    22
    33SUBROUTINE disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig,scaleheight)
    44
    55  ! Auteur : P. Le Van
     6
     7  use new_unit_m, only: new_unit
     8  use ioipsl, only: getin
     9  use assert_m, only: assert
    610
    711  IMPLICIT NONE
    … …  
    1822
    1923  real,intent(in) :: pa, preff
    20   real,intent(out) :: ap(llmp1), bp(llmp1)
     24  real,intent(out) :: ap(llmp1) ! in Pa
     25  real, intent(out):: bp(llmp1)
    2126  real,intent(out) :: dpres(llm), nivsigs(llm), nivsig(llmp1)
    2227  real,intent(out) :: presnivs(llm)
    … …  
    2631  real zk, zkm1, dzk1, dzk2, k0, k1
    2732
    28   INTEGER l
     33  INTEGER l, unit
    2934  REAL dsigmin
    3035  REAL alpha, beta, deltaz
    31   INTEGER iostat
    3236  REAL x
    3337  character(len=*),parameter :: modname="disvert"
    3438
     39  character(len=6):: vert_sampling
     40  ! (allowed values are "param", "tropo", "strato" and "read")
     41
    3542  !-----------------------------------------------------------------------
     43
     44  print *, "Call sequence information: disvert"
    3645
    3746  ! default scaleheight is 8km for earth
    3847  scaleheight=8.
    3948
    40   OPEN(99, file='sigma.def', status='old', form='formatted', iostat=iostat)
     49  vert_sampling = merge("strato", "tropo ", ok_strato) ! default value
     50  call getin('vert_sampling', vert_sampling)
     51  print *, 'vert_sampling = ' // vert_sampling
    4152
    42   IF (iostat == 0) THEN
    43      ! cas 1 on lit les options dans sigma.def:
     53  select case (vert_sampling)
     54  case ("param")
     55     ! On lit les options dans sigma.def:
     56     OPEN(99, file='sigma.def', status='old', form='formatted')
    4457     READ(99, *) scaleheight ! hauteur d'echelle 8.
    4558     READ(99, *) deltaz ! epaiseur de la premiere couche 0.04
    … …  
    6982     sig(llm+1)=0.
    7083
    71      DO l = 1, llm
    72         dsig(l) = sig(l)-sig(l+1)
    73      end DO
    74   ELSE
    75      if (ok_strato) then
    76         if (llm==39) then
    77            dsigmin=0.3
    78         else if (llm==50) then
    79            dsigmin=1.
    80         else
    81            write(lunout,*) trim(modname), &
    82            ' ATTENTION discretisation z a ajuster'
    83            dsigmin=1.
    84         endif
    85         write(lunout,*) trim(modname), &
    86         ' Discretisation verticale DSIGMIN=',dsigmin
    87      endif
     84     bp(: llm) = EXP(1. - 1. / sig(: llm)**2)
     85     bp(llmp1) = 0.
    8886
     87     ap = pa * (sig - bp)
     88  case("tropo")
    8989     DO l = 1, llm
    9090        x = 2*asin(1.) * (l - 0.5) / (llm + 1)
    91 
    92         IF (ok_strato) THEN
    93            dsig(l) =(dsigmin + 7. * SIN(x)**2) &
    94                 *(0.5*(1.-tanh(1.*(x-asin(1.))/asin(1.))))**2
    95         ELSE
    96            dsig(l) = 1.0 + 7.0 * SIN(x)**2
    97         ENDIF
     91        dsig(l) = 1.0 + 7.0 * SIN(x)**2
    9892     ENDDO
    9993     dsig = dsig / sum(dsig)
    … …  
    10296        sig(l) = sig(l+1) + dsig(l)
    10397     ENDDO
    104   ENDIF
     98
     99     bp(1)=1.
     100     bp(2: llm) = EXP(1. - 1. / sig(2: llm)**2)
     101     bp(llmp1) = 0.
     102
     103     ap(1)=0.
     104     ap(2: llm + 1) = pa * (sig(2: llm + 1) - bp(2: llm + 1))
     105  case("strato")
     106     if (llm==39) then
     107        dsigmin=0.3
     108     else if (llm==50) then
     109        dsigmin=1.
     110     else
     111        write(lunout,*) trim(modname), ' ATTENTION discretisation z a ajuster'
     112        dsigmin=1.
     113     endif
     114     WRITE(LUNOUT,*) trim(modname), 'Discretisation verticale DSIGMIN=',dsigmin
     115
     116     DO l = 1, llm
     117        x = 2*asin(1.) * (l - 0.5) / (llm + 1)
     118        dsig(l) =(dsigmin + 7. * SIN(x)**2) &
     119             *(0.5*(1.-tanh(1.*(x-asin(1.))/asin(1.))))**2
     120     ENDDO
     121     dsig = dsig / sum(dsig)
     122     sig(llm+1) = 0.
     123     DO l = llm, 1, -1
     124        sig(l) = sig(l+1) + dsig(l)
     125     ENDDO
     126
     127     bp(1)=1.
     128     bp(2: llm) = EXP(1. - 1. / sig(2: llm)**2)
     129     bp(llmp1) = 0.
     130
     131     ap(1)=0.
     132     ap(2: llm + 1) = pa * (sig(2: llm + 1) - bp(2: llm + 1))
     133  case("read")
     134     ! Read "ap" and "bp". First line is skipped (title line). "ap"
     135     ! should be in Pa. First couple of values should correspond to
     136     ! the surface, that is : "bp" should be in descending order.
     137     call new_unit(unit)
     138     open(unit, file="hybrid.txt", status="old", action="read", &
     139          position="rewind")
     140     read(unit, fmt=*) ! skip title line
     141     do l = 1, llm + 1
     142        read(unit, fmt=*) ap(l), bp(l)
     143     end do
     144     close(unit)
     145     call assert(ap(1) == 0., ap(llm + 1) == 0., bp(1) == 1., &
     146          bp(llm + 1) == 0., "disvert: bad ap or bp values")
     147  case default
     148     call abort_gcm("disvert", 'Wrong value for "vert_sampling"', 1)
     149  END select
    105150
    106151  DO l=1, llm
    … …  
    111156     nivsig(l)= REAL(l)
    112157  ENDDO
    113 
    114   ! .... Calculs de ap(l) et de bp(l) ....
    115   ! ..... pa et preff sont lus sur les fichiers start par lectba .....
    116 
    117   bp(llmp1) = 0.
    118 
    119   DO l = 1, llm
    120      bp(l) = EXP( 1. -1./( sig(l)*sig(l)) )
    121      ap(l) = pa * ( sig(l) - bp(l) )
    122   ENDDO
    123 
    124   bp(1)=1.
    125   ap(1)=0.
    126 
    127   ap(llmp1) = pa * ( sig(llmp1) - bp(llmp1) )
    128158
    129159  write(lunout, *)  trim(modname),': BP '

  • trunk/LMDZ.COMMON/libf/dyn3dpar/dynetat0.F

    r492 r776  
    66
    77      USE infotrac
     8      use netcdf, only: nf90_get_var
    89      IMPLICIT NONE
    910
    … …  
    2829#include "comconst.h"
    2930#include "comvert.h"
    30 #include "comgeom.h"
     31#include "comgeom2.h"
    3132#include "ener.h"
    3233#include "netcdf.inc"
    … …  
    4041
    4142      CHARACTER*(*) fichnom
    42       REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
    43       REAL q(ip1jmp1,llm,nqtot),masse(ip1jmp1,llm)
    44       REAL ps(ip1jmp1),phis(ip1jmp1)
     43      REAL vcov(iip1, jjm,llm),ucov(iip1, jjp1,llm),teta(iip1, jjp1,llm)
     44      REAL q(iip1,jjp1,llm,nqtot),masse(iip1, jjp1,llm)
     45      REAL ps(iip1, jjp1),phis(iip1, jjp1)
    4546
    4647      REAL time
    … …  
    7071         CALL abort
    7172      ENDIF
    72 #ifdef NC_DOUBLE
    73       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
    74 #else
    75       ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
    76 #endif
     73      ierr = nf90_get_var(nid, nvarid, tab_cntrl)
    7774      IF (ierr .NE. NF_NOERR) THEN
    7875         write(lunout,*)"dynetat0: Lecture echoue pour <controle>"
    … …  
    142139         CALL abort
    143140      ENDIF
    144 #ifdef NC_DOUBLE
    145       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonu)
    146 #else
    147       ierr = NF_GET_VAR_REAL(nid, nvarid, rlonu)
    148 #endif
     141      ierr = nf90_get_var(nid, nvarid, rlonu)
    149142      IF (ierr .NE. NF_NOERR) THEN
    150143         write(lunout,*)"dynetat0: Lecture echouee pour <rlonu>"
    … …  
    157150         CALL abort
    158151      ENDIF
    159 #ifdef NC_DOUBLE
    160       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatu)
    161 #else
    162       ierr = NF_GET_VAR_REAL(nid, nvarid, rlatu)
    163 #endif
     152      ierr = nf90_get_var(nid, nvarid, rlatu)
    164153      IF (ierr .NE. NF_NOERR) THEN
    165154         write(lunout,*)"dynetat0: Lecture echouee pour <rlatu>"
    … …  
    172161         CALL abort
    173162      ENDIF
    174 #ifdef NC_DOUBLE
    175       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonv)
    176 #else
    177       ierr = NF_GET_VAR_REAL(nid, nvarid, rlonv)
    178 #endif
     163      ierr = nf90_get_var(nid, nvarid, rlonv)
    179164      IF (ierr .NE. NF_NOERR) THEN
    180165         write(lunout,*)"dynetat0: Lecture echouee pour <rlonv>"
    … …  
    187172         CALL abort
    188173      ENDIF
    189 #ifdef NC_DOUBLE
    190       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatv)
    191 #else
    192       ierr = NF_GET_VAR_REAL(nid, nvarid, rlatv)
    193 #endif
     174      ierr = nf90_get_var(nid, nvarid, rlatv)
    194175      IF (ierr .NE. NF_NOERR) THEN
    195176         write(lunout,*)"dynetat0: Lecture echouee pour rlatv"
    … …  
    202183         CALL abort
    203184      ENDIF
    204 #ifdef NC_DOUBLE
    205       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cu)
    206 #else
    207       ierr = NF_GET_VAR_REAL(nid, nvarid, cu)
    208 #endif
     185      ierr = nf90_get_var(nid, nvarid, cu)
    209186      IF (ierr .NE. NF_NOERR) THEN
    210187         write(lunout,*)"dynetat0: Lecture echouee pour <cu>"
    … …  
    217194         CALL abort
    218195      ENDIF
    219 #ifdef NC_DOUBLE
    220       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cv)
    221 #else
    222       ierr = NF_GET_VAR_REAL(nid, nvarid, cv)
    223 #endif
     196      ierr = nf90_get_var(nid, nvarid, cv)
    224197      IF (ierr .NE. NF_NOERR) THEN
    225198         write(lunout,*)"dynetat0: Lecture echouee pour <cv>"
    … …  
    232205         CALL abort
    233206      ENDIF
    234 #ifdef NC_DOUBLE
    235       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, aire)
    236 #else
    237       ierr = NF_GET_VAR_REAL(nid, nvarid, aire)
    238 #endif
     207      ierr = nf90_get_var(nid, nvarid, aire)
    239208      IF (ierr .NE. NF_NOERR) THEN
    240209         write(lunout,*)"dynetat0: Lecture echouee pour <aire>"
    … …  
    247216         CALL abort
    248217      ENDIF
    249 #ifdef NC_DOUBLE
    250       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phis)
    251 #else
    252       ierr = NF_GET_VAR_REAL(nid, nvarid, phis)
    253 #endif
     218      ierr = nf90_get_var(nid, nvarid, phis)
    254219      IF (ierr .NE. NF_NOERR) THEN
    255220         write(lunout,*)"dynetat0: Lecture echouee pour <phisinit>"
    … …  
    262227         CALL abort
    263228      ENDIF
    264 #ifdef NC_DOUBLE
    265       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, time)
    266 #else
    267       ierr = NF_GET_VAR_REAL(nid, nvarid, time)
    268 #endif
     229      ierr = nf90_get_var(nid, nvarid, time)
    269230      IF (ierr .NE. NF_NOERR) THEN
    270231         write(lunout,*)"dynetat0: Lecture echouee <temps>"
    … …  
    277238         CALL abort
    278239      ENDIF
    279 #ifdef NC_DOUBLE
    280       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ucov)
    281 #else
    282       ierr = NF_GET_VAR_REAL(nid, nvarid, ucov)
    283 #endif
     240      ierr = nf90_get_var(nid, nvarid, ucov)
    284241      IF (ierr .NE. NF_NOERR) THEN
    285242         write(lunout,*)"dynetat0: Lecture echouee pour <ucov>"
    … …  
    292249         CALL abort
    293250      ENDIF
    294 #ifdef NC_DOUBLE
    295       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, vcov)
    296 #else
    297       ierr = NF_GET_VAR_REAL(nid, nvarid, vcov)
    298 #endif
     251      ierr = nf90_get_var(nid, nvarid, vcov)
    299252      IF (ierr .NE. NF_NOERR) THEN
    300253         write(lunout,*)"dynetat0: Lecture echouee pour <vcov>"
    … …  
    307260         CALL abort
    308261      ENDIF
    309 #ifdef NC_DOUBLE
    310       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, teta)
    311 #else
    312       ierr = NF_GET_VAR_REAL(nid, nvarid, teta)
    313 #endif
     262      ierr = nf90_get_var(nid, nvarid, teta)
    314263      IF (ierr .NE. NF_NOERR) THEN
    315264         write(lunout,*)"dynetat0: Lecture echouee pour <teta>"
    … …  
    325274     &                    "> est absent"
    326275           write(lunout,*)"          Il est donc initialise a zero"
    327            q(:,:,iq)=0.
     276           q(:,:,:,iq)=0.
    328277        ELSE
    329 #ifdef NC_DOUBLE
    330           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q(1,1,iq))
    331 #else
    332           ierr = NF_GET_VAR_REAL(nid, nvarid, q(1,1,iq))
    333 #endif
     278           ierr = NF90_GET_VAR(nid, nvarid, q(:,:,:,iq))
    334279          IF (ierr .NE. NF_NOERR) THEN
    335280            write(lunout,*)"dynetat0: Lecture echouee pour "//tname(iq)
    … …  
    345290         CALL abort
    346291      ENDIF
    347 #ifdef NC_DOUBLE
    348       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, masse)
    349 #else
    350       ierr = NF_GET_VAR_REAL(nid, nvarid, masse)
    351 #endif
     292      ierr = nf90_get_var(nid, nvarid, masse)
    352293      IF (ierr .NE. NF_NOERR) THEN
    353294         write(lunout,*)"dynetat0: Lecture echouee pour <masse>"
    … …  
    360301         CALL abort
    361302      ENDIF
    362 #ifdef NC_DOUBLE
    363       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ps)
    364 #else
    365       ierr = NF_GET_VAR_REAL(nid, nvarid, ps)
    366 #endif
     303      ierr = nf90_get_var(nid, nvarid, ps)
    367304      IF (ierr .NE. NF_NOERR) THEN
    368305         write(lunout,*)"dynetat0: Lecture echouee pour <ps>"

  • trunk/LMDZ.COMMON/libf/dyn3dpar/dynredem.F

    r492 r776  
    11!
    2 ! $Id: dynredem.F 1403 2010-07-01 09:02:53Z fairhead $
     2! $Id: dynredem.F 1635 2012-07-12 11:37:16Z lguez $
    33!
    44c
    … …  
    88#endif
    99      USE infotrac
     10      use netcdf95, only: NF95_PUT_VAR
    1011 
    1112      IMPLICIT NONE
    … …  
    1920#include "comconst.h"
    2021#include "comvert.h"
    21 #include "comgeom.h"
     22#include "comgeom2.h"
    2223#include "temps.h"
    2324#include "ener.h"
    … …  
    3132c   ----------
    3233      INTEGER iday_end
    33       REAL phis(ip1jmp1)
     34      REAL phis(iip1, jjp1)
    3435      CHARACTER*(*) fichnom
    3536
    … …  
    138139c
    139140      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27,
    140      .                       "Fichier demarrage dynamique")
     141     .                       "Fichier demmarage dynamique")
    141142c
    142143c Definir les dimensions du fichiers:
    … …  
    166167     .                       "Parametres de controle")
    167168      ierr = NF_ENDDEF(nid)
    168 #ifdef NC_DOUBLE
    169       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
    170 #else
    171       ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
    172 #endif
     169      call NF95_PUT_VAR(nid,nvarid,tab_cntrl)
    173170c
    174171      ierr = NF_REDEF (nid)
    … …  
    183180     .                       "Longitudes des points U")
    184181      ierr = NF_ENDDEF(nid)
    185 #ifdef NC_DOUBLE
    186       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu)
    187 #else
    188       ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu)
    189 #endif
     182      call NF95_PUT_VAR(nid,nvarid,rlonu)
    190183c
    191184      ierr = NF_REDEF (nid)
    … …  
    200193     .                       "Latitudes des points U")
    201194      ierr = NF_ENDDEF(nid)
    202 #ifdef NC_DOUBLE
    203       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu)
    204 #else
    205       ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu)
    206 #endif
     195      call NF95_PUT_VAR (nid,nvarid,rlatu)
    207196c
    208197      ierr = NF_REDEF (nid)
    … …  
    217206     .                       "Longitudes des points V")
    218207      ierr = NF_ENDDEF(nid)
    219 #ifdef NC_DOUBLE
    220       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv)
    221 #else
    222       ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv)
    223 #endif
     208      call NF95_PUT_VAR(nid,nvarid,rlonv)
    224209c
    225210      ierr = NF_REDEF (nid)
    … …  
    234219     .                       "Latitudes des points V")
    235220      ierr = NF_ENDDEF(nid)
    236 #ifdef NC_DOUBLE
    237       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv)
    238 #else
    239       ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv)
    240 #endif
     221      call NF95_PUT_VAR(nid,nvarid,rlatv)
    241222c
    242223      ierr = NF_REDEF (nid)
    … …  
    251232     .                       "Numero naturel des couches s")
    252233      ierr = NF_ENDDEF(nid)
    253 #ifdef NC_DOUBLE
    254       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs)
    255 #else
    256       ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs)
    257 #endif
     234      call NF95_PUT_VAR(nid,nvarid,nivsigs)
    258235c
    259236      ierr = NF_REDEF (nid)
    … …  
    268245     .                       "Numero naturel des couches sigma")
    269246      ierr = NF_ENDDEF(nid)
    270 #ifdef NC_DOUBLE
    271       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig)
    272 #else
    273       ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig)
    274 #endif
     247      call NF95_PUT_VAR(nid,nvarid,nivsig)
    275248c
    276249      ierr = NF_REDEF (nid)
    … …  
    285258     .                       "Coefficient A pour hybride")
    286259      ierr = NF_ENDDEF(nid)
    287 #ifdef NC_DOUBLE
    288       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap)
    289 #else
    290       ierr = NF_PUT_VAR_REAL (nid,nvarid,ap)
    291 #endif
     260      call NF95_PUT_VAR(nid,nvarid,ap)
    292261c
    293262      ierr = NF_REDEF (nid)
    … …  
    302271     .                       "Coefficient B pour hybride")
    303272      ierr = NF_ENDDEF(nid)
    304 #ifdef NC_DOUBLE
    305       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp)
    306 #else
    307       ierr = NF_PUT_VAR_REAL (nid,nvarid,bp)
    308 #endif
     273      call NF95_PUT_VAR(nid,nvarid,bp)
    309274c
    310275      ierr = NF_REDEF (nid)
    … …  
    317282cIM 220306 END
    318283      ierr = NF_ENDDEF(nid)
    319 #ifdef NC_DOUBLE
    320       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs)
    321 #else
    322       ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs)
    323 #endif
     284      call NF95_PUT_VAR(nid,nvarid,presnivs)
    324285c
    325286c Coefficients de passage cov. <-> contra. <--> naturel
    … …  
    338299     .                       "Coefficient de passage pour U")
    339300      ierr = NF_ENDDEF(nid)
    340 #ifdef NC_DOUBLE
    341       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu)
    342 #else
    343       ierr = NF_PUT_VAR_REAL (nid,nvarid,cu)
    344 #endif
     301      call NF95_PUT_VAR(nid,nvarid,cu)
    345302c
    346303      ierr = NF_REDEF (nid)
    … …  
    357314     .                       "Coefficient de passage pour V")
    358315      ierr = NF_ENDDEF(nid)
    359 #ifdef NC_DOUBLE
    360       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv)
    361 #else
    362       ierr = NF_PUT_VAR_REAL (nid,nvarid,cv)
    363 #endif
     316      call NF95_PUT_VAR(nid,nvarid,cv)
    364317c
    365318c Aire de chaque maille:
    … …  
    378331     .                       "Aires de chaque maille")
    379332      ierr = NF_ENDDEF(nid)
    380 #ifdef NC_DOUBLE
    381       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire)
    382 #else
    383       ierr = NF_PUT_VAR_REAL (nid,nvarid,aire)
    384 #endif
     333      call NF95_PUT_VAR(nid,nvarid,aire)
    385334c
    386335c Geopentiel au sol:
    … …  
    399348     .                       "Geopotentiel au sol")
    400349      ierr = NF_ENDDEF(nid)
    401 #ifdef NC_DOUBLE
    402       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis)
    403 #else
    404       ierr = NF_PUT_VAR_REAL (nid,nvarid,phis)
    405 #endif
     350      call NF95_PUT_VAR(nid,nvarid,phis)
    406351c
    407352c Definir les variables pour pouvoir les enregistrer plus tard:
    … …  
    524469      USE infotrac
    525470      USE control_mod
     471      use netcdf, only: NF90_get_VAR
     472      use netcdf95, only: NF95_PUT_VAR
    526473 
    527474      IMPLICIT NONE
    … …  
    538485#include "iniprint.h"
    539486
     487
    540488      INTEGER l
    541       REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm)
    542       REAL teta(ip1jmp1,llm)                   
    543       REAL ps(ip1jmp1),masse(ip1jmp1,llm)                   
    544       REAL q(ip1jmp1,llm,nqtot)
     489      REAL vcov(iip1,jjm,llm),ucov(iip1, jjp1,llm)
     490      REAL teta(iip1, jjp1,llm)                   
     491      REAL ps(iip1, jjp1),masse(iip1, jjp1,llm)                   
     492      REAL q(iip1, jjp1, llm, nqtot)
    545493      CHARACTER*(*) fichnom
    546494     
    … …  
    576524         CALL abort_gcm(modname,abort_message,ierr)
    577525      ENDIF
    578 #ifdef NC_DOUBLE
    579       ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time)
    580 #else
    581       ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time)
    582 #endif
     526      call NF95_PUT_VAR(nid,nvarid,time,start=(/nb/))
    583527      write(lunout,*) "dynredem1: Enregistrement pour ", nb, time
    584528
    … …  
    592536         CALL abort_gcm(modname,abort_message,ierr)
    593537      ENDIF
    594 #ifdef NC_DOUBLE
    595       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
    596 #else
    597       ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
    598 #endif
     538      ierr = NF90_GET_VAR(nid, nvarid, tab_cntrl)
    599539       tab_cntrl(31) = REAL(itau_dyn + itaufin)
    600 #ifdef NC_DOUBLE
    601       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
    602 #else
    603       ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
    604 #endif
     540      call NF95_PUT_VAR(nid,nvarid,tab_cntrl)
    605541
    606542c  Ecriture des champs
    … …  
    612548         CALL abort_gcm(modname,abort_message,ierr)
    613549      ENDIF
    614 #ifdef NC_DOUBLE
    615       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ucov)
    616 #else
    617       ierr = NF_PUT_VAR_REAL (nid,nvarid,ucov)
    618 #endif
     550      call NF95_PUT_VAR(nid,nvarid,ucov)
    619551
    620552      ierr = NF_INQ_VARID(nid, "vcov", nvarid)
    … …  
    624556         CALL abort_gcm(modname,abort_message,ierr)
    625557      ENDIF
    626 #ifdef NC_DOUBLE
    627       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vcov)
    628 #else
    629       ierr = NF_PUT_VAR_REAL (nid,nvarid,vcov)
    630 #endif
     558      call NF95_PUT_VAR(nid,nvarid,vcov)
    631559
    632560      ierr = NF_INQ_VARID(nid, "teta", nvarid)
    … …  
    636564         CALL abort_gcm(modname,abort_message,ierr)
    637565      ENDIF
    638 #ifdef NC_DOUBLE
    639       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,teta)
    640 #else
    641       ierr = NF_PUT_VAR_REAL (nid,nvarid,teta)
    642 #endif
     566      call NF95_PUT_VAR(nid,nvarid,teta)
    643567
    644568      IF (type_trac == 'inca') THEN
    … …  
    662586               CALL abort_gcm(modname,abort_message,ierr)
    663587            ENDIF
    664 #ifdef NC_DOUBLE
    665             ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq))
    666 #else
    667             ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq))
    668 #endif
     588            call NF95_PUT_VAR(nid,nvarid,q(:,:,:,iq))
    669589        ELSE ! type_trac = inca
    670590! lecture de la valeur du traceur dans start_trac.nc
    … …  
    681601                   CALL abort_gcm(modname,abort_message,ierr)
    682602                ENDIF
    683 #ifdef NC_DOUBLE
    684                 ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq))
    685 #else
    686                 ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq))
    687 #endif
     603                call NF95_PUT_VAR(nid,nvarid,q(:,:,:,iq))
    688604               
    689605             ELSE
    690606                write(lunout,*) "dynredem1: ",trim(tname(iq)),
    691607     &              " est present dans start_trac.nc"
    692 #ifdef NC_DOUBLE
    693                ierr = NF_GET_VAR_DOUBLE(nid_trac, nvarid_trac, trac_tmp)
    694 #else
    695                ierr = NF_GET_VAR_REAL(nid_trac, nvarid_trac, trac_tmp)
    696 #endif
     608               ierr = NF90_GET_VAR(nid_trac, nvarid_trac, trac_tmp)
    697609                IF (ierr .NE. NF_NOERR) THEN
    698610                   abort_message="dynredem1: Lecture echouee pour"//
    … …  
    708620                   CALL abort_gcm(modname,abort_message,ierr)
    709621                ENDIF
    710 #ifdef NC_DOUBLE
    711                 ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,trac_tmp)
    712 #else
    713                 ierr = NF_PUT_VAR_REAL (nid,nvarid,trac_tmp)
    714 #endif
     622                call NF95_PUT_VAR(nid, nvarid, trac_tmp)
    715623               
    716624             ENDIF ! IF (ierr .NE. NF_NOERR)
    … …  
    725633                   CALL abort_gcm(modname,abort_message,ierr)
    726634             ENDIF
    727 #ifdef NC_DOUBLE
    728              ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq))
    729 #else
    730              ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq))
    731 #endif
     635             call NF95_PUT_VAR(nid,nvarid,q(:,:,:,iq))
    732636          ENDIF ! (ierr_file .ne. 2)
    733637       END IF   !type_trac
    … …  
    742646         CALL abort_gcm(modname,abort_message,ierr)
    743647      ENDIF
    744 #ifdef NC_DOUBLE
    745       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masse)
    746 #else
    747       ierr = NF_PUT_VAR_REAL (nid,nvarid,masse)
    748 #endif
     648      call NF95_PUT_VAR(nid,nvarid,masse)
    749649c
    750650      ierr = NF_INQ_VARID(nid, "ps", nvarid)
    … …  
    754654         CALL abort_gcm(modname,abort_message,ierr)
    755655      ENDIF
    756 #ifdef NC_DOUBLE
    757       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ps)
    758 #else
    759       ierr = NF_PUT_VAR_REAL (nid,nvarid,ps)
    760 #endif
     656      call NF95_PUT_VAR(nid,nvarid,ps)
    761657
    762658      ierr = NF_CLOSE(nid)

  • trunk/LMDZ.COMMON/libf/dyn3dpar/dynredem_p.F

    r492 r776  
    11!
    2 ! $Id: dynredem_p.F 1577 2011-10-20 15:06:47Z fairhead $
     2! $Id: dynredem_p.F 1635 2012-07-12 11:37:16Z lguez $
    33!
    44c
    … …  
    99      USE parallel
    1010      USE infotrac
     11      use netcdf95, only: NF95_PUT_VAR
     12 
    1113      IMPLICIT NONE
    1214c=======================================================================
    … …  
    1921#include "comconst.h"
    2022#include "comvert.h"
    21 #include "comgeom.h"
     23#include "comgeom2.h"
    2224#include "temps.h"
    2325#include "ener.h"
    … …  
    3032c   ----------
    3133      INTEGER iday_end
    32       REAL phis(ip1jmp1)
     34      REAL phis(iip1, jjp1)
    3335      CHARACTER*(*) fichnom
    3436
    … …  
    5658      character*30 unites
    5759
     60
    5861c-----------------------------------------------------------------------
    5962      if (mpi_rank==0) then
    … …  
    6972      mmois0=1
    7073      jjour0=1
    71 #endif               
     74#endif       
    7275
    7376      DO l=1,length
    7477       tab_cntrl(l) = 0.
    7578      ENDDO
    76        tab_cntrl(1)  =  REAL(iim)
    77        tab_cntrl(2)  =  REAL(jjm)
    78        tab_cntrl(3)  =  REAL(llm)
    79        tab_cntrl(4)  =  REAL(day_ref)
    80        tab_cntrl(5)  =  REAL(annee_ref)
     79       tab_cntrl(1)  = REAL(iim)
     80       tab_cntrl(2)  = REAL(jjm)
     81       tab_cntrl(3)  = REAL(llm)
     82       tab_cntrl(4)  = REAL(day_ref)
     83       tab_cntrl(5)  = REAL(annee_ref)
    8184       tab_cntrl(6)  = rad
    8285       tab_cntrl(7)  = omeg
    … …  
    118121      ENDIF
    119122
    120        tab_cntrl(30) =  REAL(iday_end)
    121        tab_cntrl(31) =  REAL(itau_dyn + itaufin)
     123       tab_cntrl(30) = REAL(iday_end)
     124       tab_cntrl(31) = REAL(itau_dyn + itaufin)
    122125c start_time: start_time of simulation (not necessarily 0.)
    123126       tab_cntrl(32) = start_time
    … …  
    165168     .                       "Parametres de controle")
    166169      ierr = NF_ENDDEF(nid)
    167 #ifdef NC_DOUBLE
    168       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
    169 #else
    170       ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
    171 #endif
     170      call NF95_PUT_VAR(nid,nvarid,tab_cntrl)
    172171c
    173172      ierr = NF_REDEF (nid)
    … …  
    182181     .                       "Longitudes des points U")
    183182      ierr = NF_ENDDEF(nid)
    184 #ifdef NC_DOUBLE
    185       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu)
    186 #else
    187       ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu)
    188 #endif
     183      call NF95_PUT_VAR(nid,nvarid,rlonu)
    189184c
    190185      ierr = NF_REDEF (nid)
    … …  
    199194     .                       "Latitudes des points U")
    200195      ierr = NF_ENDDEF(nid)
    201 #ifdef NC_DOUBLE
    202       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu)
    203 #else
    204       ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu)
    205 #endif
     196      call NF95_PUT_VAR (nid,nvarid,rlatu)
    206197c
    207198      ierr = NF_REDEF (nid)
    … …  
    216207     .                       "Longitudes des points V")
    217208      ierr = NF_ENDDEF(nid)
    218 #ifdef NC_DOUBLE
    219       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv)
    220 #else
    221       ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv)
    222 #endif
     209      call NF95_PUT_VAR(nid,nvarid,rlonv)
    223210c
    224211      ierr = NF_REDEF (nid)
    … …  
    233220     .                       "Latitudes des points V")
    234221      ierr = NF_ENDDEF(nid)
    235 #ifdef NC_DOUBLE
    236       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv)
    237 #else
    238       ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv)
    239 #endif
     222      call NF95_PUT_VAR(nid,nvarid,rlatv)
    240223c
    241224      ierr = NF_REDEF (nid)
    … …  
    250233     .                       "Numero naturel des couches s")
    251234      ierr = NF_ENDDEF(nid)
    252 #ifdef NC_DOUBLE
    253       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs)
    254 #else
    255       ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs)
    256 #endif
     235      call NF95_PUT_VAR(nid,nvarid,nivsigs)
    257236c
    258237      ierr = NF_REDEF (nid)
    … …  
    267246     .                       "Numero naturel des couches sigma")
    268247      ierr = NF_ENDDEF(nid)
    269 #ifdef NC_DOUBLE
    270       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig)
    271 #else
    272       ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig)
    273 #endif
     248      call NF95_PUT_VAR(nid,nvarid,nivsig)
    274249c
    275250      ierr = NF_REDEF (nid)
    … …  
    284259     .                       "Coefficient A pour hybride")
    285260      ierr = NF_ENDDEF(nid)
    286 #ifdef NC_DOUBLE
    287       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap)
    288 #else
    289       ierr = NF_PUT_VAR_REAL (nid,nvarid,ap)
    290 #endif
     261      call NF95_PUT_VAR(nid,nvarid,ap)
    291262c
    292263      ierr = NF_REDEF (nid)
    … …  
    301272     .                       "Coefficient B pour hybride")
    302273      ierr = NF_ENDDEF(nid)
    303 #ifdef NC_DOUBLE
    304       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp)
    305 #else
    306       ierr = NF_PUT_VAR_REAL (nid,nvarid,bp)
    307 #endif
     274      call NF95_PUT_VAR(nid,nvarid,bp)
    308275c
    309276      ierr = NF_REDEF (nid)
    … …  
    316283cIM 220306 END
    317284      ierr = NF_ENDDEF(nid)
    318 #ifdef NC_DOUBLE
    319       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs)
    320 #else
    321       ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs)
    322 #endif
     285      call NF95_PUT_VAR(nid,nvarid,presnivs)
    323286c
    324287c Coefficients de passage cov. <-> contra. <--> naturel
    … …  
    337300     .                       "Coefficient de passage pour U")
    338301      ierr = NF_ENDDEF(nid)
    339 #ifdef NC_DOUBLE
    340       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu)
    341 #else
    342       ierr = NF_PUT_VAR_REAL (nid,nvarid,cu)
    343 #endif
     302      call NF95_PUT_VAR(nid,nvarid,cu)
    344303c
    345304      ierr = NF_REDEF (nid)
    … …  
    356315     .                       "Coefficient de passage pour V")
    357316      ierr = NF_ENDDEF(nid)
    358 #ifdef NC_DOUBLE
    359       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv)
    360 #else
    361       ierr = NF_PUT_VAR_REAL (nid,nvarid,cv)
    362 #endif
     317      call NF95_PUT_VAR(nid,nvarid,cv)
    363318c
    364319c Aire de chaque maille:
    … …  
    377332     .                       "Aires de chaque maille")
    378333      ierr = NF_ENDDEF(nid)
    379 #ifdef NC_DOUBLE
    380       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire)
    381 #else
    382       ierr = NF_PUT_VAR_REAL (nid,nvarid,aire)
    383 #endif
     334      call NF95_PUT_VAR(nid,nvarid,aire)
    384335c
    385336c Geopentiel au sol:
    … …  
    398349     .                       "Geopotentiel au sol")
    399350      ierr = NF_ENDDEF(nid)
    400 #ifdef NC_DOUBLE
    401       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis)
    402 #else
    403       ierr = NF_PUT_VAR_REAL (nid,nvarid,phis)
    404 #endif
     351      call NF95_PUT_VAR(nid,nvarid,phis)
    405352c
    406353c Definir les variables pour pouvoir les enregistrer plus tard:
    … …  
    510457      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
    511458      ierr = NF_CLOSE(nid) ! fermer le fichier
    512 
    513459
    514460      PRINT*,'iim,jjm,llm,iday_end',iim,jjm,llm,iday_end
    … …  
    524470      USE infotrac
    525471      USE control_mod
     472      use netcdf, only: NF90_get_VAR
     473      use netcdf95, only: NF95_PUT_VAR
     474 
    526475      IMPLICIT NONE
    527476c=================================================================
    … …  
    536485#include "temps.h"
    537486
     487
    538488      INTEGER l
    539       REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm)
    540       REAL teta(ip1jmp1,llm)                   
    541       REAL ps(ip1jmp1),masse(ip1jmp1,llm)                   
    542       REAL q(ip1jmp1,llm,nqtot)
     489      REAL vcov(iip1,jjm,llm),ucov(iip1, jjp1,llm)
     490      REAL teta(iip1, jjp1,llm)                   
     491      REAL ps(iip1, jjp1),masse(iip1, jjp1,llm)                   
     492      REAL q(iip1, jjp1, llm, nqtot)
    543493      CHARACTER*(*) fichnom
    544494     
    … …  
    546496      INTEGER nid, nvarid, nid_trac, nvarid_trac
    547497      REAL trac_tmp(ip1jmp1,llm)     
    548       INTEGER ierr, ierr_file
     498      INTEGER ierr, ierr_file 
    549499      INTEGER iq
    550500      INTEGER length
    … …  
    567517     
    568518      do iq=1,nqtot
    569         call Gather_Field(q(1,1,iq),ip1jmp1,llm,0)
     519        call Gather_Field(q(:,:,:,iq),ip1jmp1,llm,0)
    570520      enddo
    571521     
    … …  
    589539         CALL abort_gcm(modname,abort_message,ierr)
    590540      ENDIF
    591 #ifdef NC_DOUBLE
    592       ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time)
    593 #else
    594       ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time)
    595 #endif
     541      call NF95_PUT_VAR(nid,nvarid,time,start=(/nb/))
    596542      PRINT*, "Enregistrement pour ", nb, time
    597543
    … …  
    605551         CALL abort_gcm(modname,abort_message,ierr)
    606552      ENDIF
    607 #ifdef NC_DOUBLE
    608       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
    609 #else
    610       ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
    611 #endif
    612        tab_cntrl(31) =  REAL(itau_dyn + itaufin)
    613 #ifdef NC_DOUBLE
    614       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
    615 #else
    616       ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
    617 #endif
     553      ierr = NF90_GET_VAR(nid, nvarid, tab_cntrl)
     554       tab_cntrl(31) = REAL(itau_dyn + itaufin)
     555      call NF95_PUT_VAR(nid,nvarid,tab_cntrl)
    618556
    619557c  Ecriture des champs
    … …  
    624562         CALL abort
    625563      ENDIF
    626 #ifdef NC_DOUBLE
    627       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ucov)
    628 #else
    629       ierr = NF_PUT_VAR_REAL (nid,nvarid,ucov)
    630 #endif
     564      call NF95_PUT_VAR(nid,nvarid,ucov)
    631565
    632566      ierr = NF_INQ_VARID(nid, "vcov", nvarid)
    … …  
    635569         CALL abort
    636570      ENDIF
    637 #ifdef NC_DOUBLE
    638       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vcov)
    639 #else
    640       ierr = NF_PUT_VAR_REAL (nid,nvarid,vcov)
    641 #endif
     571      call NF95_PUT_VAR(nid,nvarid,vcov)
    642572
    643573      ierr = NF_INQ_VARID(nid, "teta", nvarid)
    … …  
    646576         CALL abort
    647577      ENDIF
    648 #ifdef NC_DOUBLE
    649       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,teta)
    650 #else
    651       ierr = NF_PUT_VAR_REAL (nid,nvarid,teta)
    652 #endif
     578      call NF95_PUT_VAR(nid,nvarid,teta)
    653579
    654580      IF (type_trac == 'inca') THEN
    … …  
    675601               CALL abort
    676602            ENDIF
    677 #ifdef NC_DOUBLE
    678             ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq))
    679 #else
    680             ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq))
    681 #endif
     603            call NF95_PUT_VAR(nid,nvarid,q(:,:,:,iq))
    682604        ELSE ! type_trac = inca
    683605! lecture de la valeur du traceur dans start_trac.nc
    … …  
    691613                   CALL abort
    692614                ENDIF
    693 #ifdef NC_DOUBLE
    694                 ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq))
    695 #else
    696                 ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq))
    697 #endif
     615                call NF95_PUT_VAR(nid,nvarid,q(:,:,:,iq))
    698616               
    699617             ELSE
    700618                PRINT*, tname(iq), "est present dans start_trac.nc"
    701 #ifdef NC_DOUBLE
    702                ierr = NF_GET_VAR_DOUBLE(nid_trac, nvarid_trac, trac_tmp)
    703 #else
    704                ierr = NF_GET_VAR_REAL(nid_trac, nvarid_trac, trac_tmp)
    705 #endif
     619               ierr = NF90_GET_VAR(nid_trac, nvarid_trac, trac_tmp)
    706620                IF (ierr .NE. NF_NOERR) THEN
    707621                   PRINT*, "Lecture echouee pour", tname(iq)
    … …  
    713627                   CALL abort
    714628                ENDIF
    715 #ifdef NC_DOUBLE
    716                 ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,trac_tmp)
    717 #else
    718                 ierr = NF_PUT_VAR_REAL (nid,nvarid,trac_tmp)
    719 #endif
     629                call NF95_PUT_VAR(nid, nvarid, trac_tmp)
    720630               
    721631             ENDIF ! IF (ierr .NE. NF_NOERR)
    … …  
    728638                CALL abort
    729639             ENDIF
    730 #ifdef NC_DOUBLE
    731              ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq))
    732 #else
    733              ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq))
    734 #endif
     640             call NF95_PUT_VAR(nid,nvarid,q(:,:,:,iq))
    735641          ENDIF ! (ierr_file .ne. 2)
    736        END IF   ! type_trac
     642       END IF   !type_trac
    737643     
    738644      ENDDO
    … …  
    746652         CALL abort
    747653      ENDIF
    748 #ifdef NC_DOUBLE
    749       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masse)
    750 #else
    751       ierr = NF_PUT_VAR_REAL (nid,nvarid,masse)
    752 #endif
     654      call NF95_PUT_VAR(nid,nvarid,masse)
    753655c
    754656      ierr = NF_INQ_VARID(nid, "ps", nvarid)
    … …  
    757659         CALL abort
    758660      ENDIF
    759 #ifdef NC_DOUBLE
    760       ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ps)
    761 #else
    762       ierr = NF_PUT_VAR_REAL (nid,nvarid,ps)
    763 #endif
     661      call NF95_PUT_VAR(nid,nvarid,ps)
    764662
    765663      ierr = NF_CLOSE(nid)

  • trunk/LMDZ.COMMON/libf/dyn3dpar/etat0_netcdf.F90

    r127 r776  
    11!
    2 ! $Id: etat0_netcdf.F90 1520 2011-05-23 11:37:09Z emillour $
     2! $Id: etat0_netcdf.F90 1625 2012-05-09 13:14:48Z lguez $
    33!
    44!-------------------------------------------------------------------------------
    … …  
    251251!*******************************************************************************
    252252  CALL pression(ip1jmp1, ap, bp, psol, p3d)
    253   if (disvert_type.eq.1) then
     253  if (pressure_exner) then
    254254    CALL exner_hyb(ip1jmp1, psol, p3d, alpha, beta, pks, pk, y)
    255   else ! we assume that we are in the disvert_type==2 case
     255  else
    256256    CALL exner_milieu(ip1jmp1,psol,p3d,beta,pks,pk,y)
    257257  endif

  • trunk/LMDZ.COMMON/libf/dyn3dpar/exner_hyb.F

    r127 r776  
    5656      ! Sanity check
    5757      if (firstcall) then
    58         ! check that vertical discretization is compatible
    59         ! with this routine
    60         if (disvert_type.ne.1) then
    61           call abort_gcm(modname,
    62      &     "this routine should only be called if disvert_type==1",42)
    63         endif
    64        
    6558        ! sanity checks for Shallow Water case (1 vertical layer)
    6659        if (llm.eq.1) then

  • trunk/LMDZ.COMMON/libf/dyn3dpar/exner_hyb_p.F

    r270 r776  
    6060      ! Sanity check
    6161      if (firstcall) then
    62         ! check that vertical discretization is compatible
    63         ! with this routine
    64         if (disvert_type.ne.1) then
    65           call abort_gcm(modname,
    66      &     "this routine should only be called if disvert_type==1",42)
    67         endif
    68        
    6962        ! sanity checks for Shallow Water case (1 vertical layer)
    7063        if (llm.eq.1) then

  • trunk/LMDZ.COMMON/libf/dyn3dpar/exner_milieu.F

    r127 r776  
    5353      ! Sanity check
    5454      if (firstcall) then
    55         ! check that vertical discretization is compatible
    56         ! with this routine
    57         if (disvert_type.ne.2) then
    58           call abort_gcm(modname,
    59      &     "this routine should only be called if disvert_type==2",42)
    60         endif
    61        
    6255        ! sanity checks for Shallow Water case (1 vertical layer)
    6356        if (llm.eq.1) then

  • trunk/LMDZ.COMMON/libf/dyn3dpar/exner_milieu_p.F

    r270 r776  
    5656      ! Sanity check
    5757      if (firstcall) then
    58         ! check that vertical discretization is compatible
    59         ! with this routine
    60         if (disvert_type.ne.2) then
    61           call abort_gcm(modname,
    62      &     "this routine should only be called if disvert_type==2",42)
    63         endif
    64        
    6558        ! sanity checks for Shallow Water case (1 vertical layer)
    6659        if (llm.eq.1) then

  • trunk/LMDZ.COMMON/libf/dyn3dpar/gcm.F

    r492 r776  
    2020      USE control_mod
    2121
    22 ! Ehouarn: for now these only apply to Earth:
    23 #ifdef CPP_EARTH
     22! Ehouarn: the following are needed with (parallel) physics:
     23#ifdef CPP_PHYS
    2424      USE mod_grid_phy_lmdz
    2525      USE mod_phys_lmdz_para, ONLY : klon_mpi_para_nb
    … …  
    182182      call ini_getparam("out.def")
    183183      call Read_Distrib
    184 ! Ehouarn : temporarily (?) keep this only for Earth
    185 !      if (planet_type.eq."earth") then
    186 !#ifdef CPP_EARTH
     184
    187185#ifdef CPP_PHYS
    188186        CALL init_phys_lmdz(iim,jjp1,llm,mpi_size,distrib_phys)
    189187#endif
    190 !      endif ! of if (planet_type.eq."earth")
    191188      CALL set_bands
    192189#ifdef CPP_PHYS
    193 ! Ehouarn: NB: For now only Earth physics is parallel
    194190      CALL Init_interface_dyn_phys
    195191#endif
    … …  
    203199c$OMP END PARALLEL
    204200
    205 ! Ehouarn : temporarily (?) keep this only for Earth
    206 !      if (planet_type.eq."earth") then
    207 !#ifdef CPP_EARTH
    208201#ifdef CPP_PHYS
    209202c$OMP PARALLEL
    … …  
    211204c$OMP END PARALLEL
    212205#endif
    213 !      endif ! of if (planet_type.eq."earth")
     206
    214207!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    215208c
    … …  
    476469         WRITE(lunout,*)
    477470     .       'GCM: WARNING!!! vitesse verticale nulle dans la physique'
    478 
    479 ! Initialisation de la physique: pose probleme quand on tourne
    480 ! SANS physique, car iniphysiq.F est dans le repertoire phy[]...
    481 ! Il faut une cle CPP_PHYS
     471! Physics
    482472#ifdef CPP_PHYS
    483473         CALL iniphysiq(ngridmx,llm,daysec,day_ini,dtphys/nsplit_phys ,
    … …  
    486476         call_iniphys=.false.
    487477      ENDIF ! of IF (call_iniphys.and.(iflag_phys.eq.1))
    488 !#endif
     478
    489479
    490480c-----------------------------------------------------------------------
    … …  
    525515#endif
    526516
     517#ifdef CPP_PHYS
     518! Create start file (startphy.nc) and boundary conditions (limit.nc)
     519! for the Earth verstion
     520       if (iflag_phys>=100) then
     521          call iniaqua(ngridmx,latfi,lonfi,iflag_phys)
     522       endif
     523#endif
     524
    527525      if (planet_type.eq."mars") then
    528526! POUR MARS, METTRE UNE FONCTION A PART, genre dynredem0_mars

  • trunk/LMDZ.COMMON/libf/dyn3dpar/gr_dyn_fi_p.F

    r1 r776  
    11!
    2 ! $Id: gr_dyn_fi_p.F 1279 2009-12-10 09:02:56Z fairhead $
     2! $Id: gr_dyn_fi_p.F 1615 2012-02-10 15:42:26Z emillour $
    33!
    44      SUBROUTINE gr_dyn_fi_p(nfield,im,jm,ngrid,pdyn,pfi)
    5 #ifdef CPP_EARTH
     5#ifdef CPP_PHYS
    66! Interface with parallel physics,
    7 ! for now this routine only works with Earth physics
    87      USE mod_interface_dyn_phys
    98      USE dimphy
    … …  
    4039      ENDDO
    4140c$OMP END DO NOWAIT
    42 #else
    43       write(lunout,*) "gr_fi_dyn_p : This routine should not be called",
    44      &   "without parallelized physics"
    45       stop
    4641#endif
    47 ! of #ifdef CPP_EARTH
     42! of #ifdef CPP_PHYS
    4843      RETURN
    4944      END

  • trunk/LMDZ.COMMON/libf/dyn3dpar/gr_fi_dyn_p.F

    r1 r776  
    11!
    2 ! $Id: gr_fi_dyn_p.F 1279 2009-12-10 09:02:56Z fairhead $
     2! $Id: gr_fi_dyn_p.F 1615 2012-02-10 15:42:26Z emillour $
    33!
    44      SUBROUTINE gr_fi_dyn_p(nfield,ngrid,im,jm,pfi,pdyn)
    5 #ifdef CPP_EARTH
     5#ifdef CPP_PHYS
    66! Interface with parallel physics,
    7 ! for now this routine only works with Earth physics
    87      USE mod_interface_dyn_phys
    98      USE dimphy
    … …  
    5251      ENDDO
    5352c$OMP END DO NOWAIT
    54 #else
    55       write(lunout,*) "gr_fi_dyn_p : This routine should not be called",
    56      &   "without parallelized physics"
    57       stop
    5853#endif
    59 ! of #ifdef CPP_EARTH
     54! of #ifdef CPP_PHYS
    6055      RETURN
    6156      END

  • trunk/LMDZ.COMMON/libf/dyn3dpar/guide_p_mod.F90

    r127 r776  
    455455!       Calcul niveaux pression milieu de couches
    456456        CALL pression_p( ip1jmp1, ap, bp, ps, p )
    457         if (disvert_type==1) then
     457        if (pressure_exner) then
    458458          CALL exner_hyb_p(ip1jmp1,ps,p,alpha,beta,pks,pk,pkf)
    459459        else
    … …  
    755755    ELSE
    756756        CALL pression_p( ip1jmp1, ap, bp, psi, p )
    757         if (disvert_type==1) then
     757        if (pressure_exner) then
    758758          CALL exner_hyb_p(ip1jmp1,psi,p,alpha,beta,pks,pk,pkf)
    759         else ! we assume that we are in the disvert_type==2 case
     759        else
    760760          CALL exner_milieu_p(ip1jmp1,psi,p,beta,pks,pk,pkf)
    761761        endif

  • trunk/LMDZ.COMMON/libf/dyn3dpar/iniacademic.F90

    r492 r776  
    11!
    2 ! $Id: iniacademic.F90 1529 2011-05-26 15:17:33Z fairhead $
     2! $Id: iniacademic.F90 1625 2012-05-09 13:14:48Z lguez $
    33!
    44SUBROUTINE iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
    … …  
    222222
    223223        CALL pression ( ip1jmp1, ap, bp, ps, p       )
    224         if (disvert_type.eq.1) then
     224        if (pressure_exner) then
    225225          CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
    226         elseif (disvert_type.eq.2) then
     226        else
    227227          call exner_milieu(ip1jmp1,ps,p,beta,pks,pk,pkf)
    228         else
    229           write(abort_message,*) "Wrong value for disvert_type: ", &
    230                               disvert_type
    231           call abort_gcm(modname,abort_message,0)
    232228        endif
    233229        CALL massdair(p,masse)

  • trunk/LMDZ.COMMON/libf/dyn3dpar/iniconst.F90

    r775 r776  
    11!
    2 ! $Id: iniconst.F 1520 2011-05-23 11:37:09Z emillour $
     2! $Id: iniconst.F90 1625 2012-05-09 13:14:48Z lguez $
    33!
    4       SUBROUTINE iniconst
     4SUBROUTINE iniconst
    55
    6       USE control_mod
     6  USE control_mod
    77#ifdef CPP_IOIPSL
    8       use IOIPSL
     8  use IOIPSL
    99#else
    10 ! if not using IOIPSL, we still need to use (a local version of) getin
    11       use ioipsl_getincom
     10  ! if not using IOIPSL, we still need to use (a local version of) getin
     11  use ioipsl_getincom
    1212#endif
    1313
    14       IMPLICIT NONE
    15 c
    16 c      P. Le Van
    17 c
    18 c-----------------------------------------------------------------------
    19 c   Declarations:
    20 c   -------------
    21 c
    22 #include "dimensions.h"
    23 #include "paramet.h"
    24 #include "comconst.h"
    25 #include "temps.h"
    26 #include "comvert.h"
    27 #include "iniprint.h"
     14  IMPLICIT NONE
     15  !
     16  !      P. Le Van
     17  !
     18  !   Declarations:
     19  !   -------------
     20  !
     21  include "dimensions.h"
     22  include "paramet.h"
     23  include "comconst.h"
     24  include "temps.h"
     25  include "comvert.h"
     26  include "iniprint.h"
    2827
     28  character(len=*),parameter :: modname="iniconst"
     29  character(len=80) :: abort_message
     30  !
     31  !
     32  !
     33  !-----------------------------------------------------------------------
     34  !   dimension des boucles:
     35  !   ----------------------
    2936
    30       character(len=*),parameter :: modname="iniconst"
    31       character(len=80) :: abort_message
    32 c
    33 c
    34 c
    35 c-----------------------------------------------------------------------
    36 c   dimension des boucles:
    37 c   ----------------------
     37  im      = iim
     38  jm      = jjm
     39  lllm    = llm
     40  imp1    = iim
     41  jmp1    = jjm + 1
     42  lllmm1  = llm - 1
     43  lllmp1  = llm + 1
    3844
    39       im      = iim
    40       jm      = jjm
    41       lllm    = llm
    42       imp1    = iim
    43       jmp1    = jjm + 1
    44       lllmm1  = llm - 1
    45       lllmp1  = llm + 1
     45  !-----------------------------------------------------------------------
    4646
    47 c-----------------------------------------------------------------------
     47  dtphys  = iphysiq * dtvr
     48  unsim   = 1./iim
     49  pi      = 2.*ASIN( 1. )
    4850
    49       dtphys  = iphysiq * dtvr
    50       unsim   = 1./iim
    51       pi      = 2.*ASIN( 1. )
     51  !-----------------------------------------------------------------------
     52  !
    5253
    53 c-----------------------------------------------------------------------
    54 c
     54  r       = cpp * kappa
    5555
    56       r       = cpp * kappa
     56  write(lunout,*) trim(modname),': R  CP  Kappa ',r,cpp,kappa
     57  !
     58  !-----------------------------------------------------------------------
    5759
    58       write(lunout,*) trim(modname),': R  CP  Kappa ',r,cpp,kappa
    59 c
    60 c-----------------------------------------------------------------------
     60  ! vertical discretization: default behavior depends on planet_type flag
     61  if (planet_type=="earth") then
     62     disvert_type=1
     63  else
     64     disvert_type=2
     65  endif
     66  ! but user can also specify using one or the other in run.def:
     67  call getin('disvert_type',disvert_type)
     68  write(lunout,*) trim(modname),': disvert_type=',disvert_type
    6169
    62 ! vertical discretization: default behavior depends on planet_type flag
    63       if (planet_type=="earth") then
    64         disvert_type=1
    65       else
    66         disvert_type=2
    67       endif
    68       ! but user can also specify using one or the other in run.def:
    69       call getin('disvert_type',disvert_type)
    70       write(lunout,*) trim(modname),': disvert_type=',disvert_type
    71      
    72       if (disvert_type==1) then
    73        ! standard case for Earth (automatic generation of levels)
    74        call disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig,
    75      &              scaleheight)
    76       else if (disvert_type==2) then
    77         ! standard case for planets (levels generated using z2sig.def file)
    78         call disvert_noterre
    79       else
    80         write(abort_message,*) "Wrong value for disvert_type: ",
    81      &                        disvert_type
    82         call abort_gcm(modname,abort_message,0)
    83       endif
     70  pressure_exner = disvert_type == 1 ! default value
     71  call getin('pressure_exner', pressure_exner)
    8472
    85       END
     73  if (disvert_type==1) then
     74     ! standard case for Earth (automatic generation of levels)
     75     call disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig, scaleheight)
     76  else if (disvert_type==2) then
     77     ! standard case for planets (levels generated using z2sig.def file)
     78     call disvert_noterre
     79  else
     80     write(abort_message,*) "Wrong value for disvert_type: ", disvert_type
     81     call abort_gcm(modname,abort_message,0)
     82  endif
     83
     84END SUBROUTINE iniconst

  • trunk/LMDZ.COMMON/libf/dyn3dpar/inidissip.F90

    r270 r776  
    2828! Local variables:
    2929  REAL fact,zvert(llm),zz
    30   REAL zh(ip1jmp1),zu(ip1jmp1),zv(ip1jm),deltap(ip1jmp1,llm)
     30  REAL zh(ip1jmp1),zu(ip1jmp1), gx(ip1jmp1), divgra(ip1jmp1)
     31  real zv(ip1jm), gy(ip1jm), deltap(ip1jmp1,llm)
    3132  REAL ullm,vllm,umin,vmin,zhmin,zhmax
    32   REAL zllm,z1llm
     33  REAL zllm
    3334
    3435  INTEGER l,ij,idum,ii
    … …  
    7879  DO l = 1,50
    7980     IF(lstardis) THEN
    80         CALL divgrad2(1,zh,deltap,niterh,zh)
     81        CALL divgrad2(1,zh,deltap,niterh,divgra)
    8182     ELSE
    82         CALL divgrad (1,zh,niterh,zh)
     83        CALL divgrad (1,zh,niterh,divgra)
    8384     ENDIF
    8485
    85      CALL minmax(iip1*jjp1,zh,zhmin,zhmax )
    86 
    87      zllm  = ABS( zhmax )
    88      z1llm = 1./zllm
    89      DO ij = 1,ip1jmp1
    90         zh(ij) = zh(ij)* z1llm
    91      ENDDO
     86     zllm  = ABS(maxval(divgra))
     87     zh = divgra / zllm
    9288  ENDDO
    9389
    … …  
    123119           !cccc             CALL covcont( 1,zu,zv,zu,zv )
    124120           IF(lstardis) THEN
    125               CALL gradiv2( 1,zu,zv,nitergdiv,zu,zv )
     121              CALL gradiv2( 1,zu,zv,nitergdiv,gx,gy )
    126122           ELSE
    127               CALL gradiv ( 1,zu,zv,nitergdiv,zu,zv )
     123              CALL gradiv ( 1,zu,zv,nitergdiv,gx,gy )
    128124           ENDIF
    129125        ELSE
    130126           IF(lstardis) THEN
    131               CALL nxgraro2( 1,zu,zv,nitergrot,zu,zv )
     127              CALL nxgraro2( 1,zu,zv,nitergrot,gx,gy )
    132128           ELSE
    133               CALL nxgrarot( 1,zu,zv,nitergrot,zu,zv )
     129              CALL nxgrarot( 1,zu,zv,nitergrot,gx,gy )
    134130           ENDIF
    135131        ENDIF
    136132
    137         CALL minmax(iip1*jjp1,zu,umin,ullm )
    138         CALL minmax(iip1*jjm, zv,vmin,vllm )
    139 
    140         ullm = ABS  ( ullm )
    141         vllm = ABS  ( vllm )
    142 
    143         zllm  = MAX( ullm,vllm )
    144         z1llm = 1./ zllm
    145         DO ij = 1, ip1jmp1
    146            zu(ij) = zu(ij)* z1llm
    147         ENDDO
    148         DO ij = 1, ip1jm
    149            zv(ij) = zv(ij)* z1llm
    150         ENDDO
     133        zllm = max(abs(maxval(gx)), abs(maxval(gy)))
     134        zu = gx / zllm
     135        zv = gy / zllm
    151136     end DO
    152137

  • trunk/LMDZ.COMMON/libf/dyn3dpar/inigrads.F

    r1 r776  
    99      implicit none
    1010
    11       integer if,im,jm,lm,i,j,l,lnblnk
     11      integer if,im,jm,lm,i,j,l
    1212      real x(im),y(jm),z(lm),fx,fy,fz,dt
    1313      real xmin,xmax,ymin,ymax
    … …  
    4040      ivar(if)=0
    4141
    42       fichier(if)=file(1:lnblnk(file))
     42      fichier(if)=trim(file)
    4343
    4444      firsttime(if)=.true.
    … …  
    7070
    7171      print*,4*(ifd(if)-iid(if))*(jfd(if)-jid(if))
    72       print*,file(1:lnblnk(file))//'.dat'
     72      print*,trim(file)//'.dat'
    7373
    74       OPEN (unit(if)+1,FILE=file(1:lnblnk(file))//'.dat'
     74      OPEN (unit(if)+1,FILE=trim(file)//'.dat'
    7575     s   ,FORM='unformatted',
    7676     s   ACCESS='direct'

  • trunk/LMDZ.COMMON/libf/dyn3dpar/integrd_p.F

    r270 r776  
    11!
    2 ! $Id: integrd_p.F 1550 2011-07-05 09:44:55Z lguez $
     2! $Id: integrd_p.F 1616 2012-02-17 11:59:00Z emillour $
    33!
    44      SUBROUTINE integrd_p
    55     $  (  nq,vcovm1,ucovm1,tetam1,psm1,massem1,
    6      $     dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps0,masse,phis,finvmaold)
     6     $     dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps0,masse,phis) !,finvmaold)
    77      USE parallel
    88      USE control_mod, only : planet_type
    … …  
    3333#include "temps.h"
    3434#include "serre.h"
     35#include "iniprint.h"
    3536
    3637c   Arguments:
    3738c   ----------
    3839
    39       INTEGER nq
    40 
    41       REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
    42       REAL q(ip1jmp1,llm,nq)
    43       REAL ps0(ip1jmp1),masse(ip1jmp1,llm),phis(ip1jmp1)
    44 
    45       REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm)
    46       REAL tetam1(ip1jmp1,llm),psm1(ip1jmp1),massem1(ip1jmp1,llm)
    47 
    48       REAL dv(ip1jm,llm),du(ip1jmp1,llm)
    49       REAL dteta(ip1jmp1,llm),dp(ip1jmp1)
    50       REAL dq(ip1jmp1,llm,nq), finvmaold(ip1jmp1,llm)
     40      integer,intent(in) :: nq ! number of tracers to handle in this routine
     41      real,intent(inout) :: vcov(ip1jm,llm) ! covariant meridional wind
     42      real,intent(inout) :: ucov(ip1jmp1,llm) ! covariant zonal wind
     43      real,intent(inout) :: teta(ip1jmp1,llm) ! potential temperature
     44      real,intent(inout) :: q(ip1jmp1,llm,nq) ! advected tracers
     45      real,intent(inout) :: ps0(ip1jmp1) ! surface pressure
     46      real,intent(inout) :: masse(ip1jmp1,llm) ! atmospheric mass
     47      real,intent(in) :: phis(ip1jmp1) ! ground geopotential !!! unused
     48      ! values at previous time step
     49      real,intent(inout) :: vcovm1(ip1jm,llm)
     50      real,intent(inout) :: ucovm1(ip1jmp1,llm)
     51      real,intent(inout) :: tetam1(ip1jmp1,llm)
     52      real,intent(inout) :: psm1(ip1jmp1)
     53      real,intent(inout) :: massem1(ip1jmp1,llm)
     54      ! the tendencies to add
     55      real,intent(in) :: dv(ip1jm,llm)
     56      real,intent(in) :: du(ip1jmp1,llm)
     57      real,intent(in) :: dteta(ip1jmp1,llm)
     58      real,intent(in) :: dp(ip1jmp1)
     59      real,intent(in) :: dq(ip1jmp1,llm,nq) !!! unused
     60!      real,intent(out) :: finvmaold(ip1jmp1,llm) !!! unused
    5161
    5262c   Local:
    … …  
    5464
    5565      REAL vscr( ip1jm ),uscr( ip1jmp1 ),hscr( ip1jmp1 ),pscr(ip1jmp1)
    56       REAL massescr( ip1jmp1,llm ), finvmasse(ip1jmp1,llm)
     66      REAL massescr( ip1jmp1,llm )
     67!      REAL finvmasse(ip1jmp1,llm)
    5768      REAL,SAVE :: p(ip1jmp1,llmp1)
    5869      REAL tpn,tps,tppn(iim),tpps(iim)
    … …  
    6071      REAL,SAVE :: deltap( ip1jmp1,llm )
    6172
    62       INTEGER  l,ij,iq
     73      INTEGER  l,ij,iq,i,j
    6374
    6475      REAL SSUM
    … …  
    126137       
    127138        IF( .NOT. checksum ) THEN
    128          PRINT*,' Au point ij = ',stop_it, ' , pression sol neg. '
    129      &         , ps(stop_it)
    130          print *, ' dans integrd'
    131          stop 1
     139         write(lunout,*) "integrd: negative surface pressure ",
     140     &                                                ps(stop_it)
     141         write(lunout,*) " at node ij =", stop_it
     142         ! since ij=j+(i-1)*jjp1 , we have
     143         j=modulo(stop_it,jjp1)
     144         i=1+(stop_it-j)/jjp1
     145         write(lunout,*) " lon = ",rlonv(i)*180./pi, " deg",
     146     &                   " lat = ",rlatu(j)*180./pi, " deg"
    132147        ENDIF
    133148
    … …  
    167182      CALL massdair_p (     p  , masse         )
    168183
    169 c      CALL   SCOPY( ijp1llm  , masse, 1, finvmasse,  1      )
    170       ijb=ij_begin
    171       ije=ij_end
    172      
    173 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    174       DO  l = 1,llm
    175         finvmasse(ijb:ije,l)=masse(ijb:ije,l)
    176       ENDDO
    177 c$OMP END DO NOWAIT
    178 
    179       jjb=jj_begin
    180       jje=jj_end
    181       CALL filtreg_p( finvmasse,jjb,jje, jjp1, llm, -2, 2, .TRUE., 1  )
     184! Ehouarn : we don't use/need finvmaold and finvmasse,
     185!           so might as well not compute them
     186!c      CALL   SCOPY( ijp1llm  , masse, 1, finvmasse,  1      )
     187!      ijb=ij_begin
     188!      ije=ij_end
     189!     
     190!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     191!      DO  l = 1,llm
     192!        finvmasse(ijb:ije,l)=masse(ijb:ije,l)
     193!      ENDDO
     194!c$OMP END DO NOWAIT
     195!
     196!      jjb=jj_begin
     197!      jje=jj_end
     198!      CALL filtreg_p( finvmasse,jjb,jje, jjp1, llm, -2, 2, .TRUE., 1  )
    182199c
    183200
    … …  
    330347      ENDIF
    331348     
    332 c         CALL  SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
    333 
    334 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    335       DO l = 1, llm     
    336         finvmaold(ijb:ije,l)=finvmasse(ijb:ije,l)       
    337       ENDDO
    338 c$OMP END DO NOWAIT
     349! Ehouarn: forget about finvmaold
     350!c         CALL  SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
     351!
     352!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     353!      DO l = 1, llm     
     354!        finvmaold(ijb:ije,l)=finvmasse(ijb:ije,l)       
     355!      ENDDO
     356!c$OMP END DO NOWAIT
    339357
    340358      endif ! of if (planet_type.eq."earth")

  • trunk/LMDZ.COMMON/libf/dyn3dpar/leapfrog_p.F

    r500 r776  
    132132      REAL  SSUM
    133133      REAL time_0
    134       REAL,SAVE :: finvmaold(ip1jmp1,llm)
     134!      REAL,SAVE :: finvmaold(ip1jmp1,llm)
    135135
    136136cym      LOGICAL  lafin
    … …  
    272272
    273273      CALL pression ( ip1jmp1, ap, bp, ps, p       )
    274       if (disvert_type==1) then
     274      if (pressure_exner) then
    275275        CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
    276       else ! we assume that we are in the disvert_type==2 case
     276      else
    277277        CALL exner_milieu( ip1jmp1, ps, p, beta, pks, pk, pkf )
    278278      endif
    … …  
    283283c et du parallelisme !!
    284284
    285    1  CONTINUE
     285   1  CONTINUE ! Matsuno Forward step begins here
    286286
    287287      jD_cur = jD_ref + day_ini - day_ref +                             &
    288      &          int (itau * dtvr / daysec)
     288     &          itau/day_step
    289289      jH_cur = jH_ref + start_time +                                    &
    290      &          (itau * dtvr / daysec - int(itau * dtvr / daysec))
     290     &         mod(itau,day_step)/float(day_step)
    291291      if (jH_cur > 1.0 ) then
    292292        jD_cur = jD_cur +1.
    … …  
    324324         psm1= ps
    325325         
    326          finvmaold = masse
    327          CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
     326! Ehouarn: finvmaold is actually not used       
     327!         finvmaold = masse
     328!         CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
    328329c$OMP END MASTER
    329330c$OMP BARRIER
    … …  
    343344           tetam1   (ijb:ije,l) = teta  (ijb:ije,l)
    344345           massem1  (ijb:ije,l) = masse (ijb:ije,l)
    345            finvmaold(ijb:ije,l)=masse(ijb:ije,l)
     346!           finvmaold(ijb:ije,l)=masse(ijb:ije,l)
    346347                 
    347348           if (pole_sud) ije=ij_end-iip1
    … …  
    353354
    354355
    355           CALL filtreg_p ( finvmaold ,jj_begin,jj_end,jjp1,
    356      .                    llm, -2,2, .TRUE., 1 )
     356! Ehouarn: finvmaold not used
     357!          CALL filtreg_p ( finvmaold ,jj_begin,jj_end,jjp1,
     358!     .                    llm, -2,2, .TRUE., 1 )
    357359
    358360       endif ! of if (FirstCaldyn)
    … …  
    370372cym      call minmax(ijp1llm,q(:,:,3),zqmin,zqmax)
    371373
    372    2  CONTINUE
     374   2  CONTINUE ! Matsuno backward or leapfrog step begins here
    373375
    374376c$OMP MASTER
    … …  
    515517         call Register_SwapFieldHallo(phi,phi,ip1jmp1,llm,
    516518     &                                jj_Nb_caldyn,0,0,TestRequest)
    517          call Register_SwapFieldHallo(finvmaold,finvmaold,ip1jmp1,llm,
    518      &                                jj_Nb_caldyn,0,0,TestRequest)
     519!         call Register_SwapFieldHallo(finvmaold,finvmaold,ip1jmp1,llm,
     520!     &                                jj_Nb_caldyn,0,0,TestRequest)
    519521 
    520522        do j=1,nqtot
    … …  
    616618      call start_timer(timer_caldyn)
    617619
     620      ! compute geopotential phi()
    618621! ADAPTATION GCM POUR CP(T)
    619622!      CALL geopot_p  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
    … …  
    699702
    700703       CALL integrd_p ( 2,vcovm1,ucovm1,tetam1,psm1,massem1 ,
    701      $         dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis ,
    702      $              finvmaold                                    )
     704     $         dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis )
     705!     $              finvmaold                                    )
    703706
    704707       IF ((planet_type.eq."titan").and.(tidal)) then
    … …  
    773776
    774777c$OMP BARRIER
    775          if (disvert_type==1) then
     778         if (pressure_exner) then
    776779           CALL exner_hyb_p(  ip1jmp1, ps, p,alpha,beta,pks, pk, pkf )
    777          else ! we assume that we are in the disvert_type==2 case
     780         else
    778781           CALL exner_milieu_p( ip1jmp1, ps, p, beta, pks, pk, pkf )
    779782         endif
    780783c$OMP BARRIER
    781784           jD_cur = jD_ref + day_ini - day_ref
    782      $        + int (itau * dtvr / daysec)
     785     $        + itau/day_step
    783786           jH_cur = jH_ref + start_time +                                &
    784      &              (itau * dtvr / daysec - int(itau * dtvr / daysec))
     787     &              mod(itau,day_step)/float(day_step)
    785788!         call ju2ymds(jD_cur+jH_cur, an, mois, jour, secondes)
    786789           if (jH_cur > 1.0 ) then
    … …  
    803806! Ehouarn: be careful, diagedyn is Earth-specific (includes ../phylmd/..)!
    804807           IF (planet_type.eq."earth") THEN
     808#ifdef CPP_EARTH
    805809            CALL diagedyn(ztit,2,1,1,dtphys
    806810     &    , ucov    , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
     811#endif
    807812           ENDIF
    808813      ENDIF
    … …  
    11311136        CALL pression_p ( ip1jmp1, ap, bp, ps, p                  )
    11321137c$OMP BARRIER
    1133         if (disvert_type==1) then
     1138        if (pressure_exner) then
    11341139          CALL exner_hyb_p( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
    1135         else ! we assume that we are in the disvert_type==2 case
     1140        else
    11361141          CALL exner_milieu_p( ip1jmp1, ps, p, beta, pks, pk, pkf )
    11371142        endif
    … …  
    12951300c$OMP END DO NOWAIT
    12961301
     1302         if (1 == 0) then
     1303!!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics
     1304!!!                     2) should probably not be here anyway
     1305!!! but are kept for those who would want to revert to previous behaviour
    12971306c$OMP MASTER               
    12981307          DO ij =  1,iim
    … …  
    13051314          ENDDO
    13061315c$OMP END MASTER
    1307         endif
     1316         endif ! of if (1 == 0)
     1317        endif ! of of (pole_nord)
    13081318       
    13091319        if (pole_sud) then
    … …  
    13211331c$OMP END DO NOWAIT
    13221332
     1333         if (1 == 0) then
     1334!!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics
     1335!!!                     2) should probably not be here anyway
     1336!!! but are kept for those who would want to revert to previous behaviour
    13231337c$OMP MASTER               
    13241338          DO ij =  1,iim
    … …  
    13311345          ENDDO
    13321346c$OMP END MASTER
    1333         endif
     1347         endif ! of if (1 == 0)
     1348        endif ! of if (pole_sud)
    13341349
    13351350

  • trunk/LMDZ.COMMON/libf/dyn3dpar/mod_interface_dyn_phys.F90

    r1 r776  
    11!
    2 ! $Id: mod_interface_dyn_phys.F90 1279 2009-12-10 09:02:56Z fairhead $
     2! $Id: mod_interface_dyn_phys.F90 1615 2012-02-10 15:42:26Z emillour $
    33!
    44MODULE mod_interface_dyn_phys
    … …  
    77 
    88 
    9 #ifdef CPP_EARTH
     9#ifdef CPP_PHYS
    1010! Interface with parallel physics,
    11 ! for now this routine only works with Earth physics
    1211CONTAINS
    1312 
    … …  
    5655  END SUBROUTINE Init_interface_dyn_phys
    5756#endif
    58 ! of #ifdef CPP_EARTH
     57! of #ifdef CPP_PHYS
    5958END MODULE mod_interface_dyn_phys

  • trunk/LMDZ.COMMON/libf/dyn3dpar/wrgrads.F

    r1 r776  
    1717      integer if,nl
    1818      real field(imx*jmx*lmx)
     19
     20      integer, parameter:: wp = selected_real_kind(p=6, r=36)
     21      real(wp) field4(imx*jmx*lmx)
     22
    1923      character*10 name,file
    2024      character*10 titlevar
    … …  
    2226c   local
    2327
    24       integer im,jm,lm,i,j,l,lnblnk,iv,iii,iji,iif,ijf
     28      integer im,jm,lm,i,j,l,iv,iii,iji,iif,ijf
    2529
    2630      logical writectl
    … …  
    2933      writectl=.false.
    3034
    31       print*,if,iid(if),jid(if),ifd(if),jfd(if)
     35c     print*,if,iid(if),jid(if),ifd(if),jfd(if)
    3236      iii=iid(if)
    3337      iji=jid(if)
    … …  
    3842      lm=lmd(if)
    3943
    40       print*,'im,jm,lm,name,firsttime(if)'
    41       print*,im,jm,lm,name,firsttime(if)
     44c     print*,'im,jm,lm,name,firsttime(if)'
     45c     print*,im,jm,lm,name,firsttime(if)
    4246
    4347      if(firsttime(if)) then
    … …  
    5559            nvar(if)=ivar(if)
    5660            var(ivar(if),if)=name
    57             tvar(ivar(if),if)=titlevar(1:lnblnk(titlevar))
     61            tvar(ivar(if),if)=trim(titlevar)
    5862            nld(ivar(if),if)=nl
    59             print*,'initialisation ecriture de ',var(ivar(if),if)
    60             print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if)
     63c           print*,'initialisation ecriture de ',var(ivar(if),if)
     64c           print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if)
    6165         endif
    6266         writectl=.true.
    … …  
    8185      endif
    8286
    83       print*,'ivar(if),nvar(if),var(ivar(if),if),writectl'
    84       print*,ivar(if),nvar(if),var(ivar(if),if),writectl
     87c     print*,'ivar(if),nvar(if),var(ivar(if),if),writectl'
     88c     print*,ivar(if),nvar(if),var(ivar(if),if),writectl
     89      field4(1:imd(if)*jmd(if)*nl)=field(1:imd(if)*jmd(if)*nl)
    8590      do l=1,nl
    8691         irec(if)=irec(if)+1
    … …  
    8994c    s ,(l-1)*imd(if)*jmd(if)+(ijf-1)*imd(if)+iif
    9095         write(unit(if)+1,rec=irec(if))
    91      s   ((field((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i)
     96     s   ((field4((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i)
    9297     s   ,i=iii,iif),j=iji,ijf)
    9398      enddo
    … …  
    96101      file=fichier(if)
    97102c   WARNING! on reecrase le fichier .ctl a chaque ecriture
    98       open(unit(if),file=file(1:lnblnk(file))//'.ctl'
     103      open(unit(if),file=trim(file)//'.ctl'
    99104     &         ,form='formatted',status='unknown')
    100105      write(unit(if),'(a5,1x,a40)')
    101      &       'DSET ','^'//file(1:lnblnk(file))//'.dat'
     106     &       'DSET ','^'//trim(file)//'.dat'
    102107
    103108      write(unit(if),'(a12)') 'UNDEF 1.0E30'
Note: See TracChangeset for help on using the changeset viewer.