source: LMDZ.3.3/trunk/libf/dyn3d/writeav.F @ 507

Last change on this file since 507 was 2, checked in by lmdz, 25 years ago

Initial revision

  • Property svn:eol-style set to native
  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 10.7 KB
Line 
1      SUBROUTINE writeav(fichnom,nq,pdtav,ptime,pu,pv,
2     .                   pteta,ppk,pq,pps,ifin)
3
4      IMPLICIT NONE
5
6c      Auteur :  L.Fairhead
7
8c      Modif. par P. Le Van ( 01/11/97 )
9
10c=======================================================================
11c
12c   Ecriture des moyennes diurnes  sur le fichier ' histmoy ' , avec
13
14c   la grille ' dynamique ' , c.a.d  decalee , u et v n'etant pas aux
15c   memes endroits que les scalaires .
16c   On ecrit la moyenne tous les jours
17c   si ifin NE 0  on ecrit la moyenne et on ferme le fichier histoire
18c
19c=======================================================================
20c   Declarations:
21c   -------------
22
23#include "dimensions.h"
24#include "paramet.h"
25#include "comav.h"
26#include "comvert.h"
27#include "comconst.h"
28#include "comgeom.h"
29#include "description.h"
30#include "netcdf.inc"
31
32c   arguments:
33c   ----------
34
35      CHARACTER*(*) fichnom
36      INTEGER nq
37      REAL pdtav
38      REAL pu(ip1jmp1*llm),pv(ip1jm*llm),pteta(ip1jmp1*llm)
39      REAL ppk(ip1jmp1*llm),pq(ip1jmp1*llm,nq)
40      REAL pps(ip1jmp1)
41      REAL ztime,ptime
42
43c   local:
44c   ------
45
46      INTEGER idaym,idayp,i,ifin,iq
47      REAL zdtm,zdtp,dttot
48      REAL zw,zwtot,zz
49      REAL ztimem,ztimep,zdtime
50      REAL um(ip1jmp1*llm),vm(ip1jm*llm),hm(ip1jmp1*llm)
51      REAL qm(ip1jmp1*llm,nqmx)
52      REAL pm(ip1jmp1)
53
54      LOGICAL firstcal
55
56      SAVE idaym
57      SAVE um,vm,hm,qm,pm,dttot
58      SAVE firstcal
59      DATA firstcal/.true./
60      INTEGER ierr, nid, nvarid
61      REAL time
62      CHARACTER*3 str3
63c
64      INTEGER nb
65      SAVE nb
66      DATA nb / 0 /
67
68c-----------------------------------------------------------------------
69c   calcul de la position par rapport aux jours pleins:
70c   ---------------------------------------------------
71
72      IF(firstcal) THEN
73         zz=-time0_av/period_av
74         idaym=INT(zz)
75         IF(zz.LT.0.) idaym=idaym-1
76         dttot=0.
77         CALL initial0(ijp1llm,um)
78         CALL initial0(ijmllm,vm)
79         CALL initial0(ijp1llm,hm)
80         IF(nq.GT.0) CALL initial0(ijp1llm*nq,qm)
81         CALL initial0(ip1jmp1,pm)
82         IF(nq.GT.nqmx) THEN
83            PRINT*,'Il faut augmenter nqmx dans writeav.f'
84            STOP ' writeav '
85         ENDIF
86      ENDIF
87
88      ztime=ptime-time0_av
89      zdtime=pdtav
90      IF(firstcal) THEN
91         ztimem = 0.
92      ELSE
93         ztimem=ztime-.5*pdtav
94      ENDIF
95      firstcal=.false.
96
97      IF(ifin.EQ.0) THEN
98         ztimep=ztime+.5*pdtav
99      ELSE
100         ztimep=ztime
101      ENDIF
102
103      zdtime = ztimep-ztimem
104      zz=ztimep/period_av
105      idayp=INT(zz)
106      IF(zz.LT.0.) idayp=idayp-1
107
108C     PRINT*,period_av,ptime,ztime,idaym,idayp
109
110c-----------------------------------------------------------------------
111c   premier cas: on ne change pas de jour:
112c   --------------------------------------
113
114c    .......   hm  calcule  les temperatures  naturelles  .......
115
116      IF(idaym.EQ.idayp) THEN
117
118         DO i=1,ijp1llm
119            um(i)=um(i)+pu(i)
120            hm(i)=hm(i)+pteta(i) * ppk(i)/cpp
121         ENDDO
122         IF(nq.GT.0) THEN
123            DO iq=1,nq
124               DO i=1,ijp1llm
125                  qm(i,iq)=qm(i,iq)+pq(i,iq)
126               ENDDO
127            ENDDO
128         ENDIF
129         DO i=1,ijmllm
130            vm(i)=vm(i)+pv(i)
131         ENDDO
132         DO i=1,ip1jmp1
133            pm(i)=pm(i)+pps(i)
134         ENDDO
135         dttot=dttot + (ztimep - ztimem)
136
137c-----------------------------------------------------------------------
138c   deuxieme cas: on change de jour dans dtav:
139c   ------------------------------------------
140
141      ELSE
142
143         zdtp=ztimep-FLOAT(idayp)*period_av
144         zdtm=zdtime-zdtp
145
146c   ajout partiel sur le jour precedent:
147c   ------------------------------------
148
149         dttot=dttot+zdtm
150
151         IF(dttot.GT.period_av*1.e-5) THEN
152            zwtot=pdtav/dttot
153            zw=zdtm/pdtav
154
155            DO i=1,ijp1llm
156               um(i)=(um(i)+pu(i)*zw)*zwtot
157               hm(i)=(hm(i)+pteta(i)*ppk(i)/cpp*zw)*zwtot
158            ENDDO
159
160
161            IF (nq.GT.0) THEN
162               DO iq=1,nq
163                  DO i=1,ijp1llm
164                     qm(i,iq)=(qm(i,iq)+pq(i,iq)*zw)*zwtot
165                  ENDDO
166               ENDDO
167            ENDIF
168            DO i=1,ijmllm
169               vm(i)=(vm(i)+pv(i)*zw)*zwtot
170            ENDDO
171            DO i=1,ip1jmp1
172               pm(i)=(pm(i)+pps(i)*zw)*zwtot
173            ENDDO
174
175c   ecriture du fichier de moyenne:
176c   -------------------------------
177
178c   transformation en variables naturelles:
179c   ---------------------------------------
180            CALL covnat(llm,um,vm,um,vm)
181c
182c Ouverture du fichier:
183c
184      ierr = NF_OPEN(fichnom, NF_WRITE, nid)
185      IF (ierr .NE. NF_NOERR) THEN
186         PRINT*, "Pb. d ouverture "//fichnom
187         CALL abort
188      ENDIF
189c
190c  Ecriture/extension de la coordonnee temps
191      nb = nb + 1
192      ierr = NF_INQ_VARID(nid, "temps", nvarid)
193      IF (ierr .NE. NF_NOERR) THEN
194         PRINT*, "writeav: Variable temps n est pas definie"
195         CALL abort
196      ENDIF
197      time = FLOAT(idayp)*period_av-.5*dttot
198#ifdef NC_DOUBLE
199      ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time)
200#else
201      ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time)
202#endif
203      PRINT*, "Enregistrement pour ", nb, time, fichnom
204
205C  Ecriture des champs
206      ierr = NF_INQ_VARID(nid, "temp", nvarid)
207      IF (ierr .NE. NF_NOERR) THEN
208         PRINT*, "writeav: Variable temp n est pas definie"
209         CALL abort
210      ENDIF
211#ifdef NC_DOUBLE
212      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,hm)
213#else
214      ierr = NF_PUT_VAR_REAL (nid,nvarid,hm)
215#endif
216
217c
218      ierr = NF_INQ_VARID(nid, "vitu", nvarid)
219      IF (ierr .NE. NF_NOERR) THEN
220         PRINT*, "writeav: Variable vitu n est pas definie"
221         CALL abort
222      ENDIF
223#ifdef NC_DOUBLE
224      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,um)
225#else
226      ierr = NF_PUT_VAR_REAL (nid,nvarid,um)
227#endif
228
229      ierr = NF_INQ_VARID(nid, "vitv", nvarid)
230      IF (ierr .NE. NF_NOERR) THEN
231         PRINT*, "writeav: Variable vitv n est pas definie"
232         CALL abort
233      ENDIF
234#ifdef NC_DOUBLE
235      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vm)
236#else
237      ierr = NF_PUT_VAR_REAL (nid,nvarid,vm)
238#endif
239c
240      IF(nq.GE.1) THEN
241      DO iq=1,nq
242      IF ( iq.GT.99 ) THEN
243         PRINT*, "Trop de traceurs"
244         CALL abort
245      ELSE
246         str3(1:1)='q'
247         WRITE(str3(2:3),'(i2.2)') iq
248         ierr = NF_INQ_VARID(nid, str3, nvarid)
249         IF (ierr .NE. NF_NOERR) THEN
250            PRINT*, "writeav: Variable "//str3//" n est pas definie"
251            CALL abort
252         ENDIF
253      ENDIF
254#ifdef NC_DOUBLE
255         ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,qm(1,iq))
256#else
257         ierr = NF_PUT_VAR_REAL (nid,nvarid,qm(1,iq))
258#endif
259      ENDDO
260      ENDIF
261c
262      ierr = NF_INQ_VARID(nid, "ps", nvarid)
263      IF (ierr .NE. NF_NOERR) THEN
264         PRINT*, "writeav: Variable ps n est pas definie"
265         CALL abort
266      ENDIF
267#ifdef NC_DOUBLE
268      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pps)
269#else
270      ierr = NF_PUT_VAR_REAL (nid,nvarid,pps)
271#endif
272
273      ierr = NF_CLOSE(nid)
274c
275
276         ENDIF
277
278c   ajout partiel sur le jour suivant:
279c   ----------------------------------
280
281         dttot=zdtp
282c        PRINT*,'dttot=zdtp',dttot
283         zw=zdtp/pdtav
284
285         DO i=1,ijp1llm
286            um(i)=pu(i)*zw
287            hm(i)=pteta(i)*ppk(i)/cpp*zw
288         ENDDO
289         IF (nq.GT.0) THEN
290            DO iq=1,nq
291               DO i=1,ijp1llm
292                  qm(i,iq)=qm(i,iq)*zw
293               ENDDO
294            ENDDO
295         ENDIF
296         DO i=1,ijmllm
297            vm(i)=pv(i)*zw
298         ENDDO
299         DO i=1,ip1jmp1
300            pm(i)=pps(i)*zw
301         ENDDO
302
303      ENDIF
304
305      idaym=idayp
306
307
308c-----------------------------------------------------------------------
309c   ecriture en fin de run et fermeture du fichier:
310c   -----------------------------------------------
311
312      IF(ifin.NE.0) THEN
313c si un temps non negligeable s'est ecoule depuis la derniere ecriture
314c on sauve garde le champs supplementaire
315
316         IF(dttot.GT.1.e-5*period_av) THEN
317
318            zwtot=pdtav/dttot
319            DO i=1,ijp1llm
320               um(i)=um(i)*zwtot
321               hm(i)=hm(i)*zwtot
322            ENDDO
323
324            DO i=1,ijmllm
325               vm(i)=vm(i)*zwtot
326            ENDDO
327            DO i=1,ip1jmp1
328               pm(i)=pm(i)*zwtot
329            ENDDO
330
331            CALL covnat(llm,um,vm,um,vm)
332
333c
334c Ouverture du fichier:
335c
336      ierr = NF_OPEN(fichnom, NF_WRITE, nid)
337      IF (ierr .NE. NF_NOERR) THEN
338         PRINT*, "Pb. d ouverture "//fichnom
339         CALL abort
340      ENDIF
341           
342c  Ecriture/extension de la coordonnee temps
343      nb = nb + 1
344      ierr = NF_INQ_VARID(nid, "temps", nvarid)
345      IF (ierr .NE. NF_NOERR) THEN
346         PRINT*, "writeav: Variable temps n est pas definie"
347         CALL abort
348      ENDIF
349      time = FLOAT(idayp)*period_av-.5*dttot
350#ifdef NC_DOUBLE
351      ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time)
352#else
353      ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time)
354#endif
355      PRINT*, "Enregistrement pour ", nb, time, fichnom
356
357C  Ecriture des champs
358      ierr = NF_INQ_VARID(nid, "temp", nvarid)
359      IF (ierr .NE. NF_NOERR) THEN
360         PRINT*, "writeav: Variable temp n est pas definie"
361         CALL abort
362      ENDIF
363#ifdef NC_DOUBLE
364      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,hm)
365#else
366      ierr = NF_PUT_VAR_REAL (nid,nvarid,hm)
367#endif
368
369c
370      ierr = NF_INQ_VARID(nid, "vitu", nvarid)
371      IF (ierr .NE. NF_NOERR) THEN
372         PRINT*, "writeav: Variable vitu n est pas definie"
373         CALL abort
374      ENDIF
375#ifdef NC_DOUBLE
376      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,um)
377#else
378      ierr = NF_PUT_VAR_REAL (nid,nvarid,um)
379#endif
380
381      ierr = NF_INQ_VARID(nid, "vitv", nvarid)
382      IF (ierr .NE. NF_NOERR) THEN
383         PRINT*, "writeav: Variable vitv n est pas definie"
384         CALL abort
385      ENDIF
386#ifdef NC_DOUBLE
387      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vm)
388#else
389      ierr = NF_PUT_VAR_REAL (nid,nvarid,vm)
390#endif
391c
392      IF(nq.GE.1) THEN
393      DO iq=1,nq
394      IF ( iq.GT.99 ) THEN
395         PRINT*, "Trop de traceurs"
396         CALL abort
397      ELSE
398         str3(1:1)='q'
399         WRITE(str3(2:3),'(i2.2)') iq
400         ierr = NF_INQ_VARID(nid, str3, nvarid)
401         IF (ierr .NE. NF_NOERR) THEN
402            PRINT*, "writeav: Variable "//str3//" n est pas definie"
403            CALL abort
404         ENDIF
405      ENDIF
406#ifdef NC_DOUBLE
407         ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,qm(1,iq))
408#else
409         ierr = NF_PUT_VAR_REAL (nid,nvarid,qm(1,iq))
410#endif
411      ENDDO
412      ENDIF
413c
414      ierr = NF_INQ_VARID(nid, "ps", nvarid)
415      IF (ierr .NE. NF_NOERR) THEN
416         PRINT*, "writeav: Variable ps n est pas definie"
417         CALL abort
418      ENDIF
419#ifdef NC_DOUBLE
420      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pps)
421#else
422      ierr = NF_PUT_VAR_REAL (nid,nvarid,pps)
423#endif
424
425      ierr = NF_CLOSE(nid)
426c
427
428         ENDIF
429         RETURN
430      ENDIF
431
432      RETURN
433      END
Note: See TracBrowser for help on using the repository browser.