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

Last change on this file since 155 was 151, checked in by ymipsl, 11 years ago

Implementation of mixte parallelism MPI/OpenMP into src directory

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