source: trunk/LMDZ.MARS/libf/dynphy_lonlat/phymars/start2archive.F @ 2913

Last change on this file since 2913 was 2913, checked in by romain.vande, 21 months ago

Mars PCM:
Adapt start2archive.F to the subslope parametrisation.
Small correction for some dimensions of variables.
RV
File size: 17.2 KB
Line 
1c=======================================================================
2      PROGRAM start2archive
3c=======================================================================
4c
5c
6c   Date:    01/1997
7c   ----
8c
9c
10c   Objet:   Passage des  fichiers netcdf d'etat initial "start" et
11c   -----    "startfi" a un fichier netcdf unique "start_archive"
12c
13c  "start_archive" est une banque d'etats initiaux:
14c  On peut stocker plusieurs etats initiaux dans un meme fichier "start_archive"
15c    (Veiller dans ce cas avoir un day_ini different pour chacun des start)
16c
17c
18c
19c=======================================================================
20
21      use infotrac, only: infotrac_init, nqtot, tname
22      use comsoil_h, only: nsoilmx, inertiedat
23      use surfdat_h, only: ini_surfdat_h, qsurf
24      use comsoil_h, only: ini_comsoil_h
25!      use comgeomphy, only: initcomgeomphy
26      use filtreg_mod, only: inifilr
27      USE mod_const_mpi, ONLY: COMM_LMDZ
28      use control_mod, only: planet_type
29      USE comvert_mod, ONLY: ap,bp
30      USE comconst_mod, ONLY: daysec,dtphys,rad,g,r,cpp
31      USE temps_mod, ONLY: day_ini,hour_ini
32      USE iniphysiq_mod, ONLY: iniphysiq
33      USE phyetat0_mod, ONLY: phyetat0
34      USE exner_hyb_m, ONLY: exner_hyb
35      use comslope_mod, ONLY: nslope,def_slope,def_slope_mean,
36     &                        subslope_dist
37      USE comcstfi_h, only: pi
38      implicit none
39
40      include "dimensions.h"
41      integer, parameter :: ngridmx = (2+(jjm-1)*iim - 1/jjm)
42      include "paramet.h"
43      include "comdissip.h"
44      include "comgeom.h"
45      include "netcdf.inc"
46
47c-----------------------------------------------------------------------
48c   Declarations
49c-----------------------------------------------------------------------
50
51c variables dynamiques du GCM
52c -----------------------------
53      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
54      REAL teta(ip1jmp1,llm)                    ! temperature potentielle
55      REAL,ALLOCATABLE :: q(:,:,:)   ! champs advectes
56      REAL pks(ip1jmp1)                      ! exner (f pour filtre)
57      REAL pk(ip1jmp1,llm)
58      REAL pkf(ip1jmp1,llm)
59      REAL phis(ip1jmp1)                     ! geopotentiel au sol
60      REAL masse(ip1jmp1,llm)                ! masse de l'atmosphere
61      REAL ps(ip1jmp1)                       ! pression au sol
62      REAL p3d(iip1, jjp1, llm+1)            ! pression aux interfaces
63     
64c Variable Physiques (grille physique)
65c ------------------------------------
66      REAL,ALLOCATABLE :: tsurf(:,:)        ! Surface temperature
67      REAL,ALLOCATABLE :: tsoil(:,:,:) ! Soil temperature
68      REAL,ALLOCATABLE :: watercap(:,:)        ! h2o ice layer
69      REAL :: tauscaling(ngridmx) ! dust conversion factor
70      REAL:: totcloudfrac(ngridmx) ! sub-grid cloud fraction
71      REAL q2(ngridmx,llm+1)
72      REAL,ALLOCATABLE :: emis(:,:)
73      REAL,ALLOCATABLE :: albedo(:,:,:)
74      REAL wstar(ngridmx)
75      INTEGER start,length
76      PARAMETER (length = 100)
77      REAL tab_cntrl_fi(length) ! tableau des parametres de startfi
78      INTEGER*4 day_ini_fi
79
80c Variable naturelle / grille scalaire
81c ------------------------------------
82      REAL T(ip1jmp1,llm),us(ip1jmp1,llm),vs(ip1jmp1,llm)
83      REAL,ALLOCATABLE :: tsurfS(:,:)
84      REAL,ALLOCATABLE :: tsoilS(:,:,:)
85      REAL ithS(ip1jmp1,nsoilmx) ! Soil Thermal Inertia
86      REAL,ALLOCATABLE :: watercapS(:,:)
87      REAL :: tauscalingS(ip1jmp1)
88      REAL :: totcloudfracS(ip1jmp1)
89      REAL q2S(ip1jmp1,llm+1)
90      REAL,ALLOCATABLE :: qsurfS(:,:,:)
91      REAL,ALLOCATABLE :: emisS(:,:)
92      REAL,ALLOCATABLE :: albedoS(:,:)
93      REAL, ALLOCATABLE :: subslope_distS(:,:)
94
95c Variables intermediaires : vent naturel, mais pas coord scalaire
96c----------------------------------------------------------------
97      REAL vn(ip1jm,llm),un(ip1jmp1,llm)
98
99c Autres  variables
100c -----------------
101      LOGICAL startdrs
102      INTEGER Lmodif
103
104      REAL ptotal, co2icetotal
105      REAL timedyn,timefi !fraction du jour dans start, startfi
106      REAL date
107
108      CHARACTER*2 str2
109      CHARACTER*80 fichier
110      data  fichier /'startfi'/
111
112      INTEGER ij, l,i,j,isoil,iq,islope
113      character*80      fichnom
114      integer :: ierr,ntime
115      integer :: igcm_co2
116      integer :: nq,numvanle
117      character(len=30) :: txt ! to store some text
118
119c Netcdf
120c-------
121      integer varid,dimid,timelen
122      INTEGER nid,nid1
123
124c-----------------------------------------------------------------------
125c   Initialisations
126c-----------------------------------------------------------------------
127
128      CALL defrun_new(99, .TRUE. )
129
130      planet_type='mars'
131
132c=======================================================================
133c Lecture des donnees
134c=======================================================================
135! Load tracer number and names:
136      call infotrac_init
137
138! allocate arrays:
139      allocate(q(ip1jmp1,llm,nqtot))     
140
141      fichnom = 'start.nc'
142      CALL dynetat0(fichnom,vcov,ucov,teta,q,masse,
143     .       ps,phis,timedyn)
144
145c-----------------------------------------------------------------------
146c   Initialisations
147c-----------------------------------------------------------------------
148
149      CALL defrun_new(99, .FALSE. )
150      call iniconst
151      call inigeom
152      call inifilr
153
154! Initialize the physics
155         CALL iniphysiq(iim,jjm,llm,
156     &                  (jjm-1)*iim+2,comm_lmdz,
157     &                  daysec,day_ini,dtphys,
158     &                  rlatu,rlatv,rlonu,rlonv,
159     &                  aire,cu,cv,rad,g,r,cpp,
160     &                  1)
161
162      fichnom = 'startfi.nc'
163      Lmodif=0
164
165      allocate(tsurf(ngridmx,nslope))
166      allocate(tsoil(ngridmx,nsoilmx,nslope))
167      allocate(watercap(ngridmx,nslope))
168      allocate(emis(ngridmx,nslope))
169      allocate(albedo(ngridmx,2,nslope))
170
171      allocate(qsurfS(ip1jmp1,nqtot,nslope))
172      allocate(tsurfS(ip1jmp1,nslope))
173      allocate(tsoilS(ip1jmp1,nsoilmx,nslope))
174      allocate(watercapS(ip1jmp1,nslope))
175      allocate(emisS(ip1jmp1,nslope))
176      allocate(albedoS(ip1jmp1,nslope))
177      allocate(subslope_distS(ip1jmp1,nslope))
178
179      CALL phyetat0 (fichnom,0,Lmodif,nsoilmx,ngridmx,llm,nqtot,
180     &      day_ini_fi,timefi,tsurf,tsoil,albedo,emis,q2,qsurf,
181     &      tauscaling,totcloudfrac,wstar,watercap,def_slope,
182     &      def_slope_mean,subslope_dist)
183
184       ierr = NF_OPEN (fichnom, NF_NOWRITE,nid1)
185       IF (ierr.NE.NF_NOERR) THEN
186         write(6,*)' Pb d''ouverture du fichier'//fichnom
187        CALL ABORT
188       ENDIF
189                                               
190      ierr = NF_INQ_VARID (nid1, "controle", varid)
191      IF (ierr .NE. NF_NOERR) THEN
192       PRINT*, "start2archive: Le champ <controle> est absent"
193       CALL abort
194      ENDIF
195#ifdef NC_DOUBLE
196       ierr = NF_GET_VAR_DOUBLE(nid1, varid, tab_cntrl_fi)
197#else
198      ierr = NF_GET_VAR_REAL(nid1, varid, tab_cntrl_fi)
199#endif
200       IF (ierr .NE. NF_NOERR) THEN
201          PRINT*, "start2archive: Lecture echoue pour <controle>"
202          CALL abort
203       ENDIF
204
205      ierr = NF_CLOSE(nid1)
206
207c-----------------------------------------------------------------------
208c Controle de la synchro
209c-----------------------------------------------------------------------
210!mars a voir      if ((day_ini_fi.ne.day_ini).or.(abs(timefi-timedyn).gt.1.e-10))
211      if ((mod(day_ini_fi,669).ne.mod(day_ini,669)))
212     &  stop ' Probleme de Synchro entre start et startfi !!!'
213
214
215c *****************************************************************
216c    Option : Reinitialisation des dates dans la premieres annees :
217       do while (day_ini.ge.669)
218          day_ini=day_ini-669
219       enddo
220c *****************************************************************
221
222      CALL pression(ip1jmp1, ap, bp, ps, p3d)
223      call exner_hyb(ip1jmp1, ps, p3d, pks, pk, pkf)
224
225c=======================================================================
226c Transformation EN VARIABLE NATURELLE / GRILLE SCALAIRE si necessaire
227c=======================================================================
228c  Les variables modeles dependent de la resolution. Il faut donc
229c  eliminer les facteurs responsables de cette dependance
230c  (pour utiliser newstart)
231c=======================================================================
232
233c-----------------------------------------------------------------------
234c Vent   (depend de la resolution horizontale)
235c-----------------------------------------------------------------------
236c
237c ucov --> un  et  vcov --> vn
238c un --> us  et   vn --> vs
239c
240c-----------------------------------------------------------------------
241
242      call covnat(llm,ucov, vcov, un, vn)
243      call wind_scal(un,vn,us,vs)
244
245c-----------------------------------------------------------------------
246c Temperature  (depend de la resolution verticale => de "sigma.def")
247c-----------------------------------------------------------------------
248c
249c h --> T
250c
251c-----------------------------------------------------------------------
252
253      DO l=1,llm
254         DO ij=1,ip1jmp1
255            T(ij,l)=teta(ij,l)*pk(ij,l)/cpp !mars deduit de l'equation dans newstart
256         ENDDO
257      ENDDO
258
259c-----------------------------------------------------------------------
260c Variable physique
261c-----------------------------------------------------------------------
262c
263c tsurf --> tsurfS
264c watercap --> watercapS
265c tsoil --> tsoilS
266c inertiedat --> ithS
267c emis --> emisS
268c albedo --> albedoS
269c q2 --> q2S
270c qsurf --> qsurfS
271c tauscaling --> tauscalingS
272c totcloudfrac --> totcloudfracS
273c
274c-----------------------------------------------------------------------
275
276      do islope=1,nslope
277      call gr_fi_dyn(1,ngridmx,iip1,jjp1,tsurf(:,islope),
278     &    tsurfS(:,islope))
279      call gr_fi_dyn(1,ngridmx,iip1,jjp1,watercap(:,islope),
280     &    watercapS(:,islope))
281      call gr_fi_dyn(nsoilmx,ngridmx,iip1,jjp1,tsoil(:,:,islope),
282     &    tsoilS(:,:,islope))
283      ! Note: thermal inertia "inertiedat" is in comsoil.h
284      call gr_fi_dyn(1,ngridmx,iip1,jjp1,emis(:,islope),
285     &     emisS(:,islope))
286      call gr_fi_dyn(1,ngridmx,iip1,jjp1,albedo(:,1,islope),
287     &   albedoS(:,islope))
288      call gr_fi_dyn(nqtot,ngridmx,iip1,jjp1,qsurf(:,:,islope),
289     &   qsurfS(:,:,islope))
290      call gr_fi_dyn(1,ngridmx,iip1,jjp1,subslope_dist(:,islope),
291     &    subslope_distS(:,islope))
292      enddo
293      call gr_fi_dyn(nsoilmx,ngridmx,iip1,jjp1,inertiedat,ithS)
294      call gr_fi_dyn(llm+1,ngridmx,iip1,jjp1,q2,q2S)
295      call gr_fi_dyn(1,ngridmx,iip1,jjp1,tauscaling,tauscalingS)
296      call gr_fi_dyn(1,ngridmx,iip1,jjp1,totcloudfrac,totcloudfracS)
297
298c=======================================================================
299c Info pour controler
300c=======================================================================
301
302      DO iq=1,nqtot
303        if (trim(tname(iq)) .eq. "co2") then
304           igcm_co2=iq
305        endif
306      enddo
307
308      ptotal =  0.
309      co2icetotal = 0.
310      DO j=1,jjp1
311         DO i=1,iim
312           DO islope=1,nslope
313           ptotal=ptotal+aire(i+(iim+1)*(j-1))*ps(i+(iim+1)*(j-1))/g
314           co2icetotal = co2icetotal +
315     &        qsurfS(i+(iim+1)*(j-1),igcm_co2,islope)*
316     &        aire(i+(iim+1)*(j-1))*
317     &    subslope_distS(i+(iim+1)*(j-1),islope)/
318     &    cos(pi*def_slope_mean(islope))
319           ENDDO
320         ENDDO
321      ENDDO
322      write(*,*)'Ancienne grille : masse de l''atm :',ptotal
323      write(*,*)'Ancienne grille : masse de la glace CO2 :',co2icetotal
324
325c-----------------------------------------------------------------------
326c Passage de "ptotal" et "co2icetotal" par tab_cntrl_fi
327c-----------------------------------------------------------------------
328
329      tab_cntrl_fi(49) = ptotal
330      tab_cntrl_fi(50) = co2icetotal
331
332c=======================================================================
333c Ecriture dans le fichier  "start_archive"
334c=======================================================================
335
336c-----------------------------------------------------------------------
337c Ouverture de "start_archive"
338c-----------------------------------------------------------------------
339
340      ierr = NF_OPEN ('start_archive.nc', NF_WRITE,nid)
341 
342c-----------------------------------------------------------------------
343c  si "start_archive" n'existe pas:
344c    1_ ouverture
345c    2_ creation de l'entete dynamique ("ini_archive")
346c-----------------------------------------------------------------------
347c ini_archive:
348c On met dans l'entete le tab_cntrl dynamique (1 a 16)
349c  On y ajoute les valeurs du tab_cntrl_fi (a partir de 51)
350c  En plus les deux valeurs ptotal et co2icetotal (99 et 100)
351c-----------------------------------------------------------------------
352
353      if (ierr.ne.NF_NOERR) then
354         write(*,*)'OK, Could not open file "start_archive.nc"'
355         write(*,*)'So let s create a new "start_archive"'
356         ierr = NF_CREATE('start_archive.nc',
357     &  IOR(NF_CLOBBER,NF_64BIT_OFFSET), nid)
358         call ini_archive(nid,day_ini,phis,ithS,tab_cntrl_fi,
359     &         def_slope,subslope_distS)
360      endif
361
362c-----------------------------------------------------------------------
363c Ecriture de la coordonnee temps (date en jours)
364c-----------------------------------------------------------------------
365
366      date = day_ini + hour_ini
367      ierr= NF_INQ_VARID(nid,"Time",varid)
368      ierr= NF_INQ_DIMID(nid,"Time",dimid)
369      ierr= NF_INQ_DIMLEN(nid,dimid,timelen)
370      ntime=timelen+1
371
372      write(*,*) "******************"
373      write(*,*) "ntime",ntime
374      write(*,*) "******************"
375#ifdef NC_DOUBLE
376      ierr= NF_PUT_VARA_DOUBLE(nid,varid,ntime,1,date)
377#else
378      ierr= NF_PUT_VARA_REAL(nid,varid,ntime,1,date)
379#endif
380      if (ierr.ne.NF_NOERR) then
381         write(*,*) "time matter ",NF_STRERROR(ierr)
382         stop
383      endif
384
385c-----------------------------------------------------------------------
386c Ecriture des champs  (co2ice,emis,albedo,ps,Tsurf,T,u,v,q2,q,qsurf)
387c-----------------------------------------------------------------------
388c ATTENTION: q2 a une couche de plus!!!!
389c    Pour creer un fichier netcdf lisible par grads,
390c    On passe donc une des couches de q2 a part
391c    comme une variable 2D (la couche au sol: "q2surf")
392c    Les lmm autres couches sont nommees "q2atm" (3D)
393c-----------------------------------------------------------------------
394
395      call write_archive(nid,ntime,'watercap','couche de glace h2o',
396     &  'kg/m2',2,watercapS)
397      call write_archive(nid,ntime,'tauscaling',
398     &  'dust conversion factor',' ',2,tauscalingS)
399      call write_archive(nid,ntime,'totcloudfrac',
400     &  'sub grid cloud fraction',' ',2,totcloudfracS)
401      call write_archive(nid,ntime,'emis','grd emis',' ',2,emisS)
402      call write_archive(nid,ntime,'albedo','surface albedo',' ',
403     &                             2,albedoS)
404      call write_archive(nid,ntime,'ps','Psurf','Pa',2,ps)
405      call write_archive(nid,ntime,'tsurf','surf T','K',2,tsurfS)
406      call write_archive(nid,ntime,'temp','temperature','K',3,t)
407      call write_archive(nid,ntime,'u','Vent zonal','m.s-1',3,us)
408      call write_archive(nid,ntime,'v','Vent merid','m.s-1',3,vs)
409      call write_archive(nid,ntime,'q2surf','wind variance','m2.s-2',2,
410     .              q2S)
411      call write_archive(nid,ntime,'q2atm','wind variance','m2.s-2',3,
412     .              q2S(1,2))
413
414c-----------------------------------------------------------------------
415c Ecriture du champs  q  ( q[1,nqtot] )
416c-----------------------------------------------------------------------
417      do iq=1,nqtot
418c       write(str2,'(i2.2)') iq
419c        call write_archive(nid,ntime,'q'//str2,'tracer','kg/kg',
420c     .         3,q(1,1,iq))
421        call write_archive(nid,ntime,tname(iq),'tracer','kg/kg',
422     &         3,q(1,1,iq))
423      end do
424c-----------------------------------------------------------------------
425c Ecriture du champs  qsurf  ( qsurf[1,nqtot] )
426c-----------------------------------------------------------------------
427      do iq=1,nqtot
428c       write(str2,'(i2.2)') iq
429c       call write_archive(nid,ntime,'qsurf'//str2,'Tracer on surface',
430c     $  'kg.m-2',2,qsurfS(1,iq))
431        txt=trim(tname(iq))//"_surf"
432        call write_archive(nid,ntime,txt,'Tracer on surface',
433     &  'kg.m-2',2,qsurfS(:,iq,:))
434      enddo
435
436
437c-----------------------------------------------------------------------
438c Ecriture du champs  tsoil  ( Tg[1,10] )
439c-----------------------------------------------------------------------
440c "tsoil" Temperature au sol definie dans 10 couches dans le sol
441c   Les 10 couches sont lues comme 10 champs
442c  nommees Tg[1,10]
443
444c      do isoil=1,nsoilmx
445c       write(str2,'(i2.2)') isoil
446c       call write_archive(nid,ntime,'Tg'//str2,'Ground Temperature ',
447c     .   'K',2,tsoilS(1,isoil))
448c      enddo
449
450! Write soil temperatures tsoil
451      call write_archive(nid,ntime,'tsoil','Soil temperature',
452     &     'K',-3,tsoilS(:,:,:))
453
454! Write soil thermal inertia
455      call write_archive(nid,ntime,'inertiedat',
456     &     'Soil thermal inertia',
457     &     'J.s-1/2.m-2.K-1',-3,ithS)
458
459! Write (0D) volumetric heat capacity (stored in comsoil.h)
460!      call write_archive(nid,ntime,'volcapa',
461!     &     'Soil volumetric heat capacity',
462!     &     'J.m-3.K-1',0,volcapa)
463! Note: no need to write volcapa, it is stored in "controle" table
464
465      ierr=NF_CLOSE(nid)
466c-----------------------------------------------------------------------
467c Fin
468c-----------------------------------------------------------------------
469
470      write(*,*) "startarchive: all is well that ends well"
471     
472      end
Note: See TracBrowser for help on using the repository browser.