source: LMDZ6/branches/Amaury_posttrusting/libf/dyn3dmem/dynetat0_loc.f90 @ 5356

Last change on this file since 5356 was 5285, checked in by abarral, 13 months ago

As discussed internally, remove generic ONLY: ... for new _mod_h modules
  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
File size: 12.8 KB
Line 
1SUBROUTINE dynetat0_loc(fichnom,vcov,ucov,teta,q,masse,ps,phis,time)
2!
3!-------------------------------------------------------------------------------
4! Authors: P. Le Van , L.Fairhead
5!-------------------------------------------------------------------------------
6! Purpose: Initial state reading.
7!-------------------------------------------------------------------------------
8  USE iniprint_mod_h
9  USE comgeom_mod_h
10  USE parallel_lmdz
11  USE infotrac,    ONLY: nqtot, tracers, niso, iqIsoPha, iH2O, isoName, &
12                         new2oldH2O, newHNO3, oldHNO3
13  USE strings_mod, ONLY: maxlen, msg, strStack, real2str, int2str, strIdx
14  USE netcdf,      ONLY: NF90_OPEN,  NF90_NOWRITE, NF90_INQUIRE_DIMENSION, NF90_INQ_VARID, &
15                         NF90_CLOSE, NF90_GET_VAR, NF90_INQUIRE_VARIABLE,  NF90_NoErr
16  USE control_mod, ONLY: planet_type
17  USE assert_eq_m, ONLY: assert_eq
18  USE comvert_mod, ONLY: pa,preff
19  USE comconst_mod, ONLY: cpp, daysec, dtvr, g, im, jm, kappa, lllm, omeg, rad
20  USE logic_mod, ONLY: fxyhypb, ysinus
21  USE serre_mod, ONLY: clon, clat, grossismx, grossismy
22  USE temps_mod, ONLY: annee_ref, day_ini, day_ref, itau_dyn, start_time
23  USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0
24  USE IOIPSL,   ONLY: getin
25  USE iso_params_mod   ! tnat_* and alpha_ideal_*
26  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA, CPPKEY_REPROBUS
27
28  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
29USE paramet_mod_h
30IMPLICIT NONE
31
32
33  !===============================================================================
34! Arguments:
35  CHARACTER(LEN=*), INTENT(IN) :: fichnom          !--- FILE NAME
36  REAL, INTENT(OUT) ::  vcov(ijb_v:ije_v,llm)      !--- V COVARIANT WIND
37  REAL, INTENT(OUT) ::  ucov(ijb_u:ije_u,llm)      !--- U COVARIANT WIND
38  REAL, INTENT(OUT) ::  teta(ijb_u:ije_u,llm)      !--- POTENTIAL TEMP.
39  REAL, INTENT(OUT) ::     q(ijb_u:ije_u,llm,nqtot)!--- TRACERS
40  REAL, INTENT(OUT) :: masse(ijb_u:ije_u,llm)      !--- MASS PER CELL
41  REAL, INTENT(OUT) ::    ps(ijb_u:ije_u)          !--- GROUND PRESSURE
42  REAL, INTENT(OUT) ::  phis(ijb_u:ije_u)          !--- GEOPOTENTIAL
43!===============================================================================
44! Local variables:
45  CHARACTER(LEN=maxlen) :: mesg, var, modname, oldVar
46  INTEGER, PARAMETER :: length=100
47  INTEGER :: iq, fID, vID, idecal, ierr, iqParent, iName, iZone, iPhase, ix
48  REAL    :: time,tab_cntrl(length)    !--- RUN PARAMS TABLE
49  REAL    :: tnat, alpha_ideal
50  REAL,             ALLOCATABLE :: vcov_glo(:,:),masse_glo(:,:),   ps_glo(:)
51  REAL,             ALLOCATABLE :: ucov_glo(:,:),    q_glo(:,:), phis_glo(:)
52  REAL,             ALLOCATABLE :: teta_glo(:,:)
53  LOGICAL :: lSkip, ll, ltnat1
54!-------------------------------------------------------------------------------
55  modname="dynetat0_loc"
56
57!--- Initial state file opening
58  var=fichnom
59  CALL err(NF90_OPEN(var,NF90_NOWRITE,fID),"open",var)
60  CALL get_var1("controle",tab_cntrl)
61
62!!! AS: idecal is a hack to be able to read planeto starts...
63!!!     .... while keeping everything OK for LMDZ EARTH
64  IF(planet_type=="generic") THEN
65    CALL msg('NOTE NOTE NOTE : Planeto-like start files', modname)
66    idecal = 4
67    annee_ref  = 2000
68  ELSE
69    CALL msg('NOTE NOTE NOTE : Earth-like start files', modname)
70    idecal = 5
71    annee_ref  = tab_cntrl(5)
72  END IF
73  im         = tab_cntrl(1)
74  jm         = tab_cntrl(2)
75  lllm       = tab_cntrl(3)
76  day_ref    = tab_cntrl(4)
77  rad        = tab_cntrl(idecal+1)
78  omeg       = tab_cntrl(idecal+2)
79  g          = tab_cntrl(idecal+3)
80  cpp        = tab_cntrl(idecal+4)
81  kappa      = tab_cntrl(idecal+5)
82  daysec     = tab_cntrl(idecal+6)
83  dtvr       = tab_cntrl(idecal+7)
84  etot0      = tab_cntrl(idecal+8)
85  ptot0      = tab_cntrl(idecal+9)
86  ztot0      = tab_cntrl(idecal+10)
87  stot0      = tab_cntrl(idecal+11)
88  ang0       = tab_cntrl(idecal+12)
89  pa         = tab_cntrl(idecal+13)
90  preff      = tab_cntrl(idecal+14)
91!
92  clon       = tab_cntrl(idecal+15)
93  clat       = tab_cntrl(idecal+16)
94  grossismx  = tab_cntrl(idecal+17)
95  grossismy  = tab_cntrl(idecal+18)
96!
97  IF ( tab_cntrl(idecal+19)==1. )  THEN
98    fxyhypb  = .TRUE.
99!   dzoomx   = tab_cntrl(25)
100!   dzoomy   = tab_cntrl(26)
101!   taux     = tab_cntrl(28)
102!   tauy     = tab_cntrl(29)
103  ELSE
104    fxyhypb = .FALSE.
105    ysinus  = tab_cntrl(idecal+22)==1.
106  END IF
107
108  day_ini    = tab_cntrl(30)
109  itau_dyn   = tab_cntrl(31)
110  start_time = tab_cntrl(32)
111
112!-------------------------------------------------------------------------------
113  CALL msg('rad, omeg, g, cpp, kappa = '//TRIM(strStack(real2str([rad,omeg,g,cpp,kappa]))), modname)
114  CALL check_dim(im,iim,'im','im')
115  CALL check_dim(jm,jjm,'jm','jm')
116  CALL check_dim(lllm,llm,'lm','lllm')
117  CALL get_var1("rlonu",rlonu)
118  CALL get_var1("rlatu",rlatu)
119  CALL get_var1("rlonv",rlonv)
120  CALL get_var1("rlatv",rlatv)
121  CALL get_var1("cu"  ,cu)
122  CALL get_var1("cv"  ,cv)
123  CALL get_var1("aire",aire)
124
125  var="temps"
126  IF(NF90_INQ_VARID(fID,var,vID)/=NF90_NoErr) THEN
127    CALL msg('missing field <temps> ; trying with <Time>', modname)
128    var="Time"
129    CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
130  END IF
131  CALL err(NF90_GET_VAR(fID,vID,time),"get",var)
132
133  ALLOCATE(phis_glo(ip1jmp1))
134  CALL get_var1("phisinit",phis_glo)
135  phis (ijb_u:ije_u)  =phis_glo(ijb_u:ije_u);    DEALLOCATE(phis_glo)
136
137  ALLOCATE(ucov_glo(ip1jmp1,llm))
138  CALL get_var2("ucov",ucov_glo)
139  ucov (ijb_u:ije_u,:)=ucov_glo(ijb_u:ije_u,:);  DEALLOCATE(ucov_glo)
140
141  ALLOCATE(vcov_glo(ip1jm,llm))
142  CALL get_var2("vcov",vcov_glo)
143  vcov (ijb_v:ije_v,:)=vcov_glo(ijb_v:ije_v,:);  DEALLOCATE(vcov_glo)
144
145  ALLOCATE(teta_glo(ip1jmp1,llm))
146  CALL get_var2("teta",teta_glo)
147  teta (ijb_u:ije_u,:)=teta_glo(ijb_u:ije_u,:);  DEALLOCATE(teta_glo)
148
149  ALLOCATE(masse_glo(ip1jmp1,llm))
150  CALL get_var2("masse",masse_glo)
151  masse(ijb_u:ije_u,:)=masse_glo(ijb_u:ije_u,:); DEALLOCATE(masse_glo)
152 
153  ALLOCATE(ps_glo(ip1jmp1))
154  CALL get_var1("ps",ps_glo)
155  ps   (ijb_u:ije_u)  =   ps_glo(ijb_u:ije_u);   DEALLOCATE(ps_glo)
156
157!--- Tracers
158  ALLOCATE(q_glo(ip1jmp1,llm))
159  ll = .FALSE.
160IF (CPPKEY_REPROBUS) THEN
161  ll = NF90_INQ_VARID(fID, 'HNO3tot', vID) /= NF90_NoErr                                 !--- DETECT OLD REPRO start.nc FILE
162END IF
163  ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)
164  DO iq=1,nqtot
165    var = tracers(iq)%name
166    oldVar = new2oldH2O(var)
167    lSkip = ll .AND. var == 'HNO3'                                                       !--- FORCE "HNO3_g" READING FOR "HNO3"
168IF (CPPKEY_REPROBUS) THEN
169    ix = strIdx(newHNO3, var); IF(ix /= 0) oldVar = oldHNO3(ix)                          !--- REPROBUS HNO3 exceptions
170END IF
171IF (CPPKEY_INCA) THEN
172    IF(var == 'O3') oldVar = 'OX'                                                        !--- DEAL WITH INCA OZONE EXCEPTION
173END IF
174    !--------------------------------------------------------------------------------------------------------------------------
175    IF(NF90_INQ_VARID(fID, var, vID) == NF90_NoErr .AND. .NOT.lSkip) THEN                !=== REGULAR CASE: AVAILABLE VARIABLE
176      CALL get_var2(var,q_glo); q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:)
177    !--------------------------------------------------------------------------------------------------------------------------
178    ELSE IF(NF90_INQ_VARID(fID, oldVar, vID) == NF90_NoErr) THEN                         !=== TRY WITH ALTERNATE NAME
179      CALL msg('Missing tracer <'//TRIM(var)//'> => initialized to <'//TRIM(oldVar)//'>', modname)
180      CALL get_var2(oldVar, q_glo); q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:)
181    !--------------------------------------------------------------------------------------------------------------------------
182    ELSE IF(tracers(iq)%iso_iGroup == iH2O .AND. niso > 0) THEN                          !=== WATER ISOTOPES
183      iName    = tracers(iq)%iso_iName
184      iPhase   = tracers(iq)%iso_iPhase
185      iqParent = tracers(iq)%iqParent
186      IF(tracers(iq)%iso_iZone == 0) THEN
187         IF(ltnat1) THEN
188            tnat = 1.0
189            alpha_ideal = 1.0
190            CALL msg(' !!!  Beware: alpha_ideal put to 1  !!!', modname)
191         ELSE
192            SELECT CASE(isoName(iName))
193              CASE('H216O'); tnat = tnat_H216O; alpha_ideal = alpha_ideal_H216O
194              CASE('H217O'); tnat = tnat_H217O; alpha_ideal = alpha_ideal_H217O
195              CASE('H218O'); tnat = tnat_H218O; alpha_ideal = alpha_ideal_H218O
196              CASE('HDO');   tnat = tnat_HDO;   alpha_ideal = alpha_ideal_HDO
197              CASE('HTO');   tnat = tnat_HTO;   alpha_ideal = alpha_ideal_HTO
198              CASE DEFAULT; CALL abort_gcm(TRIM(modname),'unknown isotope "'//TRIM(isoName(iName))//'" ; check tracer.def file',1)
199            END SELECT
200         END IF
201         CALL msg('Missing tracer <'//TRIM(var)//'> => initialized with a simplified Rayleigh distillation law.', modname)
202         q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqParent)*tnat*(q(ijb_u:ije_u,:,iqParent)/30.e-3)**(alpha_ideal-1.)
203         ! Camille 9 mars 2023: point de vigilence: initialisation incohérente
204         ! avec celle de xt_ancien dans la physiq.
205      ELSE
206         CALL msg('Missing tracer <'//TRIM(var)//'> => initialized to its parent isotope concentration.', modname)
207         ! Camille 9 mars 2023: attention!! seuls les tags qui correspondent à
208         ! izone=izone_init (définie dans isotrac_mod) sont initialisés comme
209         ! les parents. Sinon, c'est nul.
210         ! j'ai fait ça en attendant, mais il faudrait initialiser proprement en
211         ! remplacant 1 par izone_init dans la ligne qui suit.
212         IF(tracers(iq)%iso_iZone == 1) THEN
213           q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqIsoPha(iName,iPhase))
214         ELSE
215           q(ijb_u:ije_u,:,iq) =  0.
216         ENDIF
217      END IF
218    !--------------------------------------------------------------------------------------------------------------------------
219    ELSE                                                                                 !=== MISSING: SET TO 0
220      CALL msg('missing tracer <'//TRIM(var)//'> => initialized to zero', modname)
221      q(ijb_u:ije_u,:,iq)=0.
222    !--------------------------------------------------------------------------------------------------------------------------
223    END IF
224  END DO
225  DEALLOCATE(q_glo)
226  CALL err(NF90_CLOSE(fID),"close",fichnom)
227  day_ini=day_ini+INT(time)
228  time=time-INT(time)
229
230
231  CONTAINS
232
233
234SUBROUTINE check_dim(n1,n2,str1,str2)
235  INTEGER,          INTENT(IN) :: n1, n2
236  CHARACTER(LEN=*), INTENT(IN) :: str1, str2
237  CHARACTER(LEN=maxlen) :: s1, s2
238  IF(n1/=n2) CALL abort_gcm(TRIM(modname), 'value of "'//TRIM(str1)//'" = '//TRIM(int2str(n1))// &
239   ' read in starting file differs from gcm value of "'//TRIM(str2)//'" = '//TRIM(int2str(n2)), 1)
240END SUBROUTINE check_dim
241
242
243SUBROUTINE get_var1(var,v)
244  CHARACTER(LEN=*), INTENT(IN)  :: var
245  REAL,             INTENT(OUT) :: v(:)
246  REAL,             ALLOCATABLE :: w2(:,:), w3(:,:,:)
247  INTEGER :: nn(3), dids(3), k, nd, ntot
248
249  CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
250  ierr=NF90_INQUIRE_VARIABLE(fID,vID,ndims=nd)
251  IF(nd==1) THEN
252    CALL err(NF90_GET_VAR(fID,vID,v),"get",var); RETURN
253  END IF
254  ierr=NF90_INQUIRE_VARIABLE(fID,vID,dimids=dids)
255  DO k=1,nd; ierr=NF90_INQUIRE_DIMENSION(fID,dids(k),len=nn(k)); END DO
256  ntot=PRODUCT(nn(1:nd))
257  SELECT CASE(nd)
258    CASE(2); ALLOCATE(w2(nn(1),nn(2)))
259      CALL err(NF90_GET_VAR(fID,vID,w2),"get",var)
260      v=RESHAPE(w2,[ntot]); DEALLOCATE(w2)
261    CASE(3); ALLOCATE(w3(nn(1),nn(2),nn(3)))
262      CALL err(NF90_GET_VAR(fID,vID,w3),"get",var)
263      v=RESHAPE(w3,[ntot]); DEALLOCATE(w3)
264  END SELECT
265END SUBROUTINE get_var1
266
267SUBROUTINE get_var2(var,v)
268  CHARACTER(LEN=*), INTENT(IN)  :: var
269  REAL,             INTENT(OUT) :: v(:,:)
270  REAL,             ALLOCATABLE :: w4(:,:,:,:), w3(:,:,:)
271  INTEGER :: nn(4), dids(4), k, nd
272
273
274  CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
275  ierr=NF90_INQUIRE_VARIABLE(fID,vID,ndims=nd)
276
277  IF(nd==1) THEN
278    CALL err(NF90_GET_VAR(fID,vID,v),"get",var); RETURN
279  END IF
280  ierr=NF90_INQUIRE_VARIABLE(fID,vID,dimids=dids)
281
282  DO k=1,nd; ierr=NF90_INQUIRE_DIMENSION(fID,dids(k),len=nn(k)); END DO
283
284  SELECT CASE(nd)
285  CASE(3); ALLOCATE(w3(nn(1),nn(2),nn(3)))
286     CALL err(NF90_GET_VAR(fID,vID,w3),"get",var)
287     v=RESHAPE(w3,[nn(1)*nn(2),nn(3)]); DEALLOCATE(w3)
288  CASE(4);  ALLOCATE(w4(nn(1),nn(2),nn(3),nn(4)))
289     CALL err(NF90_GET_VAR(fID,vID,w4),"get",var)
290     v=RESHAPE(w4,[nn(1)*nn(2),nn(3)]); DEALLOCATE(w4)
291  END SELECT
292END SUBROUTINE get_var2
293
294
295SUBROUTINE err(ierr,typ,nam)
296  INTEGER,          INTENT(IN) :: ierr   !--- NetCDF ERROR CODE
297  CHARACTER(LEN=*), INTENT(IN) :: typ    !--- TYPE OF OPERATION
298  CHARACTER(LEN=*), INTENT(IN) :: nam    !--- FIELD/FILE NAME
299  IF(ierr==NF90_NoERR) RETURN
300  SELECT CASE(typ)
301    CASE('inq');   mesg="Field <"//TRIM(nam)//"> is missing"
302    CASE('get');   mesg="Reading failed for <"//TRIM(nam)//">"
303    CASE('open');  mesg="File opening failed for <"//TRIM(nam)//">"
304    CASE('close'); mesg="File closing failed for <"//TRIM(nam)//">"
305  END SELECT
306  CALL ABORT_gcm(TRIM(modname),TRIM(mesg),ierr)
307END SUBROUTINE err
308
309END SUBROUTINE dynetat0_loc
Note: See TracBrowser for help on using the repository browser.