source: codes/icosagcm/trunk/src/dynetat0_gcm_mod.f90 @ 150

Last change on this file since 150 was 149, checked in by sdubey, 11 years ago
Added few new routines to read NC files and compute diagnostics to r145.
Few routines of dry physics including radiation module, surface process and convective adjustment in new routine phyparam.f90. dynetat to read start files for dynamics. check_conserve routine to compute conservation of quatities like mass, energy etc.etat0_heldsz.f90 for held-suarez test case initial conditions. new Key time_style=lmd or dcmip to use day_step, ndays like in LMDZ
File size: 10.7 KB
Line 
1MODULE dynetat0_gcm_mod 
2  USE genmod
3  USE icosa
4  USE caldyn_gcm_mod 
5        IMPLICIT NONE
6          PRIVATE
7
8       PUBLIC  etat0
9         INTEGER,SAVE::ncell
10         TYPE(t_field),POINTER:: f_iu(:)
11      TYPE(t_field),POINTER:: f_iv(:) 
12         TYPE(t_field),POINTER:: f_iue(:)
13      TYPE(t_field),POINTER:: f_ive(:) 
14         REAL(rstd),POINTER :: iu(:,:),iv(:,:)
15      REAL(rstd),POINTER :: iue(:,:),ive(:,:) 
16
17         
18CONTAINS
19
20        SUBROUTINE etat0(f_ps,f_phis,f_theta_rhodz,f_u,f_q) 
21  USE icosa
22  USE caldyn_mod
23  USE write_field 
24  USE maxicosa
25        IMPLICIT NONE
26        TYPE(t_domain),POINTER :: d 
27        TYPE(t_field),POINTER:: f_ps(:)
28        TYPE(t_field),POINTER:: f_phis(:)
29        TYPE(t_field),POINTER:: f_u(:)
30        TYPE(t_field),POINTER:: f_q(:)
31        TYPE(t_field),POINTER:: f_theta_rhodz(:) 
32     TYPE(t_field),POINTER::  f_buf_i3(:), f_buf1_i(:), f_buf2_i(:)
33     REAL(rstd),POINTER :: ps(:)
34     REAL(rstd),POINTER :: phis(:)
35     REAL(rstd),POINTER :: theta_rhodz(:,:)
36     REAL(rstd),POINTER :: u(:,:) 
37     REAL(rstd),POINTER :: q(:,:,:)
38        REAL(rstd):: maxff,minff,maxuu,minuu
39        INTEGER :: ind
40 
41        CALL allocate_field(f_iu,field_t,type_real,llm) 
42     CALL allocate_field(f_iv,field_t,type_real,llm)
43        CALL allocate_field(f_iue,field_u,type_real,llm) 
44     CALL allocate_field(f_ive,field_u,type_real,llm)
45        CALL allocate_field(f_u,field_u,type_real,llm) 
46        CALL allocate_field(f_buf1_i,field_t,type_real,llm) 
47        CALL allocate_field(f_buf2_i,field_t,type_real,llm) 
48        CALL allocate_field(f_buf_i3,field_u,type_real,3,llm) 
49 
50        PRINT*,"IN NETCDF READ"
51!------------------------------------zero
52        DO ind=1,ndomain
53      CALL swap_dimensions(ind)
54      CALL swap_geometry(ind)
55          iu = f_iu(ind) 
56          iv = f_iv(ind) 
57      iue = f_iue(ind) 
58         ive = f_ive(ind)       
59          iu = 0.0 
60          iv = 0.0 
61        u = f_u(ind) 
62           u = 0.0 
63         iue = 0.0     
64         ive = 0.0 
65     END DO 
66!--------------------------------------------
67         ncell = 0
68     DO ind=1,ndomain
69      CALL swap_dimensions(ind)
70      CALL swap_geometry(ind)
71         d => domain_glo(ind)
72      ps=f_ps(ind)
73      phis=f_phis(ind)
74      theta_rhodz=f_theta_rhodz(ind)
75      q=f_q(ind)
76      iu=f_iu(ind) 
77         iv=f_iv(ind) 
78      CALL compute_dynetat0(ind,d,ps,phis,theta_rhodz,iu,iv,q)
79        ENDDO
80
81     CALL transfert_request(f_ps,req_i1)
82        CALL transfert_request(f_phis,req_i1)
83        CALL transfert_request(f_theta_rhodz,req_i1)
84        CALL transfert_request(f_q,req_i1)
85        CALL transfert_request(f_iu,req_i1)
86        CALL transfert_request(f_iv,req_i1)
87!------------------------------------------
88        DO ind=1,ndomain
89      CALL swap_dimensions(ind)
90      CALL swap_geometry(ind)
91         u=f_u(ind)
92         iu=f_iu(ind) 
93         iv=f_iv(ind) 
94         iue=f_iue(ind) 
95         ive=f_ive(ind) 
96         CALL compute_dynetatu(iu,iv,iue,ive,u)
97        ENDDO
98!----------------------------------------------------
99!------------- OUTPUT OF Variables
100        CALL un2ulonlat(f_u,f_buf_i3,f_buf1_i,f_buf2_i) 
101        CALL writefield("buf1",f_buf1_i)
102  END SUBROUTINE etat0
103
104!==================================================================
105  SUBROUTINE compute_dynetat0(ind,d,ps,phis,theta_rhodz,iu,iv,q) 
106   use icosa
107   use netcdf
108   use wind_mod 
109   USE disvert_mod
110        IMPLICIT NONE
111   TYPE(t_domain),POINTER :: d 
112   CHARACTER*20::dimname 
113   REAL(rstd), INTENT(OUT) :: ps(iim*jjm)
114   REAL(rstd), INTENT(OUT) :: phis(iim*jjm)
115   REAL(rstd), INTENT(OUT) :: theta_rhodz(iim*jjm,llm)
116   REAL(rstd), INTENT(OUT) :: q(iim*jjm,llm,nqtot)
117   REAL(rstd),ALLOCATABLE :: mass(:,:)   ! mass   
118   REAL(rstd),ALLOCATABLE :: rhodz(:,:)   ! mass density 
119   REAL(rstd),ALLOCATABLE :: theta(:,:) 
120   REAL(rstd),ALLOCATABLE :: p(:,:)  ! pression
121   REAL(rstd),POINTER :: iu(:,:),iv(:,:)
122   REAL(rstd),POINTER :: icops(:)
123   REAL(rstd),POINTER :: icophis(:)
124   REAL(rstd),POINTER :: icou(:,:),icov(:,:)
125   REAL(rstd),POINTER :: icotheta(:,:)
126   REAL(rstd),POINTER :: icoq(:,:,:)
127
128   INTEGER length,iq,ind,l
129   PARAMETER (length = 100)
130   REAL tab_cntrl(length) ! tableau des parametres du run
131   INTEGER::ierr,nid,ncid,nvarid,dimid,nind
132   INTEGER::ncells 
133   INTEGER::halo_size,i,j,k,ij
134   LOGICAL::single 
135   INTEGER::nDims,nVars,nGlobalAtts,unlimdimid
136   INTEGER:: len
137   CHARACTER(LEN=200):: iqq 
138   
139!       OPEN NETCDF FILE
140         ierr = NF90_OPEN ("start_icosa25.nc",NF90_NOWRITE,nid)
141      IF (ierr .NE. NF90_NOERR) THEN
142        write(*,*)'dynetat0: with file start_icosa.nc'
143        write(*,*)' ierr = ', ierr
144        STOP
145      ENDIF
146
147     ierr= nf90_inquire(nid,nDims,nVars,nGlobalAtts,unlimdimid)
148        IF (ierr .NE. NF90_NOERR) THEN
149        write(*,*)'Problem in inquire'
150        write(*,*)' ierr = ', ierr
151        STOP
152      ENDIF
153
154!       PRINT*,"nDims,nVars,nGlobalAtts,unlimdimid"
155!       PRINT*,nDims,nVars,nGlobalAtts,unlimdimid
156
157
158         ierr = NF90_INQ_DIMID(nid,"ncells",dimid)
159         IF (ierr .NE. NF90_NOERR ) THEN
160           write(*,*)'ncells is not present in start_icosa.nc'
161        write(*,*)' ierr = ', ierr
162           STOP
163         ENDIF
164           
165         ierr = nf90_inquire_dimension(nid,dimid,dimname,ncells)
166         IF (ierr .NE. NF90_NOERR ) THEN
167           write(*,*)'ncells  in start_icosa.nc'
168        write(*,*)' ierr = ', ierr
169           STOP
170         ENDIF
171
172          ALLOCATE(icops(ncells))
173          ALLOCATE(icophis(ncells))
174          ALLOCATE(icou(ncells,llm))
175          ALLOCATE(icov(ncells,llm))
176          ALLOCATE(icotheta(ncells,llm))
177          ALLOCATE(icoq(ncells,llm,nqtot))
178          ALLOCATE(p(iim*jjm,llm+1))
179          ALLOCATE(theta(iim*jjm,llm)) 
180       ALLOCATE(mass(iim*jjm,llm))   ! mass   
181       ALLOCATE(rhodz(iim*jjm,llm))   ! mass density   
182!============================================================
183      ierr = NF90_INQ_VARID(nid, "phisinit", nvarid)
184      IF (ierr .NE. NF90_NOERR) THEN
185        write(*,*)"dynetat0: phisinit is absent"
186           write(*,*)' ierr = ', ierr
187         STOP       
188      ENDIF
189
190      ierr = NF90_GET_VAR(nid, nvarid, icophis)
191      IF (ierr .NE. NF90_NOERR) THEN
192         write(*,*)"dynetat0: PROBLEM IN PHIS"
193         STOP
194      ENDIF
195!==============================================================
196          ierr = NF90_INQ_VARID(nid, "ps", nvarid)
197      IF (ierr .NE. NF90_NOERR) THEN
198        write(*,*)"dynetat0: ps is absent"
199           write(*,*)' ierr = ', ierr
200         STOP       
201      ENDIF
202
203      ierr = NF90_GET_VAR(nid, nvarid, icops)
204      IF (ierr .NE. NF90_NOERR) THEN
205         write(*,*)"dynetat0: PROBLEM IN PS"
206         STOP
207      ENDIF
208!================================================================
209          ierr = NF90_INQ_VARID(nid, "teta", nvarid)
210      IF (ierr .NE. NF90_NOERR) THEN
211        write(*,*)"dynetat0: teta is not available in start.nc"
212           write(*,*)' ierr = ', ierr
213         STOP       
214      ENDIF
215
216      ierr = NF90_GET_VAR(nid, nvarid,icotheta)
217      IF (ierr .NE. NF90_NOERR) THEN
218         write(*,*)"dynetat0: PROBLEM IN Teta"
219         STOP
220      ENDIF
221!================================================================
222        DO iq = 1,nqtot   
223                write(iqq,*)INT(iq)
224                iqq=ADJUSTL(iqq) 
225        ierr = NF90_INQ_VARID(nid,"q"//iqq, nvarid)
226      IF (ierr .NE. NF90_NOERR) THEN
227        write(*,*)"dynetat0: ","q"//iqq,"not here"
228           write(*,*)' ierr = ', ierr
229!         STOP       
230      ENDIF
231
232      ierr = NF90_GET_VAR(nid, nvarid,icoq(:,:,iq))
233      IF (ierr .NE. NF90_NOERR) THEN
234         write(*,*)"dynetat0: PROBLEM IN Q"
235!         STOP
236      ENDIF
237        END DO
238!================================================================
239        GO TO 121
240          ierr = NF90_INQ_VARID(nid, "q01", nvarid)
241      IF (ierr .NE. NF90_NOERR) THEN
242        write(*,*)"dynetat0: q1 is not available in start.nc"
243           write(*,*)' ierr = ', ierr
244         STOP       
245      ENDIF
246
247      ierr = NF90_GET_VAR(nid, nvarid,icoq(:,:,1))
248      IF (ierr .NE. NF90_NOERR) THEN
249         write(*,*)"dynetat0: PROBLEM IN Q01"
250         STOP
251      ENDIF
252121     CONTINUE 
253!================================================================
254          ierr = NF90_INQ_VARID(nid, "ucov", nvarid)
255      IF (ierr .NE. NF90_NOERR) THEN
256        write(*,*)"dynetat0: ucov is not available in start.nc"
257           write(*,*)' ierr = ', ierr
258         STOP       
259      ENDIF
260
261      ierr = NF90_GET_VAR(nid, nvarid,icou)
262      IF (ierr .NE. NF90_NOERR) THEN
263         write(*,*)"dynetat0: PROBLEM IN ucov"
264         STOP
265      ENDIF
266        PRINT*,"UCOV is read using start_icosa.nc" 
267!================================================================
268          ierr = NF90_INQ_VARID(nid, "vcov", nvarid)
269      IF (ierr .NE. NF90_NOERR) THEN
270        write(*,*)"dynetat0: PROBLEM in VCOV"
271           write(*,*)' ierr = ', ierr
272         STOP       
273      ENDIF
274
275      ierr = NF90_GET_VAR(nid, nvarid,icov)
276      IF (ierr .NE. NF90_NOERR) THEN
277         write(*,*)"dynetat0: PROBLEM IN vcov"
278         STOP
279      ENDIF
280!================================================================
281                        iu = 0.0 ; iv = 0.0 
282             DO j=d%jj_begin,d%jj_end
283              DO i=d%ii_begin,d%ii_end
284                  k=d%iim*(j-1)+i
285                 IF (d%assign_domain(i,j)==ind ) THEN
286                     ncell=ncell+1
287                           phis(k)=  0.0  !icophis(ncell)
288                        ps(k)= icops(ncell) 
289                        theta(k,:) = icotheta(ncell,:) 
290                        q(k,:,1)= icoq(ncell,:,1) 
291                        iu(k,:) = icou(ncell,:)
292                                 iv(k,:) = icov(ncell,:) 
293                 ENDIF
294                ENDDO
295              ENDDO
296
297    DO    l    = 1, llm+1
298      DO j=jj_begin,jj_end
299        DO i=ii_begin,ii_end
300          ij=(j-1)*iim+i
301          p(ij,l) = ap(l) + bp(l) * ps(ij)
302        ENDDO
303      ENDDO
304    ENDDO
305
306   DO l = 1, llm
307     DO j=jj_begin,jj_end
308       DO i=ii_begin,ii_end
309         ij=(j-1)*iim+i
310         mass(ij,l) = ( p(ij,l) - p(ij,l+1) )*Ai(ij)/g
311         rhodz(ij,l) = mass(ij,l) / Ai(ij)
312       ENDDO
313     ENDDO
314   ENDDO
315
316    DO    l    = 1, llm
317      DO j=jj_begin,jj_end
318        DO i=ii_begin,ii_end
319          ij=(j-1)*iim+i
320          theta_rhodz(ij,l) = theta(ij,l)*rhodz(ij,l)
321        ENDDO
322      ENDDO
323    ENDDO
324
325          DEALLOCATE(icops)
326          DEALLOCATE(icophis)
327          DEALLOCATE(icou)
328          DEALLOCATE(icov)
329          DEALLOCATE(icotheta)
330          DEALLOCATE(p)
331          DEALLOCATE(theta) 
332       DEALLOCATE(mass)   ! mass   
333       DEALLOCATE(rhodz)   !
334        END SUBROUTINE compute_dynetat0
335
336!==================================================================
337          SUBROUTINE compute_dynetatu(iu,iv,iue,ive,u) 
338   use icosa
339   use wind_mod 
340        IMPLICIT NONE
341   CHARACTER*20::dimname 
342   REAL(rstd),INTENT(OUT):: u(3*iim*jjm,llm)
343   REAL(rstd) :: iu(iim*jjm,llm),iv(iim*jjm,llm)
344   REAL(rstd) :: iue(3*iim*jjm,llm),ive(3*iim*jjm,llm)
345   INTEGER::halo_size,i,j,k,ij,l
346
347
348  Do l = 1, llm
349   DO j=jj_begin-1,jj_end+1
350      DO i=ii_begin-1,ii_end+1
351         k=iim*(j-1)+i
352           iue(k+u_right,l)=0.5*(iu(k,l)+iu(k+t_right,l))
353        iue(k+u_lup,l)  =0.5*(iu(k,l)+iu(k+t_lup,l))
354        iue(k+u_ldown,l)=0.5*(iu(k,l)+iu(k+t_ldown,l)) 
355!------------------------------------------------------
356           ive(k+u_right,l)=0.5*(iv(k,l)+iv(k+t_right,l))
357        ive(k+u_lup,l)  =0.5*(iv(k,l)+iv(k+t_lup,l))
358        ive(k+u_ldown,l)=0.5*(iv(k,l)+iv(k+t_ldown,l)) 
359         END DO
360    END DO
361  END DO
362        CALL compute_wind_perp_from_lonlat_compound(iue,ive,u) 
363
364        END SUBROUTINE compute_dynetatu
365
366
367 END MODULE dynetat0_gcm_mod 
Note: See TracBrowser for help on using the repository browser.