Ignore:
Timestamp:
Jun 15, 2015, 8:48:31 PM (9 years ago)
Author:
dcugnet
Message:

In dyn3d/:
etat0dyn_netcdf.F90: "startget_dyn3d" syntax slightly simplified.
dynredem.F90: Shortcut routines (put_var*, cre_var,
dynredem_write_*, dynredem_read_u)

modified to match dyn3dmem version and put in

module dyredem_mod.F90.
dynetat0.F90 -> *.f90: Few simplifications (no usage of NC_DOUBLE
needed => no precompilation)

Add tracers initialization in the isotope case

suppressed by accident.
dynredem_mod.F90: Created to mimic dyn3dmem equivalent.

In dyn3dmem/:
dynetat0_loc.F -> *.f90: Converted into fortran 90 to match the dyn3d
version.
dynredem_loc.F -> *.F90: Converted into fortran 90.
dynredem_mod.F90: Add some shortcut routines to match the dyn3d
version.

In phylmd/:
phyredem.F90: Bug fix: nsw instead of nsoilmx was used as
Tsoil second maximum index.

Bug fix: fevap instead of snow was saved for

"SNOW".
etat0phys_netcdf.F90: "filtreg_mod" module usage suppressed.

Local variable rugo computation removed (not

used).

In dynlonlat_phylonlat/:
grid_atob_m.F90 -> *.f90 DOUBLE PRECISION variables usage removed.

Precompilation o longer needed => .F90 extension.

File:
1 moved

Legend:

