source: LMDZ5/branches/testing/libf/dyn3d/dynetat0.f90 @ 2435

Last change on this file since 2435 was 2408, checked in by Laurent Fairhead, 9 years ago

Merged trunk changes r2298:2396 into testing branch

File size: 6.9 KB
Line 
1SUBROUTINE dynetat0(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 infotrac
9  USE netcdf,      ONLY: NF90_OPEN,  NF90_NOWRITE, NF90_INQ_VARID, NF90_NoErr, &
10                         NF90_CLOSE, NF90_GET_VAR
11  USE control_mod, ONLY: planet_type
12  USE assert_eq_m, ONLY: assert_eq
13  IMPLICIT NONE
14  include "dimensions.h"
15  include "paramet.h"
16  include "temps.h"
17  include "comconst.h"
18  include "comvert.h"
19  include "comgeom2.h"
20  include "ener.h"
21  include "description.h"
22  include "serre.h"
23  include "logic.h"
24  include "iniprint.h"
25!===============================================================================
26! Arguments:
27  CHARACTER(LEN=*), INTENT(IN) :: fichnom          !--- FILE NAME
28  REAL, INTENT(OUT) ::  vcov(iip1,jjm, llm)        !--- V COVARIANT WIND
29  REAL, INTENT(OUT) ::  ucov(iip1,jjp1,llm)        !--- U COVARIANT WIND
30  REAL, INTENT(OUT) ::  teta(iip1,jjp1,llm)        !--- POTENTIAL TEMP.
31  REAL, INTENT(OUT) ::     q(iip1,jjp1,llm,nqtot)  !--- TRACERS
32  REAL, INTENT(OUT) :: masse(iip1,jjp1,llm)        !--- MASS PER CELL
33  REAL, INTENT(OUT) ::    ps(iip1,jjp1)            !--- GROUND PRESSURE
34  REAL, INTENT(OUT) ::  phis(iip1,jjp1)            !--- GEOPOTENTIAL
35!===============================================================================
36! Local variables:
37  CHARACTER(LEN=256) :: msg, var, modname
38  INTEGER, PARAMETER :: length=100
39  INTEGER :: iq, fID, vID, idecal!, iml, jml, lml, nqt
40  REAL    :: time, tab_cntrl(length)               !--- RUN PARAMS TABLE
41!-------------------------------------------------------------------------------
42  modname="dynetat0"
43
44!--- Initial state file opening
45  var=fichnom
46  CALL err(NF90_OPEN(var,NF90_NOWRITE,fID),"open",var)
47  CALL get_var1("controle",tab_cntrl)
48
49!!! AS: idecal is a hack to be able to read planeto starts...
50!!!     .... while keeping everything OK for LMDZ EARTH
51  IF(planet_type=="generic") THEN
52    WRITE(lunout,*)'NOTE NOTE NOTE : Planeto-like start files'
53    idecal = 4
54    annee_ref  = 2000
55  ELSE
56    WRITE(lunout,*)'NOTE NOTE NOTE : Earth-like start files'
57    idecal = 5
58    annee_ref  = tab_cntrl(5)
59  END IF
60  im         = tab_cntrl(1)
61  jm         = tab_cntrl(2)
62  lllm       = tab_cntrl(3)
63  day_ref    = tab_cntrl(4)
64  rad        = tab_cntrl(idecal+1)
65  omeg       = tab_cntrl(idecal+2)
66  g          = tab_cntrl(idecal+3)
67  cpp        = tab_cntrl(idecal+4)
68  kappa      = tab_cntrl(idecal+5)
69  daysec     = tab_cntrl(idecal+6)
70  dtvr       = tab_cntrl(idecal+7)
71  etot0      = tab_cntrl(idecal+8)
72  ptot0      = tab_cntrl(idecal+9)
73  ztot0      = tab_cntrl(idecal+10)
74  stot0      = tab_cntrl(idecal+11)
75  ang0       = tab_cntrl(idecal+12)
76  pa         = tab_cntrl(idecal+13)
77  preff      = tab_cntrl(idecal+14)
78!
79  clon       = tab_cntrl(idecal+15)
80  clat       = tab_cntrl(idecal+16)
81  grossismx  = tab_cntrl(idecal+17)
82  grossismy  = tab_cntrl(idecal+18)
83!
84  IF ( tab_cntrl(idecal+19)==1. )  THEN
85    fxyhypb  = .TRUE.
86!   dzoomx   = tab_cntrl(25)
87!   dzoomy   = tab_cntrl(26)
88!   taux     = tab_cntrl(28)
89!   tauy     = tab_cntrl(29)
90  ELSE
91    fxyhypb = .FALSE.
92    ysinus  = tab_cntrl(idecal+22)==1.
93  END IF
94
95  day_ini    = tab_cntrl(30)
96  itau_dyn   = tab_cntrl(31)
97  start_time = tab_cntrl(32)
98
99!-------------------------------------------------------------------------------
100  WRITE(lunout,*)TRIM(modname)//': rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa
101  CALL check_dim(im,iim,'im','im')
102  CALL check_dim(jm,jjm,'jm','jm')
103  CALL check_dim(lllm,llm,'lm','lllm')
104  CALL get_var1("rlonu",rlonu)
105  CALL get_var1("rlatu",rlatu)
106  CALL get_var1("rlonv",rlonv)
107  CALL get_var1("rlatv",rlatv)
108  CALL get_var2("cu"   ,cu)
109  CALL get_var2("cv"   ,cv)
110  CALL get_var2("aire" ,aire)
111  var="temps"
112  IF(NF90_INQ_VARID(fID,var,vID)/=NF90_NoErr) THEN
113    WRITE(lunout,*)TRIM(modname)//": missing field <temps>"
114    WRITE(lunout,*)TRIM(modname)//": trying with <Time>"; var="Time"
115    CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
116  END IF
117  CALL err(NF90_GET_VAR(fID,vID,time),"get",var)
118  CALL get_var2("phisinit",phis)
119  CALL get_var3("ucov",ucov)
120  CALL get_var3("vcov",vcov)
121  CALL get_var3("teta",teta)
122  CALL get_var3("masse",masse)
123  CALL get_var2("ps",ps)
124
125!--- Tracers
126  DO iq=1,nqtot
127    var=tname(iq)
128    IF(NF90_INQ_VARID(fID,var,vID)==NF90_NoErr) THEN
129      CALL err(NF90_GET_VAR(fID,vID,q(:,:,:,iq)),"get",var); CYCLE
130    END IF
131    WRITE(lunout,*)TRIM(modname)//": Tracer <"//TRIM(var)//"> is missing"
132    WRITE(lunout,*)"         It is hence initialized to zero"
133    q(:,:,:,iq)=0.
134   !--- CRisi: for isotops, theoretical initialization using very simplified
135   !           Rayleigh distillation las.
136    IF(ok_isotopes.AND.iso_num(iq)>0) THEN
137      IF(zone_num(iq)==0) q(:,:,:,iq)=q(:,:,:,iqpere(iq))*tnat(iso_num(iq))    &
138     &             *(q(:,:,:,iqpere(iq))/30.e-3)**(alpha_ideal(iso_num(iq))-1)
139      IF(zone_num(iq)==1) q(:,:,:,iq)=q(:,:,:,iqiso(iso_indnum(iq),phase_num(iq)))
140    END IF
141  END DO
142
143  CALL err(NF90_CLOSE(fID),"close",fichnom)
144  day_ini=day_ini+INT(time)
145  time=time-INT(time)
146
147
148  CONTAINS
149
150
151SUBROUTINE check_dim(n1,n2,str1,str2)
152  INTEGER,          INTENT(IN) :: n1, n2
153  CHARACTER(LEN=*), INTENT(IN) :: str1, str2
154  CHARACTER(LEN=256) :: s1, s2
155  IF(n1/=n2) THEN
156    s1='value of '//TRIM(str1)//' ='
157    s2=' read in starting file differs from parametrized '//TRIM(str2)//' ='
158    WRITE(msg,'(10x,a,i4,2x,a,i4)'),s1,n1,s2,n2
159    CALL ABORT_gcm(TRIM(modname),TRIM(msg),1)
160  END IF
161END SUBROUTINE check_dim
162
163
164SUBROUTINE get_var1(var,v)
165  CHARACTER(LEN=*), INTENT(IN)  :: var
166  REAL,             INTENT(OUT) :: v(:)
167  CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
168  CALL err(NF90_GET_VAR(fID,vID,v),"get",var)
169END SUBROUTINE get_var1
170
171
172SUBROUTINE get_var2(var,v)
173  CHARACTER(LEN=*), INTENT(IN)  :: var
174  REAL,             INTENT(OUT) :: v(:,:)
175  CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
176  CALL err(NF90_GET_VAR(fID,vID,v),"get",var)
177END SUBROUTINE get_var2
178
179
180SUBROUTINE get_var3(var,v)
181  CHARACTER(LEN=*), INTENT(IN)  :: var
182  REAL,             INTENT(OUT) :: v(:,:,:)
183  CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
184  CALL err(NF90_GET_VAR(fID,vID,v),"get",var)
185END SUBROUTINE get_var3
186
187
188SUBROUTINE err(ierr,typ,nam)
189  INTEGER,          INTENT(IN) :: ierr   !--- NetCDF ERROR CODE
190  CHARACTER(LEN=*), INTENT(IN) :: typ    !--- TYPE OF OPERATION
191  CHARACTER(LEN=*), INTENT(IN) :: nam    !--- FIELD/FILE NAME
192  IF(ierr==NF90_NoERR) RETURN
193  SELECT CASE(typ)
194    CASE('inq');   msg="Field <"//TRIM(nam)//"> is missing"
195    CASE('get');   msg="Reading failed for <"//TRIM(nam)//">"
196    CASE('open');  msg="File opening failed for <"//TRIM(nam)//">"
197    CASE('close'); msg="File closing failed for <"//TRIM(nam)//">"
198  END SELECT
199  CALL ABORT_gcm(TRIM(modname),TRIM(msg),ierr)
200END SUBROUTINE err
201
202END SUBROUTINE dynetat0
Note: See TracBrowser for help on using the repository browser.