c======================================================================= PROGRAM start2archive c======================================================================= c c c Date: 01/1997 c ---- c c c Objet: Passage des fichiers netcdf d'etat initial "start" et c ----- "startfi" a un fichier netcdf unique "start_archive" c c "start_archive" est une banque d'etats initiaux: c On peut stocker plusieurs etats initiaux dans un meme fichier "start_archive" c (Veiller dans ce cas avoir un day_ini different pour chacun des start) c c c c======================================================================= use infotrac, only: infotrac_init, nqtot, tname USE comsoil_h ! use slab_ice_h, only: noceanmx c USE ocean_slab_mod, ONLY: nslay USE ioipsl_getincom, only: getin USE planete_mod, only: year_day USE mod_const_mpi, ONLY: COMM_LMDZ USE control_mod, only: planet_type c USE callkeys_mod, ONLY: ok_slab_ocean use filtreg_mod, only: inifilr USE comvert_mod, ONLY: ap,bp USE comconst_mod, ONLY: daysec,dtphys,rad,g,r,cpp USE temps_mod, ONLY: day_ini USE iniphysiq_mod, ONLY: iniphysiq use phys_state_var_mod, only: phys_state_var_init use phyetat0_mod, only: phyetat0 c use nonoro_gwd_ran_mod, only: du_nonoro_gwd, dv_nonoro_gwd, c & east_gwstress, west_gwstress use exner_hyb_m, only: exner_hyb USE surfdat_h, ONLY: albedodat,zmea,zstd,zsig,zgam,zthe implicit none include "dimensions.h" integer, parameter :: ngridmx = (2+(jjm-1)*iim - 1/jjm) include "paramet.h" include "comdissip.h" include "comgeom.h" include "netcdf.inc" c----------------------------------------------------------------------- c Declarations c----------------------------------------------------------------------- c variables dynamiques du GCM c ----------------------------- REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants REAL teta(ip1jmp1,llm) ! temperature potentielle REAL,ALLOCATABLE :: q(:,:,:) ! champs advectes REAL pks(ip1jmp1) ! exner (f pour filtre) REAL pk(ip1jmp1,llm) REAL pkf(ip1jmp1,llm) REAL phis(ip1jmp1) ! geopotentiel au sol REAL masse(ip1jmp1,llm) ! masse de l'atmosphere REAL ps(ip1jmp1) ! pression au sol REAL p3d(iip1, jjp1, llm+1) ! pression aux interfaces c Variable Physiques (grille physique) c ------------------------------------ REAL tsurf(ngridmx) ! Surface temperature REAL,ALLOCATABLE :: tsoil(:,:) ! Soil temperature REAL n2ice(ngridmx) ! N2 ice layer REAL q2(ngridmx,llm+1) REAL,ALLOCATABLE :: qsurf(:,:) REAL emis(ngridmx) REAL albedo(ngridmx) INTEGER start,length PARAMETER (length = 100) REAL tab_cntrl_fi(length) ! tableau des parametres de startfi REAL tab_cntrl_dyn(length) ! tableau des parametres de start INTEGER*4 day_ini_fi c Variable naturelle / grille scalaire c ------------------------------------ REAL T(ip1jmp1,llm),us(ip1jmp1,llm),vs(ip1jmp1,llm) REAL tsurfS(ip1jmp1) REAL,ALLOCATABLE :: tsoilS(:,:) REAL,ALLOCATABLE :: ithS(:,:) ! Soil Thermal Inertia REAL n2iceS(ip1jmp1) REAL q2S(ip1jmp1,llm+1) REAL,ALLOCATABLE :: qsurfS(:,:) REAL emisS(ip1jmp1) REAL albedoS(ip1jmp1) REAL zmeaS(ip1jmp1) REAL zsigS(ip1jmp1) REAL zstdS(ip1jmp1) REAL zgamS(ip1jmp1) REAL ztheS(ip1jmp1) REAL albedodatS(ip1jmp1) c Variables intermediaires : vent naturel, mais pas coord scalaire c---------------------------------------------------------------- REAL vn(ip1jm,llm),un(ip1jmp1,llm) c Autres variables c ----------------- LOGICAL startdrs INTEGER Lmodif REAL ptotal, n2icetotal REAL timedyn,timefi !fraction du jour dans start, startfi REAL date CHARACTER*2 str2 CHARACTER*80 fichier data fichier /'startfi'/ INTEGER ij, l,i,j,isoil,iq character*80 fichnom integer :: ierr,ntime integer :: nq,numvanle character(len=30) :: txt ! to store some text c Netcdf c------- integer varid,dimid,timelen INTEGER nid,nid1 c----------------------------------------------------------------------- c Initialisations c----------------------------------------------------------------------- CALL defrun_new(99, .TRUE. ) planet_type="generic" c======================================================================= c Lecture des donnees c======================================================================= ! Load tracer number and names: call infotrac_init ! allocate arrays: allocate(q(ip1jmp1,llm,nqtot)) allocate(qsurf(ngridmx,nqtot)) allocate(qsurfS(ip1jmp1,nqtot)) c allocate(tslab(ngridmx,nslay)) !Added by SB for slab ocean c allocate(tslabS(ip1jmp1,nslay)) !Added by SB for slab ocean ! other array allocations: ! call ini_comsoil_h(ngridmx) ! done via iniphysiq fichnom = 'start.nc' CALL dynetat0(fichnom,vcov,ucov,teta,q,masse, . ps,phis,timedyn) ! load 'controle' array from dynamics start file ierr = NF_OPEN (fichnom, NF_NOWRITE,nid1) IF (ierr.NE.NF_NOERR) THEN write(6,*)' Pb d''ouverture du fichier'//trim(fichnom) CALL ABORT ENDIF ierr = NF_INQ_VARID (nid1, "controle", varid) IF (ierr .NE. NF_NOERR) THEN PRINT*, "start2archive: Le champ est absent" CALL abort ENDIF #ifdef NC_DOUBLE ierr = NF_GET_VAR_DOUBLE(nid1, varid, tab_cntrl_dyn) #else ierr = NF_GET_VAR_REAL(nid1, varid, tab_cntrl_dyn) #endif IF (ierr .NE. NF_NOERR) THEN PRINT*, "start2archive: Lecture echoue pour " CALL abort ENDIF ierr = NF_CLOSE(nid1) ! Get value of the "subsurface_layers" dimension from physics start file fichnom = 'startfi.nc' ierr = NF_OPEN (fichnom, NF_NOWRITE,nid1) IF (ierr.NE.NF_NOERR) THEN write(6,*)' Pb d''ouverture du fichier'//trim(fichnom) CALL ABORT ENDIF ierr = NF_INQ_DIMID(nid1,"subsurface_layers",varid) IF (ierr .NE. NF_NOERR) THEN PRINT*, "start2archive: No subsurface_layers dimension!!" CALL abort ENDIF ierr = NF_INQ_DIMLEN(nid1,varid,nsoilmx) IF (ierr .NE. NF_NOERR) THEN PRINT*, "start2archive: Failed reading subsurface_layers value!!" CALL abort ENDIF ierr = NF_CLOSE(nid1) ! allocate arrays of nsoilmx size allocate(tsoil(ngridmx,nsoilmx)) allocate(tsoilS(ip1jmp1,nsoilmx)) allocate(ithS(ip1jmp1,nsoilmx)) c----------------------------------------------------------------------- c Initialisations c----------------------------------------------------------------------- CALL defrun_new(99, .FALSE. ) call iniconst call inigeom call inifilr ! Initialize the physics CALL iniphysiq(iim,jjm,llm, & (jjm-1)*iim+2,comm_lmdz, & daysec,day_ini,dtphys, & rlatu,rlatv,rlonu,rlonv, & aire,cu,cv,rad,g,r,cpp, & 1) fichnom = 'startfi.nc' Lmodif=0 ! Allocate saved arrays (as in firstcall of physiq) call phys_state_var_init(nqtot) ! Initialize tracer names, indexes and properties CALL initracer(ngridmx,nqtot) CALL phyetat0(.true.,ngridmx,llm,fichnom,0,Lmodif,nsoilmx,nqtot, . day_ini_fi,timefi, . tsurf,tsoil,emis,q2,qsurf,inertiedat) ! change FF 05/2011 c . cloudfrac,totalcloudfrac,hice, ! change BC 05/2014 c . rnat,pctsrf_sic,tslab,tsea_ice,sea_ice) ! load 'controle' array from physics start file ierr = NF_OPEN (fichnom, NF_NOWRITE,nid1) IF (ierr.NE.NF_NOERR) THEN write(6,*)' Pb d''ouverture du fichier'//trim(fichnom) CALL ABORT ENDIF ierr = NF_INQ_VARID (nid1, "controle", varid) IF (ierr .NE. NF_NOERR) THEN PRINT*, "start2archive: Le champ est absent" CALL abort ENDIF #ifdef NC_DOUBLE ierr = NF_GET_VAR_DOUBLE(nid1, varid, tab_cntrl_fi) #else ierr = NF_GET_VAR_REAL(nid1, varid, tab_cntrl_fi) #endif IF (ierr .NE. NF_NOERR) THEN PRINT*, "start2archive: Lecture echoue pour " CALL abort ENDIF ierr = NF_CLOSE(nid1) c----------------------------------------------------------------------- c Controle de la synchro c----------------------------------------------------------------------- !mars a voir if ((day_ini_fi.ne.day_ini).or.(abs(timefi-timedyn).gt.1.e-10)) if ((day_ini_fi.ne.day_ini)) & stop ' Probleme de Synchro entre start et startfi !!!' c ***************************************************************** c Option : Reinitialisation des dates dans la premieres annees : do while (day_ini.ge.year_day) day_ini=day_ini-year_day enddo c ***************************************************************** CALL pression(ip1jmp1, ap, bp, ps, p3d) call exner_hyb(ip1jmp1, ps, p3d, pks, pk, pkf) c======================================================================= c Transformation EN VARIABLE NATURELLE / GRILLE SCALAIRE si necessaire c======================================================================= c Les variables modeles dependent de la resolution. Il faut donc c eliminer les facteurs responsables de cette dependance c (pour utiliser newstart) c======================================================================= c----------------------------------------------------------------------- c Vent (depend de la resolution horizontale) c----------------------------------------------------------------------- c c ucov --> un et vcov --> vn c un --> us et vn --> vs c c----------------------------------------------------------------------- call covnat(llm,ucov, vcov, un, vn) call wind_scal(un,vn,us,vs) c----------------------------------------------------------------------- c Temperature (depend de la resolution verticale => de "sigma.def") c----------------------------------------------------------------------- c c h --> T c c----------------------------------------------------------------------- DO l=1,llm DO ij=1,ip1jmp1 T(ij,l)=teta(ij,l)*pk(ij,l)/cpp !mars deduit de l'equation dans newstart ENDDO ENDDO c----------------------------------------------------------------------- c Variable physique c----------------------------------------------------------------------- c c tsurf --> tsurfS c n2ice --> n2iceS c tsoil --> tsoilS c emis --> emisS c q2 --> q2S c qsurf --> qsurfS c c----------------------------------------------------------------------- call gr_fi_dyn(1,ngridmx,iip1,jjp1,tsurf,tsurfS) ! call gr_fi_dyn(1,ngridmx,iip1,jjp1,n2ice,n2iceS) call gr_fi_dyn(nsoilmx,ngridmx,iip1,jjp1,tsoil,tsoilS) ! Note: thermal inertia "inertiedat" is in comsoil.h call gr_fi_dyn(nsoilmx,ngridmx,iip1,jjp1,inertiedat,ithS) call gr_fi_dyn(1,ngridmx,iip1,jjp1,zmea,zmeaS) call gr_fi_dyn(1,ngridmx,iip1,jjp1,zstd,zstdS) call gr_fi_dyn(1,ngridmx,iip1,jjp1,zsig,zsigS) call gr_fi_dyn(1,ngridmx,iip1,jjp1,zthe,ztheS) call gr_fi_dyn(1,ngridmx,iip1,jjp1,zgam,zgamS) call gr_fi_dyn(1,ngridmx,iip1,jjp1,albedodat,albedodatS) call gr_fi_dyn(1,ngridmx,iip1,jjp1,emis,emisS) call gr_fi_dyn(llm+1,ngridmx,iip1,jjp1,q2,q2S) call gr_fi_dyn(nqtot,ngridmx,iip1,jjp1,qsurf,qsurfS) c call gr_fi_dyn(llm,ngridmx,iip1,jjp1,cloudfrac,cloudfracS) c call gr_fi_dyn(1,ngridmx,iip1,jjp1,hice,hiceS) c call gr_fi_dyn(1,ngridmx,iip1,jjp1,totalcloudfrac,totalcloudfracS) c call gr_fi_dyn(1,ngridmx,iip1,jjp1,rnat,rnatS) c call gr_fi_dyn(1,ngridmx,iip1,jjp1,pctsrf_sic,pctsrf_sicS) c call gr_fi_dyn(1,ngridmx,iip1,jjp1,tsea_ice,tsea_iceS) c call gr_fi_dyn(1,ngridmx,iip1,jjp1,sea_ice,sea_iceS) c call gr_fi_dyn(nslay,ngridmx,iip1,jjp1,tslab,tslabS) c call gr_fi_dyn(llm,ngridmx,iip1,jjp1,du_nonoro_gwd,du_nonoro_gwdS) c call gr_fi_dyn(llm,ngridmx,iip1,jjp1,dv_nonoro_gwd,dv_nonoro_gwdS) c call gr_fi_dyn(llm,ngridmx,iip1,jjp1,east_gwstress,east_gwstressS) c call gr_fi_dyn(llm,ngridmx,iip1,jjp1,west_gwstress,west_gwstressS) c======================================================================= c Info pour controler c======================================================================= ptotal = 0. n2icetotal = 0. DO j=1,jjp1 DO i=1,iim ptotal=ptotal+aire(i+(iim+1)*(j-1))*ps(i+(iim+1)*(j-1))/g ! n2icetotal = n2icetotal + ! & n2iceS(i+(iim+1)*(j-1))*aire(i+(iim+1)*(j-1)) ENDDO ENDDO write(*,*)'Old grid: : atmospheric mass :',ptotal ! write(*,*)'Ancienne grille : masse de la glace N2 :',n2icetotal c----------------------------------------------------------------------- c Passage de "ptotal" et "n2icetotal" par tab_cntrl_fi c----------------------------------------------------------------------- tab_cntrl_fi(49) = ptotal tab_cntrl_fi(50) = n2icetotal c======================================================================= c Ecriture dans le fichier "start_archive" c======================================================================= c----------------------------------------------------------------------- c Ouverture de "start_archive" c----------------------------------------------------------------------- ierr = NF_OPEN ('start_archive.nc', NF_WRITE,nid) c----------------------------------------------------------------------- c si "start_archive" n'existe pas: c 1_ ouverture c 2_ creation de l'entete dynamique ("ini_archive") c----------------------------------------------------------------------- c ini_archive: c On met dans l'entete le tab_cntrl dynamique (1 a 16) c On y ajoute les valeurs du tab_cntrl_fi (a partir de 51) c En plus les deux valeurs ptotal et n2icetotal (99 et 100) c----------------------------------------------------------------------- if (ierr.ne.NF_NOERR) then write(*,*)'OK, Could not open file "start_archive.nc"' write(*,*)'So let s create a new "start_archive"' ierr = NF_CREATE('start_archive.nc', NF_CLOBBER, nid) call ini_archive(nid,day_ini,phis,ithS,tab_cntrl_fi, & tab_cntrl_dyn) endif c----------------------------------------------------------------------- c Ecriture de la coordonnee temps (date en jours) c----------------------------------------------------------------------- date = day_ini ierr= NF_INQ_VARID(nid,"Time",varid) ierr= NF_INQ_DIMID(nid,"Time",dimid) ierr= NF_INQ_DIMLEN(nid,dimid,timelen) ntime=timelen+1 write(*,*) "******************" write(*,*) "ntime",ntime write(*,*) "******************" #ifdef NC_DOUBLE ierr= NF_PUT_VARA_DOUBLE(nid,varid,ntime,1,date) #else ierr= NF_PUT_VARA_REAL(nid,varid,ntime,1,date) #endif if (ierr.ne.NF_NOERR) then write(*,*) "time matter ",NF_STRERROR(ierr) stop endif c----------------------------------------------------------------------- c Ecriture des champs (n2ice,emis,ps,Tsurf,T,u,v,q2,q,qsurf) c----------------------------------------------------------------------- c ATTENTION: q2 a une couche de plus!!!! c Pour creer un fichier netcdf lisible par grads, c On passe donc une des couches de q2 a part c comme une variable 2D (la couche au sol: "q2surf") c Les lmm autres couches sont nommees "q2atm" (3D) c----------------------------------------------------------------------- ! call write_archive(nid,ntime,'n2ice','couche de glace n2', ! & 'kg/m2',2,n2iceS) call write_archive(nid,ntime,'albedo','surface albedo',' ', & 2,albedoS) call write_archive(nid,ntime,'albedodat','albedodat', & ' ',2,albedodatS) call write_archive(nid,ntime,'ZMEA','zmea',' ',2,zmeaS) call write_archive(nid,ntime,'ZSTD','zstd',' ',2,zstdS) call write_archive(nid,ntime,'ZSIG','zsig',' ',2,zsigS) call write_archive(nid,ntime,'ZTHE','zthe',' ',2,ztheS) call write_archive(nid,ntime,'ZGAM','zgam',' ',2,zgamS) call write_archive(nid,ntime,'emis','grd emis',' ',2,emisS) call write_archive(nid,ntime,'ps','Psurf','Pa',2,ps) call write_archive(nid,ntime,'tsurf','surf T','K',2,tsurfS) call write_archive(nid,ntime,'temp','temperature','K',3,t) call write_archive(nid,ntime,'u','Vent zonal','m.s-1',3,us) call write_archive(nid,ntime,'v','Vent merid','m.s-1',3,vs) call write_archive(nid,ntime,'q2surf','wind variance','m2.s-2',2, . q2S) call write_archive(nid,ntime,'q2atm','wind variance','m2.s-2',3, . q2S(1,2)) c----------------------------------------------------------------------- c Ecriture du champs q ( q[1,nqtot] ) c----------------------------------------------------------------------- do iq=1,nqtot call write_archive(nid,ntime,tname(iq),'tracer','kg/kg', & 3,q(1,1,iq)) end do c----------------------------------------------------------------------- c Ecriture du champs qsurf ( qsurf[1,nqtot] ) c----------------------------------------------------------------------- do iq=1,nqtot txt=trim(tname(iq))//"_surf" call write_archive(nid,ntime,txt,'Tracer on surface', & 'kg.m-2',2,qsurfS(1,iq)) enddo c----------------------------------------------------------------------- c Ecriture du champs tsoil ( Tg[1,10] ) c----------------------------------------------------------------------- c "tsoil" Temperature au sol definie dans 10 couches dans le sol c Les 10 couches sont lues comme 10 champs c nommees Tg[1,10] c do isoil=1,nsoilmx c write(str2,'(i2.2)') isoil c call write_archive(nid,ntime,'Tg'//str2,'Ground Temperature ', c . 'K',2,tsoilS(1,isoil)) c enddo ! Write soil temperatures tsoil call write_archive(nid,ntime,'tsoil','Soil temperature', & 'K',-3,tsoilS) ! Write soil thermal inertia call write_archive(nid,ntime,'inertiedat', & 'Soil thermal inertia', & 'J.s-1/2.m-2.K-1',-3,ithS) ! Write (0D) volumetric heat capacity (stored in comsoil.h) ! call write_archive(nid,ntime,'volcapa', ! & 'Soil volumetric heat capacity', ! & 'J.m-3.K-1',0,volcapa) ! Note: no need to write volcapa, it is stored in "controle" table c----------------------------------------------------------------------- c Ecriture du champs cloudfrac,hice,totalcloudfrac c----------------------------------------------------------------------- c call write_archive(nid,ntime,'hice', c & 'Height of oceanic ice','m',2,hiceS) c call write_archive(nid,ntime,'totalcloudfrac', c & 'Total cloud Fraction','',2,totalcloudfracS) c call write_archive(nid,ntime,'cloudfrac' c & ,'Cloud fraction','',3,cloudfracS) c----------------------------------------------------------------------- c Slab ocean c----------------------------------------------------------------------- OPEN(99,file='callphys.def',status='old',form='formatted' & ,iostat=ierr) CLOSE(99) IF(ierr.EQ.0) THEN c write(*,*) "Use slab-ocean ?" c ok_slab_ocean=.false. ! default value c call getin("ok_slab_ocean",ok_slab_ocean) c write(*,*) "ok_slab_ocean = ",ok_slab_ocean c if(ok_slab_ocean) then c call write_archive(nid,ntime,'rnat' c & ,'rnat','',2,rnatS) c call write_archive(nid,ntime,'pctsrf_sic' c & ,'pctsrf_sic','',2,pctsrf_sicS) c call write_archive(nid,ntime,'sea_ice' c & ,'sea_ice','',2,sea_iceS) c call write_archive(nid,ntime,'tslab' c & ,'tslab','',-2,tslabS) c call write_archive(nid,ntime,'tsea_ice' c & ,'tsea_ice','',2,tsea_iceS) c endif !ok_slab_ocean ENDIF ! of IF(ierr.EQ.0) ! Non-orographic gavity waves c call write_archive(nid,ntime,"du_nonoro_gwd", c & "Zonal wind tendency due to GW",'m.s-1',3,du_nonoro_gwdS) c call write_archive(nid,ntime,"dv_nonoro_gwd", c & "Meridional wind tendency due to GW",'m.s-1', c & 3,dv_nonoro_gwdS) c call write_archive(nid,ntime,"east_gwstress", c & "Eastward stress profile due to GW",'kg.m-1.s-2', c & 3,east_gwstressS) c call write_archive(nid,ntime,"west_gwstress", c & "Westward stress profile due to GW",'kg.m-1.s-2', c & 3,west_gwstressS) c----------------------------------------------------------------------- c Fin c----------------------------------------------------------------------- ierr=NF_CLOSE(nid) write(*,*) "start2archive: All is well that ends well." end