Unmodified
Added
Removed

  • LMDZ5/trunk/libf/dyn3dmem/dynetat0_loc.f90

    r2298 r2299  
     1SUBROUTINE dynetat0_loc(fichnom,vcov,ucov,teta,q,masse,ps,phis,time)
    12!
    2 ! $Id$
     3!-------------------------------------------------------------------------------
     4! Authors: P. Le Van , L.Fairhead
     5!-------------------------------------------------------------------------------
     6! Purpose: Initial state reading.
     7!-------------------------------------------------------------------------------
     8  USE parallel_lmdz
     9  USE infotrac
     10  USE netcdf, ONLY: NF90_OPEN,  NF90_INQUIRE_DIMENSION, NF90_INQ_VARID,        &
     11      NF90_NOWRITE, NF90_CLOSE, NF90_INQUIRE_VARIABLE,  NF90_GET_VAR, NF90_NoErr
     12  USE control_mod, ONLY: planet_type
     13  USE assert_eq_m, ONLY: assert_eq
     14  IMPLICIT NONE
     15  include "dimensions.h"
     16  include "paramet.h"
     17  include "temps.h"
     18  include "comconst.h"
     19  include "comvert.h"
     20  include "comgeom.h"
     21  include "ener.h"
     22  include "description.h"
     23  include "serre.h"
     24  include "logic.h"
     25  include "iniprint.h"
     26!===============================================================================
     27! Arguments:
     28  CHARACTER(LEN=*), INTENT(IN) :: fichnom          !--- FILE NAME
     29  REAL, INTENT(OUT) ::  vcov(ijb_v:ije_v,llm)      !--- V COVARIANT WIND
     30  REAL, INTENT(OUT) ::  ucov(ijb_u:ije_u,llm)      !--- U COVARIANT WIND
     31  REAL, INTENT(OUT) ::  teta(ijb_u:ije_u,llm)      !--- POTENTIAL TEMP.
     32  REAL, INTENT(OUT) ::     q(ijb_u:ije_u,llm,nqtot)!--- TRACERS
     33  REAL, INTENT(OUT) :: masse(ijb_u:ije_u,llm)      !--- MASS PER CELL
     34  REAL, INTENT(OUT) ::    ps(ijb_u:ije_u)          !--- GROUND PRESSURE
     35  REAL, INTENT(OUT) ::  phis(ijb_u:ije_u)          !--- GEOPOTENTIAL
     36!===============================================================================
     37! Local variables:
     38  CHARACTER(LEN=256) :: msg, var, modname
     39  INTEGER, PARAMETER :: length=100
     40  INTEGER :: iq, fID, vID, idecal, ierr
     41  REAL    :: time, tab_cntrl(length)               !--- RUN PARAMS TABLE
     42  REAL,             ALLOCATABLE :: vcov_glo(:,:),masse_glo(:,:),   ps_glo(:)
     43  REAL,             ALLOCATABLE :: ucov_glo(:,:),    q_glo(:,:), phis_glo(:)
     44  REAL,             ALLOCATABLE :: teta_glo(:,:)
     45!-------------------------------------------------------------------------------
     46  modname="dynetat0_loc"
     47
     48!--- Initial state file opening
     49  var=fichnom
     50  CALL err(NF90_OPEN(var,NF90_NOWRITE,fID),"open",var)
     51  CALL get_var1("controle",tab_cntrl)
     52
     53!!! AS: idecal is a hack to be able to read planeto starts...
     54!!!     .... while keeping everything OK for LMDZ EARTH
     55  IF(planet_type=="generic") THEN
     56    WRITE(lunout,*)'NOTE NOTE NOTE : Planeto-like start files'
     57    idecal = 4
     58    annee_ref  = 2000
     59  ELSE
     60    WRITE(lunout,*)'NOTE NOTE NOTE : Earth-like start files'
     61    idecal = 5
     62    annee_ref  = tab_cntrl(5)
     63  END IF
     64  im         = tab_cntrl(1)
     65  jm         = tab_cntrl(2)
     66  lllm       = tab_cntrl(3)
     67  day_ref    = tab_cntrl(4)
     68  rad        = tab_cntrl(idecal+1)
     69  omeg       = tab_cntrl(idecal+2)
     70  g          = tab_cntrl(idecal+3)
     71  cpp        = tab_cntrl(idecal+4)
     72  kappa      = tab_cntrl(idecal+5)
     73  daysec     = tab_cntrl(idecal+6)
     74  dtvr       = tab_cntrl(idecal+7)
     75  etot0      = tab_cntrl(idecal+8)
     76  ptot0      = tab_cntrl(idecal+9)
     77  ztot0      = tab_cntrl(idecal+10)
     78  stot0      = tab_cntrl(idecal+11)
     79  ang0       = tab_cntrl(idecal+12)
     80  pa         = tab_cntrl(idecal+13)
     81  preff      = tab_cntrl(idecal+14)
    382!
    4       SUBROUTINE dynetat0_loc(fichnom,vcov,ucov,
    5      .                    teta,q,masse,ps,phis,time)
    6       USE infotrac
    7       use control_mod, only : planet_type
    8       USE parallel_lmdz
    9       IMPLICIT NONE
    10 
    11 c=======================================================================
    12 c
    13 c   Auteur:  P. Le Van / L.Fairhead
    14 c   -------
    15 c
    16 c   objet:
    17 c   ------
    18 c
    19 c   Lecture de l'etat initial
    20 c
    21 c=======================================================================
    22 c-----------------------------------------------------------------------
    23 c   Declarations:
    24 c   -------------
    25 
    26 #include "dimensions.h"
    27 #include "paramet.h"
    28 #include "temps.h"
    29 #include "comconst.h"
    30 #include "comvert.h"
    31 #include "comgeom.h"
    32 #include "ener.h"
    33 #include "netcdf.inc"
    34 #include "description.h"
    35 #include "serre.h"
    36 #include "logic.h"
    37 #include "iniprint.h"
    38 
    39 c   Arguments:
    40 c   ----------
    41 
    42       CHARACTER*(*) fichnom
    43       REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
    44       REAL teta(ijb_u:ije_u,llm)
    45       REAL q(ijb_u:ije_u,llm,nqtot),masse(ijb_u:ije_u,llm)
    46       REAL ps(ijb_u:ije_u),phis(ijb_u:ije_u)
    47 
    48       REAL time
    49 
    50 c   Variables
    51 c
    52       INTEGER length,iq
    53       PARAMETER (length = 100)
    54       REAL tab_cntrl(length) ! tableau des parametres du run
    55       INTEGER ierr, nid, nvarid
    56       REAL,ALLOCATABLE :: vcov_glo(:,:),ucov_glo(:,:),teta_glo(:,:)
    57       REAL,ALLOCATABLE :: q_glo(:,:),masse_glo(:,:),ps_glo(:)
    58       REAL,ALLOCATABLE :: phis_glo(:)
    59 
    60       INTEGER idecal
    61 
    62 c-----------------------------------------------------------------------
    63 c  Ouverture NetCDF du fichier etat initial
    64 
    65       ierr = NF_OPEN (fichnom, NF_NOWRITE,nid)
    66       IF (ierr.NE.NF_NOERR) THEN
    67         write(lunout,*)
    68      &  'dynetat0_loc: Pb d''ouverture du fichier start.nc'
    69         write(lunout,*)' ierr = ', ierr
    70         CALL ABORT_GCM("DYNETAT0", "", 1)
    71       ENDIF
    72 
    73 c
    74       ierr = NF_INQ_VARID (nid, "controle", nvarid)
    75       IF (ierr .NE. NF_NOERR) THEN
    76          write(lunout,*)"dynetat0_loc: Le champ <controle> est absent"
    77          CALL abort_gcm("dynetat0", "", 1)
    78       ENDIF
    79 #ifdef NC_DOUBLE
    80       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
    81 #else
    82       ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
    83 #endif
    84       IF (ierr .NE. NF_NOERR) THEN
    85          write(lunout,*)"dynetat0_loc: Lecture echoue pour <controle>"
    86          CALL abort_gcm("dynetat0", "", 1)
    87       ENDIF
    88 
    89       !!! AS: idecal is a hack to be able to read planeto starts...
    90       !!!     .... while keeping everything OK for LMDZ EARTH
    91       if (planet_type.eq."generic") then
    92           print*,'NOTE NOTE NOTE : Planeto-like start files'
    93           idecal = 4
    94           annee_ref  = 2000
    95       else
    96           print*,'NOTE NOTE NOTE : Earth-like start files'
    97           idecal = 5
    98           annee_ref  = tab_cntrl(5)
    99       endif
    100 
    101 
    102       im         = tab_cntrl(1)
    103       jm         = tab_cntrl(2)
    104       lllm       = tab_cntrl(3)
    105       day_ref    = tab_cntrl(4)
    106       rad        = tab_cntrl(idecal+1)
    107       omeg       = tab_cntrl(idecal+2)
    108       g          = tab_cntrl(idecal+3)
    109       cpp        = tab_cntrl(idecal+4)
    110       kappa      = tab_cntrl(idecal+5)
    111       daysec     = tab_cntrl(idecal+6)
    112       dtvr       = tab_cntrl(idecal+7)
    113       etot0      = tab_cntrl(idecal+8)
    114       ptot0      = tab_cntrl(idecal+9)
    115       ztot0      = tab_cntrl(idecal+10)
    116       stot0      = tab_cntrl(idecal+11)
    117       ang0       = tab_cntrl(idecal+12)
    118       pa         = tab_cntrl(idecal+13)
    119       preff      = tab_cntrl(idecal+14)
    120 c
    121       clon       = tab_cntrl(idecal+15)
    122       clat       = tab_cntrl(idecal+16)
    123       grossismx  = tab_cntrl(idecal+17)
    124       grossismy  = tab_cntrl(idecal+18)
    125 c
    126       IF ( tab_cntrl(idecal+19).EQ.1. )  THEN
    127         fxyhypb  = . TRUE .
    128 c        dzoomx   = tab_cntrl(25)
    129 c        dzoomy   = tab_cntrl(26)
    130 c        taux     = tab_cntrl(28)
    131 c        tauy     = tab_cntrl(29)
    132       ELSE
    133         fxyhypb = . FALSE .
    134         ysinus  = . FALSE .
    135         IF( tab_cntrl(idecal+22).EQ.1. ) ysinus = . TRUE.
    136       ENDIF
    137 
    138       day_ini = tab_cntrl(30)
    139       itau_dyn = tab_cntrl(31)
    140 c   .................................................................
    141 c
    142 c
    143       write(lunout,*)'dynetat0_loc: rad,omeg,g,cpp,kappa',
    144      &               rad,omeg,g,cpp,kappa
    145 
    146       IF(   im.ne.iim           )  THEN
    147           PRINT 1,im,iim
    148           STOP
    149       ELSE  IF( jm.ne.jjm       )  THEN
    150           PRINT 2,jm,jjm
    151           STOP
    152       ELSE  IF( lllm.ne.llm     )  THEN
    153           PRINT 3,lllm,llm
    154           STOP
    155       ENDIF
    156 
    157       ierr = NF_INQ_VARID (nid, "rlonu", nvarid)
    158       IF (ierr .NE. NF_NOERR) THEN
    159          write(lunout,*)"dynetat0_loc: Le champ <rlonu> est absent"
    160          CALL abort_gcm("dynetat0", "", 1)
    161       ENDIF
    162 #ifdef NC_DOUBLE
    163       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonu)
    164 #else
    165       ierr = NF_GET_VAR_REAL(nid, nvarid, rlonu)
    166 #endif
    167       IF (ierr .NE. NF_NOERR) THEN
    168          write(lunout,*)"dynetat0_loc: Lecture echouee pour <rlonu>"
    169          CALL abort_gcm("dynetat0", "", 1)
    170       ENDIF
    171 
    172       ierr = NF_INQ_VARID (nid, "rlatu", nvarid)
    173       IF (ierr .NE. NF_NOERR) THEN
    174          write(lunout,*)"dynetat0_loc: Le champ <rlatu> est absent"
    175          CALL abort_gcm("dynetat0", "", 1)
    176       ENDIF
    177 #ifdef NC_DOUBLE
    178       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatu)
    179 #else
    180       ierr = NF_GET_VAR_REAL(nid, nvarid, rlatu)
    181 #endif
    182       IF (ierr .NE. NF_NOERR) THEN
    183          write(lunout,*)"dynetat0_loc: Lecture echouee pour <rlatu>"
    184          CALL abort_gcm("dynetat0", "", 1)
    185       ENDIF
    186 
    187       ierr = NF_INQ_VARID (nid, "rlonv", nvarid)
    188       IF (ierr .NE. NF_NOERR) THEN
    189          write(lunout,*)"dynetat0_loc: Le champ <rlonv> est absent"
    190          CALL abort_gcm("dynetat0", "", 1)
    191       ENDIF
    192 #ifdef NC_DOUBLE
    193       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonv)
    194 #else
    195       ierr = NF_GET_VAR_REAL(nid, nvarid, rlonv)
    196 #endif
    197       IF (ierr .NE. NF_NOERR) THEN
    198          write(lunout,*)"dynetat0_loc: Lecture echouee pour <rlonv>"
    199          CALL abort_gcm("dynetat0", "", 1)
    200       ENDIF
    201 
    202       ierr = NF_INQ_VARID (nid, "rlatv", nvarid)
    203       IF (ierr .NE. NF_NOERR) THEN
    204          write(lunout,*)"dynetat0_loc: Le champ <rlatv> est absent"
    205          CALL abort_gcm("dynetat0", "", 1)
    206       ENDIF
    207 #ifdef NC_DOUBLE
    208       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatv)
    209 #else
    210       ierr = NF_GET_VAR_REAL(nid, nvarid, rlatv)
    211 #endif
    212       IF (ierr .NE. NF_NOERR) THEN
    213          write(lunout,*)"dynetat0_loc: Lecture echouee pour rlatv"
    214          CALL abort_gcm("dynetat0", "", 1)
    215       ENDIF
    216 
    217       ierr = NF_INQ_VARID (nid, "cu", nvarid)
    218       IF (ierr .NE. NF_NOERR) THEN
    219          write(lunout,*)"dynetat0_loc: Le champ <cu> est absent"
    220          CALL abort_gcm("dynetat0", "", 1)
    221       ENDIF
    222 #ifdef NC_DOUBLE
    223       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cu)
    224 #else
    225       ierr = NF_GET_VAR_REAL(nid, nvarid, cu)
    226 #endif
    227       IF (ierr .NE. NF_NOERR) THEN
    228          write(lunout,*)"dynetat0_loc: Lecture echouee pour <cu>"
    229          CALL abort_gcm("dynetat0", "", 1)
    230       ENDIF
    231 
    232       ierr = NF_INQ_VARID (nid, "cv", nvarid)
    233       IF (ierr .NE. NF_NOERR) THEN
    234          write(lunout,*)"dynetat0_loc: Le champ <cv> est absent"
    235          CALL abort_gcm("dynetat0", "", 1)
    236       ENDIF
    237 #ifdef NC_DOUBLE
    238       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cv)
    239 #else
    240       ierr = NF_GET_VAR_REAL(nid, nvarid, cv)
    241 #endif
    242       IF (ierr .NE. NF_NOERR) THEN
    243          write(lunout,*)"dynetat0_loc: Lecture echouee pour <cv>"
    244          CALL abort_gcm("dynetat0", "", 1)
    245       ENDIF
    246 
    247       ierr = NF_INQ_VARID (nid, "aire", nvarid)
    248       IF (ierr .NE. NF_NOERR) THEN
    249          write(lunout,*)"dynetat0_loc: Le champ <aire> est absent"
    250          CALL abort_gcm("dynetat0", "", 1)
    251       ENDIF
    252 #ifdef NC_DOUBLE
    253       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, aire)
    254 #else
    255       ierr = NF_GET_VAR_REAL(nid, nvarid, aire)
    256 #endif
    257       IF (ierr .NE. NF_NOERR) THEN
    258          write(lunout,*)"dynetat0_loc: Lecture echouee pour <aire>"
    259          CALL abort_gcm("dynetat0", "", 1)
    260       ENDIF
    261      
    262       ALLOCATE(phis_glo(ip1jmp1))
    263      
    264       ierr = NF_INQ_VARID (nid, "phisinit", nvarid)
    265       IF (ierr .NE. NF_NOERR) THEN
    266          write(lunout,*)"dynetat0_loc: Le champ <phisinit> est absent"
    267          CALL abort_gcm("dynetat0", "", 1)
    268       ENDIF
    269 #ifdef NC_DOUBLE
    270       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phis_glo)
    271 #else
    272       ierr = NF_GET_VAR_REAL(nid, nvarid, phis_glo)
    273 #endif
    274       IF (ierr .NE. NF_NOERR) THEN
    275          write(lunout,*)"dynetat0_loc: Lecture echouee pour <phisinit>"
    276          CALL abort_gcm("dynetat0", "", 1)
    277       ENDIF
    278       phis(ijb_u:ije_u)=phis_glo(ijb_u:ije_u)
    279       DEALLOCATE(phis_glo)
    280 
    281       ierr = NF_INQ_VARID (nid, "temps", nvarid)
    282       IF (ierr .NE. NF_NOERR) THEN
    283          write(lunout,*)"dynetat0: Le champ <temps> est absent"
    284          write(lunout,*)"dynetat0: J essaie <Time>"
    285          ierr = NF_INQ_VARID (nid, "Time", nvarid)
    286          IF (ierr .NE. NF_NOERR) THEN
    287             write(lunout,*)"dynetat0: Le champ <Time> est absent"
    288             CALL abort_gcm("dynetat0", "", 1)
    289          ENDIF
    290       ENDIF
    291 #ifdef NC_DOUBLE
    292       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, time)
    293 #else
    294       ierr = NF_GET_VAR_REAL(nid, nvarid, time)
    295 #endif
    296       IF (ierr .NE. NF_NOERR) THEN
    297          write(lunout,*)"dynetat0_loc: Lecture echouee <temps>"
    298          CALL abort_gcm("dynetat0", "", 1)
    299       ENDIF
    300 
    301       ierr = NF_INQ_VARID (nid, "ucov", nvarid)
    302       IF (ierr .NE. NF_NOERR) THEN
    303          write(lunout,*)"dynetat0_loc: Le champ <ucov> est absent"
    304          CALL abort_gcm("dynetat0", "", 1)
    305       ENDIF
    306      
    307       ALLOCATE(ucov_glo(ip1jmp1,llm))
    308      
    309 #ifdef NC_DOUBLE
    310       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ucov_glo)
    311 #else
    312       ierr = NF_GET_VAR_REAL(nid, nvarid, ucov_glo)
    313 #endif
    314       IF (ierr .NE. NF_NOERR) THEN
    315          write(lunout,*)"dynetat0_loc: Lecture echouee pour <ucov>"
    316          CALL abort_gcm("dynetat0", "", 1)
    317       ENDIF
    318 
    319       ucov(ijb_u:ije_u,:)=ucov_glo(ijb_u:ije_u,:)
    320       DEALLOCATE(ucov_glo)
    321       ALLOCATE(vcov_glo(ip1jm,llm))
    322      
    323       ierr = NF_INQ_VARID (nid, "vcov", nvarid)
    324       IF (ierr .NE. NF_NOERR) THEN
    325          write(lunout,*)"dynetat0_loc: Le champ <vcov> est absent"
    326          CALL abort_gcm("dynetat0", "", 1)
    327       ENDIF
    328 #ifdef NC_DOUBLE
    329       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, vcov_glo)
    330 #else
    331       ierr = NF_GET_VAR_REAL(nid, nvarid, vcov_glo)
    332 #endif
    333       IF (ierr .NE. NF_NOERR) THEN
    334          write(lunout,*)"dynetat0_loc: Lecture echouee pour <vcov>"
    335          CALL abort_gcm("dynetat0", "", 1)
    336       ENDIF
    337       vcov(ijb_v:ije_v,:)=vcov_glo(ijb_v:ije_v,:)
    338       DEALLOCATE(vcov_glo)
    339       ALLOCATE(teta_glo(ip1jmp1,llm))
    340 
    341       ierr = NF_INQ_VARID (nid, "teta", nvarid)
    342       IF (ierr .NE. NF_NOERR) THEN
    343          write(lunout,*)"dynetat0_loc: Le champ <teta> est absent"
    344          CALL abort_gcm("dynetat0", "", 1)
    345       ENDIF
    346 #ifdef NC_DOUBLE
    347       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, teta_glo)
    348 #else
    349       ierr = NF_GET_VAR_REAL(nid, nvarid, teta_glo)
    350 #endif
    351       IF (ierr .NE. NF_NOERR) THEN
    352          write(lunout,*)"dynetat0_loc: Lecture echouee pour <teta>"
    353          CALL abort_gcm("dynetat0", "", 1)
    354       ENDIF
    355 
    356       teta(ijb_u:ije_u,:)=teta_glo(ijb_u:ije_u,:)
    357       DEALLOCATE(teta_glo)
    358       ALLOCATE(q_glo(ip1jmp1,llm))
    359 
    360 
    361       DO iq=1,nqtot
    362         ierr =  NF_INQ_VARID (nid, tname(iq), nvarid)
    363         IF (ierr .NE. NF_NOERR) THEN
    364            write(lunout,*)"dynetat0_loc: Le traceur <"                  &
    365      &     //trim(tname(iq))//"> est absent"
    366            write(lunout,*)"Il est donc initialise a zero"
    367            q(:,:,iq)=0.
    368 
    369            ! CRisi: pour les isotopes, on peut faire init théorique
    370            ! distill de Rayleigh très simplifiée
    371            if (ok_isotopes) then
    372               if ((iso_num(iq).gt.0).and.(zone_num(iq).eq.0)) then
    373                 q(:,:,iq)=q(:,:,iqpere(iq))                             &
    374      &                   *tnat(iso_num(iq))                             &
    375      &                   *(q(:,:,iqpere(iq))/30.e-3)                    &
    376      &                   **(alpha_ideal(iso_num(iq))-1)
    377               endif
    378               if ((iso_num(iq).gt.0).and.(zone_num(iq).eq.1)) then
    379                   q(:,:,iq)=q(:,:,iqiso(iso_indnum(iq),phase_num(iq)))
    380               endif 
    381            endif !if (ok_isotopes) then       
    382 
    383         ELSE
    384 #ifdef NC_DOUBLE
    385           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q_glo)
    386 #else
    387           ierr = NF_GET_VAR_REAL(nid, nvarid, q_glo)
    388 #endif
    389           IF (ierr .NE. NF_NOERR) THEN
    390             write(lunout,*)
    391      &      "dynetat0_loc: Lecture echouee pour "//tname(iq)
    392             CALL abort_gcm("dynetat0", "", 1)
    393           ENDIF
    394         q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:)
    395 
    396         ENDIF
    397       ENDDO !DO iq=1,nqtot
    398 
    399       if (ok_iso_verif) then
    400          call check_isotopes(q,ijb_u,ije_u,'dynetat0_loc')
    401       endif !if (ok_iso_verif) then
    402 
    403       DEALLOCATE(q_glo)
    404       ALLOCATE(masse_glo(ip1jmp1,llm))
    405 
    406       ierr = NF_INQ_VARID (nid, "masse", nvarid)
    407       IF (ierr .NE. NF_NOERR) THEN
    408          write(lunout,*)"dynetat0_loc: Le champ <masse> est absent"
    409          CALL abort_gcm("dynetat0", "", 1)
    410       ENDIF
    411 #ifdef NC_DOUBLE
    412       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, masse_glo)
    413 #else
    414       ierr = NF_GET_VAR_REAL(nid, nvarid, masse_glo)
    415 #endif
    416       IF (ierr .NE. NF_NOERR) THEN
    417          write(lunout,*)"dynetat0_loc: Lecture echouee pour <masse>"
    418          CALL abort_gcm("dynetat0", "", 1)
    419       ENDIF
    420       masse(ijb_u:ije_u,:)=masse_glo(ijb_u:ije_u,:)
    421       DEALLOCATE(masse_glo)
    422       ALLOCATE(ps_glo(ip1jmp1))
    423 
    424       ierr = NF_INQ_VARID (nid, "ps", nvarid)
    425       IF (ierr .NE. NF_NOERR) THEN
    426          write(lunout,*)"dynetat0_loc: Le champ <ps> est absent"
    427          CALL abort_gcm("dynetat0", "", 1)
    428       ENDIF
    429 #ifdef NC_DOUBLE
    430       ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ps_glo)
    431 #else
    432       ierr = NF_GET_VAR_REAL(nid, nvarid, ps_glo)
    433 #endif
    434       IF (ierr .NE. NF_NOERR) THEN
    435          write(lunout,*)"dynetat0_loc: Lecture echouee pour <ps>"
    436          CALL abort_gcm("dynetat0", "", 1)
    437       ENDIF
    438 
    439       ps(ijb_u:ije_u)=ps_glo(ijb_u:ije_u)
    440       DEALLOCATE(ps_glo)
    441 
    442       ierr = NF_CLOSE(nid)
    443 
    444        day_ini=day_ini+INT(time)
    445        time=time-INT(time)
    446 
    447   1   FORMAT(//10x,'la valeur de im =',i4,2x,'lue sur le fichier de dem
    448      *arrage est differente de la valeur parametree iim =',i4//)
    449    2  FORMAT(//10x,'la valeur de jm =',i4,2x,'lue sur le fichier de dem
    450      *arrage est differente de la valeur parametree jjm =',i4//)
    451    3  FORMAT(//10x,'la valeur de lmax =',i4,2x,'lue sur le fichier dema
    452      *rrage est differente de la valeur parametree llm =',i4//)
    453    4  FORMAT(//10x,'la valeur de dtrv =',i4,2x,'lue sur le fichier dema
    454      *rrage est differente de la valeur  dtinteg =',i4//)
    455 
    456       RETURN
    457       END
     83  clon       = tab_cntrl(idecal+15)
     84  clat       = tab_cntrl(idecal+16)
     85  grossismx  = tab_cntrl(idecal+17)
     86  grossismy  = tab_cntrl(idecal+18)
     87!
     88  IF ( tab_cntrl(idecal+19)==1. )  THEN
     89    fxyhypb  = .TRUE.
     90!   dzoomx   = tab_cntrl(25)
     91!   dzoomy   = tab_cntrl(26)
     92!   taux     = tab_cntrl(28)
     93!   tauy     = tab_cntrl(29)
     94  ELSE
     95    fxyhypb = .FALSE.
     96    ysinus  = tab_cntrl(idecal+22)==1.
     97  END IF
     98
     99  day_ini    = tab_cntrl(30)
     100  itau_dyn   = tab_cntrl(31)
     101!  start_time = tab_cntrl(32)   ????
     102
     103!-------------------------------------------------------------------------------
     104  WRITE(lunout,*)TRIM(modname)//': rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa
     105  CALL check_dim(im,iim,'im','im')
     106  CALL check_dim(jm,jjm,'jm','jm')
     107  CALL check_dim(lllm,llm,'lm','lllm')
     108  CALL get_var1("rlonu",rlonu)
     109  CALL get_var1("rlatu",rlatu)
     110  CALL get_var1("rlonv",rlonv)
     111  CALL get_var1("rlatv",rlatv)
     112  CALL get_var1("cu"  ,cu)
     113  CALL get_var1("cv"  ,cv)
     114  CALL get_var1("aire",aire)
     115
     116  var="temps"
     117  IF(NF90_INQ_VARID(fID,var,vID)/=NF90_NoErr) THEN
     118    WRITE(lunout,*)TRIM(modname)//": missing field <temps>"
     119    WRITE(lunout,*)TRIM(modname)//": trying with <Time>"; var="Time"
     120    CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
     121  END IF
     122  CALL err(NF90_GET_VAR(fID,vID,time),"get",var)
     123
     124  ALLOCATE(phis_glo(ip1jmp1))
     125  CALL get_var1("phisinit",phis_glo)
     126  phis (ijb_u:ije_u)  =phis_glo(ijb_u:ije_u);    DEALLOCATE(phis_glo)
     127
     128  ALLOCATE(ucov_glo(ip1jmp1,llm))
     129  CALL get_var2("ucov",ucov_glo)
     130  ucov (ijb_u:ije_u,:)=ucov_glo(ijb_u:ije_u,:);  DEALLOCATE(ucov_glo)
     131
     132  ALLOCATE(vcov_glo(ip1jm,llm))
     133  CALL get_var2("vcov",vcov_glo)
     134  vcov (ijb_v:ije_v,:)=vcov_glo(ijb_v:ije_v,:);  DEALLOCATE(vcov_glo)
     135
     136  ALLOCATE(teta_glo(ip1jmp1,llm))
     137  CALL get_var2("teta",teta_glo)
     138  teta (ijb_u:ije_u,:)=teta_glo(ijb_u:ije_u,:);  DEALLOCATE(teta_glo)
     139
     140  ALLOCATE(masse_glo(ip1jmp1,llm))
     141  CALL get_var2("masse",masse_glo)
     142  masse(ijb_u:ije_u,:)=masse_glo(ijb_u:ije_u,:); DEALLOCATE(masse_glo)
     143 
     144  ALLOCATE(ps_glo(ip1jmp1))
     145  CALL get_var1("ps",ps_glo)
     146  ps   (ijb_u:ije_u)  =   ps_glo(ijb_u:ije_u);   DEALLOCATE(ps_glo)
     147
     148!--- Tracers
     149  ALLOCATE(q_glo(ip1jmp1,llm))
     150  DO iq=1,nqtot
     151    var=tname(iq)
     152    IF(NF90_INQ_VARID(fID,var,vID)==NF90_NoErr) THEN
     153      CALL get_var2(var,q_glo); q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:); CYCLE
     154    END IF
     155    WRITE(lunout,*)TRIM(modname)//": Tracer <"//TRIM(var)//"> is missing"
     156    WRITE(lunout,*)"         It is hence initialized to zero"
     157    q(ijb_u:ije_u,:,iq)=0.
     158   !--- CRisi: for isotops, theoretical initialization using very simplified
     159   !           Rayleigh distillation las.
     160    IF(ok_isotopes.AND.iso_num(iq)>0) THEN
     161      IF(zone_num(iq)==0) q(:,:,iq)=q(:,:,iqpere(iq))*tnat(iso_num(iq))        &
     162     &           *(q(:,:,iqpere(iq))/30.e-3)**(alpha_ideal(iso_num(iq))-1)
     163      IF(zone_num(iq)==1) q(:,:,iq)=q(:,:,iqiso(iso_indnum(iq),phase_num(iq)))
     164    END IF
     165  END DO
     166  DEALLOCATE(q_glo)
     167  CALL err(NF90_CLOSE(fID),"close",fichnom)
     168  day_ini=day_ini+INT(time)
     169  time=time-INT(time)
     170
     171
     172  CONTAINS
     173
     174
     175SUBROUTINE check_dim(n1,n2,str1,str2)
     176  INTEGER,          INTENT(IN) :: n1, n2
     177  CHARACTER(LEN=*), INTENT(IN) :: str1, str2
     178  CHARACTER(LEN=256) :: s1, s2
     179  IF(n1/=n2) THEN
     180    s1='value of '//TRIM(str1)//' ='
     181    s2=' read in starting file differs from parametrized '//TRIM(str2)//' ='
     182    WRITE(msg,'(10x,a,i4,2x,a,i4)'),s1,n1,s2,n2
     183    CALL ABORT_gcm(TRIM(modname),TRIM(msg),1)
     184  END IF
     185END SUBROUTINE check_dim
     186
     187
     188SUBROUTINE get_var1(var,v)
     189  CHARACTER(LEN=*), INTENT(IN)  :: var
     190  REAL,             INTENT(OUT) :: v(:)
     191  REAL,             ALLOCATABLE :: w2(:,:), w3(:,:,:)
     192  INTEGER :: nn(3), dids(3), k, nd, ntot
     193
     194  CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
     195  ierr=NF90_INQUIRE_VARIABLE(fID,vID,ndims=nd)
     196  IF(nd==1) THEN
     197    CALL err(NF90_GET_VAR(fID,vID,v),"get",var); RETURN
     198  END IF
     199  ierr=NF90_INQUIRE_VARIABLE(fID,vID,dimids=dids)
     200  DO k=1,nd; ierr=NF90_INQUIRE_DIMENSION(fID,dids(k),len=nn(k)); END DO
     201  ntot=PRODUCT(nn(1:nd))
     202  SELECT CASE(nd)
     203    CASE(2); ALLOCATE(w2(nn(1),nn(2)))
     204      CALL err(NF90_GET_VAR(fID,vID,w2),"get",var)
     205      v=RESHAPE(w2,[ntot]); DEALLOCATE(w2)
     206    CASE(3); ALLOCATE(w3(nn(1),nn(2),nn(3)))
     207      CALL err(NF90_GET_VAR(fID,vID,w3),"get",var)
     208      v=RESHAPE(w3,[ntot]); DEALLOCATE(w3)
     209  END SELECT
     210END SUBROUTINE get_var1
     211
     212
     213SUBROUTINE get_var2(var,v)
     214  CHARACTER(LEN=*), INTENT(IN)  :: var
     215  REAL,             INTENT(OUT) :: v(:,:)
     216  REAL,             ALLOCATABLE :: w4(:,:,:,:)
     217  INTEGER :: nn(4), dids(4), k, nd
     218  CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
     219  ierr=NF90_INQUIRE_VARIABLE(fID,vID,dimids=dids,ndims=nd)
     220  DO k=1,nd; ierr=NF90_INQUIRE_DIMENSION(fID,dids(k),len=nn(k)); END DO
     221  ALLOCATE(w4(nn(1),nn(2),nn(3),nn(4)))
     222  CALL err(NF90_GET_VAR(fID,vID,w4),"get",var)
     223  v=RESHAPE(w4,[nn(1)*nn(2),nn(3)]); DEALLOCATE(w4)
     224END SUBROUTINE get_var2
     225
     226
     227SUBROUTINE err(ierr,typ,nam)
     228  INTEGER,          INTENT(IN) :: ierr   !--- NetCDF ERROR CODE
     229  CHARACTER(LEN=*), INTENT(IN) :: typ    !--- TYPE OF OPERATION
     230  CHARACTER(LEN=*), INTENT(IN) :: nam    !--- FIELD/FILE NAME
     231  IF(ierr==NF90_NoERR) RETURN
     232  SELECT CASE(typ)
     233    CASE('inq');   msg="Field <"//TRIM(nam)//"> is missing"
     234    CASE('get');   msg="Reading failed for <"//TRIM(nam)//">"
     235    CASE('open');  msg="File opening failed for <"//TRIM(nam)//">"
     236    CASE('close'); msg="File closing failed for <"//TRIM(nam)//">"
     237  END SELECT
     238  CALL ABORT_gcm(TRIM(modname),TRIM(msg),ierr)
     239END SUBROUTINE err
     240
     241END SUBROUTINE dynetat0_loc
Note: See TracChangeset for help on using the changeset viewer.